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
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
")"
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
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]
++
((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
")"
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
"])"
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"
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"
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)