content: {- |
  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 Eq
  
  -- | Compile a JSON parser for an Elm type
  jsonParserForType :: EType -> String
  jsonParserForType = jsonParserForType' Leaf
  
  isOption :: EType -> Bool
  isOption (ETyApp (ETyCon (ETCon "Maybe")) _) = True
  isOption _                                   = False
  
  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
                  in "Json.Decode.map" ++ show tupleLen ++ " tuple" ++ show tupleLen ++ " "
                      ++ 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 =
        case fields of
          [(_, ftype)] | unwrap -> [ succeed ++ " |> custom (" ++ jsonParserForType' (o ftype) ftype ++ ")" ]
          _ -> succeed : map mkField fields
      where
          succeed = "   Json.Decode.succeed (\\" ++ unwords (map ( ('p':) . fst ) fields) ++ " -> " ++ mkNewtype ("{" ++ intercalate ", " (map (\(fldName, _) -> fixReserved fldName ++ " = p" ++ fldName) fields) ++ "}") ++ ")"
          mkNewtype x = case newtyped of
                            Nothing -> x
                            Just nm -> "(" ++ et_name nm ++ " " ++ x ++ ")"
          o fldType = if isOption fldType
                        then Root
                        else Leaf
          mkField (fldName, fldType) =
             "   |> " ++ (if isOption fldType then "fnullable " else "required ")
                      ++ show fldName
                      ++ " (" ++ jsonParserForType' (o fldType) fldType ++ ")"
  
  -- | Checks that all the arguments to the ESum are unary values
  allUnaries :: Bool -> [SumTypeConstructor] -> Maybe [(String, String)]
  allUnaries False = const Nothing
  allUnaries True  = mapM isUnary
      where
          isUnary (STC o c (Anonymous args)) = if null args then Just (o,c) 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 (\(o, s) -> "(" ++ show s ++ ", " ++ o ++ ")") strs ) ++ "]"
                  , "    in  decodeSumUnaries " ++ show typename ++ " " ++ dictName
                  ]
              encodingDictionary [STC cname _ args] = "    " ++ mkDecoder cname 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 _ _
                                  | length opts > 1 ->
                                    "\n" ++ tab 8 (isObjectSetName ++ " = " ++ "Set.fromList [" ++ intercalate ", " objectSet ++ "]")
                                  where objectSet =
                                          (map (show . _stcName) $ filter (isNamed . _stcFields) opts) ++
                                          -- if field is empty, it do not have content, so add to objectSet.
                                          (map (show . _stcName) $ filter (isEmpty . _stcFields) opts)
                                _ -> ""
              dictEntry (STC cname oname args) = "(" ++ show oname ++ ", " ++ mkDecoder cname args ++ ")"
              mkDecoder cname (Named args)  =  lazy $ "Json.Decode.map "
                                           ++ cname
                                           ++ " ("
                                           ++ unwords (parseRecords Nothing False args)
                                           ++ ")"
  
              mkDecoder cname (Anonymous args) = lazy $ unwords ( decodeFunction
                                                     : cname
                                                     : 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 [1..]
  
  jsonSerForType' :: Bool -> [Int] -> EType -> String
  jsonSerForType' omitnull ns 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 " ++ jsonSerForType' omitnull ns t' ++ ")"
        ETyApp (ETyCon (ETCon "Maybe")) t' -> if omitnull
                                                  then jsonSerForType' omitnull ns t'
                                                  else "(maybeEncode (" ++ jsonSerForType' omitnull ns t' ++ "))"
        ETyApp (ETyCon (ETCon "Set")) t' -> "(encodeSet " ++ jsonSerForType' omitnull ns t' ++ ")"
        ETyApp (ETyApp (ETyCon (ETCon "Dict")) (ETyCon (ETCon "String"))) value -> "(Json.Encode.dict identity (" ++ jsonSerForType' omitnull ns value ++ "))"
        ETyApp (ETyApp (ETyCon (ETCon "Dict")) key) value -> "(encodeMap (" ++ jsonSerForType' omitnull ns key ++ ") (" ++ jsonSerForType' omitnull ns value ++ "))"
        _ ->
            case unpackTupleType ty of
              [] -> error $ "This should never happen. Failed to unpackTupleType: " ++ show ty
              [x] ->
                  case unpackToplevelConstr x of
                    (y : ys) ->
                        "(" ++ jsonSerForType' omitnull ns y ++ " "
                        ++ unwords (map (\t' -> "(" ++ jsonSerForType' omitnull ns t' ++ ")") ys)
                        ++ ")"
                    _ -> error $ "Do suitable json serialiser found for " ++ show ty
              xs ->
                  let (ns', rest) = splitAt (length xs) ns
                      tupleArgsV = zip xs ns'
                      tupleArgs =
                          intercalate "," $ map (\(_, v) -> "t" ++ show v) tupleArgsV
                  in "(\\(" ++ tupleArgs ++ ") -> Json.Encode.list identity [" ++  intercalate "," (map (\(t', idx) -> "(" ++ jsonSerForType' omitnull rest t' ++ ") t" ++ show idx) tupleArgsV) ++ "])"
  
  
  -- | Compile a JSON serializer for an Elm type definition
  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 [STC _ oname (Anonymous 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 ' ' ++) . mkcase) os
                  ++ [ "    " ++ unwords ["in", encodeFunction, "keyval", "val"] ]
                  )
                unaryEncoding names = unlines (
                  [ makeName name False ++ " ="
                  , "    case val of"
                  ] ++ map (\(o, n) -> replicate 8 ' ' ++ o ++ " -> Json.Encode.string " ++ show n) names
                  )
                mkcase :: SumTypeConstructor -> String
                mkcase (STC cname oname (Anonymous args)) = replicate 8 ' ' ++ cap cname ++ " " ++ argList args ++ " -> (" ++ show oname ++ ", encodeValue (" ++ mkEncodeList args ++ "))"
                mkcase (STC cname oname (Named args)) = replicate 8 ' ' ++ cap cname ++ " 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 identity [" ++ 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"
  
  -- | 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 etd =
    case etd of
      ETypeSum (ESum name opts (SumEncoding' _se) _ _unarystring) ->
        defaultEncoding opts
        where
          defaultEncoding os =
            unlines
              ((makeName name False ++ " =") : "    case val of" : map mkcase os)
          mkcase :: SumTypeConstructor -> String
          mkcase (STC cname oname (Anonymous args)) =
            replicate 8 ' '
              ++ cap cname
              ++ " "
              ++ argList args
              ++ " -> "
              ++ show oname
          mkcase _ =
            error "stringSerForSimpleAdt.mkcase: Expecting an Anonymous case"
          argList a = unwords $ map (\i -> "v" ++ show i) [1 .. length a]
      _ -> error "stringSerForSimpleAdt only works with ETypeSum"
    where
      fname name = "stringEnc" ++ et_name name
      makeType name =
        fname name
          ++ " : "
          ++ intercalate
            " -> "
            ([unwords (et_name name : map tv_name (et_args name))] ++ ["String"])
      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"
  
  -- | Parse a String into a maybe-value for simple ADT types. See 'stringSerForSimpleAdt' for motivation
  stringParserForSimpleAdt :: ETypeDef -> String
  stringParserForSimpleAdt etd =
    case etd of
      ETypeSum (ESum name opts (SumEncoding' _encodingType) _ _unarystring) ->
        decoderType name
          ++ "\n"
          ++ makeName name
          ++ " s =\n"
          ++ encodingDictionary opts
          ++ "\n"
        where
          tab n s = replicate n ' ' ++ s
          encodingDictionary [STC cname _ args] =
            "    " ++ mkDecoder cname args
          encodingDictionary os =
            "    case s of\n"
              ++ tab 8 ""
              ++ intercalate ("\n" ++ replicate 8 ' ') (map dictEntry os)
              ++ "\n"
              ++ tab 8 "_ -> Nothing"
          dictEntry (STC cname oname _args) =
            show oname ++ " -> Just " ++ cname
          mkDecoder _cname _ = error "impossible!"
      _ -> error "impossible"
    where
      funcname name = "stringDec" ++ et_name name
      prependTypes str = map (\tv -> str ++ tv_name tv) . et_args
      decoderType name =
        funcname name
          ++ " : "
          ++ intercalate " -> " (["String"] ++ [decoderTypeEnd name])
      decoderTypeEnd name =
        unwords ("Maybe" : et_name name : map tv_name (et_args name))
      makeName name = unwords (funcname name : prependTypes "localDecoder_" name)
  