module Elm.Module where
import Data.Proxy
import Data.List
import Control.Arrow (second, (+++))
import Elm.TyRep
import Elm.TyRender
import Elm.Json
import Elm.Versions
data DefineElm
= forall a. IsElmDefinition a => DefineElm (Proxy a)
moduleHeader :: ElmVersion
-> String
-> String
moduleHeader Elm0p18 moduleName = "module " ++ moduleName ++ " exposing(..)"
makeElmModuleWithVersion :: ElmVersion
-> String
-> [DefineElm]
-> String
makeElmModuleWithVersion elmVersion moduleName defs = unlines (
[ moduleHeader elmVersion moduleName
, ""
, "import Json.Decode"
, "import Json.Encode exposing (Value)"
, "-- The following module comes from bartavelle/json-helpers"
, "import Json.Helpers exposing (..)"
, "import Dict"
, "import Set"
, ""
, ""
]) ++ makeModuleContent defs
makeElmModule :: String
-> [DefineElm]
-> String
makeElmModule = makeElmModuleWithVersion Elm0p18
makeModuleContent :: [DefineElm] -> String
makeModuleContent = makeModuleContentWithAlterations defaultAlterations
makeModuleContentWithAlterations :: (ETypeDef -> ETypeDef) -> [DefineElm] -> String
makeModuleContentWithAlterations alt = intercalate "\n\n" . map mkDef
where
mkDef (DefineElm proxy) =
let def = alt (compileElmDef proxy)
in renderElm def ++ "\n" ++ jsonParserForDef def ++ "\n" ++ jsonSerForDef def ++ "\n"
recAlterType :: (EType -> EType) -> ETypeDef -> ETypeDef
recAlterType f td = case td of
ETypeAlias a -> ETypeAlias (a { ea_fields = map (second f') (ea_fields a) })
ETypePrimAlias (EPrimAlias n t) -> ETypePrimAlias (EPrimAlias n (f' t))
ETypeSum s -> ETypeSum (s { es_options = map (second (map (second f') +++ map f')) (es_options s) })
where
f' (ETyApp a b) = f (ETyApp (f' a) (f' b))
f' x = f x
newtypeAliases :: [String] -> ETypeDef -> ETypeDef
newtypeAliases nts (ETypeAlias e) = ETypeAlias $ if et_name (ea_name e) `elem` nts
then e { ea_newtype = True }
else e
newtypeAliases _ x = x
defaultAlterations :: ETypeDef -> ETypeDef
defaultAlterations = recAlterType $ \t -> case t of
ETyApp (ETyCon (ETCon "HashSet")) s -> checkSet s
ETyApp (ETyCon (ETCon "Set")) s -> checkSet s
ETyApp (ETyApp (ETyCon (ETCon "HashMap")) k) v -> checkMap k v
ETyApp (ETyApp (ETyCon (ETCon "THashMap")) k) v -> checkMap k v
ETyApp (ETyApp (ETyCon (ETCon "Map")) k) v -> checkMap k v
ETyCon (ETCon "Integer") -> ETyCon (ETCon "Int")
ETyCon (ETCon "Natural") -> ETyCon (ETCon "Int")
ETyCon (ETCon "Text") -> ETyCon (ETCon "String")
ETyCon (ETCon "Vector") -> ETyCon (ETCon "List")
ETyCon (ETCon "Double") -> ETyCon (ETCon "Float")
_ -> t
where
isString (ETyCon (ETCon "String")) = True
isString _ = False
isComparable (ETyCon (ETCon n)) = n `elem` ["String", "Int"]
isComparable _ = False
tc = ETyCon . ETCon
checkMap k v | isString k = ETyApp (ETyApp (tc "Dict") k) v
| otherwise = ETyApp (tc "List") (ETyApp (ETyApp (ETyTuple 2) k) v)
checkSet s | isComparable s = ETyApp (ETyCon (ETCon "Set")) s
| otherwise = ETyApp (ETyCon (ETCon "List")) s