{- |
This module implements a generator for JSON serialisers and parsers of arbitrary elm types.

It is highly recommended to either only use the functions of "Elm.Module", or to use the functions in this module
after having modified the 'ETypeDef' arguments with functions such as 'defaultAlterations'.

The reason is that Elm types might have an equivalent on the Haskell side and should be converted (ie. 'Text' -> 'String', 'Vector' -> 'List').
-}
module Elm.Json
    ( jsonParserForDef
    , jsonSerForDef
    , jsonParserForType
    , jsonSerForType
    , stringSerForSimpleAdt
    , stringParserForSimpleAdt
    )
where

import           Data.Aeson.Types (SumEncoding (..))
import           Data.List
import           Elm.TyRep
import           Elm.Utils

data MaybeHandling = Root | Leaf
                   deriving MaybeHandling -> MaybeHandling -> Bool
(MaybeHandling -> MaybeHandling -> Bool)
-> (MaybeHandling -> MaybeHandling -> Bool) -> Eq MaybeHandling
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MaybeHandling -> MaybeHandling -> Bool
== :: MaybeHandling -> MaybeHandling -> Bool
$c/= :: MaybeHandling -> MaybeHandling -> Bool
/= :: MaybeHandling -> MaybeHandling -> Bool
Eq

-- | Compile a JSON parser for an Elm type
jsonParserForType :: EType -> String
jsonParserForType :: EType -> String
jsonParserForType = MaybeHandling -> EType -> String
jsonParserForType' MaybeHandling
Leaf

isOption :: EType -> Bool
isOption :: EType -> Bool
isOption (ETyApp (ETyCon (ETCon String
"Maybe")) EType
_) = Bool
True
isOption EType
_                                   = Bool
False

jsonParserForType' :: MaybeHandling -> EType -> String
jsonParserForType' :: MaybeHandling -> EType -> String
jsonParserForType' MaybeHandling
mh EType
ty =
    case EType
ty of
      ETyVar (ETVar String
v) -> String
"localDecoder_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
v
      ETyCon (ETCon String
"Int") -> String
"Json.Decode.int"
      ETyCon (ETCon String
"Float") -> String
"Json.Decode.float"
      ETyCon (ETCon String
"String") -> String
"Json.Decode.string"
      ETyCon (ETCon String
"Bool") -> String
"Json.Decode.bool"
      ETyCon (ETCon String
c) -> String
"jsonDec" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
c
      ETyApp (ETyCon (ETCon String
"List")) EType
t' -> String
"Json.Decode.list (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ EType -> String
jsonParserForType EType
t' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
      ETyApp (ETyCon (ETCon String
"Maybe")) EType
t' -> if MaybeHandling
mh MaybeHandling -> MaybeHandling -> Bool
forall a. Eq a => a -> a -> Bool
== MaybeHandling
Root
                                                then EType -> String
jsonParserForType EType
t'
                                                else String
"Json.Decode.maybe (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ EType -> String
jsonParserForType EType
t' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
      ETyApp (ETyCon (ETCon String
"Set")) EType
t' -> String
"decodeSet (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ EType -> String
jsonParserForType EType
t' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
      ETyApp (ETyApp (ETyCon (ETCon String
"Dict")) (ETyCon (ETCon String
"String")) ) EType
value -> String
"Json.Decode.dict (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ EType -> String
jsonParserForType EType
value String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
      ETyApp (ETyApp (ETyCon (ETCon String
"Dict")) EType
key) EType
value -> String
"decodeMap (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ EType -> String
jsonParserForType EType
key String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ EType -> String
jsonParserForType EType
value String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
      EType
_ ->
          case EType -> [EType]
unpackTupleType EType
ty of
            [] -> String -> String
forall a. HasCallStack => String -> a
error (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
"This should never happen. Failed to unpackTupleType: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ EType -> String
forall a. Show a => a -> String
show EType
ty
            [EType
x] ->
                case EType -> [EType]
unpackToplevelConstr EType
x of
                  (EType
y : [EType]
ys) ->
                      EType -> String
jsonParserForType EType
y String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" "
                      String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords ((EType -> String) -> [EType] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\EType
t' -> String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ EType -> String
jsonParserForType EType
t' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")" ) [EType]
ys)
                  [EType]
_ -> String -> String
forall a. HasCallStack => String -> a
error (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
"Do suitable json parser found for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ EType -> String
forall a. Show a => a -> String
show EType
ty
            [EType]
xs ->
                let tupleLen :: Int
tupleLen = [EType] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [EType]
xs
                in String
"Json.Decode.map" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
tupleLen String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" tuple" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
tupleLen String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" "
                    String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords ((Int -> EType -> String) -> [Int] -> [EType] -> [String]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Int
i EType
t' -> String
"(Json.Decode.index " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show (Int
i :: Int) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ EType -> String
jsonParserForType EType
t' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"))") [Int
0..] [EType]
xs)

parseRecords :: Maybe ETypeName -> Bool -> [(String, EType)] -> [String]
parseRecords :: Maybe ETypeName -> Bool -> [(String, EType)] -> [String]
parseRecords Maybe ETypeName
newtyped Bool
unwrap [(String, EType)]
fields =
      case [(String, EType)]
fields of
        [(String
_, EType
ftype)] | Bool
unwrap -> [ String
succeed String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" |> custom (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ MaybeHandling -> EType -> String
jsonParserForType' (EType -> MaybeHandling
o EType
ftype) EType
ftype String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")" ]
        [(String, EType)]
_ -> String
succeed String -> [String] -> [String]
forall a. a -> [a] -> [a]
: ((String, EType) -> String) -> [(String, EType)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String, EType) -> String
forall {a}. Show a => (a, EType) -> String
mkField [(String, EType)]
fields
    where
        succeed :: String
succeed = String
"   Json.Decode.succeed (\\" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords (((String, EType) -> String) -> [(String, EType)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ( (Char
'p'Char -> String -> String
forall a. a -> [a] -> [a]
:) (String -> String)
-> ((String, EType) -> String) -> (String, EType) -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, EType) -> String
forall a b. (a, b) -> a
fst ) [(String, EType)]
fields) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" -> " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
mkNewtype (String
"{" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " (((String, EType) -> String) -> [(String, EType)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\(String
fldName, EType
_) -> String -> String
fixReserved String
fldName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" = p" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fldName) [(String, EType)]
fields) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"}") String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
        mkNewtype :: String -> String
mkNewtype String
x = case Maybe ETypeName
newtyped of
                          Maybe ETypeName
Nothing -> String
x
                          Just ETypeName
nm -> String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ETypeName -> String
et_name ETypeName
nm String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
x String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
        o :: EType -> MaybeHandling
o EType
fldType = if EType -> Bool
isOption EType
fldType
                      then MaybeHandling
Root
                      else MaybeHandling
Leaf
        mkField :: (a, EType) -> String
mkField (a
fldName, EType
fldType) =
           String
"   |> " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (if EType -> Bool
isOption EType
fldType then String
"fnullable " else String
"required ")
                    String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
fldName
                    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ MaybeHandling -> EType -> String
jsonParserForType' (EType -> MaybeHandling
o EType
fldType) EType
fldType String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"

-- | Checks that all the arguments to the ESum are unary values
allUnaries :: Bool -> [SumTypeConstructor] -> Maybe [(String, String)]
allUnaries :: Bool -> [SumTypeConstructor] -> Maybe [(String, String)]
allUnaries Bool
False = Maybe [(String, String)]
-> [SumTypeConstructor] -> Maybe [(String, String)]
forall a b. a -> b -> a
const Maybe [(String, String)]
forall a. Maybe a
Nothing
allUnaries Bool
True  = (SumTypeConstructor -> Maybe (String, String))
-> [SumTypeConstructor] -> Maybe [(String, String)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM SumTypeConstructor -> Maybe (String, String)
isUnary
    where
        isUnary :: SumTypeConstructor -> Maybe (String, String)
isUnary (STC String
o String
c (Anonymous [EType]
args)) = if [EType] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [EType]
args then (String, String) -> Maybe (String, String)
forall a. a -> Maybe a
Just (String
o,String
c) else Maybe (String, String)
forall a. Maybe a
Nothing
        isUnary SumTypeConstructor
_ = Maybe (String, String)
forall a. Maybe a
Nothing

-- | Compile a JSON parser for an Elm type definition
jsonParserForDef :: ETypeDef -> String
jsonParserForDef :: ETypeDef -> String
jsonParserForDef ETypeDef
etd =
    case ETypeDef
etd of
      ETypePrimAlias (EPrimAlias ETypeName
name EType
ty) -> [String] -> String
unlines
          [ ETypeName -> String
decoderType ETypeName
name
          , ETypeName -> String
makeName ETypeName
name String -> String -> String
forall a. [a] -> [a] -> [a]
++  String
" ="
          , String
"    " String -> String -> String
forall a. [a] -> [a] -> [a]
++ EType -> String
jsonParserForType EType
ty
          ]
      ETypeAlias (EAlias ETypeName
name [(String, EType)]
fields Bool
_ Bool
newtyping Bool
unwrap) -> [String] -> String
unlines
          ( ETypeName -> String
decoderType ETypeName
name
          String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (ETypeName -> String
makeName ETypeName
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" =")
          String -> [String] -> [String]
forall a. a -> [a] -> [a]
: Maybe ETypeName -> Bool -> [(String, EType)] -> [String]
parseRecords (if Bool
newtyping then ETypeName -> Maybe ETypeName
forall a. a -> Maybe a
Just ETypeName
name else Maybe ETypeName
forall a. Maybe a
Nothing) Bool
unwrap [(String, EType)]
fields
          )
      ETypeSum (ESum ETypeName
name [SumTypeConstructor]
opts (SumEncoding' SumEncoding
encodingType) Bool
_ Bool
unarystring) ->
            ETypeName -> String
decoderType ETypeName
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
            ETypeName -> String
makeName ETypeName
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" =" String -> String -> String
forall a. [a] -> [a] -> [a]
++
                case Bool -> [SumTypeConstructor] -> Maybe [(String, String)]
allUnaries Bool
unarystring [SumTypeConstructor]
opts of
                    Just [(String, String)]
names -> String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [(String, String)] -> String
forall {a}. Show a => [(String, a)] -> String
deriveUnaries [(String, String)]
names
                    Maybe [(String, String)]
Nothing    -> String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [SumTypeConstructor] -> String
encodingDictionary [SumTypeConstructor]
opts String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
isObjectSet String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [SumTypeConstructor] -> String
forall {a}. [a] -> String
declLine [SumTypeConstructor]
opts String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"
          where
            tab :: Int -> String -> String
tab Int
n String
s = Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
n Char
' ' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s
            typename :: String
typename = ETypeName -> String
et_name ETypeName
name
            declLine :: [a] -> String
declLine [a
_] = String
""
            declLine [a]
_   = String
"    in  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ case SumEncoding
encodingType of
                           SumEncoding
ObjectWithSingleField -> [String] -> String
unwords [ String
"decodeSumObjectWithSingleField ", String -> String
forall a. Show a => a -> String
show String
typename, String
dictName]
                           SumEncoding
TwoElemArray          -> [String] -> String
unwords [ String
"decodeSumTwoElemArray ", String -> String
forall a. Show a => a -> String
show String
typename, String
dictName ]
                           TaggedObject String
tg String
el    -> [String] -> String
unwords [ String
"decodeSumTaggedObject", String -> String
forall a. Show a => a -> String
show String
typename, String -> String
forall a. Show a => a -> String
show String
tg, String -> String
forall a. Show a => a -> String
show String
el, String
dictName, String
isObjectSetName ]
                           SumEncoding
UntaggedValue         -> String
"Json.Decode.oneOf (Dict.values " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
dictName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
            dictName :: String
dictName = String
"jsonDecDict" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
typename
            isObjectSetName :: String
isObjectSetName = String
"jsonDecObjectSet" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
typename
            deriveUnaries :: [(String, a)] -> String
deriveUnaries [(String, a)]
strs = [String] -> String
unlines
                [ String
""
                , String
"    let " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
dictName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" = Dict.fromList [" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " (((String, a) -> String) -> [(String, a)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\(String
o, a
s) -> String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
o String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")") [(String, a)]
strs ) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"]"
                , String
"    in  decodeSumUnaries " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
typename String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
dictName
                ]
            encodingDictionary :: [SumTypeConstructor] -> String
encodingDictionary [STC String
cname String
_ SumTypeFields
args] = String
"    " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> SumTypeFields -> String
mkDecoder String
cname SumTypeFields
args
            encodingDictionary [SumTypeConstructor]
os = Int -> String -> String
tab Int
4 String
"let " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
dictName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" = Dict.fromList\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String -> String
tab Int
12 String
"[ " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate (String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
12 Char
' ' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", ") ((SumTypeConstructor -> String) -> [SumTypeConstructor] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map SumTypeConstructor -> String
dictEntry [SumTypeConstructor]
os) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String -> String
tab Int
12 String
"]"
            isObjectSet :: String
isObjectSet = case SumEncoding
encodingType of
                              TaggedObject String
_ String
_
                                | [SumTypeConstructor] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [SumTypeConstructor]
opts Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 ->
                                  String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String -> String
tab Int
8 (String
isObjectSetName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Set.fromList [" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " [String]
objectSet String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"]")
                                where objectSet :: [String]
objectSet =
                                        ((SumTypeConstructor -> String) -> [SumTypeConstructor] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String
forall a. Show a => a -> String
show (String -> String)
-> (SumTypeConstructor -> String) -> SumTypeConstructor -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SumTypeConstructor -> String
_stcName) ([SumTypeConstructor] -> [String])
-> [SumTypeConstructor] -> [String]
forall a b. (a -> b) -> a -> b
$ (SumTypeConstructor -> Bool)
-> [SumTypeConstructor] -> [SumTypeConstructor]
forall a. (a -> Bool) -> [a] -> [a]
filter (SumTypeFields -> Bool
isNamed (SumTypeFields -> Bool)
-> (SumTypeConstructor -> SumTypeFields)
-> SumTypeConstructor
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SumTypeConstructor -> SumTypeFields
_stcFields) [SumTypeConstructor]
opts) [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++
                                        -- if field is empty, it do not have content, so add to objectSet.
                                        ((SumTypeConstructor -> String) -> [SumTypeConstructor] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String
forall a. Show a => a -> String
show (String -> String)
-> (SumTypeConstructor -> String) -> SumTypeConstructor -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SumTypeConstructor -> String
_stcName) ([SumTypeConstructor] -> [String])
-> [SumTypeConstructor] -> [String]
forall a b. (a -> b) -> a -> b
$ (SumTypeConstructor -> Bool)
-> [SumTypeConstructor] -> [SumTypeConstructor]
forall a. (a -> Bool) -> [a] -> [a]
filter (SumTypeFields -> Bool
isEmpty (SumTypeFields -> Bool)
-> (SumTypeConstructor -> SumTypeFields)
-> SumTypeConstructor
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SumTypeConstructor -> SumTypeFields
_stcFields) [SumTypeConstructor]
opts)
                              SumEncoding
_ -> String
""
            dictEntry :: SumTypeConstructor -> String
dictEntry (STC String
cname String
oname SumTypeFields
args) = String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
oname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> SumTypeFields -> String
mkDecoder String
cname SumTypeFields
args String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
            mkDecoder :: String -> SumTypeFields -> String
mkDecoder String
cname (Named [(String, EType)]
args)  =  String -> String
lazy (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
"Json.Decode.map "
                                         String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cname
                                         String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" ("
                                         String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords (Maybe ETypeName -> Bool -> [(String, EType)] -> [String]
parseRecords Maybe ETypeName
forall a. Maybe a
Nothing Bool
False [(String, EType)]
args)
                                         String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"

            mkDecoder String
cname (Anonymous [EType]
args) = String -> String
lazy (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords ( String
decodeFunction
                                                   String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String
cname
                                                   String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (EType -> Int -> String) -> [EType] -> [Int] -> [String]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\EType
t' Int
i -> String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ EType -> Int -> String
jsonParserForIndexedType EType
t' Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")") [EType]
args [Int
0..]
                                                   )
                where decodeFunction :: String
decodeFunction = case [EType] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [EType]
args of
                                           Int
0 -> String
"Json.Decode.succeed"
                                           Int
1 -> String
"Json.Decode.map"
                                           Int
n -> String
"Json.Decode.map" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n
                      jsonParserForIndexedType :: EType -> Int -> String
                      jsonParserForIndexedType :: EType -> Int -> String
jsonParserForIndexedType EType
t' Int
i | [EType] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [EType]
args Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
1 = EType -> String
jsonParserForType EType
t'
                                                    | Bool
otherwise = String
"Json.Decode.index " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ EType -> String
jsonParserForType EType
t' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
    where
      funcname :: ETypeName -> String
funcname ETypeName
name = String
"jsonDec" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ETypeName -> String
et_name ETypeName
name
      prependTypes :: String -> ETypeName -> [String]
prependTypes String
str = (ETVar -> String) -> [ETVar] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\ETVar
tv -> String
str String -> String -> String
forall a. [a] -> [a] -> [a]
++ ETVar -> String
tv_name ETVar
tv) ([ETVar] -> [String])
-> (ETypeName -> [ETVar]) -> ETypeName -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ETypeName -> [ETVar]
et_args
      decoderType :: ETypeName -> String
decoderType ETypeName
name = ETypeName -> String
funcname ETypeName
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" : " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
" -> " (String -> ETypeName -> [String]
prependTypes String
"Json.Decode.Decoder " ETypeName
name [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [ETypeName -> String
decoderTypeEnd ETypeName
name])
      decoderTypeEnd :: ETypeName -> String
decoderTypeEnd ETypeName
name = [String] -> String
unwords (String
"Json.Decode.Decoder" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String
"(" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: ETypeName -> String
et_name ETypeName
name String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (ETVar -> String) -> [ETVar] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ETVar -> String
tv_name (ETypeName -> [ETVar]
et_args ETypeName
name) [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
")"])
      makeName :: ETypeName -> String
makeName ETypeName
name = [String] -> String
unwords (ETypeName -> String
funcname ETypeName
name String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String -> ETypeName -> [String]
prependTypes String
"localDecoder_" ETypeName
name)
      lazy :: String -> String
lazy String
decoder = String
"Json.Decode.lazy (\\_ -> " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
decoder String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"

{-| Compile a JSON serializer for an Elm type.

The 'omitNothingFields' option is currently not implemented!
-}
jsonSerForType :: EType -> String
jsonSerForType :: EType -> String
jsonSerForType = Bool -> [Int] -> EType -> String
jsonSerForType' Bool
False [Int
1..]

jsonSerForType' :: Bool -> [Int] -> EType -> String
jsonSerForType' :: Bool -> [Int] -> EType -> String
jsonSerForType' Bool
omitnull [Int]
ns EType
ty =
    case EType
ty of
      ETyVar (ETVar String
v) -> String
"localEncoder_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
v
      ETyCon (ETCon String
"Int") -> String
"Json.Encode.int"
      ETyCon (ETCon String
"Float") -> String
"Json.Encode.float"
      ETyCon (ETCon String
"String") -> String
"Json.Encode.string"
      ETyCon (ETCon String
"Bool") -> String
"Json.Encode.bool"
      ETyCon (ETCon String
c) -> String
"jsonEnc" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
c
      ETyApp (ETyCon (ETCon String
"List")) EType
t' -> String
"(Json.Encode.list " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Bool -> [Int] -> EType -> String
jsonSerForType' Bool
omitnull [Int]
ns EType
t' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
      ETyApp (ETyCon (ETCon String
"Maybe")) EType
t' -> if Bool
omitnull
                                                then Bool -> [Int] -> EType -> String
jsonSerForType' Bool
omitnull [Int]
ns EType
t'
                                                else String
"(maybeEncode (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Bool -> [Int] -> EType -> String
jsonSerForType' Bool
omitnull [Int]
ns EType
t' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"))"
      ETyApp (ETyCon (ETCon String
"Set")) EType
t' -> String
"(encodeSet " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Bool -> [Int] -> EType -> String
jsonSerForType' Bool
omitnull [Int]
ns EType
t' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
      ETyApp (ETyApp (ETyCon (ETCon String
"Dict")) (ETyCon (ETCon String
"String"))) EType
value -> String
"(Json.Encode.dict identity (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Bool -> [Int] -> EType -> String
jsonSerForType' Bool
omitnull [Int]
ns EType
value String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"))"
      ETyApp (ETyApp (ETyCon (ETCon String
"Dict")) EType
key) EType
value -> String
"(encodeMap (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Bool -> [Int] -> EType -> String
jsonSerForType' Bool
omitnull [Int]
ns EType
key String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Bool -> [Int] -> EType -> String
jsonSerForType' Bool
omitnull [Int]
ns EType
value String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"))"
      EType
_ ->
          case EType -> [EType]
unpackTupleType EType
ty of
            [] -> String -> String
forall a. HasCallStack => String -> a
error (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
"This should never happen. Failed to unpackTupleType: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ EType -> String
forall a. Show a => a -> String
show EType
ty
            [EType
x] ->
                case EType -> [EType]
unpackToplevelConstr EType
x of
                  (EType
y : [EType]
ys) ->
                      String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Bool -> [Int] -> EType -> String
jsonSerForType' Bool
omitnull [Int]
ns EType
y String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" "
                      String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords ((EType -> String) -> [EType] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\EType
t' -> String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Bool -> [Int] -> EType -> String
jsonSerForType' Bool
omitnull [Int]
ns EType
t' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")") [EType]
ys)
                      String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
                  [EType]
_ -> String -> String
forall a. HasCallStack => String -> a
error (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ String
"Do suitable json serialiser found for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ EType -> String
forall a. Show a => a -> String
show EType
ty
            [EType]
xs ->
                let ([Int]
ns', [Int]
rest) = Int -> [Int] -> ([Int], [Int])
forall a. Int -> [a] -> ([a], [a])
splitAt ([EType] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [EType]
xs) [Int]
ns
                    tupleArgsV :: [(EType, Int)]
tupleArgsV = [EType] -> [Int] -> [(EType, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [EType]
xs [Int]
ns'
                    tupleArgs :: String
tupleArgs =
                        String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ ((EType, Int) -> String) -> [(EType, Int)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\(EType
_, Int
v) -> String
"t" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
v) [(EType, Int)]
tupleArgsV
                in String
"(\\(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
tupleArgs String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") -> Json.Encode.list identity [" String -> String -> String
forall a. [a] -> [a] -> [a]
++  String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," (((EType, Int) -> String) -> [(EType, Int)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\(EType
t', Int
idx) -> String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Bool -> [Int] -> EType -> String
jsonSerForType' Bool
omitnull [Int]
rest EType
t' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") t" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
idx) [(EType, Int)]
tupleArgsV) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"])"


-- | Compile a JSON serializer for an Elm type definition
jsonSerForDef :: ETypeDef -> String
jsonSerForDef :: ETypeDef -> String
jsonSerForDef ETypeDef
etd =
    case ETypeDef
etd of
      ETypePrimAlias (EPrimAlias ETypeName
name EType
ty) ->
          ETypeName -> Bool -> String
makeName ETypeName
name Bool
False String -> String -> String
forall a. [a] -> [a] -> [a]
++  String
" = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ EType -> String
jsonSerForType EType
ty String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" val\n"
      ETypeAlias (EAlias ETypeName
name [(String
fldName, EType
fldType)] Bool
_ Bool
newtyping Bool
True) ->
          ETypeName -> Bool -> String
makeName ETypeName
name Bool
newtyping String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" =\n   " String -> String -> String
forall a. [a] -> [a] -> [a]
++ EType -> String
jsonSerForType EType
fldType String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" val." String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
fixReserved String
fldName
      ETypeAlias (EAlias ETypeName
name [(String, EType)]
fields Bool
_ Bool
newtyping Bool
_) ->
          ETypeName -> Bool -> String
makeName ETypeName
name Bool
newtyping String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" =\n   Json.Encode.object\n   ["
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\n   ," (((String, EType) -> String) -> [(String, EType)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\(String
fldName, EType
fldType) -> String
" (\"" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
fldName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ EType -> String
jsonSerForType EType
fldType String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" val." String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
fixReserved String
fldName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")") [(String, EType)]
fields)
          String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n   ]\n"
      ETypeSum (ESum ETypeName
name [SumTypeConstructor]
opts (SumEncoding' SumEncoding
se) Bool
_ Bool
unarystring) ->
        case Bool -> [SumTypeConstructor] -> Maybe [(String, String)]
allUnaries Bool
unarystring [SumTypeConstructor]
opts of
            Maybe [(String, String)]
Nothing   -> [SumTypeConstructor] -> String
defaultEncoding [SumTypeConstructor]
opts
            Just [(String, String)]
strs -> [(String, String)] -> String
forall {a}. Show a => [(String, a)] -> String
unaryEncoding [(String, String)]
strs
          where
              encodeFunction :: String
encodeFunction = case SumEncoding
se of
                                   SumEncoding
ObjectWithSingleField -> String
"encodeSumObjectWithSingleField"
                                   SumEncoding
TwoElemArray -> String
"encodeSumTwoElementArray"
                                   TaggedObject String
k String
c -> [String] -> String
unwords [String
"encodeSumTaggedObject", String -> String
forall a. Show a => a -> String
show String
k, String -> String
forall a. Show a => a -> String
show String
c]
                                   SumEncoding
UntaggedValue -> String
"encodeSumUntagged"
              defaultEncoding :: [SumTypeConstructor] -> String
defaultEncoding [STC String
_ String
oname (Anonymous [EType]
args)] = [String] -> String
unlines
                [ ETypeName -> String
makeType ETypeName
name
                , ETypeName -> String
fname ETypeName
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" "
                    String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords ((ETVar -> String) -> [ETVar] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\ETVar
tv -> String
"localEncoder_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ETVar -> String
tv_name ETVar
tv) ([ETVar] -> [String]) -> [ETVar] -> [String]
forall a b. (a -> b) -> a -> b
$ ETypeName -> [ETVar]
et_args ETypeName
name)
                    String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
cap String
oname  String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [EType] -> String
forall {t :: * -> *} {a}. Foldable t => t a -> String
argList [EType]
args String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
") ="
                , String
"    " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [EType] -> String
mkEncodeList [EType]
args
                ]
              defaultEncoding [SumTypeConstructor]
os = [String] -> String
unlines (
                ( ETypeName -> Bool -> String
makeName ETypeName
name Bool
False String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" =")
                String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String
"    let keyval v = case v of"
                String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (SumTypeConstructor -> String) -> [SumTypeConstructor] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ((Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
12 Char
' ' String -> String -> String
forall a. [a] -> [a] -> [a]
++) (String -> String)
-> (SumTypeConstructor -> String) -> SumTypeConstructor -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SumTypeConstructor -> String
mkcase) [SumTypeConstructor]
os
                [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [ String
"    " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords [String
"in", String
encodeFunction, String
"keyval", String
"val"] ]
                )
              unaryEncoding :: [(String, a)] -> String
unaryEncoding [(String, a)]
names = [String] -> String
unlines (
                [ ETypeName -> Bool -> String
makeName ETypeName
name Bool
False String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" ="
                , String
"    case val of"
                ] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ ((String, a) -> String) -> [(String, a)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\(String
o, a
n) -> Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
8 Char
' ' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
o String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" -> Json.Encode.string " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
n) [(String, a)]
names
                )
              mkcase :: SumTypeConstructor -> String
              mkcase :: SumTypeConstructor -> String
mkcase (STC String
cname String
oname (Anonymous [EType]
args)) = Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
8 Char
' ' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
cap String
cname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [EType] -> String
forall {t :: * -> *} {a}. Foldable t => t a -> String
argList [EType]
args String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" -> (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
oname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", encodeValue (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [EType] -> String
mkEncodeList [EType]
args String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"))"
              mkcase (STC String
cname String
oname (Named [(String, EType)]
args)) = Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
8 Char
' ' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
cap String
cname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" vs -> (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
oname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [(String, EType)] -> String
mkEncodeObject [(String, EType)]
args String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
              argList :: t a -> String
argList t a
a = [String] -> String
unwords ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (Int -> String) -> [Int] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\Int
i -> String
"v" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i ) [Int
1 .. t a -> Int
forall a. t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
a]
              numargs :: (a -> String) -> [a] -> String
              numargs :: forall a. (a -> String) -> [a] -> String
numargs a -> String
f = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " ([String] -> String) -> ([a] -> [String]) -> [a] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> a -> String) -> [Int] -> [a] -> [String]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\Int
n a
a -> a -> String
f a
a String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" v" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n)  ([Int
1..] :: [Int])
              mkEncodeObject :: [(String, EType)] -> String
mkEncodeObject [(String, EType)]
args = String
"encodeObject [" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
", " (((String, EType) -> String) -> [(String, EType)] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\(String
n,EType
t) -> String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
", " String -> String -> String
forall a. [a] -> [a] -> [a]
++ EType -> String
jsonSerForType EType
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" vs." String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
fixReserved String
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")") [(String, EType)]
args) String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"]"
              mkEncodeList :: [EType] -> String
mkEncodeList [EType
arg] = EType -> String
jsonSerForType EType
arg String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" v1"
              mkEncodeList [EType]
args =  String
"Json.Encode.list identity [" String -> String -> String
forall a. [a] -> [a] -> [a]
++ (EType -> String) -> [EType] -> String
forall a. (a -> String) -> [a] -> String
numargs EType -> String
jsonSerForType [EType]
args String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"]"
    where
      fname :: ETypeName -> String
fname ETypeName
name = String
"jsonEnc" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ETypeName -> String
et_name ETypeName
name
      makeType :: ETypeName -> String
makeType ETypeName
name = ETypeName -> String
fname ETypeName
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" : " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
" -> " ((ETVar -> String) -> [ETVar] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (String -> String
mkLocalEncoder (String -> String) -> (ETVar -> String) -> ETVar -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ETVar -> String
tv_name) (ETypeName -> [ETVar]
et_args ETypeName
name) [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [[String] -> String
unwords (ETypeName -> String
et_name ETypeName
name String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (ETVar -> String) -> [ETVar] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ETVar -> String
tv_name (ETypeName -> [ETVar]
et_args ETypeName
name)) , String
"Value"])
      mkLocalEncoder :: String -> String
mkLocalEncoder String
n = String
"(" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" -> Value)"
      makeName :: ETypeName -> Bool -> String
makeName ETypeName
name Bool
newtyping =
           ETypeName -> String
makeType ETypeName
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"
           String -> String -> String
forall a. [a] -> [a] -> [a]
++ ETypeName -> String
fname ETypeName
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" "
           String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords ((ETVar -> String) -> [ETVar] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\ETVar
tv -> String
"localEncoder_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ETVar -> String
tv_name ETVar
tv) ([ETVar] -> [String]) -> [ETVar] -> [String]
forall a b. (a -> b) -> a -> b
$ ETypeName -> [ETVar]
et_args ETypeName
name)
           String -> String -> String
forall a. [a] -> [a] -> [a]
++ if Bool
newtyping
                  then String
" (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ETypeName -> String
et_name ETypeName
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" val)"
                  else String
" val"

-- | Serialize a type like 'type Color = Red | Green | Blue' in a function like
--
-- > stringEncColor : Color -> String
-- > stringEncColor x =
-- >   case x of
-- >     Red -> "red"
-- >     ...
--
-- This is mainly useful for types which are used as part of query parameters and url captures.
stringSerForSimpleAdt :: ETypeDef -> String
stringSerForSimpleAdt :: ETypeDef -> String
stringSerForSimpleAdt ETypeDef
etd =
  case ETypeDef
etd of
    ETypeSum (ESum ETypeName
name [SumTypeConstructor]
opts (SumEncoding' SumEncoding
_se) Bool
_ Bool
_unarystring) ->
      [SumTypeConstructor] -> String
defaultEncoding [SumTypeConstructor]
opts
      where
        defaultEncoding :: [SumTypeConstructor] -> String
defaultEncoding [SumTypeConstructor]
os =
          [String] -> String
unlines
            ((ETypeName -> Bool -> String
makeName ETypeName
name Bool
False String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" =") String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String
"    case val of" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (SumTypeConstructor -> String) -> [SumTypeConstructor] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map SumTypeConstructor -> String
mkcase [SumTypeConstructor]
os)
        mkcase :: SumTypeConstructor -> String
        mkcase :: SumTypeConstructor -> String
mkcase (STC String
cname String
oname (Anonymous [EType]
args)) =
          Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
8 Char
' '
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
cap String
cname
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" "
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ [EType] -> String
forall {t :: * -> *} {a}. Foldable t => t a -> String
argList [EType]
args
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" -> "
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
oname
        mkcase SumTypeConstructor
_ =
          String -> String
forall a. HasCallStack => String -> a
error String
"stringSerForSimpleAdt.mkcase: Expecting an Anonymous case"
        argList :: t a -> String
argList t a
a = [String] -> String
unwords ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ (Int -> String) -> [Int] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\Int
i -> String
"v" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
i) [Int
1 .. t a -> Int
forall a. t a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length t a
a]
    ETypeDef
_ -> String -> String
forall a. HasCallStack => String -> a
error String
"stringSerForSimpleAdt only works with ETypeSum"
  where
    fname :: ETypeName -> String
fname ETypeName
name = String
"stringEnc" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ETypeName -> String
et_name ETypeName
name
    makeType :: ETypeName -> String
makeType ETypeName
name =
      ETypeName -> String
fname ETypeName
name
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" : "
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate
          String
" -> "
          ([[String] -> String
unwords (ETypeName -> String
et_name ETypeName
name String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (ETVar -> String) -> [ETVar] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ETVar -> String
tv_name (ETypeName -> [ETVar]
et_args ETypeName
name))] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
"String"])
    makeName :: ETypeName -> Bool -> String
makeName ETypeName
name Bool
newtyping =
      ETypeName -> String
makeType ETypeName
name
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ ETypeName -> String
fname ETypeName
name
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" "
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
unwords ((ETVar -> String) -> [ETVar] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\ETVar
tv -> String
"localEncoder_" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ETVar -> String
tv_name ETVar
tv) ([ETVar] -> [String]) -> [ETVar] -> [String]
forall a b. (a -> b) -> a -> b
$ ETypeName -> [ETVar]
et_args ETypeName
name)
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ if Bool
newtyping
          then String
" (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ETypeName -> String
et_name ETypeName
name String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" val)"
          else String
" val"

-- | Parse a String into a maybe-value for simple ADT types. See 'stringSerForSimpleAdt' for motivation
stringParserForSimpleAdt :: ETypeDef -> String
stringParserForSimpleAdt :: ETypeDef -> String
stringParserForSimpleAdt ETypeDef
etd =
  case ETypeDef
etd of
    ETypeSum (ESum ETypeName
name [SumTypeConstructor]
opts (SumEncoding' SumEncoding
_encodingType) Bool
_ Bool
_unarystring) ->
      ETypeName -> String
decoderType ETypeName
name
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ ETypeName -> String
makeName ETypeName
name
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" s =\n"
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ [SumTypeConstructor] -> String
encodingDictionary [SumTypeConstructor]
opts
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"
      where
        tab :: Int -> String -> String
tab Int
n String
s = Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
n Char
' ' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
s
        encodingDictionary :: [SumTypeConstructor] -> String
encodingDictionary [STC String
cname String
_ SumTypeFields
args] =
          String
"    " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> SumTypeFields -> String
forall {p} {p} {a}. p -> p -> a
mkDecoder String
cname SumTypeFields
args
        encodingDictionary [SumTypeConstructor]
os =
          String
"    case s of\n"
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String -> String
tab Int
8 String
""
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate (String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
8 Char
' ') ((SumTypeConstructor -> String) -> [SumTypeConstructor] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map SumTypeConstructor -> String
dictEntry [SumTypeConstructor]
os)
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"
            String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String -> String
tab Int
8 String
"_ -> Nothing"
        dictEntry :: SumTypeConstructor -> String
dictEntry (STC String
cname String
oname SumTypeFields
_args) =
          String -> String
forall a. Show a => a -> String
show String
oname String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" -> Just " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
cname
        mkDecoder :: p -> p -> a
mkDecoder p
_cname p
_ = String -> a
forall a. HasCallStack => String -> a
error String
"impossible!"
    ETypeDef
_ -> String -> String
forall a. HasCallStack => String -> a
error String
"impossible"
  where
    funcname :: ETypeName -> String
funcname ETypeName
name = String
"stringDec" String -> String -> String
forall a. [a] -> [a] -> [a]
++ ETypeName -> String
et_name ETypeName
name
    prependTypes :: String -> ETypeName -> [String]
prependTypes String
str = (ETVar -> String) -> [ETVar] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (\ETVar
tv -> String
str String -> String -> String
forall a. [a] -> [a] -> [a]
++ ETVar -> String
tv_name ETVar
tv) ([ETVar] -> [String])
-> (ETypeName -> [ETVar]) -> ETypeName -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ETypeName -> [ETVar]
et_args
    decoderType :: ETypeName -> String
decoderType ETypeName
name =
      ETypeName -> String
funcname ETypeName
name
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" : "
        String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
" -> " ([String
"String"] [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [ETypeName -> String
decoderTypeEnd ETypeName
name])
    decoderTypeEnd :: ETypeName -> String
decoderTypeEnd ETypeName
name =
      [String] -> String
unwords (String
"Maybe" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: ETypeName -> String
et_name ETypeName
name String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (ETVar -> String) -> [ETVar] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map ETVar -> String
tv_name (ETypeName -> [ETVar]
et_args ETypeName
name))
    makeName :: ETypeName -> String
makeName ETypeName
name = [String] -> String
unwords (ETypeName -> String
funcname ETypeName
name String -> [String] -> [String]
forall a. a -> [a] -> [a]
: String -> ETypeName -> [String]
prependTypes String
"localDecoder_" ETypeName
name)