elm-bridge-0.4.2: src/Elm/Json.hs
{- |
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
)
where
import Data.List
import Data.Either (isLeft)
import Data.Aeson.Types (SumEncoding(..))
import Elm.TyRep
import Elm.Utils
data MaybeHandling = Root | Leaf
deriving Eq
jsonParserForType :: EType -> String
jsonParserForType = jsonParserForType' Leaf
isOption :: EType -> Bool
isOption (ETyApp (ETyCon (ETCon "Maybe")) _) = True
isOption _ = False
-- | Compile a JSON parser for an Elm type
jsonParserForType' :: MaybeHandling -> EType -> String
jsonParserForType' mh ty =
case ty of
ETyVar (ETVar v) -> "localDecoder_" ++ v
ETyCon (ETCon "Int") -> "Json.Decode.int"
ETyCon (ETCon "Float") -> "Json.Decode.float"
ETyCon (ETCon "String") -> "Json.Decode.string"
ETyCon (ETCon "Bool") -> "Json.Decode.bool"
ETyCon (ETCon c) -> "jsonDec" ++ c
ETyApp (ETyCon (ETCon "List")) t' -> "Json.Decode.list (" ++ jsonParserForType t' ++ ")"
ETyApp (ETyCon (ETCon "Maybe")) t' -> if mh == Root
then jsonParserForType t'
else "Json.Decode.maybe (" ++ jsonParserForType t' ++ ")"
ETyApp (ETyCon (ETCon "Set")) t' -> "decodeSet (" ++ jsonParserForType t' ++ ")"
ETyApp (ETyApp (ETyCon (ETCon "Dict")) (ETyCon (ETCon "String")) ) value -> "Json.Decode.dict (" ++ jsonParserForType value ++ ")"
ETyApp (ETyApp (ETyCon (ETCon "Dict")) key) value -> "decodeMap (" ++ jsonParserForType key ++ ") (" ++ jsonParserForType value ++ ")"
_ ->
case unpackTupleType ty of
[] -> error $ "This should never happen. Failed to unpackTupleType: " ++ show ty
[x] ->
case unpackToplevelConstr x of
(y : ys) ->
jsonParserForType y ++ " "
++ unwords (map (\t' -> "(" ++ jsonParserForType t' ++ ")" ) ys)
_ -> error $ "Do suitable json parser found for " ++ show ty
xs ->
let tupleLen = length xs
commas = replicate (tupleLen - 1) ','
in "Json.Decode.map" ++ show tupleLen ++ " (" ++ commas ++ ") "
++ unwords (zipWith (\i t' -> "(Json.Decode.index " ++ show (i :: Int) ++ " (" ++ jsonParserForType t' ++ "))") [0..] xs)
parseRecords :: Maybe ETypeName -> Bool -> [(String, EType)] -> [String]
parseRecords newtyped unwrap fields = map (mkField doUnwrap) fields ++ [" Json.Decode.succeed " ++ mkNewtype ("{" ++ intercalate ", " (map (\(fldName, _) -> fixReserved fldName ++ " = p" ++ fldName) fields) ++ "}")]
where
doUnwrap = length fields == 1 && unwrap
mkNewtype x = case newtyped of
Nothing -> x
Just nm -> "(" ++ et_name nm ++ " " ++ x ++ ")"
mkField u (fldName, fldType) =
let (fldStart, fldEnd, mh) = if isOption fldType
then ("(Json.Decode.maybe ", ")", Root)
else ("", "", Leaf)
in " " ++ fldStart ++ "(" ++ (if u then "" else "\"" ++ fldName ++ "\" := ")
++ jsonParserForType' mh fldType
++ fldEnd
++ ") >>= \\p" ++ fldName ++ " ->"
-- | Checks that all the arguments to the ESum are unary values
allUnaries :: Bool -> [(String, Either [(String, EType)] [EType])] -> Maybe [String]
allUnaries False = const Nothing
allUnaries True = mapM isUnary
where
isUnary (x, Right args) = if null args then Just x else Nothing
isUnary _ = Nothing
-- | Compile a JSON parser for an Elm type definition
jsonParserForDef :: ETypeDef -> String
jsonParserForDef etd =
case etd of
ETypePrimAlias (EPrimAlias name ty) -> unlines
[ decoderType name
, makeName name ++ " ="
, jsonParserForType ty
]
ETypeAlias (EAlias name fields _ newtyping unwrap) -> unlines
( decoderType name
: (makeName name ++ " =")
: parseRecords (if newtyping then Just name else Nothing) unwrap fields
)
ETypeSum (ESum name opts (SumEncoding' encodingType) _ unarystring) ->
decoderType name ++ "\n" ++
makeName name ++ " =" ++
case allUnaries unarystring opts of
Just names -> " " ++ deriveUnaries names
Nothing -> "\n" ++ encodingDictionary opts ++ isObjectSet ++ "\n" ++ declLine opts ++ "\n"
where
tab n s = replicate n ' ' ++ s
typename = et_name name
declLine [_] = ""
declLine _ = " in " ++ case encodingType of
ObjectWithSingleField -> unwords [ "decodeSumObjectWithSingleField ", show typename, dictName]
TwoElemArray -> unwords [ "decodeSumTwoElemArray ", show typename, dictName ]
TaggedObject tg el -> unwords [ "decodeSumTaggedObject", show typename, show tg, show el, dictName, isObjectSetName ]
UntaggedValue -> "Json.Decode.oneOf (Dict.values " ++ dictName ++ ")"
dictName = "jsonDecDict" ++ typename
isObjectSetName = "jsonDecObjectSet" ++ typename
deriveUnaries strs = unlines
[ ""
, " let " ++ dictName ++ " = Dict.fromList [" ++ intercalate ", " (map (\s -> "(" ++ show s ++ ", " ++ cap s ++ ")") strs ) ++ "]"
, " in decodeSumUnaries " ++ show typename ++ " " ++ dictName
]
encodingDictionary [(oname, args)] = " " ++ mkDecoder oname args
encodingDictionary os = tab 4 "let " ++ dictName ++ " = Dict.fromList\n" ++ tab 12 "[ " ++ intercalate ("\n" ++ replicate 12 ' ' ++ ", ") (map dictEntry os) ++ "\n" ++ tab 12 "]"
isObjectSet = case encodingType of
TaggedObject _ _ -> "\n" ++ tab 8 (isObjectSetName ++ " = " ++ "Set.fromList [" ++ intercalate ", " (map (show . fst) $ filter (isLeft . snd) opts) ++ "]")
_ -> ""
dictEntry (oname, args) = "(" ++ show oname ++ ", " ++ mkDecoder oname args ++ ")"
mkDecoder oname (Left args) = lazy $ "Json.Decode.map "
++ cap oname
++ " ("
++ unwords (parseRecords Nothing False args)
++ ")"
mkDecoder oname (Right args) = lazy $ unwords ( decodeFunction
: cap oname
: zipWith (\t' i -> "(" ++ jsonParserForIndexedType t' i ++ ")") args [0..]
)
where decodeFunction = case length args of
0 -> "Json.Decode.succeed"
1 -> "Json.Decode.map"
n -> "Json.Decode.map" ++ show n
jsonParserForIndexedType :: EType -> Int -> String
jsonParserForIndexedType t' i | length args <= 1 = jsonParserForType t'
| otherwise = "Json.Decode.index " ++ show i ++ " (" ++ jsonParserForType t' ++ ")"
where
funcname name = "jsonDec" ++ et_name name
prependTypes str = map (\tv -> str ++ tv_name tv) . et_args
decoderType name = funcname name ++ " : " ++ intercalate " -> " (prependTypes "Json.Decode.Decoder " name ++ [decoderTypeEnd name])
decoderTypeEnd name = unwords ("Json.Decode.Decoder" : "(" : et_name name : map tv_name (et_args name) ++ [")"])
makeName name = unwords (funcname name : prependTypes "localDecoder_" name)
lazy decoder = "Json.Decode.lazy (\\_ -> " ++ decoder ++ ")"
{-| Compile a JSON serializer for an Elm type.
The 'omitNothingFields' option is currently not implemented!
-}
jsonSerForType :: EType -> String
jsonSerForType = jsonSerForType' False
jsonSerForType' :: Bool -> EType -> String
jsonSerForType' omitnull ty =
case ty of
ETyVar (ETVar v) -> "localEncoder_" ++ v
ETyCon (ETCon "Int") -> "Json.Encode.int"
ETyCon (ETCon "Float") -> "Json.Encode.float"
ETyCon (ETCon "String") -> "Json.Encode.string"
ETyCon (ETCon "Bool") -> "Json.Encode.bool"
ETyCon (ETCon c) -> "jsonEnc" ++ c
ETyApp (ETyCon (ETCon "List")) t' -> "(Json.Encode.list << List.map " ++ jsonSerForType t' ++ ")"
ETyApp (ETyCon (ETCon "Maybe")) t' -> if omitnull
then jsonSerForType t'
else "(maybeEncode (" ++ jsonSerForType t' ++ "))"
ETyApp (ETyCon (ETCon "Set")) t' -> "(encodeSet " ++ jsonSerForType t' ++ ")"
ETyApp (ETyApp (ETyCon (ETCon "Dict")) key) value -> "(encodeMap (" ++ jsonSerForType key ++ ") (" ++ jsonSerForType value ++ "))"
_ ->
case unpackTupleType ty of
[] -> error $ "This should never happen. Failed to unpackTupleType: " ++ show ty
[x] ->
case unpackToplevelConstr x of
(y : ys) ->
"(" ++ jsonSerForType y ++ " "
++ unwords (map (\t' -> "(" ++ jsonSerForType t' ++ ")") ys)
++ ")"
_ -> error $ "Do suitable json serialiser found for " ++ show ty
xs ->
let tupleArgsV = zip xs ([1..] :: [Int])
tupleArgs =
intercalate "," $ map (\(_, v) -> "v" ++ show v) tupleArgsV
in "(\\(" ++ tupleArgs ++ ") -> Json.Encode.list [" ++ intercalate "," (map (\(t', idx) -> "(" ++ jsonSerForType t' ++ ") v" ++ show idx) tupleArgsV) ++ "])"
-- | Compile a JSON serializer for an Elm type definition
-- TODO: handle the omit null case
jsonSerForDef :: ETypeDef -> String
jsonSerForDef etd =
case etd of
ETypePrimAlias (EPrimAlias name ty) ->
makeName name False ++ " = " ++ jsonSerForType ty ++ " val\n"
ETypeAlias (EAlias name [(fldName, fldType)] _ newtyping True) ->
makeName name newtyping ++ " =\n " ++ jsonSerForType fldType ++ " val." ++ fixReserved fldName
ETypeAlias (EAlias name fields _ newtyping _) ->
makeName name newtyping ++ " =\n Json.Encode.object\n ["
++ intercalate "\n ," (map (\(fldName, fldType) -> " (\"" ++ fldName ++ "\", " ++ jsonSerForType fldType ++ " val." ++ fixReserved fldName ++ ")") fields)
++ "\n ]\n"
ETypeSum (ESum name opts (SumEncoding' se) _ unarystring) ->
case allUnaries unarystring opts of
Nothing -> defaultEncoding opts
Just strs -> unaryEncoding strs
where
encodeFunction = case se of
ObjectWithSingleField -> "encodeSumObjectWithSingleField"
TwoElemArray -> "encodeSumTwoElementArray"
TaggedObject k c -> unwords ["encodeSumTaggedObject", show k, show c]
UntaggedValue -> "encodeSumUntagged"
defaultEncoding [(oname, Right args)] = unlines $
[ makeType name
, fname name ++ " "
++ unwords (map (\tv -> "localEncoder_" ++ tv_name tv) $ et_args name)
++ "(" ++ cap oname ++ " " ++ argList args ++ ") ="
, " " ++ mkEncodeList args
]
defaultEncoding os = unlines (
( makeName name False ++ " =")
: " let keyval v = case v of"
: (map (replicate 12 ' ' ++) (map mkcase os))
++ [ " " ++ unwords ["in", encodeFunction, "keyval", "val"] ]
)
unaryEncoding names = unlines (
[ makeName name False ++ " ="
, " case val of"
] ++ map (\n -> replicate 8 ' ' ++ cap n ++ " -> Json.Encode.string " ++ show n) names
)
mkcase :: (String, Either [(String, EType)] [EType]) -> String
mkcase (oname, Right args) = replicate 8 ' ' ++ cap oname ++ " " ++ argList args ++ " -> (" ++ show oname ++ ", encodeValue (" ++ mkEncodeList args ++ "))"
mkcase (oname, Left args) = replicate 8 ' ' ++ cap oname ++ " vs -> (" ++ show oname ++ ", " ++ mkEncodeObject args ++ ")"
argList a = unwords $ map (\i -> "v" ++ show i ) [1 .. length a]
numargs :: (a -> String) -> [a] -> String
numargs f = intercalate ", " . zipWith (\n a -> f a ++ " v" ++ show n) ([1..] :: [Int])
mkEncodeObject args = "encodeObject [" ++ intercalate ", " (map (\(n,t) -> "(" ++ show n ++ ", " ++ jsonSerForType t ++ " vs." ++ fixReserved n ++ ")") args) ++ "]"
mkEncodeList [arg] = jsonSerForType arg ++ " v1"
mkEncodeList args = "Json.Encode.list [" ++ numargs jsonSerForType args ++ "]"
where
fname name = "jsonEnc" ++ et_name name
makeType name = fname name ++ " : " ++ intercalate " -> " (map (mkLocalEncoder . tv_name) (et_args name) ++ [unwords (et_name name : map tv_name (et_args name)) , "Value"])
mkLocalEncoder n = "(" ++ n ++ " -> Value)"
makeName name newtyping =
makeType name ++ "\n"
++ fname name ++ " "
++ unwords (map (\tv -> "localEncoder_" ++ tv_name tv) $ et_args name)
++ if newtyping
then " (" ++ et_name name ++ " val)"
else " val"