{-# 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, tagSingleConstructors)
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 :: Options
defaultOptions
= Options
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 :: Options -> Bool
unwrapUnaryRecords = Options -> Bool
A.unwrapUnaryRecords
defaultOptionsDropLower :: Int -> A.Options
defaultOptionsDropLower :: Int -> Options
defaultOptionsDropLower Int
n = Options
defaultOptions { A.fieldLabelModifier = lower . drop n }
where
lower :: String -> String
lower String
"" = String
""
lower (Char
x:String
xs) = Char -> Char
toLower Char
x Char -> String -> String
forall a. a -> [a] -> [a]
: String
xs
compileType :: Type -> Q Exp
compileType :: Type -> Q Exp
compileType Type
ty =
case Type
ty of
Type
ListT -> [|ETyCon (ETCon "List")|]
TupleT Int
i -> [|ETyTuple i|]
VarT Name
name ->
let n :: String
n = Name -> String
nameBase Name
name
in [|ETyVar (ETVar n)|]
SigT Type
ty' Type
_ ->
Type -> Q Exp
compileType Type
ty'
AppT Type
a Type
b -> [|ETyApp $(Type -> Q Exp
compileType Type
a) $(Type -> Q Exp
compileType Type
b)|]
ConT Name
name ->
let n :: String
n = Name -> String
nameBase Name
name
in [|ETyCon (ETCon n)|]
Type
_ -> String -> Q Exp
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ String
"Unsupported type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Type -> String
forall a. Show a => a -> String
show Type
ty
optSumType :: SumEncoding -> Q Exp
optSumType :: SumEncoding -> Q Exp
optSumType SumEncoding
se =
case SumEncoding
se of
SumEncoding
TwoElemArray -> [|SumEncoding' TwoElemArray|]
SumEncoding
ObjectWithSingleField -> [|SumEncoding' ObjectWithSingleField|]
TaggedObject String
tn String
cn -> [|SumEncoding' (TaggedObject tn cn)|]
SumEncoding
UntaggedValue -> [|SumEncoding' UntaggedValue|]
runDerive :: Name -> [TyVarBndr ()] -> (Q Exp -> Q Exp) -> Q [Dec]
runDerive :: Name -> [TyVarBndr ()] -> (Q Exp -> Q Exp) -> Q [Dec]
runDerive Name
name [TyVarBndr ()]
vars Q Exp -> Q Exp
mkBody =
(Dec -> [Dec]) -> Q Dec -> Q [Dec]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
:[]) Q Dec
elmDefInst
where
elmDefInst :: Q Dec
elmDefInst =
Q Cxt -> Q Type -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m Cxt -> m Type -> [m Dec] -> m Dec
instanceD ([Q Type] -> Q Cxt
forall (m :: * -> *). Quote m => [m Type] -> m Cxt
cxt [])
(Q Type
classType Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Q Type
instanceType)
[ Name -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD 'compileElmDef
[ [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause [ Pat -> Q Pat
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Pat
WildP ] (Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB Q Exp
body) []
]
]
classType :: Q Type
classType = Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT ''IsElmDefinition
instanceType :: Q Type
instanceType = (Q Type -> Q Type -> Q Type) -> Q Type -> [Q Type] -> Q Type
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Q Type -> Q Type -> Q Type
forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
appT (Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
conT Name
name) ([Q Type] -> Q Type) -> [Q Type] -> Q Type
forall a b. (a -> b) -> a -> b
$ (Name -> Q Type) -> [Name] -> [Q Type]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
varT [Name]
argNames
body :: Q Exp
body = Q Exp -> Q Exp
mkBody [|ETypeName { et_name = nameStr, et_args = $Q Exp
args }|]
nameStr :: String
nameStr = Name -> String
nameBase Name
name
args :: Q Exp
args =
[Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ (Name -> Q Exp) -> [Name] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Exp
mkTVar [Name]
argNames
mkTVar :: Name -> Q Exp
mkTVar :: Name -> Q Exp
mkTVar Name
n =
let str :: String
str = Name -> String
nameBase Name
n
in [|ETVar str|]
argNames :: [Name]
argNames =
((TyVarBndr () -> Name) -> [TyVarBndr ()] -> [Name])
-> [TyVarBndr ()] -> (TyVarBndr () -> Name) -> [Name]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (TyVarBndr () -> Name) -> [TyVarBndr ()] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map [TyVarBndr ()]
vars ((TyVarBndr () -> Name) -> [Name])
-> (TyVarBndr () -> Name) -> [Name]
forall a b. (a -> b) -> a -> b
$ \TyVarBndr ()
v ->
case TyVarBndr ()
v of
PlainTV Name
tv ()
_ -> Name
tv
KindedTV Name
tv ()
_ Type
_ -> Name
tv
deriveAlias :: Bool -> A.Options -> Name -> [TyVarBndr ()] -> [VarStrictType] -> Q [Dec]
deriveAlias :: Bool
-> Options -> Name -> [TyVarBndr ()] -> [VarStrictType] -> Q [Dec]
deriveAlias Bool
isNewtype Options
opts Name
name [TyVarBndr ()]
vars [VarStrictType]
conFields =
Name -> [TyVarBndr ()] -> (Q Exp -> Q Exp) -> Q [Dec]
runDerive Name
name [TyVarBndr ()]
vars ((Q Exp -> Q Exp) -> Q [Dec]) -> (Q Exp -> Q Exp) -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ \Q Exp
typeName ->
[|ETypeAlias (EAlias $Q Exp
typeName $Q Exp
fields omitNothing isNewtype unwrapUnary)|]
where
unwrapUnary :: Bool
unwrapUnary = Options -> Bool
unwrapUnaryRecords Options
opts
fields :: Q Exp
fields = [Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ (VarStrictType -> Q Exp) -> [VarStrictType] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map VarStrictType -> Q Exp
mkField [VarStrictType]
conFields
omitNothing :: Bool
omitNothing = Options -> Bool
A.omitNothingFields Options
opts
mkField :: VarStrictType -> Q Exp
mkField :: VarStrictType -> Q Exp
mkField (Name
fname, Bang
_, Type
ftype) =
[|(fldName, $Q Exp
fldType)|]
where
fldName :: String
fldName = Options -> String -> String
A.fieldLabelModifier Options
opts (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Name -> String
nameBase Name
fname
fldType :: Q Exp
fldType = Type -> Q Exp
compileType Type
ftype
deriveSum :: A.Options -> Name -> [TyVarBndr ()] -> [Con] -> Q [Dec]
deriveSum :: Options -> Name -> [TyVarBndr ()] -> [Con] -> Q [Dec]
deriveSum Options
opts Name
name [TyVarBndr ()]
vars [Con]
constrs =
Name -> [TyVarBndr ()] -> (Q Exp -> Q Exp) -> Q [Dec]
runDerive Name
name [TyVarBndr ()]
vars ((Q Exp -> Q Exp) -> Q [Dec]) -> (Q Exp -> Q Exp) -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ \Q Exp
typeName ->
[|ETypeSum (ESum $Q Exp
typeName $Q Exp
sumOpts $Q Exp
sumEncOpts omitNothing allNullary)|]
where
allNullary :: Bool
allNullary = Options -> Bool
A.allNullaryToStringTag Options
opts
sumEncOpts :: Q Exp
sumEncOpts = SumEncoding -> Q Exp
optSumType (Options -> SumEncoding
A.sumEncoding Options
opts)
omitNothing :: Bool
omitNothing = Options -> Bool
A.omitNothingFields Options
opts
sumOpts :: Q Exp
sumOpts = [Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ (Con -> Q Exp) -> [Con] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map Con -> Q Exp
mkOpt [Con]
constrs
mkOpt :: Con -> Q Exp
mkOpt :: Con -> Q Exp
mkOpt Con
c =
let modifyName :: Name -> (String, String)
modifyName Name
n = (Name -> String
nameBase Name
n, Options -> String -> String
A.constructorTagModifier Options
opts (Name -> String
nameBase Name
n))
in case Con
c of
NormalC Name
name' [BangType]
args ->
let (String
b, String
n) = Name -> (String, String)
modifyName Name
name'
tyArgs :: Q Exp
tyArgs = [Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ (BangType -> Q Exp) -> [BangType] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map (\(Bang
_, Type
ty) -> Type -> Q Exp
compileType Type
ty) [BangType]
args
in [|STC b n (Anonymous $Q Exp
tyArgs)|]
RecC Name
name' [VarStrictType]
args ->
let (String
b, String
n) = Name -> (String, String)
modifyName Name
name'
tyArgs :: Q Exp
tyArgs = [Q Exp] -> Q Exp
forall (m :: * -> *). Quote m => [m Exp] -> m Exp
listE ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ (VarStrictType -> Q Exp) -> [VarStrictType] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map (\(Name
nm, Bang
_, Type
ty) -> let nm' :: String
nm' = Options -> String -> String
A.fieldLabelModifier Options
opts (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Name -> String
nameBase Name
nm
in [|(nm', $(Type -> Q Exp
compileType Type
ty))|]) [VarStrictType]
args
in [|STC b n (Named $Q Exp
tyArgs)|]
Con
_ -> String -> Q Exp
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Can't derive this sum: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Con -> String
forall a. Show a => a -> String
show Con
c)
deriveSynonym :: A.Options -> Name -> [TyVarBndr ()] -> Type -> Q [Dec]
deriveSynonym :: Options -> Name -> [TyVarBndr ()] -> Type -> Q [Dec]
deriveSynonym Options
_ Name
name [TyVarBndr ()]
vars Type
otherT =
Name -> [TyVarBndr ()] -> (Q Exp -> Q Exp) -> Q [Dec]
runDerive Name
name [TyVarBndr ()]
vars ((Q Exp -> Q Exp) -> Q [Dec]) -> (Q Exp -> Q Exp) -> Q [Dec]
forall a b. (a -> b) -> a -> b
$ \Q Exp
typeName ->
[|ETypePrimAlias (EPrimAlias $Q Exp
typeName $Q Exp
otherType)|]
where
otherType :: Q Exp
otherType = Type -> Q Exp
compileType Type
otherT
deriveBoth :: A.Options -> Name -> Q [Dec]
deriveBoth :: Options -> Name -> Q [Dec]
deriveBoth Options
o Name
n = [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
(++) ([Dec] -> [Dec] -> [Dec]) -> Q [Dec] -> Q ([Dec] -> [Dec])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Options -> Name -> Q [Dec]
deriveElmDef Options
o Name
n Q ([Dec] -> [Dec]) -> Q [Dec] -> Q [Dec]
forall a b. Q (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Options -> Name -> Q [Dec]
deriveJSON Options
o Name
n
deriveElmDef :: A.Options -> Name -> Q [Dec]
deriveElmDef :: Options -> Name -> Q [Dec]
deriveElmDef Options
opts Name
name =
do TyConI Dec
tyCon <- Name -> Q Info
reify Name
name
case Dec
tyCon of
DataD Cxt
_ Name
_ [TyVarBndr ()]
tyVars Maybe Type
_ [Con]
constrs [DerivClause]
_ ->
case [Con]
constrs of
[] -> String -> Q [Dec]
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Can not derive empty data decls"
[RecC Name
_ [VarStrictType]
conFields] | Bool -> Bool
not (Options -> Bool
tagSingleConstructors Options
opts) -> Bool
-> Options -> Name -> [TyVarBndr ()] -> [VarStrictType] -> Q [Dec]
deriveAlias Bool
False Options
opts Name
name [TyVarBndr ()]
tyVars [VarStrictType]
conFields
[Con]
_ -> Options -> Name -> [TyVarBndr ()] -> [Con] -> Q [Dec]
deriveSum Options
opts Name
name [TyVarBndr ()]
tyVars [Con]
constrs
NewtypeD [] Name
_ [] Maybe Type
Nothing (NormalC Name
_ [(Bang SourceUnpackedness
NoSourceUnpackedness SourceStrictness
NoSourceStrictness, Type
otherTy)]) [] ->
Options -> Name -> [TyVarBndr ()] -> Type -> Q [Dec]
deriveSynonym Options
opts Name
name [] Type
otherTy
NewtypeD [] Name
_ [] Maybe Type
Nothing (RecC Name
_ conFields :: [VarStrictType]
conFields@[(Name (OccName String
_) NameFlavour
_, Bang SourceUnpackedness
NoSourceUnpackedness SourceStrictness
NoSourceStrictness, Type
otherTy)]) [] ->
if Options -> Bool
A.unwrapUnaryRecords Options
opts
then Options -> Name -> [TyVarBndr ()] -> Type -> Q [Dec]
deriveSynonym Options
opts Name
name [] Type
otherTy
else Bool
-> Options -> Name -> [TyVarBndr ()] -> [VarStrictType] -> Q [Dec]
deriveAlias Bool
True Options
opts Name
name [] [VarStrictType]
conFields
TySynD Name
_ [TyVarBndr ()]
vars Type
otherTy ->
Options -> Name -> [TyVarBndr ()] -> Type -> Q [Dec]
deriveSynonym Options
opts Name
name [TyVarBndr ()]
vars Type
otherTy
NewtypeD Cxt
_ Name
_ [TyVarBndr ()]
tyvars Maybe Type
Nothing (NormalC Name
_ [(Bang SourceUnpackedness
NoSourceUnpackedness SourceStrictness
NoSourceStrictness, Type
otherTy)]) [] ->
Options -> Name -> [TyVarBndr ()] -> Type -> Q [Dec]
deriveSynonym Options
opts Name
name [TyVarBndr ()]
tyvars Type
otherTy
NewtypeD Cxt
_ Name
_ [TyVarBndr ()]
tyvars Maybe Type
Nothing (RecC Name
_ conFields :: [VarStrictType]
conFields@[(Name (OccName String
_) NameFlavour
_, Bang SourceUnpackedness
NoSourceUnpackedness SourceStrictness
NoSourceStrictness, Type
otherTy)]) [] ->
if Options -> Bool
A.unwrapUnaryRecords Options
opts
then Options -> Name -> [TyVarBndr ()] -> Type -> Q [Dec]
deriveSynonym Options
opts Name
name [TyVarBndr ()]
tyvars Type
otherTy
else Bool
-> Options -> Name -> [TyVarBndr ()] -> [VarStrictType] -> Q [Dec]
deriveAlias Bool
True Options
opts Name
name [TyVarBndr ()]
tyvars [VarStrictType]
conFields
Dec
_ -> String -> Q [Dec]
forall a. String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"Oops, can only derive data and newtype, not this: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Dec -> String
forall a. Show a => a -> String
show Dec
tyCon)