module Elm.Derive
(
A.Options(..)
, A.SumEncoding(..)
, defaultOptions
, defaultOptionsDropLower
, deriveElmDef
, deriveBoth
)
where
import Elm.TyRep
import Control.Monad
import Data.Aeson.TH (deriveJSON, SumEncoding(..))
import qualified Data.Aeson.TH as A
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import Data.Char (toLower)
import Control.Applicative
import Prelude
defaultOptions :: A.Options
defaultOptions = A.Options { A.sumEncoding = A.ObjectWithSingleField
, A.fieldLabelModifier = id
, A.constructorTagModifier = id
, A.allNullaryToStringTag = True
, A.omitNothingFields = False
#if MIN_VERSION_aeson(0,10,0)
, A.unwrapUnaryRecords = False
#endif
}
unwrapUnaryRecords :: A.Options -> Bool
#if MIN_VERSION_aeson(0,10,0)
unwrapUnaryRecords opts = A.unwrapUnaryRecords opts
#else
unwrapUnaryRecords _ = False
#endif
defaultOptionsDropLower :: Int -> A.Options
defaultOptionsDropLower n = defaultOptions { A.fieldLabelModifier = lower . drop n }
where
lower "" = ""
lower (x:xs) = toLower x : xs
compileType :: Type -> Q Exp
compileType ty =
case ty of
ListT -> [|ETyCon (ETCon "List")|]
TupleT i -> [|ETyTuple i|]
VarT name ->
let n = nameBase name
in [|ETyVar (ETVar n)|]
SigT ty' _ ->
compileType ty'
AppT a b -> [|ETyApp $(compileType a) $(compileType b)|]
ConT name ->
let n = nameBase name
in [|ETyCon (ETCon n)|]
_ -> fail $ "Unsupported type: " ++ show ty
optSumType :: SumEncoding -> Q Exp
optSumType se =
case se of
TwoElemArray -> [|SumEncoding' TwoElemArray|]
ObjectWithSingleField -> [|SumEncoding' ObjectWithSingleField|]
TaggedObject tn cn -> [|SumEncoding' (TaggedObject tn cn)|]
runDerive :: Name -> [TyVarBndr] -> (Q Exp -> Q Exp) -> Q [Dec]
runDerive name vars mkBody =
liftM (:[]) elmDefInst
where
elmDefInst =
instanceD (cxt [])
(classType `appT` instanceType)
[ funD 'compileElmDef
[ clause [ return WildP ] (normalB body) []
]
]
classType = conT ''IsElmDefinition
instanceType = foldl appT (conT name) $ map varT argNames
body = mkBody [|ETypeName { et_name = nameStr, et_args = $args }|]
nameStr = nameBase name
args =
listE $ map mkTVar argNames
mkTVar :: Name -> Q Exp
mkTVar n =
let str = nameBase n
in [|ETVar str|]
argNames =
flip map vars $ \v ->
case v of
PlainTV tv -> tv
KindedTV tv _ -> tv
deriveAlias :: A.Options -> Name -> [TyVarBndr] -> [VarStrictType] -> Q [Dec]
deriveAlias opts name vars conFields =
runDerive name vars $ \typeName ->
[|ETypeAlias (EAlias $typeName $fields omitNothing False unwrapUnary)|]
where
unwrapUnary = unwrapUnaryRecords opts
fields = listE $ map mkField conFields
omitNothing = A.omitNothingFields opts
mkField :: VarStrictType -> Q Exp
mkField (fname, _, ftype) =
[|(fldName, $fldType)|]
where
fldName = A.fieldLabelModifier opts $ nameBase fname
fldType = compileType ftype
deriveSum :: A.Options -> Name -> [TyVarBndr] -> [Con] -> Q [Dec]
deriveSum opts name vars constrs =
runDerive name vars $ \typeName ->
[|ETypeSum (ESum $typeName $sumOpts $sumEncOpts omitNothing allNullary)|]
where
allNullary = A.allNullaryToStringTag opts
sumEncOpts = optSumType (A.sumEncoding opts)
omitNothing = A.omitNothingFields opts
sumOpts = listE $ map mkOpt constrs
mkOpt :: Con -> Q Exp
mkOpt c =
let modifyName = A.constructorTagModifier opts . nameBase
in case c of
NormalC name' args ->
let n = modifyName name'
tyArgs = listE $ map (\(_, ty) -> compileType ty) args
in [|(n, Right $tyArgs)|]
RecC name' args ->
let n = modifyName name'
tyArgs = listE $ map (\(nm, _, ty) -> let nm' = A.fieldLabelModifier opts $ nameBase nm
in [|(nm', $(compileType ty))|]) args
in [|(n, Left $tyArgs)|]
_ -> fail ("Can't derive this sum: " ++ show c)
deriveSynonym :: A.Options -> Name -> [TyVarBndr] -> Type -> Q [Dec]
deriveSynonym _ name vars otherT =
runDerive name vars $ \typeName ->
[|ETypePrimAlias (EPrimAlias $typeName $otherType)|]
where
otherType = compileType otherT
deriveBoth :: A.Options -> Name -> Q [Dec]
deriveBoth o n = (++) <$> deriveElmDef o n <*> deriveJSON o n
deriveElmDef :: A.Options -> Name -> Q [Dec]
deriveElmDef opts name =
do TyConI tyCon <- reify name
case tyCon of
#if __GLASGOW_HASKELL__ >= 800
DataD _ _ tyVars _ constrs _ ->
#else
DataD _ _ tyVars constrs _ ->
#endif
case constrs of
[] -> fail "Can not derive empty data decls"
[RecC _ conFields] -> deriveAlias opts name tyVars conFields
_ -> deriveSum opts name tyVars constrs
#if __GLASGOW_HASKELL__ >= 800
NewtypeD _ _ tyVars _ (RecC _ conFields) _ ->
#else
NewtypeD _ _ tyVars (RecC _ conFields) _ ->
#endif
deriveAlias opts name tyVars conFields
TySynD _ vars otherTy ->
deriveSynonym opts name vars otherTy
_ -> fail ("Oops, can only derive data and newtype, not this: " ++ show tyCon)