{- |
This module implements a generator for JSON serialisers and parsers of arbitrary elm types.
Please note: It's still very hacky and might not work for all possible elm types yet.
-}
module Elm.Json
    ( jsonParserForDef
    , jsonSerForDef
    )
where

import Data.List
import Data.Maybe

import Elm.TyRep

-- | Compile a JSON parser for an Elm type
jsonParserForType :: EType -> String
jsonParserForType 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' -> "Json.Decode.maybe (" ++ jsonParserForType t' ++ ")"
      _ ->
          case unpackTupleType ty of
            [] -> error $ "This should never happen. Failed to unpackTupleType: " ++ show ty
            [x] ->
                case unpackToplevelConstr x of
                  (y : ys) ->
                      jsonParserForType y ++ " "
                      ++ unwords (catMaybes $ map (\t' ->
                                                 case t' of
                                                   ETyVar _ -> Just $ "(" ++ jsonParserForType t' ++ ")"
                                                   _ -> Nothing
                                            ) ys)
                  _ -> error $ "Do suitable json parser found for " ++ show ty
            xs ->
                let tupleLen = length xs
                    commas = replicate (tupleLen - 1) ','
                in "Json.Decode.tuple" ++ show tupleLen ++ " (" ++ commas ++ ") "
                    ++ unwords (map (\t' -> "(" ++ jsonParserForType t' ++ ")") xs)

-- | Compile a JSON parser for an Elm type definition
jsonParserForDef :: ETypeDef -> String
jsonParserForDef etd =
    case etd of
      ETypePrimAlias (EPrimAlias name ty) ->
          makeName name ++  " = " ++ jsonParserForType ty ++ "\n"
      ETypeAlias (EAlias name fields) ->
          makeName name ++ " = \n"
          ++ intercalate "\n" (map (\(fldName, fldType) -> "   (\"" ++ fldName ++ "\" := "
                                    ++ jsonParserForType fldType
                                    ++ ") `Json.Decode.andThen` \\p" ++ fldName ++ " -> ") fields)
          ++ "\n   Json.Decode.succeed {" ++ intercalate ", " (map (\(fldName, _) -> fldName ++ " = p" ++ fldName) fields) ++ "}\n"
      ETypeSum (ESum name opts) ->
          makeName name ++ " = \n"
          ++ "   Json.Decode.oneOf \n   [ "
          ++ intercalate "\n   , " (map mkOpt opts) ++ "\n"
          ++ "   ]\n"
          where
            mkOpt (name, args) =
                let argLen = length args
                in "(\"" ++ name ++ "\" := Json.tuple" ++ show argLen ++ " " ++ name ++ " "
                   ++ unwords (map (\t' -> "(" ++ jsonParserForType t' ++ ")") args)
                   ++ ")"
    where
      makeName name =
           "jsonDec" ++ et_name name ++ " "
           ++ unwords (map (\tv -> "localDecoder_" ++ tv_name tv) $ et_args name)

-- | Compile a JSON serializer for an Elm type
jsonSerForType :: EType -> String
jsonSerForType 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 << map " ++ jsonSerForType t' ++ ")"
      ETyApp (ETyCon (ETCon "Maybe")) t' -> "(\v -> case v of Just val -> " ++ jsonSerForType t' ++ " val Nothing -> Json.Encode.null)"
      _ ->
          case unpackTupleType ty of
            [] -> error $ "This should never happen. Failed to unpackTupleType: " ++ show ty
            [x] ->
                case unpackToplevelConstr x of
                  (y : ys) ->
                      "(" ++ jsonSerForType y ++ " "
                      ++ unwords (catMaybes $ map (\t' ->
                                                 case t' of
                                                   ETyVar _ -> Just $ "(" ++ jsonSerForType t' ++ ")"
                                                   _ -> Nothing
                                            ) ys) ++ ")"
                  _ -> error $ "Do suitable json serialiser found for " ++ show ty
            xs ->
                let tupleLen = length xs
                    tupleArgsV = zip xs [1..]
                    tupleArgs =
                        unwords $ map (\(_, v) -> "v" ++ show v) tupleArgsV
                in "(\\" ++ tupleArgs ++ " -> [" ++  intercalate "," (map (\(t', idx) -> "(" ++ jsonSerForType t' ++ ") v" ++ 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 ++  " = " ++ jsonSerForType ty ++ " val\n"
      ETypeAlias (EAlias name fields) ->
          makeName name ++ " = \n   Json.Encode.object\n   ["
          ++ intercalate "\n   ," (map (\(fldName, fldType) -> " (\"" ++ fldName ++ "\", " ++ jsonSerForType fldType ++ " val." ++ fldName ++ ")") fields)
          ++ "\n   ]\n"
      ETypeSum (ESum name opts) ->
          makeName name ++ " = \n"
          ++ "   case val of\n   "
          ++ intercalate "\n   " (map mkOpt opts) ++ "\n"
          where
            mkOpt (name, args) =
                let namedArgs = zip args [1..]
                    argList = unwords $ map (\(_, i) -> "v" ++ show i ) namedArgs
                    mkArg :: (EType, Int) -> String
                    mkArg (arg, idx) =
                        jsonSerForType arg ++ " v" ++ show idx
                in "   " ++ name ++ " " ++ argList ++ " -> [" ++ intercalate ", " (map mkArg namedArgs) ++ "]"
    where
      makeName name =
           "jsonEnc" ++ et_name name ++ " "
           ++ unwords (map (\tv -> "localEncoder_" ++ tv_name tv) $ et_args name)
           ++ " val"