Provide a simple graph reduction of examples in Array's Bind explanation

module Control.Bind
  ( class Bind, bind, (>>=)
  , bindFlipped, (=<<)
  , class Discard, discard
  , join
  , composeKleisli, (>=>)
  , composeKleisliFlipped, (<=<)
  , ifM
  , module Data.Functor
  , module Control.Apply
  , module Control.Applicative
  ) where

import Control.Applicative (class Applicative, liftA1, pure, unless, when)
import Control.Apply (class Apply, apply, (*>), (<*), (<*>))
import Control.Category (identity)

import Data.Function (flip)
import Data.Functor (class Functor, map, void, ($>), (<#>), (<$), (<$>))
import Data.Unit (Unit)

-- | 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

infixl 1 bind as >>=

-- | `bindFlipped` is `bind` with its arguments reversed. For example:
-- |
-- | ```purescript
-- | print =<< random
-- | ```
bindFlipped :: forall m a b. Bind m => (a -> m b) -> m a -> m b
bindFlipped = flip bind

infixr 1 bindFlipped as =<<

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

-- | The `Array` monad works like a nested for loop. Each
-- | `bind`/`>>=` adds another level of nesting in the loop:
-- | ```
-- | foo :: Array Int
-- | foo =
-- |   ["a", "b"] >>= \eachElementInArray1 ->
-- |     ["c", "d"] >>= \eachElementInArray2
-- |       pure (eachElementInArray1 <> eachElementInArray2)
-- |
-- | -- In other words...
-- | foo
-- | -- ... is the same as...
-- | [ ("a" <> "c"), ("a" <> "d"), ("b" <> "c"), ("b" <> "d") ]
-- | -- which simplifies to...
-- | [ "ac", "ad", "bc", "bd"]
-- | ```
instance bindArray :: Bind Array where
  bind = arrayBind

foreign import arrayBind :: forall a b. Array a -> (a -> Array b) -> Array b

-- | A class for types whose values can safely be discarded
-- | in a `do` notation block.
-- |
-- | An example is the `Unit` type, since there is only one
-- | possible value which can be returned.
class Discard a where
  discard :: forall f b. Bind f => f a -> (a -> f b) -> f b

instance discardUnit :: Discard Unit where
  discard = bind

-- | Collapse two applications of a monadic type constructor into one.
join :: forall a m. Bind m => m (m a) -> m a
join m = m >>= identity

-- | Forwards Kleisli composition.
-- |
-- | For example:
-- |
-- | ```purescript
-- | import Data.Array (head, tail)
-- |
-- | third = tail >=> tail >=> head
-- | ```
composeKleisli :: forall a b c m. Bind m => (a -> m b) -> (b -> m c) -> a -> m c
composeKleisli f g a = f a >>= g

infixr 1 composeKleisli as >=>

-- | Backwards Kleisli composition.
composeKleisliFlipped :: forall a b c m. Bind m => (b -> m c) -> (a -> m b) -> a -> m c
composeKleisliFlipped f g a = f =<< g a

infixr 1 composeKleisliFlipped as <=<

-- | Execute a monadic action if a condition holds.
-- |
-- | For example:
-- |
-- | ```purescript
-- | main = ifM ((< 0.5) <$> random)
-- |          (trace "Heads")
-- |          (trace "Tails")
-- | ```
ifM :: forall a m. Bind m => m Boolean -> m a -> m a -> m a
ifM cond t f = cond >>= \cond' -> if cond' then t else f

module Control.Bind
  ( class Bind, bind, (>>=)
  , bindFlipped, (=<<)
  , class Discard, discard
  , join
  , composeKleisli, (>=>)
  , composeKleisliFlipped, (<=<)
  , ifM
  , module Data.Functor
  , module Control.Apply
  , module Control.Applicative
  ) where

import Control.Applicative (class Applicative, liftA1, pure, unless, when)
import Control.Apply (class Apply, apply, (*>), (<*), (<*>))
import Control.Category (identity)

import Data.Function (flip)
import Data.Functor (class Functor, map, void, ($>), (<#>), (<$), (<$>))
import Data.Unit (Unit)

-- | 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

infixl 1 bind as >>=

-- | `bindFlipped` is `bind` with its arguments reversed. For example:
-- |
-- | ```purescript
-- | print =<< random
-- | ```
bindFlipped :: forall m a b. Bind m => (a -> m b) -> m a -> m b
bindFlipped = flip bind

infixr 1 bindFlipped as =<<

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

-- | The `Array` monad works like a nested for loop. Each
-- | `bind`/`>>=` adds another level of nesting in the loop:
-- | ```
-- | foo :: Array Int
-- | foo =
-- |   ["a", "b"] >>= \eachElementInArray1 ->
-- |     ["c", "d"] >>= \eachElementInArray2
-- |       pure (eachElementInArray1 <> eachElementInArray2)
-- |
-- | foo == [ ("a" <> "c"), ("a" <> "d"), ("b" <> "c"), ("b" <> "d") == [ "ac", "ad", "bc", "bd"]
-- | ```
instance bindArray :: Bind Array where
  bind = arrayBind

foreign import arrayBind :: forall a b. Array a -> (a -> Array b) -> Array b

-- | A class for types whose values can safely be discarded
-- | in a `do` notation block.
-- |
-- | An example is the `Unit` type, since there is only one
-- | possible value which can be returned.
class Discard a where
  discard :: forall f b. Bind f => f a -> (a -> f b) -> f b

instance discardUnit :: Discard Unit where
  discard = bind

-- | Collapse two applications of a monadic type constructor into one.
join :: forall a m. Bind m => m (m a) -> m a
join m = m >>= identity

-- | Forwards Kleisli composition.
-- |
-- | For example:
-- |
-- | ```purescript
-- | import Data.Array (head, tail)
-- |
-- | third = tail >=> tail >=> head
-- | ```
composeKleisli :: forall a b c m. Bind m => (a -> m b) -> (b -> m c) -> a -> m c
composeKleisli f g a = f a >>= g

infixr 1 composeKleisli as >=>

-- | Backwards Kleisli composition.
composeKleisliFlipped :: forall a b c m. Bind m => (b -> m c) -> (a -> m b) -> a -> m c
composeKleisliFlipped f g a = f =<< g a

infixr 1 composeKleisliFlipped as <=<

-- | Execute a monadic action if a condition holds.
-- |
-- | For example:
-- |
-- | ```purescript
-- | main = ifM ((< 0.5) <$> random)
-- |          (trace "Heads")
-- |          (trace "Tails")
-- | ```
ifM :: forall a m. Bind m => m Boolean -> m a -> m a -> m a
ifM cond t f = cond >>= \cond' -> if cond' then t else f


Spine validation

Spine validation

Adds a function `isValidSpine` which takes GenericSignature and
GenericSpine and checks does that spine conforms to the signature.

module Data.Generic
  (Generic, toSpine, toSignature, fromSpine,
   GenericSpine(..),
   GenericSignature(..),
   isValidSpine,
   Proxy(..),
   anyProxy,
   gShow,
   gEq,
   gCompare
  ) where

import Prelude

import Data.Either (Either(..))
import Data.Maybe (Maybe(..))
import Data.Tuple (Tuple(..))
import Data.Traversable (traverse)
import Data.Foldable (all, and, find)
import Data.Array (null, length, sortBy, zipWith)
import Data.String (joinWith)

-- | A GenericSpine is a universal represntation of an arbitrary data structure (that does not contain function arrows).
data GenericSpine = SProd String (Array (Unit -> GenericSpine))
                  | SRecord (Array {recLabel :: String, recValue :: Unit -> GenericSpine})
                  | SNumber Number
                  | SBoolean Boolean
                  | SInt Int
                  | SString String
                  | SArray (Array (Unit -> GenericSpine))

-- | A GenericSignature is a universal representation of the structure of an arbitrary data structure (that does not contain function arrows).
data GenericSignature = SigProd (Array {sigConstructor :: String, sigValues :: Array (Unit -> GenericSignature)})
                      | SigRecord (Array {recLabel :: String, recValue :: Unit -> GenericSignature})
                      | SigNumber
                      | SigBoolean
                      | SigInt
                      | SigString
                      | SigArray (Unit -> GenericSignature)

-- | A proxy is a simple placeholder data type to allow us to pass type-level data at runtime.
data Proxy a = Proxy

anyProxy :: forall a. Proxy a
anyProxy = Proxy

-- | The Generic typeclass provides methods for sending data to/from spine representations, as well as querying about the signatures of spine representations.
-- | For standard data structures, you can simply write "instance Generic Foo" in the module they are declared, and the instance methods will be filled in for you.
class Generic a where
    toSpine :: a -> GenericSpine
    toSignature :: Proxy a -> GenericSignature
    fromSpine :: GenericSpine -> Maybe a

-- | Checks that the spine follows the structure defined by the signature
isValidSpine :: GenericSignature -> GenericSpine -> Boolean
isValidSpine SigBoolean (SBoolean _) = true
isValidSpine SigNumber (SNumber _) = true
isValidSpine SigInt (SInt _) = true
isValidSpine SigString (SString _) = true
isValidSpine (SigArray sig) (SArray spines) = all (isValidSpine (sig unit) <<< (unit #)) spines
isValidSpine (SigProd alts) (SProd tag values) =
  case find ((tag ==) <<< _.sigConstructor) alts of
    Nothing -> false
    Just { sigValues: sigValues } ->
      and $ zipWith (\sig spine -> isValidSpine (sig unit) (spine unit)) sigValues values
isValidSpine (SigRecord fieldSigs) (SRecord fieldVals) =
  and $ zipWith (\sig val -> isValidSpine (sig.recValue unit) (val.recValue unit))
                (sortBy (\a b -> compare a.recLabel b.recLabel) fieldSigs)
                (sortBy (\a b -> compare a.recLabel b.recLabel) fieldVals)
isValidSpine _ _ = false

instance genericNumber :: Generic Number where
    toSpine x = SNumber x
    toSignature _ = SigNumber
    fromSpine (SNumber n) = Just n
    fromSpine _ = Nothing

instance genericInt :: Generic Int where
    toSpine x = SInt x
    toSignature _ = SigInt
    fromSpine (SInt n) = Just n
    fromSpine _ = Nothing

instance genericString :: Generic String where
    toSpine x = SString x
    toSignature _ = SigString
    fromSpine (SString s) = Just s
    fromSpine _ = Nothing

instance genericBool :: Generic Boolean where
    toSpine b = SBoolean b
    toSignature _ = SigBoolean
    fromSpine (SBoolean b)  = Just b
    fromSpine _ = Nothing

instance genericArray :: (Generic a) => Generic (Array a) where
    toSpine xs = SArray ((\x y -> toSpine x) <$> xs)
    toSignature x = SigArray (\unit -> toSignature (lowerProxy x))
        where lowerProxy :: Proxy (Array a) -> Proxy a
              lowerProxy Proxy = (anyProxy :: Proxy a)

    fromSpine (SArray x) = traverse (fromSpine <<< ($ unit)) x
    fromSpine _ = Nothing

instance genericTuple :: (Generic a, Generic b) => Generic (Tuple a b) where
      toSpine (Tuple x y) = SProd "Data.Tuple.Tuple" [\u -> toSpine x, \u -> toSpine y]

      toSignature x = SigProd [{sigConstructor: "Data.Tuple.Tuple", sigValues: [\u -> toSignature (fstProxy x), \u -> toSignature (sndProxy x)]}]
                    where fstProxy :: Proxy (Tuple a b) -> Proxy a
                          fstProxy Proxy = (anyProxy :: Proxy a)
                          sndProxy :: Proxy (Tuple a b) -> Proxy b
                          sndProxy Proxy = (anyProxy :: Proxy b)

      fromSpine (SProd "Data.Tuple.Tuple" [x,y]) = Tuple <$> fromSpine (x unit) <*> fromSpine (y unit)
      fromSpine _ = Nothing

instance genericMaybe :: (Generic a) => Generic (Maybe a) where
      toSpine (Just x) = SProd "Data.Maybe.Just" [\u -> toSpine x]
      toSpine Nothing = SProd "Data.Maybe.Nothing" []
      toSignature x = SigProd [{sigConstructor: "Data.Maybe.Just",sigValues: [\u -> toSignature (mbProxy x)]},
                               {sigConstructor: "Data.Maybe.Nothing",sigValues:[]}]
          where mbProxy :: Proxy (Maybe a) -> Proxy a
                mbProxy Proxy = (anyProxy :: Proxy a)
      fromSpine (SProd "Data.Maybe.Just" [x]) = Just <$> fromSpine (x unit)
      fromSpine (SProd "Data.Maybe.Nothing" []) = return Nothing
      fromSpine _ = Nothing

instance genericEither :: (Generic a, Generic b) => Generic (Either a b) where
    toSpine (Left x) = SProd "Data.Either.Left" [\u -> toSpine x]
    toSpine (Right x) = SProd "Data.Either.Right" [\u -> toSpine x]
    toSignature x = SigProd [{sigConstructor: "Data.Either.Left",  sigValues: [\u -> toSignature (lproxy x)]},
                             {sigConstructor: "Data.Either.Right", sigValues: [\u -> toSignature (rproxy x)]}]
          where lproxy :: Proxy (Either a b) -> Proxy a
                lproxy Proxy = (anyProxy :: Proxy a)
                rproxy :: Proxy (Either a b) -> Proxy b
                rproxy Proxy = (anyProxy :: Proxy b)
    fromSpine (SProd "Data.Either.Left"  [x]) = Left  <$> fromSpine (x unit)
    fromSpine (SProd "Data.Either.Right" [x]) = Right <$> fromSpine (x unit)
    fromSpine _ = Nothing

--- Generic Functions
genericShowPrec :: Int -> GenericSpine -> String
genericShowPrec d (SProd s arr) =
    if null arr
    then s
    else showParen (d > 10) $ s <> " " <> joinWith " " (map (\x -> genericShowPrec 11 (x unit)) arr)
  where showParen false x = x
        showParen true  x = "(" <> x <> ")"

genericShowPrec d (SRecord xs) = "{" <> joinWith ", " (map (\x -> x.recLabel <> ": " <> genericShowPrec 0 (x.recValue unit)) xs) <> "}"
genericShowPrec d (SBoolean x) = show x
genericShowPrec d (SInt x)     = show x
genericShowPrec d (SNumber x)  = show x
genericShowPrec d (SString x)  = show x
genericShowPrec d (SArray xs)  = "[" <> joinWith ", "  (map (\x -> genericShowPrec 0 (x unit)) xs) <> "]"

-- | This function can be used as the default instance for Show for any instance of Generic
gShow :: forall a. (Generic a) => a -> String
gShow = genericShowPrec 0 <<< toSpine

foreign import zipAll :: forall a b c. (a -> b -> Boolean) -> Array a -> Array b -> Boolean

instance eqGeneric :: Eq GenericSpine where
    eq (SProd s1 arr1) (SProd s2 arr2) = s1 == s2
                                      && length arr1 == length arr2
                                      && zipAll (\x y -> x unit == y unit) arr1 arr2
    eq (SRecord xs) (SRecord ys) = length xs == length ys && zipAll go xs ys
             where go x y = x.recLabel == y.recLabel && x.recValue unit == y.recValue unit
    eq (SInt x)     (SInt y)     = x == y
    eq (SNumber x)  (SNumber y)  = x == y
    eq (SBoolean x) (SBoolean y) = x == y
    eq (SString x)  (SString y)  = x == y
    eq (SArray xs)  (SArray ys)  = length xs == length ys && zipAll (\x y -> x unit == y unit) xs ys
    eq _ _ = false

-- | This function can be used as the default instance for Eq for any instance of Generic
gEq :: forall a. (Generic a) => a -> a -> Boolean
gEq x y = toSpine x == toSpine y

foreign import zipCompare :: forall a b c. (a -> b -> Int) -> Array a -> Array b -> Int

instance ordGeneric :: Ord GenericSpine where
    compare (SProd s1 arr1) (SProd s2 arr2) =
        case compare s1 s2 of
          EQ -> compare 0 $ zipCompare (\x y -> case compare (x unit) (y unit) of
                                                  EQ -> 0
                                                  LT -> 1
                                                  GT -> -1) arr1 arr2
          c1 -> c1
    compare (SProd _ _) _ = LT
    compare _ (SProd _ _) = GT
    compare (SRecord xs) (SRecord ys) = compare 0 $ zipCompare go xs ys
        where go x y = case compare x.recLabel y.recLabel of
                         EQ -> case compare (x.recValue unit) (y.recValue unit) of
                                 EQ -> 0
                                 LT -> 1
                                 GT -> -1
                         LT -> 1
                         GT -> -1
    compare (SRecord _) _ = LT
    compare _ (SRecord _) = GT
    compare (SInt x) (SInt y) = compare x y
    compare (SInt _) _ = LT
    compare _ (SInt _) = GT
    compare (SBoolean x) (SBoolean y) = compare x y
    compare (SBoolean _) _ = LT
    compare _ (SBoolean _) = GT
    compare (SNumber x) (SNumber y) = compare x y
    compare (SNumber _) _ = LT
    compare _ (SNumber _) = GT
    compare (SString x) (SString y) = compare x y
    compare (SString _) _ = LT
    compare _ (SString _) = GT
    compare (SArray xs) (SArray ys) = compare 0 $ zipCompare (\x y -> case compare (x unit) (y unit) of
                                                                        EQ -> 0
                                                                        LT -> 1
                                                                        GT -> -1) xs ys

-- | This function can be used as the default instance for the compare method of Ord for any instance of Generic
gCompare :: forall a. (Generic a) => a -> a -> Ordering
gCompare x y = compare (toSpine x) (toSpine y)

module Data.Generic
  (Generic, toSpine, toSignature, fromSpine,
   GenericSpine(..),
   GenericSignature(..),
   Proxy(..),
   anyProxy,
   gShow,
   gEq,
   gCompare
  ) where

import Prelude

import Data.Either (Either(..))
import Data.Maybe (Maybe(..))
import Data.Tuple (Tuple(..))
import Data.Traversable (traverse)
import Data.Array (null, length)
import Data.String (joinWith)

-- | A GenericSpine is a universal represntation of an arbitrary data structure (that does not contain function arrows).
data GenericSpine = SProd String (Array (Unit -> GenericSpine))
                  | SRecord (Array {recLabel :: String, recValue :: Unit -> GenericSpine})
                  | SNumber Number
                  | SBoolean Boolean
                  | SInt Int
                  | SString String
                  | SArray (Array (Unit -> GenericSpine))

-- | A GenericSignature is a universal representation of the structure of an arbitrary data structure (that does not contain function arrows).
data GenericSignature = SigProd (Array {sigConstructor :: String, sigValues :: Array (Unit -> GenericSignature)})
                      | SigRecord (Array {recLabel :: String, recValue :: Unit -> GenericSignature})
                      | SigNumber
                      | SigBoolean
                      | SigInt
                      | SigString
                      | SigArray (Unit -> GenericSignature)

-- | A proxy is a simple placeholder data type to allow us to pass type-level data at runtime.
data Proxy a = Proxy

anyProxy :: forall a. Proxy a
anyProxy = Proxy

-- | The Generic typeclass provides methods for sending data to/from spine representations, as well as querying about the signatures of spine representations.
-- | For standard data structures, you can simply write "instance Generic Foo" in the module they are declared, and the instance methods will be filled in for you.
class Generic a where
    toSpine :: a -> GenericSpine
    toSignature :: Proxy a -> GenericSignature
    fromSpine :: GenericSpine -> Maybe a

instance genericNumber :: Generic Number where
    toSpine x = SNumber x
    toSignature _ = SigNumber
    fromSpine (SNumber n) = Just n
    fromSpine _ = Nothing

instance genericInt :: Generic Int where
    toSpine x = SInt x
    toSignature _ = SigInt
    fromSpine (SInt n) = Just n
    fromSpine _ = Nothing

instance genericString :: Generic String where
    toSpine x = SString x
    toSignature _ = SigString
    fromSpine (SString s) = Just s
    fromSpine _ = Nothing

instance genericBool :: Generic Boolean where
    toSpine b = SBoolean b
    toSignature _ = SigBoolean
    fromSpine (SBoolean b)  = Just b
    fromSpine _ = Nothing

instance genericArray :: (Generic a) => Generic (Array a) where
    toSpine xs = SArray ((\x y -> toSpine x) <$> xs)
    toSignature x = SigArray (\unit -> toSignature (lowerProxy x))
        where lowerProxy :: Proxy (Array a) -> Proxy a
              lowerProxy Proxy = (anyProxy :: Proxy a)

    fromSpine (SArray x) = traverse (fromSpine <<< ($ unit)) x
    fromSpine _ = Nothing

instance genericTuple :: (Generic a, Generic b) => Generic (Tuple a b) where
      toSpine (Tuple x y) = SProd "Data.Tuple.Tuple" [\u -> toSpine x, \u -> toSpine y]

      toSignature x = SigProd [{sigConstructor: "Data.Tuple.Tuple", sigValues: [\u -> toSignature (fstProxy x), \u -> toSignature (sndProxy x)]}]
                    where fstProxy :: Proxy (Tuple a b) -> Proxy a
                          fstProxy Proxy = (anyProxy :: Proxy a)
                          sndProxy :: Proxy (Tuple a b) -> Proxy b
                          sndProxy Proxy = (anyProxy :: Proxy b)

      fromSpine (SProd "Data.Tuple.Tuple" [x,y]) = Tuple <$> fromSpine (x unit) <*> fromSpine (y unit)
      fromSpine _ = Nothing

instance genericMaybe :: (Generic a) => Generic (Maybe a) where
      toSpine (Just x) = SProd "Data.Maybe.Just" [\u -> toSpine x]
      toSpine Nothing = SProd "Data.Maybe.Nothing" []
      toSignature x = SigProd [{sigConstructor: "Data.Maybe.Just",sigValues: [\u -> toSignature (mbProxy x)]},
                               {sigConstructor: "Data.Maybe.Nothing",sigValues:[]}]
          where mbProxy :: Proxy (Maybe a) -> Proxy a
                mbProxy Proxy = (anyProxy :: Proxy a)
      fromSpine (SProd "Data.Maybe.Just" [x]) = Just <$> fromSpine (x unit)
      fromSpine (SProd "Data.Maybe.Nothing" []) = return Nothing
      fromSpine _ = Nothing

instance genericEither :: (Generic a, Generic b) => Generic (Either a b) where
    toSpine (Left x) = SProd "Data.Either.Left" [\u -> toSpine x]
    toSpine (Right x) = SProd "Data.Either.Right" [\u -> toSpine x]
    toSignature x = SigProd [{sigConstructor: "Data.Either.Left",  sigValues: [\u -> toSignature (lproxy x)]},
                             {sigConstructor: "Data.Either.Right", sigValues: [\u -> toSignature (rproxy x)]}]
          where lproxy :: Proxy (Either a b) -> Proxy a
                lproxy Proxy = (anyProxy :: Proxy a)
                rproxy :: Proxy (Either a b) -> Proxy b
                rproxy Proxy = (anyProxy :: Proxy b)
    fromSpine (SProd "Data.Either.Left"  [x]) = Left  <$> fromSpine (x unit)
    fromSpine (SProd "Data.Either.Right" [x]) = Right <$> fromSpine (x unit)
    fromSpine _ = Nothing

--- Generic Functions
genericShowPrec :: Int -> GenericSpine -> String
genericShowPrec d (SProd s arr) =
    if null arr
    then s
    else showParen (d > 10) $ s <> " " <> joinWith " " (map (\x -> genericShowPrec 11 (x unit)) arr)
  where showParen false x = x
        showParen true  x = "(" <> x <> ")"

genericShowPrec d (SRecord xs) = "{" <> joinWith ", " (map (\x -> x.recLabel <> ": " <> genericShowPrec 0 (x.recValue unit)) xs) <> "}"
genericShowPrec d (SBoolean x) = show x
genericShowPrec d (SInt x)     = show x
genericShowPrec d (SNumber x)  = show x
genericShowPrec d (SString x)  = show x
genericShowPrec d (SArray xs)  = "[" <> joinWith ", "  (map (\x -> genericShowPrec 0 (x unit)) xs) <> "]"

-- | This function can be used as the default instance for Show for any instance of Generic
gShow :: forall a. (Generic a) => a -> String
gShow = genericShowPrec 0 <<< toSpine

foreign import zipAll :: forall a b c. (a -> b -> Boolean) -> Array a -> Array b -> Boolean

instance eqGeneric :: Eq GenericSpine where
    eq (SProd s1 arr1) (SProd s2 arr2) = s1 == s2
                                      && length arr1 == length arr2
                                      && zipAll (\x y -> x unit == y unit) arr1 arr2
    eq (SRecord xs) (SRecord ys) = length xs == length ys && zipAll go xs ys
             where go x y = x.recLabel == y.recLabel && x.recValue unit == y.recValue unit
    eq (SInt x)     (SInt y)     = x == y
    eq (SNumber x)  (SNumber y)  = x == y
    eq (SBoolean x) (SBoolean y) = x == y
    eq (SString x)  (SString y)  = x == y
    eq (SArray xs)  (SArray ys)  = length xs == length ys && zipAll (\x y -> x unit == y unit) xs ys
    eq _ _ = false

-- | This function can be used as the default instance for Eq for any instance of Generic
gEq :: forall a. (Generic a) => a -> a -> Boolean
gEq x y = toSpine x == toSpine y

foreign import zipCompare :: forall a b c. (a -> b -> Int) -> Array a -> Array b -> Int

instance ordGeneric :: Ord GenericSpine where
    compare (SProd s1 arr1) (SProd s2 arr2) =
        case compare s1 s2 of
          EQ -> compare 0 $ zipCompare (\x y -> case compare (x unit) (y unit) of
                                                  EQ -> 0
                                                  LT -> 1
                                                  GT -> -1) arr1 arr2
          c1 -> c1
    compare (SProd _ _) _ = LT
    compare _ (SProd _ _) = GT
    compare (SRecord xs) (SRecord ys) = compare 0 $ zipCompare go xs ys
        where go x y = case compare x.recLabel y.recLabel of
                         EQ -> case compare (x.recValue unit) (y.recValue unit) of
                                 EQ -> 0
                                 LT -> 1
                                 GT -> -1
                         LT -> 1
                         GT -> -1
    compare (SRecord _) _ = LT
    compare _ (SRecord _) = GT
    compare (SInt x) (SInt y) = compare x y
    compare (SInt _) _ = LT
    compare _ (SInt _) = GT
    compare (SBoolean x) (SBoolean y) = compare x y
    compare (SBoolean _) _ = LT
    compare _ (SBoolean _) = GT
    compare (SNumber x) (SNumber y) = compare x y
    compare (SNumber _) _ = LT
    compare _ (SNumber _) = GT
    compare (SString x) (SString y) = compare x y
    compare (SString _) _ = LT
    compare _ (SString _) = GT
    compare (SArray xs) (SArray ys) = compare 0 $ zipCompare (\x y -> case compare (x unit) (y unit) of
                                                                        EQ -> 0
                                                                        LT -> 1
                                                                        GT -> -1) xs ys

-- | This function can be used as the default instance for the compare method of Ord for any instance of Generic
gCompare :: forall a. (Generic a) => a -> a -> Ordering
gCompare x y = compare (toSpine x) (toSpine y)


Module name option for Elm

Module name option for Elm

module Language.Elm
    ( renderer
    ) where

import Prelude

import Data.Array as A
import Data.Foldable (for_, intercalate)
import Data.List (List, (:))
import Data.List as L
import Data.Map (Map)
import Data.Map as M
import Data.Maybe (Maybe(..))
import Data.String.Util (camelCase, capitalize, decapitalize, isLetterOrUnderscore, isLetterOrUnderscoreOrDigit, legalizeCharacters, startWithLetter, stringEscape)
import Data.Tuple (Tuple(..), fst)
import Doc (Doc, Namer, Renderer, blank, combineNames, forEachTopLevel_, getClasses, getOptionValue, getTopLevelNames, getTopLevels, getTypeNameForUnion, getUnions, indent, line, lookupClassName, lookupName, lookupUnionName, renderRenderItems, simpleNamer, transformPropertyNames, unionIsNotSimpleNullable, unionNameIntercalated, unlessOption, whenOption)
import IRGraph (IRClassData(..), IRType(..), IRUnionRep, isArray, nullableFromUnion, unionToList)
import Options (Option, enumOption, stringOption)
import Utils (forEnumerated_, sortByKey, sortByKeyM, mapM)

forbiddenNames :: Array String
forbiddenNames =
    [ "if", "then", "else"
    , "case", "of"
    , "let", "in"
    , "type"
    , "module", "where"
    , "import", "exposing"
    , "as"
    , "port"
    , "int", "float", "bool", "string"
    , "Jenc", "Jdec", "Jpipe"
    , "always", "identity"
    , "Array", "Dict", "Maybe", "map", "toList"
    , "makeArrayEncoder", "makeDictEncoder", "makeNullableEncoder"
    ]

listOption :: Option Boolean
listOption = enumOption "array-type" "Use Array or List" [Tuple "array" false, Tuple "list" true]

moduleOption :: Option String
moduleOption = stringOption "module" "The module name for the classes" "NAME" "QuickType"

renderer :: Renderer
renderer =
    { displayName: "Elm"
    , names: [ "elm" ]
    , aceMode: "elm"
    , extension: "elm"
    , doc: elmDoc
    , options:
        [ listOption.specification
        , moduleOption.specification
        ]
    , transforms:
        { nameForClass: elmNamer nameForClass
        , nextName: \s -> "Other" <> s
        , forbiddenNames
        , topLevelName: elmNamer upperNameStyle
        , unions: Just
            { predicate: unionIsNotSimpleNullable
            , properName: elmNamer (upperNameStyle <<< combineNames)
            , nameFromTypes: elmNamer (unionNameIntercalated upperNameStyle "Or")
            }
        }
    }

decoderNameFromTypeName :: String -> String
decoderNameFromTypeName = decapitalize

encoderNameFromTypeName :: String -> String
encoderNameFromTypeName className = "encode" <> className

alsoForbiddenForTypeName :: String -> Array String
alsoForbiddenForTypeName n = [decoderNameFromTypeName n, encoderNameFromTypeName n]

elmNamer :: forall a. Ord a => (a -> String) -> Namer a
elmNamer namer thing = case _ of
    Just name -> result name
    Nothing -> result $ namer thing
    where
        result name = { name, forbid: A.cons name $ alsoForbiddenForTypeName name }

nameForClass :: IRClassData -> String
nameForClass (IRClassData { names }) = upperNameStyle $ combineNames names

typeNameForTopLevelNameGiven :: String -> String
typeNameForTopLevelNameGiven = upperNameStyle

namesFromTopLevelNameGiven :: String -> Array String
namesFromTopLevelNameGiven given =
    let name = typeNameForTopLevelNameGiven given
    in A.cons name $ alsoForbiddenForTypeName name

legalize :: String -> String
legalize = legalizeCharacters isLetterOrUnderscoreOrDigit

elmNameStyle :: Boolean -> String -> String
elmNameStyle upper = legalize >>> camelCase >>> (startWithLetter isLetterOrUnderscore upper)

lowerNameStyle :: String -> String
lowerNameStyle = elmNameStyle false

upperNameStyle :: String -> String
upperNameStyle = elmNameStyle true

renderComment :: Maybe String -> String
renderComment (Just s) = " -- " <> s
renderComment Nothing = ""

renderArrayType :: Doc String
renderArrayType = do
    useList <- getOptionValue listOption
    pure $ if useList then "List" else "Array"

elmDoc :: Doc Unit
elmDoc = do
    topLevels <- getTopLevels
    -- givenTopLevel <- typeNameForTopLevelNameGiven <$> getTopLevelNameGiven
    -- let topLevelDecoder = decoderNameFromTypeName givenTopLevel
    -- let topLevelEncoder = encoderNameFromTypeName givenTopLevel
    classes <- getClasses
    unions <- getUnions
    classNames <- mapM (\t -> lookupClassName $ fst t) classes
    unionNames <- mapM lookupUnionName unions
    topLevelNames <- M.values <$> getTopLevelNames
    let topLevelDecoders = map decoderNameFromTypeName topLevelNames
    let alsoTopLevelExports = L.concat $ map (alsoForbiddenForTypeName >>> L.fromFoldable) topLevelNames
    let exports = L.concat $ topLevelNames : alsoTopLevelExports : classNames : unionNames : L.Nil
    moduleName <- getOptionValue moduleOption
    line """-- To decode the JSON data, add this file to your project, run
--
--     elm-package install NoRedInk/elm-decode-pipeline
--
-- add these imports
--
--     import Json.Decode exposing (decodeString)"""
    line $ "--     import " <> moduleName <> " exposing (" <> (intercalate ", " topLevelDecoders) <> ")"
    line """--
-- and you're off to the races with
--"""
    forEachTopLevel_ \topLevelName topLevelType -> do
        let topLevelDecoder = decoderNameFromTypeName topLevelName
        line $ "--     decodeString " <> topLevelDecoder <> " myJsonString"
    blank
    line $ "module " <> moduleName <> " exposing"
    indent do
        forWithPrefix_ exports "( " ", " \parenOrComma name ->
            line $ parenOrComma <> name
        line ")"
    blank
    line """import Json.Decode as Jdec
import Json.Decode.Pipeline as Jpipe
import Json.Encode as Jenc
import Dict exposing (Dict, map, toList)"""
    arrayType <- renderArrayType
    whenOption listOption do
        line $ "import List exposing (map)"
    unlessOption listOption do
        line $ "import Array exposing (Array, map)"
    blank
    renderRenderItems blank (Just renderTopLevelDefinition) (typeRenderer renderTypeDefinition) (Just renderUnionDefinition)
    blank
    line "-- decoders and encoders"
    blank
    renderRenderItems blank (Just renderTopLevelFunctions) (typeRenderer renderTypeFunctions) (Just renderUnionFunctions)
    blank
    line "--- encoder helpers"
    blank
    line $ "make" <> arrayType <> "Encoder : (a -> Jenc.Value) -> " <> arrayType <> " a -> Jenc.Value"
    line $ "make" <> arrayType <> "Encoder f arr ="
    indent do
        line $ "Jenc." <> decapitalize arrayType <> " (" <> arrayType <> ".map f arr)"
    blank
    line """makeDictEncoder : (a -> Jenc.Value) -> Dict String a -> Jenc.Value
makeDictEncoder f dict =
    Jenc.object (toList (Dict.map (\k -> f) dict))

makeNullableEncoder : (a -> Jenc.Value) -> Maybe a -> Jenc.Value
makeNullableEncoder f m =
    case m of
    Just x -> f x
    Nothing -> Jenc.null"""

renderTopLevelDefinition :: String -> IRType -> Doc Unit
renderTopLevelDefinition topLevelName topLevel = do
    { rendered: topLevelRendered } <- typeStringForType topLevel
    line $ "type alias " <> topLevelName <> " = " <> topLevelRendered

renderTopLevelFunctions :: String -> IRType -> Doc Unit
renderTopLevelFunctions topLevelName topLevel = do
    let topLevelDecoder = decoderNameFromTypeName topLevelName
    let topLevelEncoder = encoderNameFromTypeName topLevelName
    { rendered: rootDecoder } <- decoderNameForType topLevel
    line $ topLevelDecoder <> " : Jdec.Decoder " <> topLevelName
    line $ topLevelDecoder <> " = " <> rootDecoder
    blank
    { rendered: rootEncoder } <- encoderNameForType topLevel
    line $ topLevelEncoder <> " : " <> topLevelName <> " -> String"
    line $ topLevelEncoder <> " r = Jenc.encode 0 (" <> rootEncoder <> " r)"

singleWord :: String -> Doc { rendered :: String, multiWord :: Boolean }
singleWord w = pure { rendered: w, multiWord: false }

multiWord :: String -> String -> Doc { rendered :: String, multiWord :: Boolean }
multiWord s1 s2 = pure { rendered: s1 <> " " <> s2, multiWord: true }

parenIfNeeded :: { rendered :: String, multiWord :: Boolean } -> String
parenIfNeeded { rendered, multiWord: false } = rendered
parenIfNeeded { rendered, multiWord: true } = "(" <> rendered <> ")"

typeStringForType :: IRType -> Doc { rendered :: String, multiWord :: Boolean }
typeStringForType = case _ of
    IRNoInformation -> singleWord "FIXME_THIS_SHOULD_NOT_HAPPEN"
    IRAnyType -> singleWord "Jdec.Value"
    IRNull -> singleWord "()"
    IRInteger -> singleWord "Int"
    IRDouble -> singleWord "Float"
    IRBool -> singleWord "Bool"
    IRString -> singleWord "String"
    IRArray a -> do
        ts <- typeStringForType a
        arrayType <- renderArrayType
        multiWord arrayType $ parenIfNeeded ts
    IRClass i -> singleWord =<< lookupClassName i
    IRMap t -> do
        ts <- typeStringForType t
        multiWord "Dict String" $ parenIfNeeded ts
    IRUnion u ->
        case nullableFromUnion u of
        Just x -> do
            ts <- typeStringForType x
            multiWord "Maybe" $ parenIfNeeded ts
        Nothing -> do
            singleWord =<< lookupUnionName u

unionConstructorName :: String -> IRType -> Doc String
unionConstructorName unionName t = do
    typeName <- upperNameStyle <$> getTypeNameForUnion t
    pure $ typeName <> "In" <> unionName

decoderNameForType :: IRType -> Doc { rendered :: String, multiWord :: Boolean }
decoderNameForType = case _ of
    IRNoInformation -> singleWord "FIXME_THIS_SHOULD_NOT_HAPPEN"
    IRAnyType -> singleWord "Jdec.value"
    IRNull -> multiWord "Jdec.null" "()"
    IRInteger -> singleWord "Jdec.int"
    IRDouble -> singleWord "Jdec.float"
    IRBool -> singleWord "Jdec.bool"
    IRString -> singleWord "Jdec.string"
    IRArray a -> do
        dn <- decoderNameForType a
        arrayType <- renderArrayType
        multiWord ("Jdec." <> decapitalize arrayType) $ parenIfNeeded dn
    IRClass i -> singleWord =<< decoderNameFromTypeName <$> lookupClassName i
    IRMap t -> do
        dn <- decoderNameForType t
        multiWord "Jdec.dict" $ parenIfNeeded dn
    IRUnion u ->
        case nullableFromUnion u of
        Just t -> do
            dn <- decoderNameForType t
            multiWord "Jdec.nullable" $ parenIfNeeded dn
        Nothing -> do
            singleWord =<< decoderNameFromTypeName <$> lookupUnionName u

encoderNameForType :: IRType -> Doc { rendered :: String, multiWord :: Boolean }
encoderNameForType = case _ of
    IRNoInformation -> singleWord "FIXME_THIS_SHOULD_NOT_HAPPEN"
    IRAnyType -> singleWord "identity"
    IRNull -> multiWord "always" "Jenc.null"
    IRInteger -> singleWord "Jenc.int"
    IRDouble -> singleWord "Jenc.float"
    IRBool -> singleWord "Jenc.bool"
    IRString -> singleWord "Jenc.string"
    IRArray a -> do
        rendered <- encoderNameForType a
        arrayType <- renderArrayType
        multiWord ("make" <> arrayType <> "Encoder") $ parenIfNeeded rendered
    IRClass i -> singleWord =<< encoderNameFromTypeName <$> lookupClassName i
    IRMap t -> do
        rendered <- encoderNameForType t
        multiWord "makeDictEncoder" $ parenIfNeeded rendered
    IRUnion u ->
        case nullableFromUnion u of
        Just t -> do
            rendered <- encoderNameForType t
            multiWord "makeNullableEncoder" $ parenIfNeeded rendered
        Nothing ->
            singleWord =<< encoderNameFromTypeName <$> lookupUnionName u

forWithPrefix_ :: forall a b p m. Applicative m => List a -> p -> p -> (p -> a -> m b) -> m Unit
forWithPrefix_ l firstPrefix restPrefix f =
    forEnumerated_ l (\i -> f $ if i == 0 then firstPrefix else restPrefix)

isOptional :: IRType -> Boolean
isOptional = case _ of
    IRUnion u -> not $ unionIsNotSimpleNullable u
    _ -> false

renderTypeDefinition :: String -> Map String String -> List (Tuple String IRType) -> Doc Unit
renderTypeDefinition className propertyNames propsList = do
    line $ "type alias " <> className <> " ="
    indent do
        forWithPrefix_ propsList "{ " ", " \braceOrComma (Tuple pname ptype) -> do
            let propName = lookupName pname propertyNames
            { rendered } <- typeStringForType ptype
            line $ braceOrComma <> propName <> " : " <> rendered
        when (propsList == L.Nil) do
            line "{"
        line "}"

renderTypeFunctions :: String -> Map String String -> List (Tuple String IRType) -> Doc Unit
renderTypeFunctions className propertyNames propsList = do
    let decoderName = decoderNameFromTypeName className
    line $ decoderName <> " : Jdec.Decoder " <> className
    line $ decoderName <> " ="
    indent do
        line $ "Jpipe.decode " <> className
        for_ propsList \(Tuple pname ptype) -> do
            indent do
                propDecoder <- decoderNameForType ptype
                let { reqOrOpt, fallback } = if isOptional ptype then { reqOrOpt: "Jpipe.optional", fallback: " Nothing" } else { reqOrOpt: "Jpipe.required", fallback: "" }
                line $ "|> " <> reqOrOpt <> " \"" <> stringEscape pname <> "\" " <> (parenIfNeeded propDecoder) <> fallback
    blank
    let encoderName = encoderNameFromTypeName className
    line $ encoderName <> " : " <> className <> " -> Jenc.Value"
    line $ encoderName <> " x ="
    indent do
        line "Jenc.object"
        indent do
            forWithPrefix_ propsList "[ " ", " \bracketOrComma (Tuple pname ptype) -> do
                let propName = lookupName pname propertyNames
                { rendered: propEncoder } <- encoderNameForType ptype
                line $ bracketOrComma <> "(\"" <> stringEscape pname <> "\", " <> propEncoder <> " x." <> propName <> ")"
            when (propsList == L.Nil) do
                line "["
            line "]"

typeRenderer :: (String -> Map String String -> List (Tuple String IRType) -> Doc Unit) -> String -> Map String IRType -> Doc Unit
typeRenderer renderer' className properties = do
    let propertyNames = transformPropertyNames (simpleNamer lowerNameStyle) (\n -> "other" <> capitalize n) forbiddenNames properties
    let propsList = M.toUnfoldable properties # sortByKey (\t -> lookupName (fst t) propertyNames)
    renderer' className propertyNames propsList

renderUnionDefinition :: String -> IRUnionRep -> Doc Unit
renderUnionDefinition unionName unionRep = do
    fields <- unionToList unionRep # sortByKeyM (unionConstructorName unionName)
    line $ "type " <> unionName
    forWithPrefix_ fields "=" "|" \equalsOrPipe t -> do
        indent do
            constructor <- unionConstructorName unionName t
            when (t == IRNull) do
                line $ equalsOrPipe <> " " <> constructor
            unless (t == IRNull) do
                ts <- typeStringForType t
                line $ equalsOrPipe <> " " <> constructor <> " " <> (parenIfNeeded ts)

renderUnionFunctions :: String -> IRUnionRep -> Doc Unit
renderUnionFunctions unionName unionRep = do
    let decoderName = decoderNameFromTypeName unionName
    line $ decoderName <> " : Jdec.Decoder " <> unionName
    line $ decoderName <> " ="
    indent do
        let decFields = L.sortBy arrayFirstOrder $ unionToList unionRep
        line "Jdec.oneOf"
        indent do
            forWithPrefix_ decFields "[" "," \bracketOrComma t -> do
                constructor <- unionConstructorName unionName t
                when (t == IRNull) do
                    line $ bracketOrComma <> " Jdec.null " <> constructor
                unless (t == IRNull) do
                    decoder <- decoderNameForType t
                    line $ bracketOrComma <> " Jdec.map " <> constructor <> " " <> parenIfNeeded decoder
            line "]"
    blank
    let encoderName = encoderNameFromTypeName unionName
    line $ encoderName <> " : " <> unionName <> " -> Jenc.Value"
    line $ encoderName <> " x = case x of"
    indent do
        fields <- unionToList unionRep # sortByKeyM (unionConstructorName unionName)
        for_ fields \t -> do
            constructor <- unionConstructorName unionName t
            when (t == IRNull) do
                line $ constructor <> " -> Jenc.null"
            unless (t == IRNull) do
                { rendered: encoder } <- encoderNameForType t
                line $ constructor <> " y -> " <> encoder <> " y"
    where
        arrayFirstOrder a b =
            if isArray a then
                if isArray b then
                    compare a b
                else
                    LT
            else
                if isArray b then
                    GT
                else
                    compare a b

module Language.Elm
    ( renderer
    ) where

import Prelude

import Data.Array as A
import Data.Foldable (for_, intercalate)
import Data.List (List, (:))
import Data.List as L
import Data.Map (Map)
import Data.Map as M
import Data.Maybe (Maybe(..))
import Data.String.Util (camelCase, capitalize, decapitalize, isLetterOrUnderscore, isLetterOrUnderscoreOrDigit, legalizeCharacters, startWithLetter, stringEscape)
import Data.Tuple (Tuple(..), fst)
import Doc (Doc, Namer, Renderer, blank, combineNames, forEachTopLevel_, getClasses, getModuleName, getOptionValue, getTopLevelNames, getTopLevels, getTypeNameForUnion, getUnions, indent, line, lookupClassName, lookupName, lookupUnionName, renderRenderItems, simpleNamer, transformPropertyNames, unionIsNotSimpleNullable, unionNameIntercalated, unlessOption, whenOption)
import IRGraph (IRClassData(..), IRType(..), IRUnionRep, isArray, nullableFromUnion, unionToList)
import Options (Option, enumOption)
import Utils (forEnumerated_, sortByKey, sortByKeyM, mapM)

forbiddenNames :: Array String
forbiddenNames =
    [ "if", "then", "else"
    , "case", "of"
    , "let", "in"
    , "type"
    , "module", "where"
    , "import", "exposing"
    , "as"
    , "port"
    , "int", "float", "bool", "string"
    , "Jenc", "Jdec", "Jpipe"
    , "always", "identity"
    , "Array", "Dict", "Maybe", "map", "toList"
    , "makeArrayEncoder", "makeDictEncoder", "makeNullableEncoder"
    ]

listOption :: Option Boolean
listOption = enumOption "array-type" "Use Array or List" [Tuple "array" false, Tuple "list" true]

renderer :: Renderer
renderer =
    { displayName: "Elm"
    , names: [ "elm" ]
    , aceMode: "elm"
    , extension: "elm"
    , doc: elmDoc
    , options: [listOption.specification]
    , transforms:
        { nameForClass: elmNamer nameForClass
        , nextName: \s -> "Other" <> s
        , forbiddenNames
        , topLevelName: elmNamer upperNameStyle
        , unions: Just
            { predicate: unionIsNotSimpleNullable
            , properName: elmNamer (upperNameStyle <<< combineNames)
            , nameFromTypes: elmNamer (unionNameIntercalated upperNameStyle "Or")
            }
        }
    }

decoderNameFromTypeName :: String -> String
decoderNameFromTypeName = decapitalize

encoderNameFromTypeName :: String -> String
encoderNameFromTypeName className = "encode" <> className

alsoForbiddenForTypeName :: String -> Array String
alsoForbiddenForTypeName n = [decoderNameFromTypeName n, encoderNameFromTypeName n]

elmNamer :: forall a. Ord a => (a -> String) -> Namer a
elmNamer namer thing = case _ of
    Just name -> result name
    Nothing -> result $ namer thing
    where
        result name = { name, forbid: A.cons name $ alsoForbiddenForTypeName name }

nameForClass :: IRClassData -> String
nameForClass (IRClassData { names }) = upperNameStyle $ combineNames names

typeNameForTopLevelNameGiven :: String -> String
typeNameForTopLevelNameGiven = upperNameStyle

namesFromTopLevelNameGiven :: String -> Array String
namesFromTopLevelNameGiven given =
    let name = typeNameForTopLevelNameGiven given
    in A.cons name $ alsoForbiddenForTypeName name

legalize :: String -> String
legalize = legalizeCharacters isLetterOrUnderscoreOrDigit

elmNameStyle :: Boolean -> String -> String
elmNameStyle upper = legalize >>> camelCase >>> (startWithLetter isLetterOrUnderscore upper)

lowerNameStyle :: String -> String
lowerNameStyle = elmNameStyle false

upperNameStyle :: String -> String
upperNameStyle = elmNameStyle true

renderComment :: Maybe String -> String
renderComment (Just s) = " -- " <> s
renderComment Nothing = ""

renderArrayType :: Doc String
renderArrayType = do
    useList <- getOptionValue listOption
    pure $ if useList then "List" else "Array"

elmDoc :: Doc Unit
elmDoc = do
    topLevels <- getTopLevels
    -- givenTopLevel <- typeNameForTopLevelNameGiven <$> getTopLevelNameGiven
    -- let topLevelDecoder = decoderNameFromTypeName givenTopLevel
    -- let topLevelEncoder = encoderNameFromTypeName givenTopLevel
    classes <- getClasses
    unions <- getUnions
    classNames <- mapM (\t -> lookupClassName $ fst t) classes
    unionNames <- mapM lookupUnionName unions
    topLevelNames <- M.values <$> getTopLevelNames
    let topLevelDecoders = map decoderNameFromTypeName topLevelNames
    let alsoTopLevelExports = L.concat $ map (alsoForbiddenForTypeName >>> L.fromFoldable) topLevelNames
    let exports = L.concat $ topLevelNames : alsoTopLevelExports : classNames : unionNames : L.Nil
    moduleName <- getModuleName upperNameStyle
    line """-- To decode the JSON data, add this file to your project, run
--
--     elm-package install NoRedInk/elm-decode-pipeline
--
-- add these imports
--
--     import Json.Decode exposing (decodeString)"""
    line $ "--     import " <> moduleName <> " exposing (" <> (intercalate ", " topLevelDecoders) <> ")"
    line """--
-- and you're off to the races with
--"""
    forEachTopLevel_ \topLevelName topLevelType -> do
        let topLevelDecoder = decoderNameFromTypeName topLevelName
        line $ "--     decodeString " <> topLevelDecoder <> " myJsonString"
    blank
    line $ "module " <> moduleName <> " exposing"
    indent do
        forWithPrefix_ exports "( " ", " \parenOrComma name ->
            line $ parenOrComma <> name
        line ")"
    blank
    line """import Json.Decode as Jdec
import Json.Decode.Pipeline as Jpipe
import Json.Encode as Jenc
import Dict exposing (Dict, map, toList)"""
    arrayType <- renderArrayType
    whenOption listOption do
        line $ "import List exposing (map)"
    unlessOption listOption do
        line $ "import Array exposing (Array, map)"
    blank
    renderRenderItems blank (Just renderTopLevelDefinition) (typeRenderer renderTypeDefinition) (Just renderUnionDefinition)
    blank
    line "-- decoders and encoders"
    blank
    renderRenderItems blank (Just renderTopLevelFunctions) (typeRenderer renderTypeFunctions) (Just renderUnionFunctions)
    blank
    line "--- encoder helpers"
    blank
    line $ "make" <> arrayType <> "Encoder : (a -> Jenc.Value) -> " <> arrayType <> " a -> Jenc.Value"
    line $ "make" <> arrayType <> "Encoder f arr ="
    indent do
        line $ "Jenc." <> decapitalize arrayType <> " (" <> arrayType <> ".map f arr)"
    blank
    line """makeDictEncoder : (a -> Jenc.Value) -> Dict String a -> Jenc.Value
makeDictEncoder f dict =
    Jenc.object (toList (Dict.map (\k -> f) dict))

makeNullableEncoder : (a -> Jenc.Value) -> Maybe a -> Jenc.Value
makeNullableEncoder f m =
    case m of
    Just x -> f x
    Nothing -> Jenc.null"""

renderTopLevelDefinition :: String -> IRType -> Doc Unit
renderTopLevelDefinition topLevelName topLevel = do
    { rendered: topLevelRendered } <- typeStringForType topLevel
    line $ "type alias " <> topLevelName <> " = " <> topLevelRendered

renderTopLevelFunctions :: String -> IRType -> Doc Unit
renderTopLevelFunctions topLevelName topLevel = do
    let topLevelDecoder = decoderNameFromTypeName topLevelName
    let topLevelEncoder = encoderNameFromTypeName topLevelName
    { rendered: rootDecoder } <- decoderNameForType topLevel
    line $ topLevelDecoder <> " : Jdec.Decoder " <> topLevelName
    line $ topLevelDecoder <> " = " <> rootDecoder
    blank
    { rendered: rootEncoder } <- encoderNameForType topLevel
    line $ topLevelEncoder <> " : " <> topLevelName <> " -> String"
    line $ topLevelEncoder <> " r = Jenc.encode 0 (" <> rootEncoder <> " r)"

singleWord :: String -> Doc { rendered :: String, multiWord :: Boolean }
singleWord w = pure { rendered: w, multiWord: false }

multiWord :: String -> String -> Doc { rendered :: String, multiWord :: Boolean }
multiWord s1 s2 = pure { rendered: s1 <> " " <> s2, multiWord: true }

parenIfNeeded :: { rendered :: String, multiWord :: Boolean } -> String
parenIfNeeded { rendered, multiWord: false } = rendered
parenIfNeeded { rendered, multiWord: true } = "(" <> rendered <> ")"

typeStringForType :: IRType -> Doc { rendered :: String, multiWord :: Boolean }
typeStringForType = case _ of
    IRNoInformation -> singleWord "FIXME_THIS_SHOULD_NOT_HAPPEN"
    IRAnyType -> singleWord "Jdec.Value"
    IRNull -> singleWord "()"
    IRInteger -> singleWord "Int"
    IRDouble -> singleWord "Float"
    IRBool -> singleWord "Bool"
    IRString -> singleWord "String"
    IRArray a -> do
        ts <- typeStringForType a
        arrayType <- renderArrayType
        multiWord arrayType $ parenIfNeeded ts
    IRClass i -> singleWord =<< lookupClassName i
    IRMap t -> do
        ts <- typeStringForType t
        multiWord "Dict String" $ parenIfNeeded ts
    IRUnion u ->
        case nullableFromUnion u of
        Just x -> do
            ts <- typeStringForType x
            multiWord "Maybe" $ parenIfNeeded ts
        Nothing -> do
            singleWord =<< lookupUnionName u

unionConstructorName :: String -> IRType -> Doc String
unionConstructorName unionName t = do
    typeName <- upperNameStyle <$> getTypeNameForUnion t
    pure $ typeName <> "In" <> unionName

decoderNameForType :: IRType -> Doc { rendered :: String, multiWord :: Boolean }
decoderNameForType = case _ of
    IRNoInformation -> singleWord "FIXME_THIS_SHOULD_NOT_HAPPEN"
    IRAnyType -> singleWord "Jdec.value"
    IRNull -> multiWord "Jdec.null" "()"
    IRInteger -> singleWord "Jdec.int"
    IRDouble -> singleWord "Jdec.float"
    IRBool -> singleWord "Jdec.bool"
    IRString -> singleWord "Jdec.string"
    IRArray a -> do
        dn <- decoderNameForType a
        arrayType <- renderArrayType
        multiWord ("Jdec." <> decapitalize arrayType) $ parenIfNeeded dn
    IRClass i -> singleWord =<< decoderNameFromTypeName <$> lookupClassName i
    IRMap t -> do
        dn <- decoderNameForType t
        multiWord "Jdec.dict" $ parenIfNeeded dn
    IRUnion u ->
        case nullableFromUnion u of
        Just t -> do
            dn <- decoderNameForType t
            multiWord "Jdec.nullable" $ parenIfNeeded dn
        Nothing -> do
            singleWord =<< decoderNameFromTypeName <$> lookupUnionName u

encoderNameForType :: IRType -> Doc { rendered :: String, multiWord :: Boolean }
encoderNameForType = case _ of
    IRNoInformation -> singleWord "FIXME_THIS_SHOULD_NOT_HAPPEN"
    IRAnyType -> singleWord "identity"
    IRNull -> multiWord "always" "Jenc.null"
    IRInteger -> singleWord "Jenc.int"
    IRDouble -> singleWord "Jenc.float"
    IRBool -> singleWord "Jenc.bool"
    IRString -> singleWord "Jenc.string"
    IRArray a -> do
        rendered <- encoderNameForType a
        arrayType <- renderArrayType
        multiWord ("make" <> arrayType <> "Encoder") $ parenIfNeeded rendered
    IRClass i -> singleWord =<< encoderNameFromTypeName <$> lookupClassName i
    IRMap t -> do
        rendered <- encoderNameForType t
        multiWord "makeDictEncoder" $ parenIfNeeded rendered
    IRUnion u ->
        case nullableFromUnion u of
        Just t -> do
            rendered <- encoderNameForType t
            multiWord "makeNullableEncoder" $ parenIfNeeded rendered
        Nothing ->
            singleWord =<< encoderNameFromTypeName <$> lookupUnionName u

forWithPrefix_ :: forall a b p m. Applicative m => List a -> p -> p -> (p -> a -> m b) -> m Unit
forWithPrefix_ l firstPrefix restPrefix f =
    forEnumerated_ l (\i -> f $ if i == 0 then firstPrefix else restPrefix)

isOptional :: IRType -> Boolean
isOptional = case _ of
    IRUnion u -> not $ unionIsNotSimpleNullable u
    _ -> false

renderTypeDefinition :: String -> Map String String -> List (Tuple String IRType) -> Doc Unit
renderTypeDefinition className propertyNames propsList = do
    line $ "type alias " <> className <> " ="
    indent do
        forWithPrefix_ propsList "{ " ", " \braceOrComma (Tuple pname ptype) -> do
            let propName = lookupName pname propertyNames
            { rendered } <- typeStringForType ptype
            line $ braceOrComma <> propName <> " : " <> rendered
        when (propsList == L.Nil) do
            line "{"
        line "}"

renderTypeFunctions :: String -> Map String String -> List (Tuple String IRType) -> Doc Unit
renderTypeFunctions className propertyNames propsList = do
    let decoderName = decoderNameFromTypeName className
    line $ decoderName <> " : Jdec.Decoder " <> className
    line $ decoderName <> " ="
    indent do
        line $ "Jpipe.decode " <> className
        for_ propsList \(Tuple pname ptype) -> do
            indent do
                propDecoder <- decoderNameForType ptype
                let { reqOrOpt, fallback } = if isOptional ptype then { reqOrOpt: "Jpipe.optional", fallback: " Nothing" } else { reqOrOpt: "Jpipe.required", fallback: "" }
                line $ "|> " <> reqOrOpt <> " \"" <> stringEscape pname <> "\" " <> (parenIfNeeded propDecoder) <> fallback
    blank
    let encoderName = encoderNameFromTypeName className
    line $ encoderName <> " : " <> className <> " -> Jenc.Value"
    line $ encoderName <> " x ="
    indent do
        line "Jenc.object"
        indent do
            forWithPrefix_ propsList "[ " ", " \bracketOrComma (Tuple pname ptype) -> do
                let propName = lookupName pname propertyNames
                { rendered: propEncoder } <- encoderNameForType ptype
                line $ bracketOrComma <> "(\"" <> stringEscape pname <> "\", " <> propEncoder <> " x." <> propName <> ")"
            when (propsList == L.Nil) do
                line "["
            line "]"

typeRenderer :: (String -> Map String String -> List (Tuple String IRType) -> Doc Unit) -> String -> Map String IRType -> Doc Unit
typeRenderer renderer' className properties = do
    let propertyNames = transformPropertyNames (simpleNamer lowerNameStyle) (\n -> "other" <> capitalize n) forbiddenNames properties
    let propsList = M.toUnfoldable properties # sortByKey (\t -> lookupName (fst t) propertyNames)
    renderer' className propertyNames propsList

renderUnionDefinition :: String -> IRUnionRep -> Doc Unit
renderUnionDefinition unionName unionRep = do
    fields <- unionToList unionRep # sortByKeyM (unionConstructorName unionName)
    line $ "type " <> unionName
    forWithPrefix_ fields "=" "|" \equalsOrPipe t -> do
        indent do
            constructor <- unionConstructorName unionName t
            when (t == IRNull) do
                line $ equalsOrPipe <> " " <> constructor
            unless (t == IRNull) do
                ts <- typeStringForType t
                line $ equalsOrPipe <> " " <> constructor <> " " <> (parenIfNeeded ts)

renderUnionFunctions :: String -> IRUnionRep -> Doc Unit
renderUnionFunctions unionName unionRep = do
    let decoderName = decoderNameFromTypeName unionName
    line $ decoderName <> " : Jdec.Decoder " <> unionName
    line $ decoderName <> " ="
    indent do
        let decFields = L.sortBy arrayFirstOrder $ unionToList unionRep
        line "Jdec.oneOf"
        indent do
            forWithPrefix_ decFields "[" "," \bracketOrComma t -> do
                constructor <- unionConstructorName unionName t
                when (t == IRNull) do
                    line $ bracketOrComma <> " Jdec.null " <> constructor
                unless (t == IRNull) do
                    decoder <- decoderNameForType t
                    line $ bracketOrComma <> " Jdec.map " <> constructor <> " " <> parenIfNeeded decoder
            line "]"
    blank
    let encoderName = encoderNameFromTypeName unionName
    line $ encoderName <> " : " <> unionName <> " -> Jenc.Value"
    line $ encoderName <> " x = case x of"
    indent do
        fields <- unionToList unionRep # sortByKeyM (unionConstructorName unionName)
        for_ fields \t -> do
            constructor <- unionConstructorName unionName t
            when (t == IRNull) do
                line $ constructor <> " -> Jenc.null"
            unless (t == IRNull) do
                { rendered: encoder } <- encoderNameForType t
                line $ constructor <> " y -> " <> encoder <> " y"
    where
        arrayFirstOrder a b =
            if isArray a then
                if isArray b then
                    compare a b
                else
                    LT
            else
                if isArray b then
                    GT
                else
                    compare a b