module Data.Enum.Deriving.Internal (
deriveEnum
, makeSucc
, makePred
, makeToEnum
, makeFromEnum
, makeEnumFrom
, makeEnumFromThen
) where
import Data.Deriving.Internal
import Language.Haskell.TH.Datatype
import Language.Haskell.TH.Lib
import Language.Haskell.TH.Syntax
deriveEnum :: Name -> Q [Dec]
deriveEnum :: Name -> Q [Dec]
deriveEnum name :: Name
name = do
DatatypeInfo
info <- Name -> Q DatatypeInfo
reifyDatatype Name
name
case DatatypeInfo
info of
DatatypeInfo { datatypeContext :: DatatypeInfo -> Cxt
datatypeContext = Cxt
ctxt
, datatypeName :: DatatypeInfo -> Name
datatypeName = Name
parentName
, datatypeInstTypes :: DatatypeInfo -> Cxt
datatypeInstTypes = Cxt
instTypes
, datatypeVariant :: DatatypeInfo -> DatatypeVariant
datatypeVariant = DatatypeVariant
variant
, datatypeCons :: DatatypeInfo -> [ConstructorInfo]
datatypeCons = [ConstructorInfo]
cons
} -> do
(instanceCxt :: Cxt
instanceCxt, instanceType :: Type
instanceType)
<- EnumClass -> Name -> Cxt -> Cxt -> DatatypeVariant -> Q (Cxt, Type)
forall a.
ClassRep a =>
a -> Name -> Cxt -> Cxt -> DatatypeVariant -> Q (Cxt, Type)
buildTypeInstance EnumClass
EnumClass Name
parentName Cxt
ctxt Cxt
instTypes DatatypeVariant
variant
(Dec -> [Dec] -> [Dec]
forall a. a -> [a] -> [a]
:[]) (Dec -> [Dec]) -> Q Dec -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` CxtQ -> TypeQ -> [Q Dec] -> Q Dec
instanceD (Cxt -> CxtQ
forall (m :: * -> *) a. Monad m => a -> m a
return Cxt
instanceCxt)
(Type -> TypeQ
forall (m :: * -> *) a. Monad m => a -> m a
return Type
instanceType)
(Name -> Type -> [ConstructorInfo] -> [Q Dec]
enumFunDecs Name
parentName Type
instanceType [ConstructorInfo]
cons)
makeSucc :: Name -> Q Exp
makeSucc :: Name -> Q Exp
makeSucc = EnumFun -> Name -> Q Exp
makeEnumFun EnumFun
Succ
makePred :: Name -> Q Exp
makePred :: Name -> Q Exp
makePred = EnumFun -> Name -> Q Exp
makeEnumFun EnumFun
Pred
makeToEnum :: Name -> Q Exp
makeToEnum :: Name -> Q Exp
makeToEnum = EnumFun -> Name -> Q Exp
makeEnumFun EnumFun
ToEnum
makeFromEnum :: Name -> Q Exp
= EnumFun -> Name -> Q Exp
makeEnumFun EnumFun
FromEnum
makeEnumFrom :: Name -> Q Exp
makeEnumFrom :: Name -> Q Exp
makeEnumFrom = EnumFun -> Name -> Q Exp
makeEnumFun EnumFun
EnumFrom
makeEnumFromThen :: Name -> Q Exp
makeEnumFromThen :: Name -> Q Exp
makeEnumFromThen = EnumFun -> Name -> Q Exp
makeEnumFun EnumFun
EnumFromThen
enumFunDecs :: Name -> Type -> [ConstructorInfo] -> [Q Dec]
enumFunDecs :: Name -> Type -> [ConstructorInfo] -> [Q Dec]
enumFunDecs tyName :: Name
tyName ty :: Type
ty cons :: [ConstructorInfo]
cons =
(EnumFun -> Q Dec) -> [EnumFun] -> [Q Dec]
forall a b. (a -> b) -> [a] -> [b]
map EnumFun -> Q Dec
makeFunD [ EnumFun
Succ
, EnumFun
Pred
, EnumFun
ToEnum
, EnumFun
EnumFrom
, EnumFun
EnumFromThen
, EnumFun
FromEnum
]
where
makeFunD :: EnumFun -> Q Dec
makeFunD :: EnumFun -> Q Dec
makeFunD ef :: EnumFun
ef =
Name -> [ClauseQ] -> Q Dec
funD (EnumFun -> Name
enumFunName EnumFun
ef)
[ [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause []
(Q Exp -> BodyQ
normalB (Q Exp -> BodyQ) -> Q Exp -> BodyQ
forall a b. (a -> b) -> a -> b
$ EnumFun -> Name -> Type -> [ConstructorInfo] -> Q Exp
makeEnumFunForCons EnumFun
ef Name
tyName Type
ty [ConstructorInfo]
cons)
[]
]
makeEnumFun :: EnumFun -> Name -> Q Exp
makeEnumFun :: EnumFun -> Name -> Q Exp
makeEnumFun ef :: EnumFun
ef name :: Name
name = do
DatatypeInfo
info <- Name -> Q DatatypeInfo
reifyDatatype Name
name
case DatatypeInfo
info of
DatatypeInfo { datatypeContext :: DatatypeInfo -> Cxt
datatypeContext = Cxt
ctxt
, datatypeName :: DatatypeInfo -> Name
datatypeName = Name
parentName
, datatypeInstTypes :: DatatypeInfo -> Cxt
datatypeInstTypes = Cxt
instTypes
, datatypeVariant :: DatatypeInfo -> DatatypeVariant
datatypeVariant = DatatypeVariant
variant
, datatypeCons :: DatatypeInfo -> [ConstructorInfo]
datatypeCons = [ConstructorInfo]
cons
} -> do
(_, instanceType :: Type
instanceType) <- EnumClass -> Name -> Cxt -> Cxt -> DatatypeVariant -> Q (Cxt, Type)
forall a.
ClassRep a =>
a -> Name -> Cxt -> Cxt -> DatatypeVariant -> Q (Cxt, Type)
buildTypeInstance EnumClass
EnumClass Name
parentName Cxt
ctxt Cxt
instTypes DatatypeVariant
variant
EnumFun -> Name -> Type -> [ConstructorInfo] -> Q Exp
makeEnumFunForCons EnumFun
ef Name
parentName Type
instanceType [ConstructorInfo]
cons
makeEnumFunForCons :: EnumFun -> Name -> Type -> [ConstructorInfo] -> Q Exp
makeEnumFunForCons :: EnumFun -> Name -> Type -> [ConstructorInfo] -> Q Exp
makeEnumFunForCons _ _ _ [] = Q Exp
forall a. Q a
noConstructorsError
makeEnumFunForCons ef :: EnumFun
ef tyName :: Name
tyName ty :: Type
ty cons :: [ConstructorInfo]
cons
| Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [ConstructorInfo] -> Bool
isEnumerationType [ConstructorInfo]
cons
= String -> Q Exp
forall a. String -> Q a
enumerationError String
tyNameBase
| Bool
otherwise = case EnumFun
ef of
Succ -> (Name -> Q Exp) -> Q Exp
lamOneHash ((Name -> Q Exp) -> Q Exp) -> (Name -> Q Exp) -> Q Exp
forall a b. (a -> b) -> a -> b
$ \aHash :: Name
aHash ->
Q Exp -> Q Exp -> Q Exp -> Q Exp
condE (Name -> Q Exp
varE Name
eqValName Q Exp -> Q Exp -> Q Exp
`appE` Q Exp
maxTagExpr Q Exp -> Q Exp -> Q Exp
`appE`
(Name -> Q Exp
conE Name
iHashDataName Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE Name
aHash))
(String -> String -> String -> Q Exp
illegalExpr "succ" String
tyNameBase
"tried to take `succ' of last tag in enumeration")
(Q Exp
tag2Con Q Exp -> Q Exp -> Q Exp
`appE` (Name -> Q Exp
varE Name
plusValName Q Exp -> Q Exp -> Q Exp
`appE`
(Name -> Q Exp
conE Name
iHashDataName Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE Name
aHash) Q Exp -> Q Exp -> Q Exp
`appE` Int -> Q Exp
integerE 1))
Pred -> (Name -> Q Exp) -> Q Exp
lamOneHash ((Name -> Q Exp) -> Q Exp) -> (Name -> Q Exp) -> Q Exp
forall a b. (a -> b) -> a -> b
$ \aHash :: Name
aHash ->
Q Exp -> Q Exp -> Q Exp -> Q Exp
condE (Name -> Q Exp
varE Name
eqValName Q Exp -> Q Exp -> Q Exp
`appE` Int -> Q Exp
integerE 0 Q Exp -> Q Exp -> Q Exp
`appE`
(Name -> Q Exp
conE Name
iHashDataName Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE Name
aHash))
(String -> String -> String -> Q Exp
illegalExpr "pred" String
tyNameBase
"tried to take `pred' of first tag in enumeration")
(Q Exp
tag2Con Q Exp -> Q Exp -> Q Exp
`appE` (Name -> Q Exp
varE Name
plusValName Q Exp -> Q Exp -> Q Exp
`appE`
(Name -> Q Exp
conE Name
iHashDataName Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE Name
aHash) Q Exp -> Q Exp -> Q Exp
`appE` Int -> Q Exp
integerE (-1)))
ToEnum -> (Name -> Q Exp) -> Q Exp
lamOne ((Name -> Q Exp) -> Q Exp) -> (Name -> Q Exp) -> Q Exp
forall a b. (a -> b) -> a -> b
$ \a :: Name
a ->
Q Exp -> Q Exp -> Q Exp -> Q Exp
condE ([Q Exp] -> Q Exp
appsE [ Name -> Q Exp
varE Name
andValName
, Name -> Q Exp
varE Name
geValName Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE Name
a Q Exp -> Q Exp -> Q Exp
`appE` Int -> Q Exp
integerE 0
, Name -> Q Exp
varE Name
leValName Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE Name
a Q Exp -> Q Exp -> Q Exp
`appE` Q Exp
maxTagExpr
])
(Q Exp
tag2Con Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE Name
a)
(String -> Q Exp -> Name -> Q Exp
illegalToEnumTag String
tyNameBase Q Exp
maxTagExpr Name
a)
EnumFrom -> (Name -> Q Exp) -> Q Exp
lamOneHash ((Name -> Q Exp) -> Q Exp) -> (Name -> Q Exp) -> Q Exp
forall a b. (a -> b) -> a -> b
$ \aHash :: Name
aHash ->
[Q Exp] -> Q Exp
appsE [ Name -> Q Exp
varE Name
mapValName
, Q Exp
tag2Con
, Q Exp -> Q Exp -> Q Exp
enumFromToExpr (Name -> Q Exp
conE Name
iHashDataName Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE Name
aHash) Q Exp
maxTagExpr
]
EnumFromThen -> do
Name
a <- String -> Q Name
newName "a"
Name
aHash <- String -> Q Name
newName "a#"
Name
b <- String -> Q Name
newName "b"
Name
bHash <- String -> Q Name
newName "b#"
[PatQ] -> Q Exp -> Q Exp
lamE [Name -> PatQ
varP Name
a, Name -> PatQ
varP Name
b] (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ [(Name, Name)] -> Q Exp -> Q Exp
untagExpr [(Name
a, Name
aHash), (Name
b, Name
bHash)] (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$
Q Exp -> Q Exp -> Q Exp
appE (Name -> Q Exp
varE Name
mapValName Q Exp -> Q Exp -> Q Exp
`appE` Q Exp
tag2Con) (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$
Q Exp -> Q Exp -> Q Exp -> Q Exp
enumFromThenToExpr
(Name -> Q Exp
conE Name
iHashDataName Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE Name
aHash)
(Name -> Q Exp
conE Name
iHashDataName Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE Name
bHash)
(Q Exp -> Q Exp -> Q Exp -> Q Exp
condE ([Q Exp] -> Q Exp
appsE [ Name -> Q Exp
varE Name
gtValName
, Name -> Q Exp
conE Name
iHashDataName Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE Name
aHash
, Name -> Q Exp
conE Name
iHashDataName Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE Name
bHash
])
(Int -> Q Exp
integerE 0) Q Exp
maxTagExpr)
FromEnum -> (Name -> Q Exp) -> Q Exp
lamOneHash ((Name -> Q Exp) -> Q Exp) -> (Name -> Q Exp) -> Q Exp
forall a b. (a -> b) -> a -> b
$ \aHash :: Name
aHash ->
Name -> Q Exp
conE Name
iHashDataName Q Exp -> Q Exp -> Q Exp
`appE` Name -> Q Exp
varE Name
aHash
where
tyNameBase :: String
tyNameBase :: String
tyNameBase = Name -> String
nameBase Name
tyName
maxTagExpr :: Q Exp
maxTagExpr :: Q Exp
maxTagExpr = Int -> Q Exp
integerE ([ConstructorInfo] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [ConstructorInfo]
cons Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1) Q Exp -> TypeQ -> Q Exp
`sigE` Name -> TypeQ
conT Name
intTypeName
lamOne :: (Name -> Q Exp) -> Q Exp
lamOne :: (Name -> Q Exp) -> Q Exp
lamOne f :: Name -> Q Exp
f = do
Name
a <- String -> Q Name
newName "a"
PatQ -> Q Exp -> Q Exp
lam1E (Name -> PatQ
varP Name
a) (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
f Name
a
lamOneHash :: (Name -> Q Exp) -> Q Exp
lamOneHash :: (Name -> Q Exp) -> Q Exp
lamOneHash f :: Name -> Q Exp
f = (Name -> Q Exp) -> Q Exp
lamOne ((Name -> Q Exp) -> Q Exp) -> (Name -> Q Exp) -> Q Exp
forall a b. (a -> b) -> a -> b
$ \a :: Name
a -> do
Name
aHash <- String -> Q Name
newName "a#"
[(Name, Name)] -> Q Exp -> Q Exp
untagExpr [(Name
a, Name
aHash)] (Q Exp -> Q Exp) -> Q Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
f Name
aHash
tag2Con :: Q Exp
tag2Con :: Q Exp
tag2Con = Type -> Q Exp
tag2ConExpr (Type -> Q Exp) -> Type -> Q Exp
forall a b. (a -> b) -> a -> b
$ Type -> Type
removeClassApp Type
ty
data EnumClass = EnumClass
instance ClassRep EnumClass where
arity :: EnumClass -> Int
arity _ = 0
allowExQuant :: EnumClass -> Bool
allowExQuant _ = Bool
True
fullClassName :: EnumClass -> Name
fullClassName _ = Name
enumTypeName
classConstraint :: EnumClass -> Int -> Maybe Name
classConstraint _ 0 = Name -> Maybe Name
forall a. a -> Maybe a
Just (Name -> Maybe Name) -> Name -> Maybe Name
forall a b. (a -> b) -> a -> b
$ Name
enumTypeName
classConstraint _ _ = Maybe Name
forall a. Maybe a
Nothing
data EnumFun = Succ
| Pred
| ToEnum
|
| EnumFrom
| EnumFromThen
deriving Int -> EnumFun -> ShowS
[EnumFun] -> ShowS
EnumFun -> String
(Int -> EnumFun -> ShowS)
-> (EnumFun -> String) -> ([EnumFun] -> ShowS) -> Show EnumFun
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [EnumFun] -> ShowS
$cshowList :: [EnumFun] -> ShowS
show :: EnumFun -> String
$cshow :: EnumFun -> String
showsPrec :: Int -> EnumFun -> ShowS
$cshowsPrec :: Int -> EnumFun -> ShowS
Show
enumFunName :: EnumFun -> Name
enumFunName :: EnumFun -> Name
enumFunName Succ = Name
succValName
enumFunName Pred = Name
predValName
enumFunName ToEnum = Name
toEnumValName
enumFunName FromEnum = Name
fromEnumValName
enumFunName EnumFrom = Name
enumFromValName
enumFunName EnumFromThen = Name
enumFromThenValName
enumFromThenToExpr :: Q Exp -> Q Exp -> Q Exp -> Q Exp
enumFromThenToExpr :: Q Exp -> Q Exp -> Q Exp -> Q Exp
enumFromThenToExpr f :: Q Exp
f t1 :: Q Exp
t1 t2 :: Q Exp
t2 = Name -> Q Exp
varE Name
enumFromThenToValName Q Exp -> Q Exp -> Q Exp
`appE` Q Exp
f Q Exp -> Q Exp -> Q Exp
`appE` Q Exp
t1 Q Exp -> Q Exp -> Q Exp
`appE` Q Exp
t2
illegalExpr :: String -> String -> String -> Q Exp
illegalExpr :: String -> String -> String -> Q Exp
illegalExpr meth :: String
meth tp :: String
tp msg :: String
msg =
Name -> Q Exp
varE Name
errorValName Q Exp -> Q Exp -> Q Exp
`appE` String -> Q Exp
stringE (String
meth String -> ShowS
forall a. [a] -> [a] -> [a]
++ '{'Char -> ShowS
forall a. a -> [a] -> [a]
:String
tp String -> ShowS
forall a. [a] -> [a] -> [a]
++ "}: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
msg)
illegalToEnumTag :: String -> Q Exp -> Name -> Q Exp
illegalToEnumTag :: String -> Q Exp -> Name -> Q Exp
illegalToEnumTag tp :: String
tp maxtag :: Q Exp
maxtag a :: Name
a =
Q Exp -> Q Exp -> Q Exp
appE (Name -> Q Exp
varE Name
errorValName)
(Q Exp -> Q Exp -> Q Exp
appE (Q Exp -> Q Exp -> Q Exp
appE (Name -> Q Exp
varE Name
appendValName)
(String -> Q Exp
stringE ("toEnum{" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
tp String -> ShowS
forall a. [a] -> [a] -> [a]
++ "}: tag(")))
(Q Exp -> Q Exp -> Q Exp
appE (Q Exp -> Q Exp -> Q Exp
appE (Q Exp -> Q Exp -> Q Exp
appE
(Name -> Q Exp
varE Name
showsPrecValName)
(Int -> Q Exp
integerE 0))
(Name -> Q Exp
varE Name
a))
(Q Exp -> Q Exp -> Q Exp
appE (Q Exp -> Q Exp -> Q Exp
appE
(Name -> Q Exp
varE Name
appendValName)
(String -> Q Exp
stringE ") is outside of enumeration's range (0,"))
(Q Exp -> Q Exp -> Q Exp
appE (Q Exp -> Q Exp -> Q Exp
appE (Q Exp -> Q Exp -> Q Exp
appE
(Name -> Q Exp
varE Name
showsPrecValName)
(Int -> Q Exp
integerE 0))
Q Exp
maxtag)
(String -> Q Exp
stringE ")")))))