{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE ScopedTypeVariables       #-}
{-|
Functions in this module are used to generate Elm modules. Note that the generated modules depend on the @bartavelle/json-helpers@ package.

-}
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

-- | Existential quantification wrapper for lists of type definitions
data DefineElm
   = forall a. IsElmDefinition a => DefineElm (Proxy a)

-- | The module header line for this version of Elm
moduleHeader :: ElmVersion
             -> String
             -> String
moduleHeader :: ElmVersion -> String -> String
moduleHeader ElmVersion
_ String
moduleName = String
"module " forall a. [a] -> [a] -> [a]
++ String
moduleName forall a. [a] -> [a] -> [a]
++ String
" exposing(..)"

-- | Creates an Elm module for the given version. This will use the default
-- type conversion rules (to -- convert @Vector@ to @List@, @HashMap a b@
-- to @List (a,b)@, etc.).
makeElmModuleWithVersion :: ElmVersion
                         -> String  -- ^ Module name
                         -> [DefineElm]  -- ^ List of definitions to be included in the module
                         -> 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

-- | Creates an Elm module. This will use the default type conversion rules (to
-- convert @Vector@ to @List@, @HashMap a b@ to @List (a,b)@, etc.).
--
-- default to 0.19
makeElmModule :: String -- ^ Module name
              -> [DefineElm] -- ^ List of definitions to be included in the module
              -> String
makeElmModule :: String -> [DefineElm] -> String
makeElmModule = ElmVersion -> String -> [DefineElm] -> String
makeElmModuleWithVersion ElmVersion
Elm0p19

-- | Generates the content of a module. You will be responsible for
-- including the required Elm headers. This uses the default type
-- conversion rules.
makeModuleContent :: [DefineElm] -> String
makeModuleContent :: [DefineElm] -> String
makeModuleContent = (ETypeDef -> ETypeDef) -> [DefineElm] -> String
makeModuleContentWithAlterations ETypeDef -> ETypeDef
defaultAlterations

-- | Generates the content of a module, using custom type conversion rules.
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"

{-| A helper function that will recursively traverse type definitions and let you convert types.

> myAlteration : ETypeDef -> ETypeDef
> myAlteration = recAlterType $ \t -> case t of
>                   ETyCon (ETCon "Integer") -> ETyCon (ETCon "Int")
>                   ETyCon (ETCon "Text")    -> ETyCon (ETCon "String")
>                   _                        -> t

-}
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

-- | Given a list of type names, will @newtype@ all the matching type
-- definitions.
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

{-| A default set of type conversion rules:

 * @HashSet a@, @Set a@ -> if @a@ is comparable, then @Set a@, else @List a@
 * @HashMap String v@, @Map String v@ -> @Dict String v@
 * @HashMap k v@, @Map k v@ -> @List (k, v)@
 * @Integer@ -> @Int@
 * @Text@ -> @String@
 * @Vector@ -> @List@
 * @Double@ -> @Float@
 * @Tagged t v@ -> @v@
-}
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 -- TODO Lists and Tuples of comparable types
        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