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