{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
module Elm.Derive
(
A.Options(..)
, A.SumEncoding(..)
, defaultOptions
, defaultOptionsDropLower
, deriveElmDef
, deriveBoth
)
where
import Elm.TyRep
import Control.Applicative
import Control.Monad
import Data.Aeson.TH (SumEncoding (..), deriveJSON)
import qualified Data.Aeson.TH as A
import Data.Char (toLower)
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import Prelude
defaultOptions :: A.Options
defaultOptions
= A.defaultOptions
{ A.sumEncoding = A.ObjectWithSingleField
, A.fieldLabelModifier = id
, A.constructorTagModifier = id
, A.allNullaryToStringTag = True
, A.omitNothingFields = False
, A.unwrapUnaryRecords = True
}
unwrapUnaryRecords :: A.Options -> Bool
unwrapUnaryRecords = A.unwrapUnaryRecords
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)|]
UntaggedValue -> [|SumEncoding' UntaggedValue|]
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 :: Bool -> A.Options -> Name -> [TyVarBndr] -> [VarStrictType] -> Q [Dec]
deriveAlias isNewtype opts name vars conFields =
runDerive name vars $ \typeName ->
[|ETypeAlias (EAlias $typeName $fields omitNothing isNewtype 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 n = (nameBase n, A.constructorTagModifier opts (nameBase n))
in case c of
NormalC name' args ->
let (b, n) = modifyName name'
tyArgs = listE $ map (\(_, ty) -> compileType ty) args
in [|STC b n (Anonymous $tyArgs)|]
RecC name' args ->
let (b, n) = modifyName name'
tyArgs = listE $ map (\(nm, _, ty) -> let nm' = A.fieldLabelModifier opts $ nameBase nm
in [|(nm', $(compileType ty))|]) args
in [|STC b n (Named $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
DataD _ _ tyVars _ constrs _ ->
case constrs of
[] -> fail "Can not derive empty data decls"
[RecC _ conFields] -> deriveAlias False opts name tyVars conFields
_ -> deriveSum opts name tyVars constrs
NewtypeD [] _ [] Nothing (NormalC _ [(Bang NoSourceUnpackedness NoSourceStrictness, otherTy)]) [] ->
deriveSynonym opts name [] otherTy
NewtypeD [] _ [] Nothing (RecC _ conFields@[(Name (OccName _) _, Bang NoSourceUnpackedness NoSourceStrictness, otherTy)]) [] ->
if A.unwrapUnaryRecords opts
then deriveSynonym opts name [] otherTy
else deriveAlias True opts name [] conFields
TySynD _ vars otherTy ->
deriveSynonym opts name vars otherTy
NewtypeD _ _ tyvars Nothing (NormalC _ [(Bang NoSourceUnpackedness NoSourceStrictness, otherTy)]) [] ->
deriveSynonym opts name tyvars otherTy
NewtypeD _ _ tyvars Nothing (RecC _ conFields@[(Name (OccName _) _, Bang NoSourceUnpackedness NoSourceStrictness, otherTy)]) [] ->
if A.unwrapUnaryRecords opts
then deriveSynonym opts name tyvars otherTy
else deriveAlias True opts name tyvars conFields
_ -> fail ("Oops, can only derive data and newtype, not this: " ++ show tyCon)