{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Elm.Module where
import Control.Arrow (second)
import Data.List
import Data.Proxy
import Elm.Json
import Elm.TyRender
import Elm.TyRep
import Elm.Versions
data DefineElm
= forall a. IsElmDefinition a => DefineElm (Proxy a)
moduleHeader :: ElmVersion
-> String
-> String
ElmVersion
_ String
moduleName = String
"module " forall a. [a] -> [a] -> [a]
++ String
moduleName forall a. [a] -> [a] -> [a]
++ String
" exposing(..)"
makeElmModuleWithVersion :: ElmVersion
-> String
-> [DefineElm]
-> String
makeElmModuleWithVersion :: ElmVersion -> String -> [DefineElm] -> String
makeElmModuleWithVersion ElmVersion
elmVersion String
moduleName [DefineElm]
defs = [String] -> String
unlines
[ ElmVersion -> String -> String
moduleHeader ElmVersion
elmVersion String
moduleName
, String
""
, String
"import Json.Decode"
, String
"import Json.Encode exposing (Value)"
, String
"-- The following module comes from bartavelle/json-helpers"
, String
"import Json.Helpers exposing (..)"
, String
"import Dict exposing (Dict)"
, String
"import Set exposing (Set)"
, String
""
, String
""
] forall a. [a] -> [a] -> [a]
++ [DefineElm] -> String
makeModuleContent [DefineElm]
defs
makeElmModule :: String
-> [DefineElm]
-> String
makeElmModule :: String -> [DefineElm] -> String
makeElmModule = ElmVersion -> String -> [DefineElm] -> String
makeElmModuleWithVersion ElmVersion
Elm0p19
makeModuleContent :: [DefineElm] -> String
makeModuleContent :: [DefineElm] -> String
makeModuleContent = (ETypeDef -> ETypeDef) -> [DefineElm] -> String
makeModuleContentWithAlterations ETypeDef -> ETypeDef
defaultAlterations
makeModuleContentWithAlterations :: (ETypeDef -> ETypeDef) -> [DefineElm] -> String
makeModuleContentWithAlterations :: (ETypeDef -> ETypeDef) -> [DefineElm] -> String
makeModuleContentWithAlterations ETypeDef -> ETypeDef
alt = forall a. [a] -> [[a]] -> [a]
intercalate String
"\n\n" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map DefineElm -> String
mkDef
where
mkDef :: DefineElm -> String
mkDef (DefineElm Proxy a
proxy) =
let def :: ETypeDef
def = ETypeDef -> ETypeDef
alt (forall a. IsElmDefinition a => Proxy a -> ETypeDef
compileElmDef Proxy a
proxy)
in forall a. ElmRenderable a => a -> String
renderElm ETypeDef
def forall a. [a] -> [a] -> [a]
++ String
"\n" forall a. [a] -> [a] -> [a]
++ ETypeDef -> String
jsonParserForDef ETypeDef
def forall a. [a] -> [a] -> [a]
++ String
"\n" forall a. [a] -> [a] -> [a]
++ ETypeDef -> String
jsonSerForDef ETypeDef
def forall a. [a] -> [a] -> [a]
++ String
"\n"
recAlterType :: (EType -> EType) -> ETypeDef -> ETypeDef
recAlterType :: (EType -> EType) -> ETypeDef -> ETypeDef
recAlterType EType -> EType
f ETypeDef
td = case ETypeDef
td of
ETypeAlias EAlias
a -> EAlias -> ETypeDef
ETypeAlias (EAlias
a { ea_fields :: [(String, EType)]
ea_fields = forall a b. (a -> b) -> [a] -> [b]
map (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second EType -> EType
f') (EAlias -> [(String, EType)]
ea_fields EAlias
a) })
ETypePrimAlias (EPrimAlias ETypeName
n EType
t) -> EPrimAlias -> ETypeDef
ETypePrimAlias (ETypeName -> EType -> EPrimAlias
EPrimAlias ETypeName
n (EType -> EType
f' EType
t))
ETypeSum ESum
s -> ESum -> ETypeDef
ETypeSum (ESum
s { es_constructors :: [SumTypeConstructor]
es_constructors = forall a b. (a -> b) -> [a] -> [b]
map SumTypeConstructor -> SumTypeConstructor
alterTypes (ESum -> [SumTypeConstructor]
es_constructors ESum
s) })
where
alterTypes :: SumTypeConstructor -> SumTypeConstructor
alterTypes :: SumTypeConstructor -> SumTypeConstructor
alterTypes (STC String
cn String
dn SumTypeFields
s) = String -> String -> SumTypeFields -> SumTypeConstructor
STC String
cn String
dn forall a b. (a -> b) -> a -> b
$ case SumTypeFields
s of
Anonymous [EType]
flds -> [EType] -> SumTypeFields
Anonymous (forall a b. (a -> b) -> [a] -> [b]
map EType -> EType
f' [EType]
flds)
Named [(String, EType)]
flds -> [(String, EType)] -> SumTypeFields
Named (forall a b. (a -> b) -> [a] -> [b]
map (forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second EType -> EType
f') [(String, EType)]
flds)
f' :: EType -> EType
f' (ETyApp EType
a EType
b) = EType -> EType
f (EType -> EType -> EType
ETyApp (EType -> EType
f' EType
a) (EType -> EType
f' EType
b))
f' EType
x = EType -> EType
f EType
x
newtypeAliases :: [String] -> ETypeDef -> ETypeDef
newtypeAliases :: [String] -> ETypeDef -> ETypeDef
newtypeAliases [String]
nts (ETypeAlias EAlias
e) = EAlias -> ETypeDef
ETypeAlias forall a b. (a -> b) -> a -> b
$ if ETypeName -> String
et_name (EAlias -> ETypeName
ea_name EAlias
e) forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
nts
then EAlias
e { ea_newtype :: Bool
ea_newtype = Bool
True }
else EAlias
e
newtypeAliases [String]
_ ETypeDef
x = ETypeDef
x
defaultAlterations :: ETypeDef -> ETypeDef
defaultAlterations :: ETypeDef -> ETypeDef
defaultAlterations = (EType -> EType) -> ETypeDef -> ETypeDef
recAlterType EType -> EType
defaultTypeAlterations
defaultTypeAlterations :: EType -> EType
defaultTypeAlterations :: EType -> EType
defaultTypeAlterations EType
t = case EType
t of
ETyApp (ETyCon (ETCon String
"HashSet")) EType
s -> EType -> EType
checkSet forall a b. (a -> b) -> a -> b
$ EType -> EType
defaultTypeAlterations EType
s
ETyApp (ETyCon (ETCon String
"Set")) EType
s -> EType -> EType
checkSet forall a b. (a -> b) -> a -> b
$ EType -> EType
defaultTypeAlterations EType
s
ETyApp (ETyApp (ETyCon (ETCon String
"HashMap")) EType
k) EType
v -> EType -> EType -> EType
checkMap (EType -> EType
defaultTypeAlterations EType
k) (EType -> EType
defaultTypeAlterations EType
v)
ETyApp (ETyApp (ETyCon (ETCon String
"THashMap")) EType
k) EType
v -> EType -> EType -> EType
checkMap (EType -> EType
defaultTypeAlterations EType
k) (EType -> EType
defaultTypeAlterations EType
v)
ETyApp (ETyCon (ETCon String
"IntMap")) EType
v -> EType -> EType -> EType
checkMap EType
int (EType -> EType
defaultTypeAlterations EType
v)
ETyApp (ETyApp (ETyCon (ETCon String
"Map")) EType
k) EType
v -> EType -> EType -> EType
checkMap (EType -> EType
defaultTypeAlterations EType
k) (EType -> EType
defaultTypeAlterations EType
v)
ETyApp (ETyApp (ETyCon (ETCon String
"Tagged")) EType
_) EType
v -> EType -> EType
defaultTypeAlterations EType
v
ETyApp EType
x EType
y -> EType -> EType -> EType
ETyApp (EType -> EType
defaultTypeAlterations EType
x) (EType -> EType
defaultTypeAlterations EType
y)
ETyCon (ETCon String
"Integer") -> EType
int
ETyCon (ETCon String
"Natural") -> String -> EType
tc String
"Int"
ETyCon (ETCon String
"Text") -> String -> EType
tc String
"String"
ETyCon (ETCon String
"Vector") -> String -> EType
tc String
"List"
ETyCon (ETCon String
"Double") -> String -> EType
tc String
"Float"
ETyCon (ETCon String
"UTCTime") -> String -> EType
tc String
"Posix"
EType
_ -> EType
t
where
int :: EType
int = String -> EType
tc String
"Int"
isComparable :: EType -> Bool
isComparable (ETyCon (ETCon String
n)) = String
n forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
"String", String
"Int", String
"Float", String
"Posix", String
"Char"]
isComparable EType
_ = Bool
False
tc :: String -> EType
tc = ETCon -> EType
ETyCon forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ETCon
ETCon
checkMap :: EType -> EType -> EType
checkMap EType
k EType
v | EType -> Bool
isComparable EType
k = EType -> EType -> EType
ETyApp (EType -> EType -> EType
ETyApp (String -> EType
tc String
"Dict") EType
k) EType
v
| Bool
otherwise = EType -> EType -> EType
ETyApp (String -> EType
tc String
"List") (EType -> EType -> EType
ETyApp (EType -> EType -> EType
ETyApp (Int -> EType
ETyTuple Int
2) EType
k) EType
v)
checkSet :: EType -> EType
checkSet EType
s | EType -> Bool
isComparable EType
s = EType -> EType -> EType
ETyApp (String -> EType
tc String
"Set") EType
s
| Bool
otherwise = EType -> EType -> EType
ETyApp (String -> EType
tc String
"List") EType
s