{-# 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"

makeModule :: Module -> T.Text
makeModule m =
    T.unlines
    [ "-- | This file was auto generated by typed-wire. Do not modify by hand"
    , "module " <> printModuleName (m_name m) <> " where"
    , ""
    , 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