{-# LANGUAGE CPP #-}
module Data.Bounded.Deriving.Internal (
deriveBounded
, makeMinBound
, makeMaxBound
) where
import Data.Deriving.Internal
import Language.Haskell.TH.Datatype
import Language.Haskell.TH.Lib
import Language.Haskell.TH.Syntax
deriveBounded :: Name -> Q [Dec]
deriveBounded :: Name -> Q [Dec]
deriveBounded 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)
<- BoundedClass
-> Name -> Cxt -> Cxt -> DatatypeVariant -> Q (Cxt, Type)
forall a.
ClassRep a =>
a -> Name -> Cxt -> Cxt -> DatatypeVariant -> Q (Cxt, Type)
buildTypeInstance BoundedClass
BoundedClass 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 -> [ConstructorInfo] -> [Q Dec]
boundedFunDecs Name
parentName [ConstructorInfo]
cons)
makeMinBound :: Name -> Q Exp
makeMinBound :: Name -> Q Exp
makeMinBound = BoundedFun -> Name -> Q Exp
makeBoundedFun BoundedFun
MinBound
makeMaxBound :: Name -> Q Exp
makeMaxBound :: Name -> Q Exp
makeMaxBound = BoundedFun -> Name -> Q Exp
makeBoundedFun BoundedFun
MaxBound
boundedFunDecs :: Name -> [ConstructorInfo] -> [Q Dec]
boundedFunDecs :: Name -> [ConstructorInfo] -> [Q Dec]
boundedFunDecs Name
tyName [ConstructorInfo]
cons = [BoundedFun -> Q Dec
makeFunD BoundedFun
MinBound, BoundedFun -> Q Dec
makeFunD BoundedFun
MaxBound]
where
makeFunD :: BoundedFun -> Q Dec
makeFunD :: BoundedFun -> Q Dec
makeFunD BoundedFun
bf =
Name -> [ClauseQ] -> Q Dec
funD (BoundedFun -> Name
boundedFunName BoundedFun
bf)
[ [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause []
(Q Exp -> BodyQ
normalB (Q Exp -> BodyQ) -> Q Exp -> BodyQ
forall a b. (a -> b) -> a -> b
$ BoundedFun -> Name -> [ConstructorInfo] -> Q Exp
makeBoundedFunForCons BoundedFun
bf Name
tyName [ConstructorInfo]
cons)
[]
]
makeBoundedFun :: BoundedFun -> Name -> Q Exp
makeBoundedFun :: BoundedFun -> Name -> Q Exp
makeBoundedFun BoundedFun
bf 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
BoundedClass
-> Name -> Cxt -> Cxt -> DatatypeVariant -> Q (Cxt, Type)
forall a.
ClassRep a =>
a -> Name -> Cxt -> Cxt -> DatatypeVariant -> Q (Cxt, Type)
buildTypeInstance BoundedClass
BoundedClass Name
parentName Cxt
ctxt Cxt
instTypes DatatypeVariant
variant
Q (Cxt, Type) -> Q Exp -> Q Exp
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> BoundedFun -> Name -> [ConstructorInfo] -> Q Exp
makeBoundedFunForCons BoundedFun
bf Name
parentName [ConstructorInfo]
cons
makeBoundedFunForCons :: BoundedFun -> Name -> [ConstructorInfo] -> Q Exp
makeBoundedFunForCons :: BoundedFun -> Name -> [ConstructorInfo] -> Q Exp
makeBoundedFunForCons BoundedFun
_ Name
_ [] = Q Exp
forall a. Q a
noConstructorsError
makeBoundedFunForCons BoundedFun
bf Name
tyName [ConstructorInfo]
cons
| Bool -> Bool
not (Bool
isProduct Bool -> Bool -> Bool
|| Bool
isEnumeration)
= String -> Q Exp
forall a. String -> Q a
enumerationOrProductError (String -> Q Exp) -> String -> Q Exp
forall a b. (a -> b) -> a -> b
$ Name -> String
nameBase Name
tyName
| Bool
isEnumeration
= Q Exp
pickCon
| Bool
otherwise
= Q Exp
pickConApp
where
isProduct, isEnumeration :: Bool
isProduct :: Bool
isProduct = [ConstructorInfo] -> Bool
isProductType [ConstructorInfo]
cons
isEnumeration :: Bool
isEnumeration = [ConstructorInfo] -> Bool
isEnumerationType [ConstructorInfo]
cons
con1, conN :: Q Exp
con1 :: Q Exp
con1 = Name -> Q Exp
conE (Name -> Q Exp) -> Name -> Q Exp
forall a b. (a -> b) -> a -> b
$ ConstructorInfo -> Name
constructorName (ConstructorInfo -> Name) -> ConstructorInfo -> Name
forall a b. (a -> b) -> a -> b
$ [ConstructorInfo] -> ConstructorInfo
forall a. [a] -> a
head [ConstructorInfo]
cons
conN :: Q Exp
conN = Name -> Q Exp
conE (Name -> Q Exp) -> Name -> Q Exp
forall a b. (a -> b) -> a -> b
$ ConstructorInfo -> Name
constructorName (ConstructorInfo -> Name) -> ConstructorInfo -> Name
forall a b. (a -> b) -> a -> b
$ [ConstructorInfo] -> ConstructorInfo
forall a. [a] -> a
last [ConstructorInfo]
cons
pickCon :: Q Exp
pickCon :: Q Exp
pickCon = case BoundedFun
bf of
BoundedFun
MinBound -> Q Exp
con1
BoundedFun
MaxBound -> Q Exp
conN
pickConApp :: Q Exp
pickConApp :: Q Exp
pickConApp = [Q Exp] -> Q Exp
appsE
([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
forall a b. (a -> b) -> a -> b
$ Q Exp
pickCon
Q Exp -> [Q Exp] -> [Q Exp]
forall a. a -> [a] -> [a]
: (Name -> Q Exp) -> [Name] -> [Q Exp]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Q Exp
varE (Int -> Name -> [Name]
forall a. Int -> a -> [a]
replicate (ConstructorInfo -> Int
conArity (ConstructorInfo -> Int) -> ConstructorInfo -> Int
forall a b. (a -> b) -> a -> b
$ [ConstructorInfo] -> ConstructorInfo
forall a. [a] -> a
head [ConstructorInfo]
cons) (BoundedFun -> Name
boundedFunName BoundedFun
bf))
data BoundedClass = BoundedClass
instance ClassRep BoundedClass where
arity :: BoundedClass -> Int
arity BoundedClass
_ = Int
0
allowExQuant :: BoundedClass -> Bool
allowExQuant BoundedClass
_ = Bool
True
fullClassName :: BoundedClass -> Name
fullClassName BoundedClass
_ = Name
boundedTypeName
classConstraint :: BoundedClass -> Int -> Maybe Name
classConstraint BoundedClass
_ Int
0 = Name -> Maybe Name
forall a. a -> Maybe a
Just (Name -> Maybe Name) -> Name -> Maybe Name
forall a b. (a -> b) -> a -> b
$ Name
boundedTypeName
classConstraint BoundedClass
_ Int
_ = Maybe Name
forall a. Maybe a
Nothing
data BoundedFun = MinBound | MaxBound
boundedFunName :: BoundedFun -> Name
boundedFunName :: BoundedFun -> Name
boundedFunName BoundedFun
MinBound = Name
minBoundValName
boundedFunName BoundedFun
MaxBound = Name
maxBoundValName