Update comments referencing operators

Update comments referencing operators

module Prelude
  ( Unit(..), unit
  , ($), (#)
  , flip
  , const
  , asTypeOf
  , otherwise
  , (:), cons
  , Semigroupoid, compose, (<<<), (>>>)
  , Category, id
  , Functor, map, (<$>), (<#>), void
  , Apply, apply, (<*>)
  , Applicative, pure, liftA1
  , Bind, bind, (>>=)
  , Monad, return, liftM1, ap
  , Semigroup, append, (<>), (++)
  , Semiring, add, zero, mul, one, (+), (*)
  , ModuloSemiring, div, mod, (/)
  , Ring, sub, negate, (-)
  , Num
  , DivisionRing
  , Eq, eq, (==), (/=)
  , Ordering(..), Ord, compare, (<), (>), (<=), (>=)
  , Bounded, top, bottom
  , Lattice, sup, inf, (||), (&&)
  , BoundedLattice
  , ComplementedLattice, not
  , DistributiveLattice
  , BooleanAlgebra
  , Show, show
  ) where

-- | The `Unit` type has a single inhabitant, called `unit`. It represents
-- | values with no computational content.
-- |
-- | `Unit` is often used, wrapped in a monadic type constructor, as the
-- | return type of a computation where only
-- | the _effects_ are important.
newtype Unit = Unit {}

-- | `unit` is the sole inhabitant of the `Unit` type.
unit :: Unit
unit = Unit {}

infixr 0 $
infixl 0 #

-- | Applies a function to its argument.
-- |
-- | ```purescript
-- | length $ groupBy productCategory $ filter isInStock $ products
-- | ```
-- |
-- | is equivalent to:
-- |
-- | ```purescript
-- | length (groupBy productCategory (filter isInStock products))
-- | ```
-- |
-- | `($)` is different from [`(#)`](#-2) because it is right-infix instead of
-- | left: `a $ b $ c $ d x = a $ (b $ (c $ (d $ x))) = a (b (c (d x)))`
($) :: forall a b. (a -> b) -> a -> b
($) f x = f x

-- | Applies an argument to a function.
-- |
-- | ```purescript
-- | products # filter isInStock # groupBy productCategory # length
-- | ```
-- |
-- | is equivalent to:
-- |
-- | ```purescript
-- | length (groupBy productCategory (filter isInStock products))
-- | ```
-- |
-- | `(#)` is different from [`($)`](#-1) because it is left-infix instead of
-- | right: `x # a # b # c # d = (((x # a) # b) # c) # d = d (c (b (a x)))`
(#) :: forall a b. a -> (a -> b) -> b
(#) x f = f x

-- | Flips the order of the arguments to a function of two arguments.
-- |
-- | ```purescript
-- | flip const 1 2 = const 2 1 = 2
-- | ```
flip :: forall a b c. (a -> b -> c) -> b -> a -> c
flip f b a = f a b

-- | Returns its first argument and ignores its second.
-- |
-- | ```purescript
-- | const 1 "hello" = 1
-- | ```
const :: forall a b. a -> b -> a
const a _ = a

-- | This function returns its first argument, and can be used to assert type
-- | equalities. This can be useful when types are otherwise ambiguous.
-- |
-- | ```purescript
-- | main = print $ [] `asTypeOf` [0]
-- | ```
-- |
-- | If instead, we had written `main = print []`, the type of the argument
-- | `[]` would have been ambiguous, resulting in a compile-time error.
asTypeOf :: forall a. a -> a -> a
asTypeOf x _ = x

-- | An alias for `true`, which can be useful in guard clauses:
-- |
-- | ```purescript
-- | max x y | x >= y    = x
-- |         | otherwise = y
-- | ```
otherwise :: Boolean
otherwise = true

-- | Attaches an element to the front of an array, creating a new array.
-- |
-- | ```purescript
-- | cons 1 [2, 3, 4] = [1, 2, 3, 4]
-- | ```
-- |
-- | Note, the running time of this function is `O(n)`.
foreign import cons
  """
  function cons(e) {
    return function(l) {
      return [e].concat(l);
    };
  }
  """ :: forall a. a -> [a] -> [a]

infixr 6 :

-- | An infix alias for `cons`.
-- |
-- | Note, the running time of this function is `O(n)`.
(:) :: forall a. a -> [a] -> [a]
(:) = cons

infixr 9 >>>
infixr 9 <<<

-- | A `Semigroupoid` is similar to a [`Category`](#category) but does not
-- | require an identity element `id`, just composable morphisms.
-- |
-- | `Semigroupoid`s must satisfy the following law:
-- |
-- | - Associativity: `p <<< (q <<< r) = (p <<< q) <<< r`
-- |
-- | One example of a `Semigroupoid` is the function type constructor `(->)`,
-- | with `(<<<)` defined as function composition.
class Semigroupoid a where
  compose :: forall b c d. a c d -> a b c -> a b d

instance semigroupoidArr :: Semigroupoid (->) where
  compose f g x = f (g x)

(<<<) :: forall a b c d. (Semigroupoid a) => a c d -> a b c -> a b d
(<<<) = compose

-- | Forwards composition, or `(<<<)` with its arguments reversed.
(>>>) :: forall a b c d. (Semigroupoid a) => a b c -> a c d -> a b d
(>>>) f g = g <<< f

-- | `Category`s consist of objects and composable morphisms between them, and
-- | as such are [`Semigroupoids`](#semigroupoid), but unlike `semigroupoids`
-- | must have an identity element.
-- |
-- | Instances must satisfy the following law in addition to the
-- | `Semigroupoid` law:
-- |
-- | - Identity: `id <<< p = p <<< id = p`
class (Semigroupoid a) <= Category a where
  id :: forall t. a t t

instance categoryArr :: Category (->) where
  id x = x

infixl 4 <$>
infixl 1 <#>

-- | A `Functor` is a type constructor which supports a mapping operation
-- | `(<$>)`.
-- |
-- | `(<$>)` can be used to turn functions `a -> b` into functions
-- | `f a -> f b` whose argument and return types use the type constructor `f`
-- | to represent some computational context.
-- |
-- | Instances must satisfy the following laws:
-- |
-- | - Identity: `(<$>) id = id`
-- | - Composition: `(<$>) (f <<< g) = (f <$>) <<< (g <$>)`
class Functor f where
  map :: forall a b. (a -> b) -> f a -> f b

instance functorArr :: Functor ((->) r) where
  map = compose

(<$>) :: forall f a b. (Functor f) => (a -> b) -> f a -> f b
(<$>) = map

-- | `(<#>)` is `(<$>)` with its arguments reversed. For example:
-- |
-- | ```purescript
-- | [1, 2, 3] <#> \n -> n * n
-- | ```
(<#>) :: forall f a b. (Functor f) => f a -> (a -> b) -> f b
(<#>) fa f = f <$> fa

-- | The `void` function is used to ignore the type wrapped by a
-- | [`Functor`](#functor), replacing it with `Unit` and keeping only the type
-- | information provided by the type constructor itself.
-- |
-- | `void` is often useful when using `do` notation to change the return type
-- | of a monadic computation:
-- |
-- | ```purescript
-- | main = forE 1 10 \n -> void do
-- |   print n
-- |   print (n * n)
-- | ```
void :: forall f a. (Functor f) => f a -> f Unit
void fa = const unit <$> fa

infixl 4 <*>

-- | The `Apply` class provides the `(<*>)` which is used to apply a function
-- | to an argument under a type constructor.
-- |
-- | `Apply` can be used to lift functions of two or more arguments to work on
-- | values wrapped with the type constructor `f`. It might also be understood
-- | in terms of the `lift2` function:
-- |
-- | ```purescript
-- | lift2 :: forall f a b c. (Apply f) => (a -> b -> c) -> f a -> f b -> f c
-- | lift2 f a b = f <$> a <*> b
-- | ```
-- |
-- | `(<*>)` is recovered from `lift2` as `lift2 ($)`. That is, `(<*>)` lifts
-- | the function application operator `($)` to arguments wrapped with the
-- | type constructor `f`.
-- |
-- | Instances must satisfy the following law in addition to the `Functor`
-- | laws:
-- |
-- | - Associative composition: `(<<<) <$> f <*> g <*> h = f <*> (g <*> h)`
-- |
-- | Formally, `Apply` represents a strong lax semi-monoidal endofunctor.
class (Functor f) <= Apply f where
  apply :: forall a b. f (a -> b) -> f a -> f b

instance applyArr :: Apply ((->) r) where
  apply f g x = f x (g x)

(<*>) :: forall f a b. (Apply f) => f (a -> b) -> f a -> f b
(<*>) = apply

-- | The `Applicative` type class extends the [`Apply`](#apply) type class
-- | with a `pure` function, which can be used to create values of type `f a`
-- | from values of type `a`.
-- |
-- | Where [`Apply`](#apply) provides the ability to lift functions of two or
-- | more arguments to functions whose arguments are wrapped using `f`, and
-- | [`Functor`](#functor) provides the ability to lift functions of one
-- | argument, `pure` can be seen as the function which lifts functions of
-- | _zero_ arguments. That is, `Applicative` functors support a lifting
-- | operation for any number of function arguments.
-- |
-- | Instances must satisfy the following laws in addition to the `Apply`
-- | laws:
-- |
-- | - Identity: `(pure id) <*> v = v`
-- | - Composition: `(pure <<<) <*> f <*> g <*> h = f <*> (g <*> h)`
-- | - Homomorphism: `(pure f) <*> (pure x) = pure (f x)`
-- | - Interchange: `u <*> (pure y) = (pure ($ y)) <*> u`
class (Apply f) <= Applicative f where
  pure :: forall a. a -> f a

instance applicativeArr :: Applicative ((->) r) where
  pure = const

-- | `return` is an alias for `pure`.
return :: forall m a. (Applicative m) => a -> m a
return = pure

-- | `liftA1` provides a default implementation of `(<$>)` for any
-- | [`Applicative`](#applicative) functor, without using `(<$>)` as provided
-- | by the [`Functor`](#functor)-[`Applicative`](#applicative) superclass
-- | relationship.
-- |
-- | `liftA1` can therefore be used to write [`Functor`](#functor) instances
-- | as follows:
-- |
-- | ```purescript
-- | instance functorF :: Functor F where
-- |   map = liftA1
-- | ```
liftA1 :: forall f a b. (Applicative f) => (a -> b) -> f a -> f b
liftA1 f a = pure f <*> a

infixl 1 >>=

-- | The `Bind` type class extends the [`Apply`](#apply) type class with a
-- | "bind" operation `(>>=)` which composes computations in sequence, using
-- | the return value of one computation to determine the next computation.
-- |
-- | The `>>=` operator can also be expressed using `do` notation, as follows:
-- |
-- | ```purescript
-- | x >>= f = do y <- x
-- |              f y
-- | ```
-- |
-- | where the function argument of `f` is given the name `y`.
-- |
-- | Instances must satisfy the following law in addition to the `Apply`
-- | laws:
-- |
-- | - Associativity: `(x >>= f) >>= g = x >>= (\k => f k >>= g)`
-- |
-- | Associativity tells us that we can regroup operations which use `do`
-- | notation so that we can unambiguously write, for example:
-- |
-- | ```purescript
-- | do x <- m1
-- |    y <- m2 x
-- |    m3 x y
-- | ```
class (Apply m) <= Bind m where
  bind :: forall a b. m a -> (a -> m b) -> m b

instance bindArr :: Bind ((->) r) where
  bind m f x = f (m x) x

(>>=) :: forall m a b. (Monad m) => m a -> (a -> m b) -> m b
(>>=) = bind

-- | The `Monad` type class combines the operations of the `Bind` and
-- | `Applicative` type classes. Therefore, `Monad` instances represent type
-- | constructors which support sequential composition, and also lifting of
-- | functions of arbitrary arity.
-- |
-- | Instances must satisfy the following laws in addition to the
-- | `Applicative` and `Bind` laws:
-- |
-- | - Left Identity: `pure x >>= f = f x`
-- | - Right Identity: `x >>= pure = x`
class (Applicative m, Bind m) <= Monad m

instance monadArr :: Monad ((->) r)

-- | `liftM1` provides a default implementation of `(<$>)` for any
-- | [`Monad`](#monad), without using `(<$>)` as provided by the
-- | [`Functor`](#functor)-[`Monad`](#monad) superclass relationship.
-- |
-- | `liftM1` can therefore be used to write [`Functor`](#functor) instances
-- | as follows:
-- |
-- | ```purescript
-- | instance functorF :: Functor F where
-- |   map = liftM1
-- | ```
liftM1 :: forall m a b. (Monad m) => (a -> b) -> m a -> m b
liftM1 f a = do
  a' <- a
  return (f a')

-- | `ap` provides a default implementation of `(<*>)` for any
-- | [`Monad`](#monad), without using `(<*>)` as provided by the
-- | [`Apply`](#apply)-[`Monad`](#monad) superclass relationship.
-- |
-- | `ap` can therefore be used to write [`Apply`](#apply) instances as
-- | follows:
-- |
-- | ```purescript
-- | instance applyF :: Apply F where
-- |   apply = ap
-- | ```
ap :: forall m a b. (Monad m) => m (a -> b) -> m a -> m b
ap f a = do
  f' <- f
  a' <- a
  return (f' a')

infixr 5 <>
infixr 5 ++

-- | The `Semigroup` type class identifies an associative operation on a type.
-- |
-- | Instances are required to satisfy the following law:
-- |
-- | - Associativity: `(x <> y) <> z = x <> (y <> z)`
-- |
-- | One example of a `Semigroup` is `String`, with `(<>)` defined as string
-- | concatenation.
class Semigroup a where
  append :: a -> a -> a

-- | `(<>)` is an alias for `append`.
(<>) :: forall s. (Semigroup s) => s -> s -> s
(<>) = append

-- | `(++)` is an alias for `append`.
(++) :: forall s. (Semigroup s) => s -> s -> s
(++) = append

instance semigroupString :: Semigroup String where
  append = concatString

instance semigroupUnit :: Semigroup Unit where
  append _ _ = unit

instance semigroupArr :: (Semigroup s') => Semigroup (s -> s') where
  append f g = \x -> f x <> g x

instance semigroupOrdering :: Semigroup Ordering where
  append LT _ = LT
  append GT _ = GT
  append EQ y = y

foreign import concatString
  """
  function concatString(s1) {
    return function(s2) {
      return s1 + s2;
    };
  }
  """ :: String -> String -> String

infixl 6 +
infixl 7 *

-- | The `Semiring` class is for types that support an addition and
-- | multiplication operation.
-- |
-- | Instances must satisfy the following laws:
-- |
-- | - Commutative monoid under addition:
-- |   - Associativity: `(a + b) + c = a + (b + c)`
-- |   - Identity: `zero + a = a + zero = a`
-- |   - Commutative: `a + b = b + a`
-- | - Monoid under multiplication:
-- |   - Associativity: `(a * b) * c = a * (b * c)`
-- |   - Identity: `one * a = a * one = a`
-- | - Multiplication distributes over addition:
-- |   - Left distributivity: `a * (b + c) = (a * b) + (a * c)`
-- |   - Right distributivity: `(a + b) * c = (a * c) + (b * c)`
-- | - Annihiliation: `zero * a = a * zero = zero`
class Semiring a where
  add  :: a -> a -> a
  zero :: a
  mul  :: a -> a -> a
  one  :: a

instance semiringNumber :: Semiring Number where
  add = numAdd
  zero = 0
  mul = numMul
  one = 1

instance semiringUnit :: Semiring Unit where
  add _ _ = unit
  zero = unit
  mul _ _ = unit
  one = unit

(+) :: forall a. (Semiring a) => a -> a -> a
(+) = add

(*) :: forall a. (Semiring a) => a -> a -> a
(*) = mul

infixl 6 -

-- | The `Ring` class is for types that support addition, multiplication,
-- | and subtraction operations.
-- |
-- | Instances must satisfy the following law in addition to the `Semiring`
-- | laws:
-- |
-- | - Additive inverse: `a + (-a) = (-a) + a = zero`
class (Semiring a) <= Ring a where
  sub :: a -> a -> a

instance ringNumber :: Ring Number where
  sub = numSub

instance ringUnit :: Ring Unit where
  sub _ _ = unit

(-) :: forall a. (Ring a) => a -> a -> a
(-) = sub

negate :: forall a. (Ring a) => a -> a
negate a = zero - a

infixl 7 /

-- | The `ModuloSemiring` class is for types that support addition,
-- | multiplication, division, and modulo (division remainder) operations.
-- |
-- | Instances must satisfy the following law in addition to the `Semiring`
-- | laws:
-- |
-- | - Remainder: `a / b * b + (a `mod` b) = a`
class (Semiring a) <= ModuloSemiring a where
  div :: a -> a -> a
  mod :: a -> a -> a

instance moduloSemiringNumber :: ModuloSemiring Number where
  div = numDiv
  mod _ _ = 0

instance moduloSemiringUnit :: ModuloSemiring Unit where
  div _ _ = unit
  mod _ _ = unit

(/) :: forall a. (ModuloSemiring a) => a -> a -> a
(/) = div

-- | A `Ring` where every nonzero element has a multiplicative inverse.
-- |
-- | Instances must satisfy the following law in addition to the `Ring` and
-- | `ModuloSemiring` laws:
-- |
-- | - Multiplicative inverse: `(one / x) * x = one`
-- |
-- | As a consequence of this ```a `mod` b = zero``` as no divide operation
-- | will have a remainder.
class (Ring a, ModuloSemiring a) <= DivisionRing a

instance divisionRingNumber :: DivisionRing Number

instance divisionRingUnit :: DivisionRing Unit

-- | The `Num` class is for types that are commutative fields.
-- |
-- | Instances must satisfy the following law in addition to the
-- | `DivisionRing` laws:
-- |
-- | - Commutative multiplication: `a * b = b * a`
class (DivisionRing a) <= Num a

instance numNumber :: Num Number

instance numUnit :: Num Unit

foreign import numAdd
  """
  function numAdd(n1) {
    return function(n2) {
      return n1 + n2;
    };
  }
  """ :: Number -> Number -> Number

foreign import numMul
  """
  function numMul(n1) {
    return function(n2) {
      return n1 * n2;
    };
  }
  """ :: Number -> Number -> Number

foreign import numDiv
  """
  function numDiv(n1) {
    return function(n2) {
      return n1 / n2;
    };
  }
  """ :: Number -> Number -> Number

foreign import numSub
  """
  function numSub(n1) {
    return function(n2) {
      return n1 - n2;
    };
  }
  """ :: Number -> Number -> Number

infix 4 ==
infix 4 /=

-- | The `Eq` type class represents types which support decidable equality.
-- |
-- | `Eq` instances should satisfy the following laws:
-- |
-- | - Reflexivity: `x == x = true`
-- | - Symmetry: `x == y = y == x`
-- | - Transitivity: if `x == y` and `y == z` then `x == z`
-- | - Negation: `x /= y = not (x == y)`
class Eq a where
  eq :: a -> a -> Boolean

(==) :: forall a. (Eq a) => a -> a -> Boolean
(==) = eq

(/=) :: forall a. (Eq a) => a -> a -> Boolean
(/=) x y = not (x == y)

instance eqBoolean :: Eq Boolean where
  eq = refEq

instance eqNumber :: Eq Number where
  eq = refEq

instance eqString :: Eq String where
  eq = refEq

instance eqUnit :: Eq Unit where
  eq _ _ = true

instance eqArray :: (Eq a) => Eq [a] where
  eq = eqArrayImpl (==)

instance eqOrdering :: Eq Ordering where
  eq LT LT = true
  eq GT GT = true
  eq EQ EQ = true
  eq _  _  = false

foreign import refEq
  """
  function refEq(r1) {
    return function(r2) {
      return r1 === r2;
    };
  }
  """ :: forall a. a -> a -> Boolean

foreign import refIneq
  """
  function refIneq(r1) {
    return function(r2) {
      return r1 !== r2;
    };
  }
  """ :: forall a. a -> a -> Boolean

foreign import eqArrayImpl
  """
  function eqArrayImpl(f) {
    return function(xs) {
      return function(ys) {
        if (xs.length !== ys.length) return false;
        for (var i = 0; i < xs.length; i++) {
          if (!f(xs[i])(ys[i])) return false;
        }
        return true;
      };
    };
  }
  """ :: forall a. (a -> a -> Boolean) -> [a] -> [a] -> Boolean

-- | The `Ordering` data type represents the three possible outcomes of
-- | comparing two values:
-- |
-- | `LT` - The first value is _less than_ the second.
-- | `GT` - The first value is _greater than_ the second.
-- | `EQ` - The first value is _equal to_ or _incomparable to_ the second.
data Ordering = LT | GT | EQ

-- | The `Ord` type class represents types which support comparisons.
-- |
-- | `Ord` instances should satisfy the laws of _partially orderings_:
-- |
-- | - Reflexivity: `a <= a`
-- | - Antisymmetry: if `a <= b` and `b <= a` then `a = b`
-- | - Transitivity: if `a <= b` and `b <= c` then `a <= c`
class (Eq a) <= Ord a where
  compare :: a -> a -> Ordering

instance ordBoolean :: Ord Boolean where
  compare false false = EQ
  compare false true  = LT
  compare true  true  = EQ
  compare true  false = GT

instance ordNumber :: Ord Number where
  compare = unsafeCompare

instance ordString :: Ord String where
  compare = unsafeCompare

instance ordUnit :: Ord Unit where
  compare _ _ = EQ

instance ordArray :: (Ord a) => Ord [a] where
  compare [] [] = EQ
  compare [] _ = LT
  compare _ [] = GT
  compare (x:xs) (y:ys) = case compare x y of
    EQ -> compare xs ys
    other -> other

instance ordOrdering :: Ord Ordering where
  compare LT LT = EQ
  compare EQ EQ = EQ
  compare GT GT = EQ
  compare LT _  = LT
  compare EQ LT = GT
  compare EQ GT = LT
  compare GT _  = GT

infixl 4 <
infixl 4 >
infixl 4 <=
infixl 4 >=

-- | Test whether one value is _strictly less than_ another.
(<) :: forall a. (Ord a) => a -> a -> Boolean
(<) a1 a2 = case a1 `compare` a2 of
  LT -> true
  _ -> false

-- | Test whether one value is _strictly greater than_ another.
(>) :: forall a. (Ord a) => a -> a -> Boolean
(>) a1 a2 = case a1 `compare` a2 of
  GT -> true
  _ -> false

-- | Test whether one value is _non-strictly less than_ another.
(<=) :: forall a. (Ord a) => a -> a -> Boolean
(<=) a1 a2 = case a1 `compare` a2 of
  GT -> false
  _ -> true

-- | Test whether one value is _non-strictly greater than_ another.
(>=) :: forall a. (Ord a) => a -> a -> Boolean
(>=) a1 a2 = case a1 `compare` a2 of
  LT -> false
  _ -> true

unsafeCompare :: forall a. a -> a -> Ordering
unsafeCompare = unsafeCompareImpl LT EQ GT

foreign import unsafeCompareImpl
  """
  function unsafeCompareImpl(lt) {
    return function(eq) {
      return function(gt) {
        return function(x) {
          return function(y) {
            return x < y ? lt : x > y ? gt : eq;
          };
        };
      };
    };
  }
  """ :: forall a. Ordering -> Ordering -> Ordering -> a -> a -> Ordering

-- | The `Bounded` type class represents types that are finite partially
-- | ordered sets.
-- |
-- | Instances should satisfy the following law in addition to the `Ord` laws:
-- |
-- | - Ordering: `bottom <= a <= top`
class (Ord a) <= Bounded a where
  top :: a
  bottom :: a

instance boundedBoolean :: Bounded Boolean where
  top = true
  bottom = false

instance boundedUnit :: Bounded Unit where
  top = unit
  bottom = unit

instance boundedOrdering :: Bounded Ordering where
  top = GT
  bottom = LT

-- | The `Lattice` type class represents types that are partially ordered
-- | sets with a supremum (`sup` or `||`) and infimum (`inf` or `&&`).
-- |
-- | Instances should satisfy the following laws in addition to the `Ord`
-- | laws:
-- |
-- | - Associativity:
-- |   - `a || (b || c) = (a || b) || c`
-- |   - `a && (b && c) = (a && b) && c`
-- | - Commutativity:
-- |   - `a || b = b || a`
-- |   - `a && b = b && a`
-- | - Absorption:
-- |   - `a || (a && b) = a`
-- |   - `a && (a || b) = a`
-- | - Idempotent:
-- |   - `a || a = a`
-- |   - `a && a = a`
class (Ord a) <= Lattice a where
  sup :: a -> a -> a
  inf :: a -> a -> a

instance latticeBoolean :: Lattice Boolean where
  sup = boolOr
  inf = boolAnd

instance latticeUnit :: Lattice Unit where
  sup _ _ = unit
  inf _ _ = unit

infixr 2 ||
infixr 3 &&

-- | The `sup` operator.
(||) :: forall a. (Lattice a) => a -> a -> a
(||) = sup

-- | The `inf` operator.
(&&) :: forall a. (Lattice a) => a -> a -> a
(&&) = inf

-- | The `BoundedLattice` type class represents types that are finite
-- | lattices.
-- |
-- | Instances should satisfy the following law in addition to the `Lattice`
-- | and `Bounded` laws:
-- |
-- | - Identity:
-- |   - `a || bottom = a`
-- |   - `a && top = a`
-- | - Annihiliation:
-- |   - `a || top = top`
-- |   - `a && bottom = bottom`
class (Bounded a, Lattice a) <= BoundedLattice a

instance boundedLatticeBoolean :: BoundedLattice Boolean

instance boundedLatticeUnit :: BoundedLattice Unit

-- | The `ComplementedLattice` type class represents types that are lattices
-- | where every member is also uniquely complemented.
-- |
-- | Instances should satisfy the following law in addition to the
-- | `BoundedLattice` laws:
-- |
-- | - Complemented:
-- |   - `not a || a == top`
-- |   - `not a && a == bottom`
-- | - Double negation:
-- |   - `not <<< not == id`
class (BoundedLattice a) <= ComplementedLattice a where
  not :: a -> a

instance complementedLatticeBoolean :: ComplementedLattice Boolean where
  not = boolNot

instance complementedLatticeUnit :: ComplementedLattice Unit where
  not _ = unit

-- | The `DistributiveLattice` type class represents types that are lattices
-- | where the `&&` and `||` distribute over each other.
-- |
-- | Instances should satisfy the following law in addition to the `Lattice`
-- | laws:
-- |
-- | - Distributivity: `x && (y || z) = (x && y) || (x && z)`
class (Lattice a) <= DistributiveLattice a

instance distributiveLatticeBoolean :: DistributiveLattice Boolean

instance distributiveLatticeUnit :: DistributiveLattice Unit

-- | The `BooleanAlgebra` type class represents types that are Boolean
-- | algebras, also known as Boolean lattices.
-- |
-- | Instances should satisfy the `ComplementedLattice` and
-- | `DistributiveLattice` laws.
class (ComplementedLattice a, DistributiveLattice a) <= BooleanAlgebra a

instance booleanAlgebraBoolean :: BooleanAlgebra Boolean

instance booleanAlgebraUnit :: BooleanAlgebra Unit

foreign import boolOr
  """
  function boolOr(b1) {
    return function(b2) {
      return b1 || b2;
    };
  }
  """ :: Boolean -> Boolean -> Boolean

foreign import boolAnd
  """
  function boolAnd(b1) {
    return function(b2) {
      return b1 && b2;
    };
  }
  """  :: Boolean -> Boolean -> Boolean

foreign import boolNot
  """
  function boolNot(b) {
    return !b;
  }
  """ :: Boolean -> Boolean

-- | The `Show` type class represents those types which can be converted into
-- | a human-readable `String` representation.
-- |
-- | While not required, it is recommended that for any expression `x`, the
-- | string `show x` be executable PureScript code which evaluates to the same
-- | value as the expression `x`.
class Show a where
  show :: a -> String

instance showBoolean :: Show Boolean where
  show true = "true"
  show false = "false"

instance showNumber :: Show Number where
  show = showNumberImpl

instance showString :: Show String where
  show = showStringImpl

instance showUnit :: Show Unit where
  show _ = "unit"

instance showArray :: (Show a) => Show [a] where
  show = showArrayImpl show

instance showOrdering :: Show Ordering where
  show LT = "LT"
  show GT = "GT"
  show EQ = "EQ"

foreign import showNumberImpl
  """
  function showNumberImpl(n) {
    return n.toString();
  }
  """ :: Number -> String

foreign import showStringImpl
  """
  function showStringImpl(s) {
    return JSON.stringify(s);
  }
  """ :: String -> String

foreign import showArrayImpl
  """
  function showArrayImpl(f) {
    return function(xs) {
      var ss = [];
      for (var i = 0, l = xs.length; i < l; i++) {
        ss[i] = f(xs[i]);
      }
      return '[' + ss.join(',') + ']';
    };
  }
  """ :: forall a. (a -> String) -> [a] -> String

module Prelude
  ( Unit(..), unit
  , ($), (#)
  , flip
  , const
  , asTypeOf
  , otherwise
  , (:), cons
  , Semigroupoid, compose, (<<<), (>>>)
  , Category, id
  , Functor, map, (<$>), (<#>), void
  , Apply, apply, (<*>)
  , Applicative, pure, liftA1
  , Bind, bind, (>>=)
  , Monad, return, liftM1, ap
  , Semigroup, append, (<>), (++)
  , Semiring, add, zero, mul, one, (+), (*)
  , ModuloSemiring, div, mod, (/)
  , Ring, sub, negate, (-)
  , Num
  , DivisionRing
  , Eq, eq, (==), (/=)
  , Ordering(..), Ord, compare, (<), (>), (<=), (>=)
  , Bounded, top, bottom
  , Lattice, sup, inf, (||), (&&)
  , BoundedLattice
  , ComplementedLattice, not
  , DistributiveLattice
  , BooleanAlgebra
  , Show, show
  ) where

-- | The `Unit` type has a single inhabitant, called `unit`. It represents
-- | values with no computational content.
-- |
-- | `Unit` is often used, wrapped in a monadic type constructor, as the
-- | return type of a computation where only
-- | the _effects_ are important.
newtype Unit = Unit {}

-- | `unit` is the sole inhabitant of the `Unit` type.
unit :: Unit
unit = Unit {}

infixr 0 $
infixl 0 #

-- | Applies a function to its argument.
-- |
-- | ```purescript
-- | length $ groupBy productCategory $ filter isInStock $ products
-- | ```
-- |
-- | is equivalent to:
-- |
-- | ```purescript
-- | length (groupBy productCategory (filter isInStock products))
-- | ```
-- |
-- | `($)` is different from [`(#)`](#-2) because it is right-infix instead of
-- | left: `a $ b $ c $ d x = a $ (b $ (c $ (d $ x))) = a (b (c (d x)))`
($) :: forall a b. (a -> b) -> a -> b
($) f x = f x

-- | Applies an argument to a function.
-- |
-- | ```purescript
-- | products # filter isInStock # groupBy productCategory # length
-- | ```
-- |
-- | is equivalent to:
-- |
-- | ```purescript
-- | length (groupBy productCategory (filter isInStock products))
-- | ```
-- |
-- | `(#)` is different from [`($)`](#-1) because it is left-infix instead of
-- | right: `x # a # b # c # d = (((x # a) # b) # c) # d = d (c (b (a x)))`
(#) :: forall a b. a -> (a -> b) -> b
(#) x f = f x

-- | Flips the order of the arguments to a function of two arguments.
-- |
-- | ```purescript
-- | flip const 1 2 = const 2 1 = 2
-- | ```
flip :: forall a b c. (a -> b -> c) -> b -> a -> c
flip f b a = f a b

-- | Returns its first argument and ignores its second.
-- |
-- | ```purescript
-- | const 1 "hello" = 1
-- | ```
const :: forall a b. a -> b -> a
const a _ = a

-- | This function returns its first argument, and can be used to assert type
-- | equalities. This can be useful when types are otherwise ambiguous.
-- |
-- | ```purescript
-- | main = print $ [] `asTypeOf` [0]
-- | ```
-- |
-- | If instead, we had written `main = print []`, the type of the argument
-- | `[]` would have been ambiguous, resulting in a compile-time error.
asTypeOf :: forall a. a -> a -> a
asTypeOf x _ = x

-- | An alias for `true`, which can be useful in guard clauses:
-- |
-- | ```purescript
-- | max x y | x >= y    = x
-- |         | otherwise = y
-- | ```
otherwise :: Boolean
otherwise = true

-- | Attaches an element to the front of an array, creating a new array.
-- |
-- | ```purescript
-- | cons 1 [2, 3, 4] = [1, 2, 3, 4]
-- | ```
-- |
-- | Note, the running time of this function is `O(n)`.
foreign import cons
  """
  function cons(e) {
    return function(l) {
      return [e].concat(l);
    };
  }
  """ :: forall a. a -> [a] -> [a]

infixr 6 :

-- | An infix alias for `cons`.
-- |
-- | Note, the running time of this function is `O(n)`.
(:) :: forall a. a -> [a] -> [a]
(:) = cons

infixr 9 >>>
infixr 9 <<<

-- | A `Semigroupoid` is similar to a [`Category`](#category) but does not
-- | require an identity element `id`, just composable morphisms.
-- |
-- | `Semigroupoid`s must satisfy the following law:
-- |
-- | - Associativity: `p <<< (q <<< r) = (p <<< q) <<< r`
-- |
-- | One example of a `Semigroupoid` is the function type constructor `(->)`,
-- | with `(<<<)` defined as function composition.
class Semigroupoid a where
  compose :: forall b c d. a c d -> a b c -> a b d

instance semigroupoidArr :: Semigroupoid (->) where
  compose f g x = f (g x)

(<<<) :: forall a b c d. (Semigroupoid a) => a c d -> a b c -> a b d
(<<<) = compose

-- | Forwards composition, or `(<<<)` with its arguments reversed.
(>>>) :: forall a b c d. (Semigroupoid a) => a b c -> a c d -> a b d
(>>>) f g = g <<< f

-- | `Category`s consist of objects and composable morphisms between them, and
-- | as such are [`Semigroupoids`](#semigroupoid), but unlike `semigroupoids`
-- | must have an identity element.
-- |
-- | Instances must satisfy the following law in addition to the
-- | `Semigroupoid` law:
-- |
-- | - Identity: `id <<< p = p <<< id = p`
class (Semigroupoid a) <= Category a where
  id :: forall t. a t t

instance categoryArr :: Category (->) where
  id x = x

infixl 4 <$>
infixl 1 <#>

-- | A `Functor` is a type constructor which supports a mapping operation
-- | `(<$>)`.
-- |
-- | `(<$>)` can be used to turn functions `a -> b` into functions
-- | `f a -> f b` whose argument and return types use the type constructor `f`
-- | to represent some computational context.
-- |
-- | Instances must satisfy the following laws:
-- |
-- | - Identity: `(<$>) id = id`
-- | - Composition: `(<$>) (f <<< g) = (f <$>) <<< (g <$>)`
class Functor f where
  map :: forall a b. (a -> b) -> f a -> f b

instance functorArr :: Functor ((->) r) where
  map = compose

(<$>) :: forall f a b. (Functor f) => (a -> b) -> f a -> f b
(<$>) = map

-- | `(<#>)` is `(<$>)` with its arguments reversed. For example:
-- |
-- | ```purescript
-- | [1, 2, 3] <#> \n -> n * n
-- | ```
(<#>) :: forall f a b. (Functor f) => f a -> (a -> b) -> f b
(<#>) fa f = f <$> fa

-- | The `void` function is used to ignore the type wrapped by a
-- | [`Functor`](#functor), replacing it with `Unit` and keeping only the type
-- | information provided by the type constructor itself.
-- |
-- | `void` is often useful when using `do` notation to change the return type
-- | of a monadic computation:
-- |
-- | ```purescript
-- | main = forE 1 10 \n -> void do
-- |   print n
-- |   print (n * n)
-- | ```
void :: forall f a. (Functor f) => f a -> f Unit
void fa = const unit <$> fa

infixl 4 <*>

-- | The `Apply` class provides the `(<*>)` which is used to apply a function
-- | to an argument under a type constructor.
-- |
-- | `Apply` can be used to lift functions of two or more arguments to work on
-- | values wrapped with the type constructor `f`. It might also be understood
-- | in terms of the `lift2` function:
-- |
-- | ```purescript
-- | lift2 :: forall f a b c. (Apply f) => (a -> b -> c) -> f a -> f b -> f c
-- | lift2 f a b = f <$> a <*> b
-- | ```
-- |
-- | `(<*>)` is recovered from `lift2` as `lift2 ($)`. That is, `(<*>)` lifts
-- | the function application operator `($)` to arguments wrapped with the
-- | type constructor `f`.
-- |
-- | Instances must satisfy the following law in addition to the `Functor`
-- | laws:
-- |
-- | - Associative composition: `(<<<) <$> f <*> g <*> h = f <*> (g <*> h)`
-- |
-- | Formally, `Apply` represents a strong lax semi-monoidal endofunctor.
class (Functor f) <= Apply f where
  apply :: forall a b. f (a -> b) -> f a -> f b

instance applyArr :: Apply ((->) r) where
  apply f g x = f x (g x)

(<*>) :: forall f a b. (Apply f) => f (a -> b) -> f a -> f b
(<*>) = apply

-- | The `Applicative` type class extends the [`Apply`](#apply) type class
-- | with a `pure` function, which can be used to create values of type `f a`
-- | from values of type `a`.
-- |
-- | Where [`Apply`](#apply) provides the ability to lift functions of two or
-- | more arguments to functions whose arguments are wrapped using `f`, and
-- | [`Functor`](#functor) provides the ability to lift functions of one
-- | argument, `pure` can be seen as the function which lifts functions of
-- | _zero_ arguments. That is, `Applicative` functors support a lifting
-- | operation for any number of function arguments.
-- |
-- | Instances must satisfy the following laws in addition to the `Apply`
-- | laws:
-- |
-- | - Identity: `(pure id) <*> v = v`
-- | - Composition: `(pure <<<) <*> f <*> g <*> h = f <*> (g <*> h)`
-- | - Homomorphism: `(pure f) <*> (pure x) = pure (f x)`
-- | - Interchange: `u <*> (pure y) = (pure ($ y)) <*> u`
class (Apply f) <= Applicative f where
  pure :: forall a. a -> f a

instance applicativeArr :: Applicative ((->) r) where
  pure = const

-- | `return` is an alias for `pure`.
return :: forall m a. (Applicative m) => a -> m a
return = pure

-- | `liftA1` provides a default implementation of `(<$>)` for any
-- | [`Applicative`](#applicative) functor, without using `(<$>)` as provided
-- | by the [`Functor`](#functor)-[`Applicative`](#applicative) superclass
-- | relationship.
-- |
-- | `liftA1` can therefore be used to write [`Functor`](#functor) instances
-- | as follows:
-- |
-- | ```purescript
-- | instance functorF :: Functor F where
-- |   (<$>) = liftA1
-- | ```
liftA1 :: forall f a b. (Applicative f) => (a -> b) -> f a -> f b
liftA1 f a = pure f <*> a

infixl 1 >>=

-- | The `Bind` type class extends the [`Apply`](#apply) type class with a
-- | "bind" operation `(>>=)` which composes computations in sequence, using
-- | the return value of one computation to determine the next computation.
-- |
-- | The `>>=` operator can also be expressed using `do` notation, as follows:
-- |
-- | ```purescript
-- | x >>= f = do y <- x
-- |              f y
-- | ```
-- |
-- | where the function argument of `f` is given the name `y`.
-- |
-- | Instances must satisfy the following law in addition to the `Apply`
-- | laws:
-- |
-- | - Associativity: `(x >>= f) >>= g = x >>= (\k => f k >>= g)`
-- |
-- | Associativity tells us that we can regroup operations which use `do`
-- | notation so that we can unambiguously write, for example:
-- |
-- | ```purescript
-- | do x <- m1
-- |    y <- m2 x
-- |    m3 x y
-- | ```
class (Apply m) <= Bind m where
  bind :: forall a b. m a -> (a -> m b) -> m b

instance bindArr :: Bind ((->) r) where
  bind m f x = f (m x) x

(>>=) :: forall m a b. (Monad m) => m a -> (a -> m b) -> m b
(>>=) = bind

-- | The `Monad` type class combines the operations of the `Bind` and
-- | `Applicative` type classes. Therefore, `Monad` instances represent type
-- | constructors which support sequential composition, and also lifting of
-- | functions of arbitrary arity.
-- |
-- | Instances must satisfy the following laws in addition to the
-- | `Applicative` and `Bind` laws:
-- |
-- | - Left Identity: `pure x >>= f = f x`
-- | - Right Identity: `x >>= pure = x`
class (Applicative m, Bind m) <= Monad m

instance monadArr :: Monad ((->) r)

-- | `liftM1` provides a default implementation of `(<$>)` for any
-- | [`Monad`](#monad), without using `(<$>)` as provided by the
-- | [`Functor`](#functor)-[`Monad`](#monad) superclass relationship.
-- |
-- | `liftM1` can therefore be used to write [`Functor`](#functor) instances
-- | as follows:
-- |
-- | ```purescript
-- | instance functorF :: Functor F where
-- |   (<$>) = liftM1
-- | ```
liftM1 :: forall m a b. (Monad m) => (a -> b) -> m a -> m b
liftM1 f a = do
  a' <- a
  return (f a')

-- | `ap` provides a default implementation of `(<*>)` for any
-- | [`Monad`](#monad), without using `(<*>)` as provided by the
-- | [`Apply`](#apply)-[`Monad`](#monad) superclass relationship.
-- |
-- | `ap` can therefore be used to write [`Apply`](#apply) instances as
-- | follows:
-- |
-- | ```purescript
-- | instance applyF :: Apply F where
-- |   (<*>) = ap
-- | ```
ap :: forall m a b. (Monad m) => m (a -> b) -> m a -> m b
ap f a = do
  f' <- f
  a' <- a
  return (f' a')

infixr 5 <>
infixr 5 ++

-- | The `Semigroup` type class identifies an associative operation on a type.
-- |
-- | Instances are required to satisfy the following law:
-- |
-- | - Associativity: `(x <> y) <> z = x <> (y <> z)`
-- |
-- | One example of a `Semigroup` is `String`, with `(<>)` defined as string
-- | concatenation.
class Semigroup a where
  append :: a -> a -> a

-- | `(<>)` is an alias for `append`.
(<>) :: forall s. (Semigroup s) => s -> s -> s
(<>) = append

-- | `(++)` is an alias for `append`.
(++) :: forall s. (Semigroup s) => s -> s -> s
(++) = append

instance semigroupString :: Semigroup String where
  append = concatString

instance semigroupUnit :: Semigroup Unit where
  append _ _ = unit

instance semigroupArr :: (Semigroup s') => Semigroup (s -> s') where
  append f g = \x -> f x <> g x

instance semigroupOrdering :: Semigroup Ordering where
  append LT _ = LT
  append GT _ = GT
  append EQ y = y

foreign import concatString
  """
  function concatString(s1) {
    return function(s2) {
      return s1 + s2;
    };
  }
  """ :: String -> String -> String

infixl 6 +
infixl 7 *

-- | The `Semiring` class is for types that support an addition and
-- | multiplication operation.
-- |
-- | Instances must satisfy the following laws:
-- |
-- | - Commutative monoid under addition:
-- |   - Associativity: `(a + b) + c = a + (b + c)`
-- |   - Identity: `zero + a = a + zero = a`
-- |   - Commutative: `a + b = b + a`
-- | - Monoid under multiplication:
-- |   - Associativity: `(a * b) * c = a * (b * c)`
-- |   - Identity: `one * a = a * one = a`
-- | - Multiplication distributes over addition:
-- |   - Left distributivity: `a * (b + c) = (a * b) + (a * c)`
-- |   - Right distributivity: `(a + b) * c = (a * c) + (b * c)`
-- | - Annihiliation: `zero * a = a * zero = zero`
class Semiring a where
  add  :: a -> a -> a
  zero :: a
  mul  :: a -> a -> a
  one  :: a

instance semiringNumber :: Semiring Number where
  add = numAdd
  zero = 0
  mul = numMul
  one = 1

instance semiringUnit :: Semiring Unit where
  add _ _ = unit
  zero = unit
  mul _ _ = unit
  one = unit

(+) :: forall a. (Semiring a) => a -> a -> a
(+) = add

(*) :: forall a. (Semiring a) => a -> a -> a
(*) = mul

infixl 6 -

-- | The `Ring` class is for types that support addition, multiplication,
-- | and subtraction operations.
-- |
-- | Instances must satisfy the following law in addition to the `Semiring`
-- | laws:
-- |
-- | - Additive inverse: `a + (-a) = (-a) + a = zero`
class (Semiring a) <= Ring a where
  sub :: a -> a -> a

instance ringNumber :: Ring Number where
  sub = numSub

instance ringUnit :: Ring Unit where
  sub _ _ = unit

(-) :: forall a. (Ring a) => a -> a -> a
(-) = sub

negate :: forall a. (Ring a) => a -> a
negate a = zero - a

infixl 7 /

-- | The `ModuloSemiring` class is for types that support addition,
-- | multiplication, division, and modulo (division remainder) operations.
-- |
-- | Instances must satisfy the following law in addition to the `Semiring`
-- | laws:
-- |
-- | - Remainder: `a / b * b + (a `mod` b) = a`
class (Semiring a) <= ModuloSemiring a where
  div :: a -> a -> a
  mod :: a -> a -> a

instance moduloSemiringNumber :: ModuloSemiring Number where
  div = numDiv
  mod _ _ = 0

instance moduloSemiringUnit :: ModuloSemiring Unit where
  div _ _ = unit
  mod _ _ = unit

(/) :: forall a. (ModuloSemiring a) => a -> a -> a
(/) = div

-- | A `Ring` where every nonzero element has a multiplicative inverse.
-- |
-- | Instances must satisfy the following law in addition to the `Ring` and
-- | `ModuloSemiring` laws:
-- |
-- | - Multiplicative inverse: `(one / x) * x = one`
-- |
-- | As a consequence of this ```a `mod` b = zero``` as no divide operation
-- | will have a remainder.
class (Ring a, ModuloSemiring a) <= DivisionRing a

instance divisionRingNumber :: DivisionRing Number

instance divisionRingUnit :: DivisionRing Unit

-- | The `Num` class is for types that are commutative fields.
-- |
-- | Instances must satisfy the following law in addition to the
-- | `DivisionRing` laws:
-- |
-- | - Commutative multiplication: `a * b = b * a`
class (DivisionRing a) <= Num a

instance numNumber :: Num Number

instance numUnit :: Num Unit

foreign import numAdd
  """
  function numAdd(n1) {
    return function(n2) {
      return n1 + n2;
    };
  }
  """ :: Number -> Number -> Number

foreign import numMul
  """
  function numMul(n1) {
    return function(n2) {
      return n1 * n2;
    };
  }
  """ :: Number -> Number -> Number

foreign import numDiv
  """
  function numDiv(n1) {
    return function(n2) {
      return n1 / n2;
    };
  }
  """ :: Number -> Number -> Number

foreign import numSub
  """
  function numSub(n1) {
    return function(n2) {
      return n1 - n2;
    };
  }
  """ :: Number -> Number -> Number

infix 4 ==
infix 4 /=

-- | The `Eq` type class represents types which support decidable equality.
-- |
-- | `Eq` instances should satisfy the following laws:
-- |
-- | - Reflexivity: `x == x = true`
-- | - Symmetry: `x == y = y == x`
-- | - Transitivity: if `x == y` and `y == z` then `x == z`
-- | - Negation: `x /= y = not (x == y)`
-- |
-- | `(/=)` may be implemented in terms of `(==)`, but it might give a performance improvement to implement it separately.
class Eq a where
  eq :: a -> a -> Boolean

(==) :: forall a. (Eq a) => a -> a -> Boolean
(==) = eq

(/=) :: forall a. (Eq a) => a -> a -> Boolean
(/=) x y = not (x == y)

instance eqBoolean :: Eq Boolean where
  eq = refEq

instance eqNumber :: Eq Number where
  eq = refEq

instance eqString :: Eq String where
  eq = refEq

instance eqUnit :: Eq Unit where
  eq _ _ = true

instance eqArray :: (Eq a) => Eq [a] where
  eq = eqArrayImpl (==)

instance eqOrdering :: Eq Ordering where
  eq LT LT = true
  eq GT GT = true
  eq EQ EQ = true
  eq _  _  = false

foreign import refEq
  """
  function refEq(r1) {
    return function(r2) {
      return r1 === r2;
    };
  }
  """ :: forall a. a -> a -> Boolean

foreign import refIneq
  """
  function refIneq(r1) {
    return function(r2) {
      return r1 !== r2;
    };
  }
  """ :: forall a. a -> a -> Boolean

foreign import eqArrayImpl
  """
  function eqArrayImpl(f) {
    return function(xs) {
      return function(ys) {
        if (xs.length !== ys.length) return false;
        for (var i = 0; i < xs.length; i++) {
          if (!f(xs[i])(ys[i])) return false;
        }
        return true;
      };
    };
  }
  """ :: forall a. (a -> a -> Boolean) -> [a] -> [a] -> Boolean

-- | The `Ordering` data type represents the three possible outcomes of
-- | comparing two values:
-- |
-- | `LT` - The first value is _less than_ the second.
-- | `GT` - The first value is _greater than_ the second.
-- | `EQ` - The first value is _equal to_ or _incomparable to_ the second.
data Ordering = LT | GT | EQ

-- | The `Ord` type class represents types which support comparisons.
-- |
-- | `Ord` instances should satisfy the laws of _partially orderings_:
-- |
-- | - Reflexivity: `a <= a`
-- | - Antisymmetry: if `a <= b` and `b <= a` then `a = b`
-- | - Transitivity: if `a <= b` and `b <= c` then `a <= c`
class (Eq a) <= Ord a where
  compare :: a -> a -> Ordering

instance ordBoolean :: Ord Boolean where
  compare false false = EQ
  compare false true  = LT
  compare true  true  = EQ
  compare true  false = GT

instance ordNumber :: Ord Number where
  compare = unsafeCompare

instance ordString :: Ord String where
  compare = unsafeCompare

instance ordUnit :: Ord Unit where
  compare _ _ = EQ

instance ordArray :: (Ord a) => Ord [a] where
  compare [] [] = EQ
  compare [] _ = LT
  compare _ [] = GT
  compare (x:xs) (y:ys) = case compare x y of
    EQ -> compare xs ys
    other -> other

instance ordOrdering :: Ord Ordering where
  compare LT LT = EQ
  compare EQ EQ = EQ
  compare GT GT = EQ
  compare LT _  = LT
  compare EQ LT = GT
  compare EQ GT = LT
  compare GT _  = GT

infixl 4 <
infixl 4 >
infixl 4 <=
infixl 4 >=

-- | Test whether one value is _strictly less than_ another.
(<) :: forall a. (Ord a) => a -> a -> Boolean
(<) a1 a2 = case a1 `compare` a2 of
  LT -> true
  _ -> false

-- | Test whether one value is _strictly greater than_ another.
(>) :: forall a. (Ord a) => a -> a -> Boolean
(>) a1 a2 = case a1 `compare` a2 of
  GT -> true
  _ -> false

-- | Test whether one value is _non-strictly less than_ another.
(<=) :: forall a. (Ord a) => a -> a -> Boolean
(<=) a1 a2 = case a1 `compare` a2 of
  GT -> false
  _ -> true

-- | Test whether one value is _non-strictly greater than_ another.
(>=) :: forall a. (Ord a) => a -> a -> Boolean
(>=) a1 a2 = case a1 `compare` a2 of
  LT -> false
  _ -> true

unsafeCompare :: forall a. a -> a -> Ordering
unsafeCompare = unsafeCompareImpl LT EQ GT

foreign import unsafeCompareImpl
  """
  function unsafeCompareImpl(lt) {
    return function(eq) {
      return function(gt) {
        return function(x) {
          return function(y) {
            return x < y ? lt : x > y ? gt : eq;
          };
        };
      };
    };
  }
  """ :: forall a. Ordering -> Ordering -> Ordering -> a -> a -> Ordering

-- | The `Bounded` type class represents types that are finite partially
-- | ordered sets.
-- |
-- | Instances should satisfy the following law in addition to the `Ord` laws:
-- |
-- | - Ordering: `bottom <= a <= top`
class (Ord a) <= Bounded a where
  top :: a
  bottom :: a

instance boundedBoolean :: Bounded Boolean where
  top = true
  bottom = false

instance boundedUnit :: Bounded Unit where
  top = unit
  bottom = unit

instance boundedOrdering :: Bounded Ordering where
  top = GT
  bottom = LT

-- | The `Lattice` type class represents types that are partially ordered
-- | sets with a supremum (`sup` or `||`) and infimum (`inf` or `&&`).
-- |
-- | Instances should satisfy the following laws in addition to the `Ord`
-- | laws:
-- |
-- | - Associativity:
-- |   - `a || (b || c) = (a || b) || c`
-- |   - `a && (b && c) = (a && b) && c`
-- | - Commutativity:
-- |   - `a || b = b || a`
-- |   - `a && b = b && a`
-- | - Absorption:
-- |   - `a || (a && b) = a`
-- |   - `a && (a || b) = a`
-- | - Idempotent:
-- |   - `a || a = a`
-- |   - `a && a = a`
class (Ord a) <= Lattice a where
  sup :: a -> a -> a
  inf :: a -> a -> a

instance latticeBoolean :: Lattice Boolean where
  sup = boolOr
  inf = boolAnd

instance latticeUnit :: Lattice Unit where
  sup _ _ = unit
  inf _ _ = unit

infixr 2 ||
infixr 3 &&

-- | The `sup` operator.
(||) :: forall a. (Lattice a) => a -> a -> a
(||) = sup

-- | The `inf` operator.
(&&) :: forall a. (Lattice a) => a -> a -> a
(&&) = inf

-- | The `BoundedLattice` type class represents types that are finite
-- | lattices.
-- |
-- | Instances should satisfy the following law in addition to the `Lattice`
-- | and `Bounded` laws:
-- |
-- | - Identity:
-- |   - `a || bottom = a`
-- |   - `a && top = a`
-- | - Annihiliation:
-- |   - `a || top = top`
-- |   - `a && bottom = bottom`
class (Bounded a, Lattice a) <= BoundedLattice a

instance boundedLatticeBoolean :: BoundedLattice Boolean

instance boundedLatticeUnit :: BoundedLattice Unit

-- | The `ComplementedLattice` type class represents types that are lattices
-- | where every member is also uniquely complemented.
-- |
-- | Instances should satisfy the following law in addition to the
-- | `BoundedLattice` laws:
-- |
-- | - Complemented:
-- |   - `not a || a == top`
-- |   - `not a && a == bottom`
-- | - Double negation:
-- |   - `not <<< not == id`
class (BoundedLattice a) <= ComplementedLattice a where
  not :: a -> a

instance complementedLatticeBoolean :: ComplementedLattice Boolean where
  not = boolNot

instance complementedLatticeUnit :: ComplementedLattice Unit where
  not _ = unit

-- | The `DistributiveLattice` type class represents types that are lattices
-- | where the `&&` and `||` distribute over each other.
-- |
-- | Instances should satisfy the following law in addition to the `Lattice`
-- | laws:
-- |
-- | - Distributivity: `x && (y || z) = (x && y) || (x && z)`
class (Lattice a) <= DistributiveLattice a

instance distributiveLatticeBoolean :: DistributiveLattice Boolean

instance distributiveLatticeUnit :: DistributiveLattice Unit

-- | The `BooleanAlgebra` type class represents types that are Boolean
-- | algebras, also known as Boolean lattices.
-- |
-- | Instances should satisfy the `ComplementedLattice` and
-- | `DistributiveLattice` laws.
class (ComplementedLattice a, DistributiveLattice a) <= BooleanAlgebra a

instance booleanAlgebraBoolean :: BooleanAlgebra Boolean

instance booleanAlgebraUnit :: BooleanAlgebra Unit

foreign import boolOr
  """
  function boolOr(b1) {
    return function(b2) {
      return b1 || b2;
    };
  }
  """ :: Boolean -> Boolean -> Boolean

foreign import boolAnd
  """
  function boolAnd(b1) {
    return function(b2) {
      return b1 && b2;
    };
  }
  """  :: Boolean -> Boolean -> Boolean

foreign import boolNot
  """
  function boolNot(b) {
    return !b;
  }
  """ :: Boolean -> Boolean

-- | The `Show` type class represents those types which can be converted into
-- | a human-readable `String` representation.
-- |
-- | While not required, it is recommended that for any expression `x`, the
-- | string `show x` be executable PureScript code which evaluates to the same
-- | value as the expression `x`.
class Show a where
  show :: a -> String

instance showBoolean :: Show Boolean where
  show true = "true"
  show false = "false"

instance showNumber :: Show Number where
  show = showNumberImpl

instance showString :: Show String where
  show = showStringImpl

instance showUnit :: Show Unit where
  show _ = "unit"

instance showArray :: (Show a) => Show [a] where
  show = showArrayImpl show

instance showOrdering :: Show Ordering where
  show LT = "LT"
  show GT = "GT"
  show EQ = "EQ"

foreign import showNumberImpl
  """
  function showNumberImpl(n) {
    return n.toString();
  }
  """ :: Number -> String

foreign import showStringImpl
  """
  function showStringImpl(s) {
    return JSON.stringify(s);
  }
  """ :: String -> String

foreign import showArrayImpl
  """
  function showArrayImpl(f) {
    return function(xs) {
      var ss = [];
      for (var i = 0, l = xs.length; i < l; i++) {
        ss[i] = f(xs[i]);
      }
      return '[' + ss.join(',') + ']';
    };
  }
  """ :: forall a. (a -> String) -> [a] -> String


Implement aroundF using second derivative

Better maintainability. Added more instances.

module Zippers where

import Prelude

import Control.Apply (lift2)
import Control.Comonad (class Comonad)
import Control.Comonad.Cofree (Cofree)
import Control.Comonad.Env (EnvT(..))
import Control.Extend (class Extend)
import Data.Bifunctor (bimap, lmap)
import Data.Const (Const(..))
import Data.Either (Either(..), either)
import Data.Function (on)
import Data.Functor.Compose (Compose(..))
import Data.Functor.Coproduct (Coproduct, left, right)
import Data.Functor.Product (Product(..), product)
import Data.Functor.Variant (VariantF)
import Data.Functor.Variant as VF
import Data.Identity (Identity(..))
import Data.Lazy (Lazy, defer, force)
import Data.Lens (Lens', lens, (^.))
import Data.List (List(Nil), (:))
import Data.Maybe (Maybe, maybe)
import Data.Monoid.Additive (Additive)
import Data.Newtype (unwrap, wrap)
import Data.Pair (Pair(..))
import Data.StrMap (StrMap)
import Data.StrMap as StrMap
import Data.Symbol (class IsSymbol, SProxy(..))
import Data.Tuple (Tuple(..), fst)
import Data.Variant.Internal (FProxy(..), RLProxy(..))
import Matryoshka (class Corecursive, class Recursive, Algebra, cata, embed, project)
import Recursion (Alg)
import Test.QuickCheck (class Arbitrary, class Coarbitrary, arbitrary, coarbitrary)
import Type.Row (class ListToRow, class RowToList, Cons, Nil, kind RowList)
import Types (ATypeV, ATypeVF, Ident, Proper, Qualified, _app, _function, _name, _var)
import Unsafe.Coerce (unsafeCoerce)

type Tag = Tuple (Additive Int) (Additive Int)
type ATypeVC = Cofree ATypeVF Tag

class (Functor f, Functor f') <= Diff1 f f' | f -> f' where
  upF   :: forall x. ZF f x  ->             f x
  downF :: forall x.    f x  -> f (Lazy (ZF f x))

aroundF :: forall f f' f'' x. Diff1 f f' => Diff1 f' f'' => ZF f x  -> ZF f (ZF f x)
aroundF z@(c :<-: f) = (_ :<-: z) $ toDF $
  downF (fromDF c) <#> (force >>> upZ)
  where
    upZ :: ZF f' x -> ZF f x
    upZ z'@(_ :<-: x) = toDF (upF z') :<-: x

instance derivativeEnvT :: (Functor f, Diff1 f f') => Diff1 (EnvT e f) (EnvT e f') where
  downF (EnvT (Tuple e f)) = EnvT $ Tuple e $ downF f <#> map
    (injZF (EnvT <<< Tuple e))
  upF (dex :<-: x) =
    case fromDF dex of
      EnvT (Tuple e dfx) ->
        EnvT $ Tuple e $ upF (toDF' (FProxy :: FProxy f) dfx :<-: x)

foreign import data DF :: (Type -> Type) -> Type -> Type
toDF' :: forall f f' x. Diff1 f f' => FProxy f -> f' x -> DF f x
toDF' _ = toDF
toDF :: forall f f' x. Diff1 f f' => f' x -> DF f x
toDF = unsafeCoerce
fromDF :: forall f f' x. Diff1 f f' => DF f x -> f' x
fromDF = unsafeCoerce
reDF :: forall f g f' x. Diff1 f f' => Diff1 g f' => DF f x -> DF g x
reDF = fromDF >>> toDF
reDF' :: forall f g f' x. Diff1 f f' => Diff1 g f' => FProxy g -> DF f x -> DF g x
reDF' p = fromDF >>> toDF' p
injDF :: forall f f' g x. Diff1 f f' => Diff1 (g f) (g f') =>
  (forall x. x ~> g x) -> DF f x -> DF (g f) x
injDF g = fromDF >>> g >>> toDF
liftDF :: forall f f' g g' x. Diff1 f f' => Diff1 g g' => (f' x -> g' x) -> DF f x -> DF g x
liftDF fg = fromDF >>> fg >>> toDF

instance functorDF :: Diff1 f f' => Functor (DF f) where
  map f = fromDF >>> map f >>> toDF

instance arbitraryDF :: ( Diff1 f f', Arbitrary (f' x), Arbitrary x ) => Arbitrary (DF f x) where
  arbitrary = toDF <$> arbitrary
instance coarbitraryDF :: ( Diff1 f f', Coarbitrary (f' x), Coarbitrary x ) => Coarbitrary (DF f x) where
  coarbitrary = fromDF >>> coarbitrary
instance eqDF :: ( Diff1 f f', Eq (f' x), Eq x ) => Eq (DF f x) where
  eq = eq `on` fromDF

data ZF f x = ZF (DF f x) x
infix 1 ZF as :<-:
cxF :: forall f x. ZF f x -> DF f x
cxF = (_ ^. _contextF)
toZF :: forall f f' x. Diff1 f f' => Tuple (f' x) x -> ZF f x
toZF (Tuple f'x x) = toDF f'x :<-: x
fromZF :: forall f f' x. Diff1 f f' => ZF f x -> Tuple (f' x) x
fromZF (f'x :<-: x) = Tuple (fromDF f'x) x
reZF :: forall f g f' x. Diff1 f f' => Diff1 g f' => ZF f x -> ZF g x
reZF (f'x :<-: x) = reDF f'x :<-: x
reZF' :: forall f g f' x. Diff1 f f' => Diff1 g f' => FProxy g -> ZF f x -> ZF g x
reZF' p (f'x :<-: x) = reDF' p f'x :<-: x
injZF :: forall f f' g x. Diff1 f f' => Diff1 (g f) (g f') =>
  (forall x. x ~> g x) -> ZF f x -> ZF (g f) x
injZF g (f'x :<-: x) = injDF g f'x :<-: x
injZF2 :: forall f f' g x. Diff1 f f' => Diff1 (g f) (g f') =>
  (forall x. x ~> g x) -> ZF f (ZF f x) -> ZF (g f) (ZF (g f) x)
injZF2 g (f'x :<-: x) = injDF g f'x <#> injZF g :<-: injZF g x
liftZF :: forall f f' g g' x. Diff1 f f' => Diff1 g g' => (f' x -> g' x) -> ZF f x -> ZF g x
liftZF fg (f'x :<-: x) = liftDF fg f'x :<-: x

_contextF :: forall f x. Lens' (ZF f x) (DF f x)
_contextF = lens (\(c :<-: _) -> c)
  \(_ :<-: f) c -> c :<-: f

_focusF :: forall f x. Lens' (ZF f x) x
_focusF = lens (\(_ :<-: f) -> f)
  \(c :<-: _) f -> c :<-: f

instance functorZF :: Diff1 f f' => Functor (ZF f) where
  map f (f'x :<-: x) = map f f'x :<-: f x
instance extendZF :: (Diff1 f f', Diff1 f' f'') => Extend (ZF f) where
  extend f = map f <<< aroundF
instance comonadZF :: (Diff1 f f', Diff1 f' f'') => Comonad (ZF f) where
  extract (_ :<-: x) = x

instance arbitraryZF :: ( Diff1 f f', Arbitrary (f' x), Arbitrary x ) => Arbitrary (ZF f x) where
  arbitrary = lift2 ZF arbitrary arbitrary
instance coarbitraryZF :: ( Diff1 f f', Coarbitrary (f' x), Coarbitrary x ) => Coarbitrary (ZF f x) where
  coarbitrary (c :<-: f) = coarbitrary c <<< coarbitrary f
instance eqZF :: ( Diff1 f f', Eq (f' x), Eq x ) => Eq (ZF f x) where
  eq (c1 :<-: f1) (c2 :<-: f2) = eq c1 c2 && eq f1 f2

ixPair :: forall a b. (Boolean -> a -> b) -> Pair a -> Pair b
ixPair f (Pair l r) = Pair (f false l) (f true r)

ixDPair :: forall a. DPair a -> Boolean
ixDPair = fst

instance derivativeofTuple_keepsA :: Diff1 (Tuple a) (Const a) where
  downF (Tuple a b) = Tuple a $ defer \_ -> toDF (Const a) :<-: b
  upF (a :<-: b) = Tuple (unwrap $ fromDF a) b

type DPair = Tuple Boolean
instance derivativeofPair_isDPair :: Diff1 Pair (Tuple Boolean) where
  downF (Pair l r) = Pair
    (defer \_ -> toDF (Tuple false r) :<-: l)
    (defer \_ -> toDF (Tuple true  l) :<-: r)
  upF (c :<-: x) = case fromDF c, x of
    Tuple false r, l -> Pair l r
    Tuple true  l, r -> Pair l r

type DStrMap = Compose (Tuple String) StrMap
instance derivativeofStrMap_isDStrMap :: Diff1 StrMap (Compose (Tuple String) StrMap) where
  downF sm = sm # StrMap.mapWithKey \k v -> defer \_ ->
    toDF (Compose (Tuple k (StrMap.delete k sm))) :<-: v
  upF (c :<-: v) = case fromDF c of
    Compose (Tuple k sm) ->
      StrMap.insert k v sm

instance derivativeofConst_isVoid :: Diff1 (Const a) (Const Void) where
  downF (Const a) = Const a
  upF (c :<-: _) = absurd $ unwrap $ fromDF c

instance derivativeofIdentity_isUnit :: Diff1 Identity (Const Unit) where
  downF = map \x -> defer \_ ->
    toDF (Const unit) :<-: x
  upF (_ :<-: x) = Identity x

instance derivativeofMaybe_isUnit :: Diff1 Maybe (Const Unit) where
  downF = map \x -> defer \_ ->
    toDF (Const unit) :<-: x
  upF (_ :<-: x) = pure x

instance derivativeofEither_isUnit :: Diff1 (Either e) (Const Unit) where
  downF = map \x -> defer \_ ->
    toDF (Const unit) :<-: x
  upF (_ :<-: x) = pure x

instance derivativeofCoproduct :: ( Functor f, Diff1 f f', Functor g, Diff1 g g' ) =>
  Diff1 (Coproduct f g) (Coproduct f' g') where
  downF = unwrap >>> bimap
    (downF >>> map (map (liftZF \f' -> left f')))
    (downF >>> map (map (liftZF \g' -> right g'))) >>> wrap
  upF (c :<-: x) = case unwrap (fromDF c) of
    Left  f' -> left  (upF (toDF f' :<-: x))
    Right g' -> right (upF (toDF g' :<-: x))

instance derivativeofProduct :: ( Functor f, Diff1 f f', Functor g, Diff1 g g' ) =>
  Diff1 (Product f g) (Coproduct (Product f' g) (Product f g')) where
  upF (c :<-: x) = case bimap unwrap unwrap (unwrap (fromDF c)) of
    Left (Tuple f' g) -> product
      (upF (toDF f' :<-: x))
      (g)
    Right (Tuple f g') -> product
      (f)
      (upF (toDF g' :<-: x))
  downF (Product (Tuple f g)) = product
    (downF f <#> map (liftZF \f' -> left  (product f' g)))
    (downF g <#> map (liftZF \g' -> right (product f g')))

instance deriveofVariant_isVariantOfDerivatives ::
  ( RowToList r rl
  , DiffVariantF r r' rl rl'
  , ListToRow rl' r'
  ) => Diff1 (VariantF r) (VariantF r') where
  downF = unsafeCoerce (downV (RLProxy :: RLProxy rl))
  upF = unsafeCoerce (upV (RLProxy :: RLProxy rl))

type VF r' a = Tuple (VariantF r' a) a

class DiffVariantF (r :: # Type) (r' :: # Type) (rl :: RowList) (rl' :: RowList) | rl -> r r' rl' where
  upV :: forall a. RLProxy rl -> VF r' a -> VariantF r a
  downV :: forall a. RLProxy rl -> VariantF r a -> VariantF r (Lazy (VF r' a))

instance diffVNil :: DiffVariantF () () Nil Nil where
  upV _ = fst >>> VF.case_
  downV _ = VF.case_

instance diffVCons ::
  ( IsSymbol sym
  , Functor f
  , Diff1 f f'
  , RowCons sym (FProxy f) n r
  , ListToRow rl n
  , DiffVariantF n n' rl rl'
  , RowToList n' rl'
  , RowCons sym (FProxy f') n' r'
  , Union n m r
  , Union n' m' r'
  ) => DiffVariantF r r' (Cons sym (FProxy f) rl) (Cons sym (FProxy f') rl') where
    upV _ (Tuple v x) = handleThis handleOther v
      where
        sym = SProxy :: SProxy sym
        handleOther v' = VF.expand $
          upV (RLProxy :: RLProxy rl) (Tuple v' x)
        handleThis = VF.on sym \f' -> VF.inj sym $ upF $
          toDF' (FProxy :: FProxy f) f' :<-: x
    downV _ = handleThis handleOther
      where
        sym = SProxy :: SProxy sym
        handleOther v' = VF.expand $ map (lmap VF.expand) <$>
          downV (RLProxy :: RLProxy rl) v'
        handleThis = VF.on sym \f -> VF.inj sym $
          (map (lmap (VF.inj sym) <<< fromZF) <$> downF f)

type ParentCtx t = DF (Alg t) t
type ParentCtxs t = List (ParentCtx t)
data ZRec t = ZRec (ParentCtxs t) t
infix 1 ZRec as :<<~:

toParentCtx ::
  forall t f f'.
    Recursive t f =>
    Corecursive t f =>
    Diff1 f f' =>
  DF f ~> DF (Alg t)
toParentCtx = unsafeCoerce

fromParentCtx ::
  forall t f f'.
    Recursive t f =>
    Corecursive t f =>
    Diff1 f f' =>
  DF (Alg t) ~> DF f
fromParentCtx = unsafeCoerce

downRec ::
  forall t f f'.
    Recursive t f => Corecursive t f =>
    Functor f => Diff1 f f' =>
  ZRec t -> f (Lazy (ZRec t))
downRec (context :<<~: focus) = downF (project focus) <#> map
  case _ of
    cx :<-: fc ->
      toParentCtx cx : context :<<~: fc

upRec ::
  forall t f f'.
    Recursive t f => Corecursive t f =>
    Functor f => Diff1 f f' =>
  ZRec t -> Either t (ZRec t)
upRec (Nil :<<~: focus) = Left focus
upRec (cx : context :<<~: focus) = Right $
  context :<<~: embed (upF (fromParentCtx cx :<-: focus))

tipRec ::
  forall t f f'.
    Recursive t f => Corecursive t f =>
    Functor f => Diff1 f f' =>
  t -> ZRec t
tipRec = ZRec Nil

topRec ::
  forall t f f'.
    Recursive t f => Corecursive t f =>
    Functor f => Diff1 f f' =>
  ZRec t -> t
topRec z = upRec z # either id topRec

downIntoRec ::
  forall t f f'.
    Recursive t f => Corecursive t f =>
    Functor f => Diff1 f f' =>
  (f ~> Maybe) -> ZRec t -> ZRec t
downIntoRec f z = maybe z force (f (downRec z))

_contextRec :: forall t. Lens' (ZRec t) (List (DF (Alg t) t))
_contextRec = lens (\(c :<<~: _) -> c)
  \(_ :<<~: f) c -> c :<<~: f

_focusRec :: forall t. Lens' (ZRec t) t
_focusRec = lens (\(_ :<<~: f) -> f)
  \(c :<<~: _) f -> c :<<~: f

type ZipperVRec = ZRec ATypeVC

handleATypeVFByTypes :: forall a r.
  { "Const" :: forall b. Const b a -> r
  , "Pair" :: Pair a -> r } ->
  ATypeVF a -> r
handleATypeVFByTypes methods = handleATypeVF
  { name: methods."Const"
  , var: methods."Const"
  , function: methods."Pair"
  , app: methods."Pair"
  }

handleATypeVFPairs :: forall a r.
  { name :: Const (Qualified Proper) a -> r
  , var :: Const Ident a -> r
  , "Pair" :: Pair a -> r } ->
  ATypeVF a -> r
handleATypeVFPairs methods = handleATypeVF
  { name: methods.name
  , var: methods.var
  , function: methods."Pair"
  , app: methods."Pair"
  }

handleATypeVFConsts :: forall a r.
  { "Const" :: forall b. Const b a -> r
  , function :: Pair a -> r
  , app :: Pair a -> r } ->
  ATypeVF a -> r
handleATypeVFConsts methods = handleATypeVF
  { name: methods."Const"
  , var: methods."Const"
  , function: methods.function
  , app: methods.app
  }

handleATypeVF :: forall a r.
  { name :: Const (Qualified Proper) a -> r
  , var :: Const Ident a -> r
  , function :: Pair a -> r
  , app :: Pair a -> r } ->
  ATypeVF a -> r
handleATypeVF methods = VF.case_
  # VF.on _name methods.name
  # VF.on _var methods.var
  # VF.on _function methods.function
  # VF.on _app methods.app

handleATypeVFReinjector :: forall a r.
  { "Const" :: forall b.
      (Const b ~> ATypeVF) ->
      (DF (Const b) ~> DF ATypeVF) ->
      Const b a -> r
  , "Pair" ::
      (Pair ~> ATypeVF) ->
      (DF Pair ~> DF ATypeVF) ->
      Pair a -> r
  } -> ATypeVF a -> r
handleATypeVFReinjector methods = VF.case_
  # VF.on _name (methods."Const" (VF.inj _name) (fromDF >>> unwrap >>> absurd))
  # VF.on _var (methods."Const" (VF.inj _var) (fromDF >>> unwrap >>> absurd))
  # VF.on _function (methods."Pair" (VF.inj _function) (fromDF >>> VF.inj _function >>> toDF))
  # VF.on _app (methods."Pair" (VF.inj _app) (fromDF >>> VF.inj _app >>> toDF))

simpleShowZRec :: ZRec ATypeV -> String
simpleShowZRec (context :<<~: focus) = go context cx
  where
    show1 :: Algebra ATypeVF String
    show1 = VF.match
      { name: unwrap >>> show
      , var: unwrap >>> show
      , function: \(Pair l r) ->
          "(" <> l <> ") -> (" <> r <> ")"
      , app: \(Pair l r) ->
          "(" <> l <> ") (" <> r <> ")"
      }
    showAll = cata show1
    cx = showAll focus
    go Nil s = s
    go (h : r) s = go r $ VF.match
      { function: showBranch " -> " s
      , app: showBranch " " s
      , name: unwrap >>> absurd
      , var: unwrap >>> absurd
      } $ fromDF $ fromParentCtx h
    showBranch :: String -> String -> DPair ATypeV -> String
    showBranch sep s (Tuple false a) = "{" <> s <> "}" <> sep <> showAll a
    showBranch sep s (Tuple true a) = showAll a <> sep <> "{" <> s <> "}"

module Zippers where

import Prelude

import Control.Apply (lift2)
import Control.Comonad (class Comonad, extract)
import Control.Comonad.Cofree (Cofree)
import Control.Comonad.Env (EnvT(..))
import Control.Extend (class Extend)
import Data.Bifunctor (bimap, lmap)
import Data.Const (Const(..))
import Data.Either (Either(..), either)
import Data.Function (on)
import Data.Functor.Compose (Compose(..))
import Data.Functor.Coproduct (Coproduct, left, right)
import Data.Functor.Product (Product(..), product)
import Data.Functor.Variant (VariantF)
import Data.Functor.Variant as VF
import Data.Identity (Identity(..))
import Data.Lazy (Lazy, defer, force)
import Data.Lens (Lens', lens, (^.))
import Data.List (List(Nil), (:))
import Data.Maybe (Maybe, maybe)
import Data.Monoid.Additive (Additive)
import Data.Newtype (unwrap)
import Data.Pair (Pair(..))
import Data.StrMap (StrMap)
import Data.StrMap as StrMap
import Data.Symbol (class IsSymbol, SProxy(..))
import Data.Tuple (Tuple(..), fst)
import Data.Variant.Internal (FProxy(..), RLProxy(..))
import Matryoshka (class Corecursive, class Recursive, Algebra, cata, embed, project)
import Recursion (Alg)
import Test.QuickCheck (class Arbitrary, class Coarbitrary, arbitrary, coarbitrary)
import Type.Row (class ListToRow, class RowToList, Cons, Nil, kind RowList)
import Types (ATypeV, ATypeVF, Ident, Proper, Qualified, _app, _function, _name, _var)
import Unsafe.Coerce (unsafeCoerce)

type Tag = Tuple (Additive Int) (Additive Int)
type ATypeVC = Cofree ATypeVF Tag

class (Functor f, Functor f') <= Diff1 f f' | f -> f' where
  upF      ::  forall x. ZF f x  ->                 f x
  downF    ::  forall x.    f x  ->     f (Lazy (ZF f x))
  aroundF  ::  forall x. ZF f x  ->  ZF f       (ZF f x)

instance derivativeEnvT :: (Functor f, Diff1 f f') => Diff1 (EnvT e f) (EnvT e f') where
  downF (EnvT (Tuple e f)) = EnvT $ Tuple e $ downF f <#> map
    (injZF (EnvT <<< Tuple e))
  upF (dex :<-: x) =
    case fromDF dex of
      EnvT (Tuple e dfx) ->
        EnvT $ Tuple e $ upF (toDF' (FProxy :: FProxy f) dfx :<-: x)
  aroundF (dex :<-: x) =
    case fromDF dex of
      EnvT (Tuple e dfx) ->
        injZF2 (EnvT <<< Tuple e) $
        aroundF (toDF' (FProxy :: FProxy f) dfx :<-: x)

foreign import data DF :: (Type -> Type) -> Type -> Type
toDF' :: forall f f' x. Diff1 f f' => FProxy f -> f' x -> DF f x
toDF' _ = toDF
toDF :: forall f f' x. Diff1 f f' => f' x -> DF f x
toDF = unsafeCoerce
fromDF :: forall f f' x. Diff1 f f' => DF f x -> f' x
fromDF = unsafeCoerce
reDF :: forall f g f' x. Diff1 f f' => Diff1 g f' => DF f x -> DF g x
reDF = fromDF >>> toDF
reDF' :: forall f g f' x. Diff1 f f' => Diff1 g f' => FProxy g -> DF f x -> DF g x
reDF' p = fromDF >>> toDF' p
injDF :: forall f f' g x. Diff1 f f' => Diff1 (g f) (g f') =>
  (forall x. x ~> g x) -> DF f x -> DF (g f) x
injDF g = fromDF >>> g >>> toDF
liftDF :: forall f f' g g' x. Diff1 f f' => Diff1 g g' => (f' x -> g' x) -> DF f x -> DF g x
liftDF fg = fromDF >>> fg >>> toDF

instance functorDF :: Diff1 f f' => Functor (DF f) where
  map f = fromDF >>> map f >>> toDF

instance arbitraryDF :: ( Diff1 f f', Arbitrary (f' x), Arbitrary x ) => Arbitrary (DF f x) where
  arbitrary = toDF <$> arbitrary
instance coarbitraryDF :: ( Diff1 f f', Coarbitrary (f' x), Coarbitrary x ) => Coarbitrary (DF f x) where
  coarbitrary = fromDF >>> coarbitrary
instance eqDF :: ( Diff1 f f', Eq (f' x), Eq x ) => Eq (DF f x) where
  eq = eq `on` fromDF

data ZF f x = ZF (DF f x) x
infix 1 ZF as :<-:
cxF :: forall f x. ZF f x -> DF f x
cxF = (_ ^. _contextF)
toZF :: forall f f' x. Diff1 f f' => Tuple (f' x) x -> ZF f x
toZF (Tuple f'x x) = toDF f'x :<-: x
fromZF :: forall f f' x. Diff1 f f' => ZF f x -> Tuple (f' x) x
fromZF (f'x :<-: x) = Tuple (fromDF f'x) x
reZF :: forall f g f' x. Diff1 f f' => Diff1 g f' => ZF f x -> ZF g x
reZF (f'x :<-: x) = reDF f'x :<-: x
reZF' :: forall f g f' x. Diff1 f f' => Diff1 g f' => FProxy g -> ZF f x -> ZF g x
reZF' p (f'x :<-: x) = reDF' p f'x :<-: x
injZF :: forall f f' g x. Diff1 f f' => Diff1 (g f) (g f') =>
  (forall x. x ~> g x) -> ZF f x -> ZF (g f) x
injZF g (f'x :<-: x) = injDF g f'x :<-: x
injZF2 :: forall f f' g x. Diff1 f f' => Diff1 (g f) (g f') =>
  (forall x. x ~> g x) -> ZF f (ZF f x) -> ZF (g f) (ZF (g f) x)
injZF2 g (f'x :<-: x) = injDF g f'x <#> injZF g :<-: injZF g x
liftZF :: forall f f' g g' x. Diff1 f f' => Diff1 g g' => (f' x -> g' x) -> ZF f x -> ZF g x
liftZF fg (f'x :<-: x) = liftDF fg f'x :<-: x

_contextF :: forall f x. Lens' (ZF f x) (DF f x)
_contextF = lens (\(c :<-: _) -> c)
  \(_ :<-: f) c -> c :<-: f

_focusF :: forall f x. Lens' (ZF f x) x
_focusF = lens (\(_ :<-: f) -> f)
  \(c :<-: _) f -> c :<-: f

instance functorZF :: Diff1 f f' => Functor (ZF f) where
  map f (f'x :<-: x) = map f f'x :<-: f x
instance extendZF :: Diff1 f f' => Extend (ZF f) where
  extend f = map f <<< aroundF
instance comonadZF :: Diff1 f f' => Comonad (ZF f) where
  extract (_ :<-: x) = x

instance arbitraryZF :: ( Diff1 f f', Arbitrary (f' x), Arbitrary x ) => Arbitrary (ZF f x) where
  arbitrary = lift2 ZF arbitrary arbitrary
instance coarbitraryZF :: ( Diff1 f f', Coarbitrary (f' x), Coarbitrary x ) => Coarbitrary (ZF f x) where
  coarbitrary (c :<-: f) = coarbitrary c <<< coarbitrary f
instance eqZF :: ( Diff1 f f', Eq (f' x), Eq x ) => Eq (ZF f x) where
  eq (c1 :<-: f1) (c2 :<-: f2) = eq c1 c2 && eq f1 f2

ixPair :: forall a b. (Boolean -> a -> b) -> Pair a -> Pair b
ixPair f (Pair l r) = Pair (f false l) (f true r)

ixDPair :: forall a. DPair a -> Boolean
ixDPair = fst

type DPair = Tuple Boolean
instance derivativeofPair_isDPair :: Diff1 Pair (Tuple Boolean) where
  downF (Pair l r) = Pair
    (defer \_ -> toDF (Tuple false r) :<-: l)
    (defer \_ -> toDF (Tuple true  l) :<-: r)
  upF (c :<-: x) = case fromDF c, x of
    Tuple false r, l -> Pair l r
    Tuple true  l, r -> Pair l r
  aroundF z@(c :<-: _) =
    let ix = fst (fromDF c)
        x = extract (fromDF c)
    in toDF (Tuple ix (z $> x)) :<-: z

type DStrMap = Compose (Tuple String) StrMap
instance derivativeofStrMap_isDStrMap :: Diff1 StrMap (Compose (Tuple String) StrMap) where
  downF sm = sm # StrMap.mapWithKey \k v -> defer \_ ->
    toDF (Compose (Tuple k (StrMap.delete k sm))) :<-: v
  upF (c :<-: v) = case fromDF c of
    Compose (Tuple k sm) ->
      StrMap.insert k v sm
  aroundF z@(c :<-: _) =
    let k = fst (unwrap (fromDF c))
    -- FIXME: probably wrong
    in toDF (Compose (Tuple k (StrMap.singleton k z))) :<-: z

instance derivativeofConst_isVoid :: Diff1 (Const a) (Const Void) where
  downF (Const a) = Const a
  upF (c :<-: _) = absurd $ unwrap $ fromDF c
  aroundF (c :<-: _) = absurd $ unwrap $ fromDF c

instance derivativeofIdentity_isUnit :: Diff1 Identity (Const Unit) where
  downF = map \x -> defer \_ ->
    toDF (Const unit) :<-: x
  upF (_ :<-: x) = Identity x
  aroundF z = toDF (Const unit) :<-: z

instance derivativeofMaybe_isUnit :: Diff1 Maybe (Const Unit) where
  downF = map \x -> defer \_ ->
    toDF (Const unit) :<-: x
  upF (_ :<-: x) = pure x
  aroundF z = toDF (Const unit) :<-: z

instance derivativeofEither_isUnit :: Diff1 (Either e) (Const Unit) where
  downF = map \x -> defer \_ ->
    toDF (Const unit) :<-: x
  upF (_ :<-: x) = pure x
  aroundF z = toDF (Const unit) :<-: z

instance derivativeofProduct :: ( Functor f, Diff1 f f', Functor g, Diff1 g g' ) =>
  Diff1 (Product f g) (Coproduct (Product f' g) (Product f g')) where
  upF (c :<-: x) = case bimap unwrap unwrap (unwrap (fromDF c)) of
    Left (Tuple f' g) -> product
      (upF (toDF f' :<-: x))
      (g)
    Right (Tuple f g') -> product
      (f)
      (upF (toDF g' :<-: x))
  downF (Product (Tuple f g)) = product
    (downF f <#> map (liftZF \f' -> left  (product f' g)))
    (downF g <#> map (liftZF \g' -> right (product f g')))
  aroundF z@(c :<-: x) =
    let
      this = FProxy :: FProxy (Product f g)
      _f = FProxy :: FProxy f
      _g = FProxy :: FProxy g
      intoLeft g f' = left (product f' g)
      intoRight f g' = right (product f g')
    in case bimap unwrap unwrap (unwrap (fromDF c)) of
      Left (Tuple f' g) ->
        let
          lower = toDF' _f f' :<-: x
          f = upF lower
          l = cxF (aroundF lower) <#>
              liftZF (intoLeft g)
          r = downF g <#> force >>>
              liftZF (intoRight f)
        in toDF' this (left (product (fromDF l) r)) :<-: z
      Right (Tuple f g') ->
        let
          lower = toDF' _g g' :<-: x
          g = upF lower
          l = downF f <#> force >>>
              liftZF (intoLeft g)
          r = cxF (aroundF lower) <#>
              liftZF (intoRight f)
        in toDF' this (right (product l (fromDF r))) :<-: z

instance deriveofVariant_isVariantOfDerivatives ::
  ( RowToList r rl
  , DiffVariantF r r' rl rl'
  , ListToRow rl' r'
  ) => Diff1 (VariantF r) (VariantF r') where
  downF = unsafeCoerce (downV (RLProxy :: RLProxy rl))
  upF = unsafeCoerce (upV (RLProxy :: RLProxy rl))
  aroundF = unsafeCoerce (aroundV (RLProxy :: RLProxy rl))

type VF r' a = Tuple (VariantF r' a) a

class DiffVariantF (r :: # Type) (r' :: # Type) (rl :: RowList) (rl' :: RowList) | rl -> r r' rl' where
  upV :: forall a. RLProxy rl -> VF r' a -> VariantF r a
  downV :: forall a. RLProxy rl -> VariantF r a -> VariantF r (Lazy (VF r' a))
  aroundV :: forall a. RLProxy rl -> VF r' a -> VF r' (VF r' a)

instance diffVNil :: DiffVariantF () () Nil Nil where
  upV _ = fst >>> VF.case_
  downV _ = VF.case_
  aroundV _ = fst >>> VF.case_

instance diffVCons ::
  ( IsSymbol sym
  , Functor f
  , Diff1 f f'
  , RowCons sym (FProxy f) n r
  , ListToRow rl n
  , DiffVariantF n n' rl rl'
  , RowToList n' rl'
  , RowCons sym (FProxy f') n' r'
  , Union n m r
  , Union n' m' r'
  ) => DiffVariantF r r' (Cons sym (FProxy f) rl) (Cons sym (FProxy f') rl') where
    upV _ (Tuple v x) = handleThis handleOther v
      where
        sym = SProxy :: SProxy sym
        handleOther v' = VF.expand $
          upV (RLProxy :: RLProxy rl) (Tuple v' x)
        handleThis = VF.on sym \f' -> VF.inj sym $ upF $
          toDF' (FProxy :: FProxy f) f' :<-: x
    downV _ = handleThis handleOther
      where
        sym = SProxy :: SProxy sym
        handleOther v' = VF.expand $ map (lmap VF.expand) <$>
          downV (RLProxy :: RLProxy rl) v'
        handleThis = VF.on sym \f -> VF.inj sym $
          (map (lmap (VF.inj sym) <<< fromZF) <$> downF f)
    aroundV _ (Tuple v x) = handleThis handleOther v
      where
        sym = SProxy :: SProxy sym
        handleOther v' = bimap
          (VF.expand >>> map (lmap VF.expand))
          (lmap VF.expand)
          $ aroundV (RLProxy :: RLProxy rl) (Tuple v' x)
        inj :: forall a. f' a -> VariantF r' a
        inj = VF.inj sym
        handleThis = VF.on sym \f' ->
          lmap (map (fromZF >>> lmap inj) >>> inj) $
          map (lmap inj <<< fromZF) $ fromZF $
          aroundF $ toDF' (FProxy :: FProxy f) f' :<-: x

type ParentCtx t = DF (Alg t) t
type ParentCtxs t = List (ParentCtx t)
data ZRec t = ZRec (ParentCtxs t) t
infix 1 ZRec as :<<~:

toParentCtx ::
  forall t f f'.
    Recursive t f =>
    Corecursive t f =>
    Diff1 f f' =>
  DF f ~> DF (Alg t)
toParentCtx = unsafeCoerce

fromParentCtx ::
  forall t f f'.
    Recursive t f =>
    Corecursive t f =>
    Diff1 f f' =>
  DF (Alg t) ~> DF f
fromParentCtx = unsafeCoerce

downRec ::
  forall t f f'.
    Recursive t f => Corecursive t f =>
    Functor f => Diff1 f f' =>
  ZRec t -> f (Lazy (ZRec t))
downRec (context :<<~: focus) = downF (project focus) <#> map
  case _ of
    cx :<-: fc ->
      toParentCtx cx : context :<<~: fc

upRec ::
  forall t f f'.
    Recursive t f => Corecursive t f =>
    Functor f => Diff1 f f' =>
  ZRec t -> Either t (ZRec t)
upRec (Nil :<<~: focus) = Left focus
upRec (cx : context :<<~: focus) = Right $
  context :<<~: embed (upF (fromParentCtx cx :<-: focus))

tipRec ::
  forall t f f'.
    Recursive t f => Corecursive t f =>
    Functor f => Diff1 f f' =>
  t -> ZRec t
tipRec = ZRec Nil

topRec ::
  forall t f f'.
    Recursive t f => Corecursive t f =>
    Functor f => Diff1 f f' =>
  ZRec t -> t
topRec z = upRec z # either id topRec

downIntoRec ::
  forall t f f'.
    Recursive t f => Corecursive t f =>
    Functor f => Diff1 f f' =>
  (f ~> Maybe) -> ZRec t -> ZRec t
downIntoRec f z = maybe z force (f (downRec z))

_contextRec :: forall t. Lens' (ZRec t) (List (DF (Alg t) t))
_contextRec = lens (\(c :<<~: _) -> c)
  \(_ :<<~: f) c -> c :<<~: f

_focusRec :: forall t. Lens' (ZRec t) t
_focusRec = lens (\(_ :<<~: f) -> f)
  \(c :<<~: _) f -> c :<<~: f

type ZipperVRec = ZRec ATypeVC

handleATypeVFByTypes :: forall a r.
  { "Const" :: forall b. Const b a -> r
  , "Pair" :: Pair a -> r } ->
  ATypeVF a -> r
handleATypeVFByTypes methods = handleATypeVF
  { name: methods."Const"
  , var: methods."Const"
  , function: methods."Pair"
  , app: methods."Pair"
  }

handleATypeVFPairs :: forall a r.
  { name :: Const (Qualified Proper) a -> r
  , var :: Const Ident a -> r
  , "Pair" :: Pair a -> r } ->
  ATypeVF a -> r
handleATypeVFPairs methods = handleATypeVF
  { name: methods.name
  , var: methods.var
  , function: methods."Pair"
  , app: methods."Pair"
  }

handleATypeVFConsts :: forall a r.
  { "Const" :: forall b. Const b a -> r
  , function :: Pair a -> r
  , app :: Pair a -> r } ->
  ATypeVF a -> r
handleATypeVFConsts methods = handleATypeVF
  { name: methods."Const"
  , var: methods."Const"
  , function: methods.function
  , app: methods.app
  }

handleATypeVF :: forall a r.
  { name :: Const (Qualified Proper) a -> r
  , var :: Const Ident a -> r
  , function :: Pair a -> r
  , app :: Pair a -> r } ->
  ATypeVF a -> r
handleATypeVF methods = VF.case_
  # VF.on _name methods.name
  # VF.on _var methods.var
  # VF.on _function methods.function
  # VF.on _app methods.app

handleATypeVFReinjector :: forall a r.
  { "Const" :: forall b.
      (Const b ~> ATypeVF) ->
      (DF (Const b) ~> DF ATypeVF) ->
      Const b a -> r
  , "Pair" ::
      (Pair ~> ATypeVF) ->
      (DF Pair ~> DF ATypeVF) ->
      Pair a -> r
  } -> ATypeVF a -> r
handleATypeVFReinjector methods = VF.case_
  # VF.on _name (methods."Const" (VF.inj _name) (fromDF >>> unwrap >>> absurd))
  # VF.on _var (methods."Const" (VF.inj _var) (fromDF >>> unwrap >>> absurd))
  # VF.on _function (methods."Pair" (VF.inj _function) (fromDF >>> VF.inj _function >>> toDF))
  # VF.on _app (methods."Pair" (VF.inj _app) (fromDF >>> VF.inj _app >>> toDF))

simpleShowZRec :: ZRec ATypeV -> String
simpleShowZRec (context :<<~: focus) = go context cx
  where
    show1 :: Algebra ATypeVF String
    show1 = VF.match
      { name: unwrap >>> show
      , var: unwrap >>> show
      , function: \(Pair l r) ->
          "(" <> l <> ") -> (" <> r <> ")"
      , app: \(Pair l r) ->
          "(" <> l <> ") (" <> r <> ")"
      }
    showAll = cata show1
    cx = showAll focus
    go Nil s = s
    go (h : r) s = go r $ VF.match
      { function: showBranch " -> " s
      , app: showBranch " " s
      , name: unwrap >>> absurd
      , var: unwrap >>> absurd
      } $ fromDF $ fromParentCtx h
    showBranch :: String -> String -> DPair ATypeV -> String
    showBranch sep s (Tuple false a) = "{" <> s <> "}" <> sep <> showAll a
    showBranch sep s (Tuple true a) = showAll a <> sep <> "{" <> s <> "}"


Removed unsafecoerce

Removed unsafecoerce

module OIDCCryptUtils.JSONWebKey (JSONWebKey()) where

import Prelude (pure, (<<<))
import Data.Argonaut as JS

newtype JSONWebKey = JSONWebKey JS.Json

instance decodeJsonJSONWebKey :: JS.DecodeJson JSONWebKey where
  decodeJson = pure <<< JSONWebKey

module OIDCCryptUtils.JSONWebKey (JSONWebKey()) where

import Prelude (pure, (<<<))
import Data.Argonaut as JS

foreign import
  data JSONWebKey :: *

instance decodeJsonJSONWebKey :: JS.DecodeJson JSONWebKey where
  decodeJson = pure <<< Unsafe.Coerce.unsafeCoerce


removed commented code

removed commented code

{-
Copyright 2016 SlamData, Inc.

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}

{-
Copyright 2016 SlamData, Inc.

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}

module SlamData.Workspace.Card.Setups.Chart.Parallel.Eval
  ( eval
  , module SlamData.Workspace.Card.Setups.Chart.Parallel.Model
  ) where

import SlamData.Prelude

import Data.Argonaut (JArray, Json, decodeJson, (.?))
import Data.Array as A
import Data.List as L
import Data.StrMap as Sm
import Data.String as S

import ECharts.Monad (DSL)
import ECharts.Commands as E
import ECharts.Types as ET
import ECharts.Types.Phantom (OptionI)

import SlamData.Workspace.Card.CardType.ChartType (ChartType(Parallel))
import SlamData.Workspace.Card.Port as Port
import SlamData.Workspace.Card.Setups.Axis (Axes)
import SlamData.Workspace.Card.Setups.Chart.ColorScheme (colors)
import SlamData.Workspace.Card.Setups.Chart.Common as SCC
import SlamData.Workspace.Card.Setups.Chart.Parallel.Model (ModelR, Model)
import SlamData.Workspace.Card.Setups.Common.Eval as BCE
import SlamData.Workspace.Card.Setups.Dimension as D
import SlamData.Workspace.Card.Setups.Semantics as Sem

import SqlSquare as Sql

import Utils.Array (enumerate)
import Utils.Foldable (enumeratedFor_)

type Item =
  { series ∷ String
  , dims ∷ Array Number
  }

decodeItem ∷ Json → String ⊹ Item
decodeItem = decodeJson >=> \obj → do
  series ← map (fromMaybe "" ∘ Sem.maybeString) $ obj .? "series"
  let
    ks ∷ Array String
    ks = map ("measure" ⊕ _) $ A.mapMaybe (S.stripPrefix $ S.Pattern "measure") $ Sm.keys obj

  dims ← for ks \k →
    map (fromMaybe zero ∘ Sem.maybeNumber) $ obj .? k

  pure { dims, series }

eval ∷ ∀ m. BCE.ChartSetupEval ModelR m
eval = BCE.chartSetupEval (SCC.buildBasicSql buildProjections buildGroupBy) buildParallel

buildProjections ∷ ModelR → L.List (Sql.Projection Sql.Sql)
buildProjections r = L.fromFoldable
  $ [ r.series # SCC.jcursorPrj # Sql.as "series" ]
  ⊕ ( map mkProjection $ enumerate r.dims )
  where
  mkProjection (ix × field) =
    field # SCC.jcursorPrj # Sql.as ("measure" ⊕ show ix) # SCC.applyTransform field

buildGroupBy ∷ ModelR → Maybe (Sql.GroupBy Sql.Sql)
buildGroupBy r =
  SCC.groupBy
  $ pure
  $ r.series # SCC.jcursorSql

buildParallel ∷ ModelR → Axes → JArray → Port.Port
buildParallel m axes jarr =
  Port.ChartInstructions
    { options: pOptions axes m $ buildPData jarr
    , chartType: Parallel
    }

buildPData ∷ JArray → Array Item
buildPData =
  foldMap $ foldMap A.singleton ∘ decodeItem

pOptions ∷ Axes → ModelR → Array Item → DSL OptionI
pOptions _ r pData = do
  E.parallel do
    E.left $ ET.Percent 5.0
    E.right $ ET.Percent 18.0
    E.bottom $ ET.Pixel 100

  E.colors colors
  E.series series

  E.parallelAxes axes

  when (A.length serieNames < 30) $ E.legend do
    E.topBottom
    E.textStyle $ E.fontFamily "Ubuntu, sans"
    E.items $ map ET.strItem serieNames

  where
  serieNames = map _.series pData

  series = for_ pData \serie → E.parallelSeries do
    E.name serie.series
    E.buildItems
      $ E.addItem
      $ E.buildValues
      $ for_ serie.dims E.addValue

  axes = enumeratedFor_ r.dims \(dimIx × dim) → E.addParallelAxis do
    E.dim dimIx
    E.name $ D.jcursorLabel dim

{-
buildParallelData ∷ ModelR → JArray → Array Series
buildParallelData r records = series
  where
  -- | maybe series >> data mapped to r.dims
  dataMap ∷ Maybe String >> Array (Array Number)
  dataMap =
    foldl dataMapFoldFn M.empty records

  dataMapFoldFn
    ∷ Maybe String >> Array (Array Number)
    → Json
    → Maybe String >> Array (Array Number)
  dataMapFoldFn acc js =
    let
      getMaybeString = Sem.getMaybeString js
      getValues = Sem.getValues js

      mbSeries =
        getMaybeString =<< r.series ^? D._value ∘ D._projection
      values =
        r.dims <#> \rr → getValues $ rr ^? D._value ∘ D._projection

      alterSeriesFn
        ∷ Maybe (Array (Array Number))
        → Maybe (Array (Array Number))
      alterSeriesFn Nothing =
        Just values
      alterSeriesFn (Just arrs) =
        Just $ map (uncurry append) $ A.zip arrs values

    in
      M.alter alterSeriesFn mbSeries acc

  series ∷ Array Series
  series =
    foldMap mkSeries $ M.toList dataMap

  mkSeries
    ∷ Maybe String × Array (Array Number)
    → Array Series
  mkSeries (name × values) =
    [ { name
      , items: map aggregateValues $ enumerate values
      } ]

  aggregateValues
    ∷ Int × (Array Number)
    → Maybe Number
  aggregateValues (i × vals)
    | A.null vals = Nothing
    | otherwise = do
      agg ← r.dims ^? ix i ∘ D._value ∘ D._transform ∘ _Just ∘ T._Aggregation
      pure $ Ag.runAggregation agg vals
-}