content: {-# LANGUAGE OverloadedStrings #-}
  module TW.CodeGen.Elm
      ( makeFileName, makeModule
      , libraryInfo
      )
  where
  
  import TW.Ast
  import TW.BuiltIn
  import TW.JsonRepr
  import TW.Types
  
  import Data.Maybe
  import Data.Monoid
  import System.FilePath
  import qualified Data.List as L
  import qualified Data.Text as T
  
  jsonEncQual :: T.Text
  jsonEncQual = "JE"
  
  jsonEnc :: T.Text -> T.Text
  jsonEnc x = jsonEncQual <> "." <> x
  
  jsonDecQual :: T.Text
  jsonDecQual = "JD"
  
  jsonDec :: T.Text -> T.Text
  jsonDec x = jsonDecQual <> "." <> x
  
  makeFileName :: ModuleName -> FilePath
  makeFileName (ModuleName parts) =
      (L.foldl' (</>) "" $ map T.unpack parts) ++ ".elm"
  
  libraryInfo :: LibraryInfo
  libraryInfo = LibraryInfo "Elm" "elm-typed-wire-utils" "2.0.0"
  
  fromExplicitVersion :: Maybe ElmVersion -> T.Text
  fromExplicitVersion m = case m of
    Just Elm0p17 -> "exposing (..)"
    Just Elm0p16  -> "where"
    _ -> "where"
  
  
  makeModule :: Maybe ElmVersion -> Module -> T.Text
  makeModule v m =
      T.unlines
      [ "-- | This file was auto generated by typed-wire. Do not modify by hand"
      , "module " <> printModuleName (m_name m) <> " " <> fromExplicitVersion v
      , ""
      , T.intercalate "\n" (map makeImport $ m_imports m)
      , ""
      , "import TypedWire as TW"
      , "import List as L"
      , "import Json.Decode as " <> jsonDecQual
      , "import Json.Decode exposing ((:=))"
      , "import Json.Encode as " <> jsonEncQual
      , ""
      , T.intercalate "\n" (map makeTypeDef $ m_typeDefs m)
      ]
  
  makeImport :: ModuleName -> T.Text
  makeImport m =
      "import " <> printModuleName m
  
  makeTypeDef :: TypeDef -> T.Text
  makeTypeDef td =
      case td of
        TypeDefEnum ed ->
            makeEnumDef ed
        TypeDefStruct sd ->
            makeStructDef sd
  
  makeStructDef :: StructDef -> T.Text
  makeStructDef sd =
      T.unlines
      [ "type alias " <> fullType <> " ="
      , "   { " <> T.intercalate "\n   , " (map makeStructField $ sd_fields sd)
      , "   }"
      , ""
      , "jenc" <> unTypeName (sd_name sd) <> " : " <> encTy <> fullType <> " -> " <> jsonEnc "Value"
      , "jenc" <> unTypeName (sd_name sd) <> " " <> encArgs <> " = "
          <> jsonEnc "object" <> " << " <> "jencTuples" <> unTypeName (sd_name sd) <> " " <> encArgs
      , "jencTuples" <> unTypeName (sd_name sd) <> " : " <> encTy <> fullType <> " -> List (String, " <> jsonEnc "Value" <> ")"
      , "jencTuples" <> unTypeName (sd_name sd) <> " " <> encArgs <> " x ="
      , "    [ " <> T.intercalate "\n    , " (map makeToJsonFld $ sd_fields sd)
      , "    ]"
      , "jdec" <> unTypeName (sd_name sd) <> " : " <> decTy <> jsonDec "Decoder" <> " (" <> fullType <> ")"
      , "jdec" <> unTypeName (sd_name sd) <> " " <> decArgs <> " ="
      , "    " <> T.intercalate "\n    " (map makeFromJsonFld $ sd_fields sd)
      , "    " <> jsonDec "succeed" <> " (" <> unTypeName (sd_name sd) <> " " <> funArgs <> ")"
      ]
      where
        (encTy, encArgs) =
            case sd_args sd of
              [] -> ("", "")
              _ ->
                  let mkEncTy (TypeVar v) =
                          "(" <> v <> " -> " <> jsonEnc "Value" <> ")"
                  in ( T.intercalate " -> " (map mkEncTy $ sd_args sd) <> " -> "
                     , T.intercalate " " (map varEnc $ sd_args sd)
                     )
        (decTy, decArgs) =
            case sd_args sd of
              [] -> ("", "")
              _ ->
                  let mkDecTy (TypeVar v) = "(JD.Decoder " <> v <> ")"
                  in ( T.intercalate " -> " (map mkDecTy $ sd_args sd) <> " -> "
                     , T.intercalate " " (map varDec $ sd_args sd)
                     )
        jArg fld = "j_" <> (unFieldName $ sf_name fld)
        makeFromJsonFld fld =
            let name = unFieldName $ sf_name fld
                arg = jArg fld
                (maybePrefix, decoder) =
                    case isBuiltIn (sf_type fld) of
                      Just (bi, [maybeArg]) | bi == tyMaybe ->
                          ( jsonDec "maybe" <> " "
                          , jsonDecFor maybeArg
                          )
                      _ -> ("", jsonDecFor $ sf_type fld)
                dec =
                    maybePrefix <> "(" <> T.pack (show name) <> " := " <> decoder <> ")"
            in dec <> " `" <> jsonDec "andThen" <> "` \\" <> arg <> " -> "
        makeToJsonFld fld =
            let name = unFieldName $ sf_name fld
                encoder = jsonEncFor (sf_type fld)
            in "(" <> T.pack (show name) <> ", " <> encoder <> " x." <> name <> ")"
        funArgs =
            T.intercalate " " $ map jArg (sd_fields sd)
        fullType =
            unTypeName (sd_name sd) <> " " <> T.intercalate " " (map unTypeVar $ sd_args sd)
  
  makeStructField :: StructField -> T.Text
  makeStructField sf =
      (unFieldName $ sf_name sf) <> " : " <> (makeType $ sf_type sf)
  
  makeEnumDef :: EnumDef -> T.Text
  makeEnumDef ed =
      T.unlines
      [ "type " <> fullType
      , "   = " <> T.intercalate "\n   | " (map makeEnumChoice $ ed_choices ed)
      , ""
      , "jenc" <> unTypeName (ed_name ed) <> " : " <> encTy <> fullType <> " -> " <> jsonEnc "Value"
      , "jenc" <> unTypeName (ed_name ed) <> " " <> encArgs <> " x ="
      , "    case x of"
      , "      " <> T.intercalate "\n      " (map mkToJsonChoice $ ed_choices ed)
      , "jdec" <> unTypeName (ed_name ed) <> " : " <> jsonDec "Decoder" <> " (" <> fullType <> ")"
      , "jdec" <> unTypeName (ed_name ed) <> " ="
      , "    " <> jsonDec "oneOf"
      , "    [ " <> T.intercalate "\n    , " (map mkFromJsonChoice $ ed_choices ed)
      , "    ]"
      ]
      where
        (encTy, encArgs) =
            case ed_args ed of
              [] -> ("", "")
              _ ->
                  let mkEncTy (TypeVar v) =
                          "(" <> v <> " -> " <> jsonEnc "Value" <> ")"
                  in ( T.intercalate " -> " (map mkEncTy $ ed_args ed) <> " -> "
                     , T.intercalate " " (map varEnc $ ed_args ed)
                     )
        mkFromJsonChoice ec =
            let constr = unChoiceName $ ec_name ec
                tag = camelTo2 '_' $ T.unpack constr
                (decoder, andThen) =
                    case ec_arg ec of
                      Nothing -> (jsonDec "bool", "\\_ -> " <> jsonDec "succeed" <> " " <> constr)
                      Just arg -> (jsonDecFor arg, "\\z -> " <> jsonDec "succeed" <> " (" <> constr <> " z)")
            in "(" <> T.pack (show tag) <> " := " <> decoder <> ") `" <> jsonDec "andThen" <> "` " <> andThen
        mkToJsonChoice ec =
            let constr = unChoiceName $ ec_name ec
                tag = camelTo2 '_' $ T.unpack constr
                (argParam, argVal, encoder) =
                    case ec_arg ec of
                      Nothing -> ("", "True", jsonEnc "bool")
                      Just arg -> ("x", "x", jsonEncFor arg)
            in constr <> " " <> argParam <> " -> "
               <> jsonEnc "object" <> "[(" <> T.pack (show tag) <>  ", " <> encoder <> " " <> argVal <> ")]"
        fullType =
            unTypeName (ed_name ed) <> " " <> T.intercalate " " (map unTypeVar $ ed_args ed)
  
  makeEnumChoice :: EnumChoice -> T.Text
  makeEnumChoice ec =
      (unChoiceName $ ec_name ec) <> fromMaybe "" (fmap ((<>) " " . makeType) $ ec_arg ec)
  
  jsonEncFor :: Type -> T.Text
  jsonEncFor t =
      case isBuiltIn t of
        Nothing ->
            case t of
              TyVar v -> varEnc v
              TyCon qt args ->
                  let ty = makeQualEnc qt
                  in case args of
                       [] -> ty
                       _ -> "(" <> ty <> " " <> T.intercalate " " (map jsonEncFor args) <> ")"
        Just (bi, tvars)
            | bi == tyString -> jsonEnc "string"
            | bi == tyInt -> jsonEnc "int"
            | bi == tyBool -> jsonEnc "bool"
            | bi == tyFloat -> jsonEnc "float"
            | bi == tyBytes -> "TW.encAsBase64"
            | bi == tyDateTime -> "TW.encDateTime"
            | bi == tyTime -> "TW.encTime"
            | bi == tyDate -> "TW.encDate"
            | bi == tyList ->
                case tvars of
                  [arg] ->
                      "(" <> jsonEnc "list" <> " << L.map (" <> jsonEncFor arg <> "))"
                  _ -> error $ "Elm: odly shaped List value"
            | bi == tyMaybe ->
                case tvars of
                  [arg] -> "TW.encMaybe (" <> jsonEncFor arg <> ")"
                  _ -> error $ "Elm: odly shaped Maybe value"
            | otherwise ->
                error $ "Elm: Missing jsonEnc for built in type: " ++ show t
  
  jsonDecFor :: Type -> T.Text
  jsonDecFor t =
      case isBuiltIn t of
        Nothing ->
            case t of
              TyVar v -> varDec v
              TyCon qt args ->
                  let ty = makeQualDec qt
                  in case args of
                       [] -> ty
                       _ -> "(" <> ty <> " " <> T.intercalate " " (map jsonDecFor args) <> ")"
        Just (bi, tvars)
            | bi == tyString -> jsonDec "string"
            | bi == tyInt -> jsonDec "int"
            | bi == tyBool -> jsonDec "bool"
            | bi == tyFloat -> jsonDec "float"
            | bi == tyBytes -> "TW.decAsBase64"
            | bi == tyDateTime -> "TW.decDateTime"
            | bi == tyTime -> "TW.decTime"
            | bi == tyDate -> "TW.decDate"
            | bi == tyList ->
                case tvars of
                  [arg] -> jsonDec "list" <> " (" <> jsonDecFor arg <> ")"
                  _ -> error "Elm: odly shaped List value"
            | bi == tyMaybe ->
                case tvars of
                  [arg] -> jsonDec "maybe" <> " (" <> jsonDecFor arg <> ")"
                  _ -> error "Elm: odly shaped Maybe value"
            | otherwise ->
                error $ "Elm: Missing jsonDec for built in type: " ++ show t
  
  varEnc :: TypeVar -> T.Text
  varEnc (TypeVar x) = "enc_" <> x
  
  varDec :: TypeVar -> T.Text
  varDec (TypeVar x) = "dec_" <> x
  
  makeType :: Type -> T.Text
  makeType t =
      case isBuiltIn t of
        Nothing ->
            case t of
              TyVar (TypeVar x) -> x
              TyCon qt args ->
                  let ty = makeQualTypeName qt
                  in case args of
                       [] -> ty
                       _ -> "(" <> ty <> " " <> T.intercalate " " (map makeType args) <> ")"
        Just (bi, tvars)
            | bi == tyString -> "String"
            | bi == tyInt -> "Int"
            | bi == tyBool -> "Bool"
            | bi == tyFloat -> "Float"
            | bi == tyDateTime -> "TW.DateTime"
            | bi == tyTime -> "TW.Time"
            | bi == tyDate -> "TW.Date"
            | bi == tyMaybe -> "(Maybe " <> T.intercalate " " (map makeType tvars) <> ")"
            | bi == tyList -> "(List " <> T.intercalate " " (map makeType tvars) <> ")"
            | bi == tyBytes -> "TW.AsBase64"
            | otherwise ->
                error $ "Elm: Unimplemented built in type: " ++ show t
  
  makeQualTypeName :: QualTypeName -> T.Text
  makeQualTypeName qtn =
      case unModuleName $ qtn_module qtn of
        [] -> ty
        _ -> printModuleName (qtn_module qtn) <> "." <> ty
      where
        ty = unTypeName $ qtn_type qtn
  
  makeQualEnc :: QualTypeName -> T.Text
  makeQualEnc qtn =
      case unModuleName $ qtn_module qtn of
        [] -> "jenc" <> ty
        _ -> printModuleName (qtn_module qtn) <> ".jenc" <> ty
      where
        ty = unTypeName $ qtn_type qtn
  
  makeQualDec :: QualTypeName -> T.Text
  makeQualDec qtn =
      case unModuleName $ qtn_module qtn of
        [] -> "jdec" <> ty
        _ -> printModuleName (qtn_module qtn) <> ".jdec" <> ty
      where
        ty = unTypeName $ qtn_type qtn
  