{-# 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)
<- forall a.
ClassRep a =>
a -> Name -> Cxt -> Cxt -> DatatypeVariant -> Q (Cxt, Type)
buildTypeInstance BoundedClass
BoundedClass 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 -> [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 =
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD (BoundedFun -> Name
boundedFunName BoundedFun
bf)
[ 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
$ 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
forall a.
ClassRep a =>
a -> Name -> Cxt -> Cxt -> DatatypeVariant -> Q (Cxt, Type)
buildTypeInstance BoundedClass
BoundedClass Name
parentName Cxt
ctxt Cxt
instTypes DatatypeVariant
variant
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
_ [] = forall a. Q a
noConstructorsError
makeBoundedFunForCons BoundedFun
bf Name
tyName [ConstructorInfo]
cons
| Bool -> Bool
not (Bool
isProduct Bool -> Bool -> Bool
|| Bool
isEnumeration)
= forall a. String -> Q a
enumerationOrProductError 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 = forall (m :: * -> *). Quote m => Name -> m Exp
conE forall a b. (a -> b) -> a -> b
$ ConstructorInfo -> Name
constructorName forall a b. (a -> b) -> a -> b
$ forall a. [a] -> a
head [ConstructorInfo]
cons
conN :: Q Exp
conN = forall (m :: * -> *). Quote m => Name -> m Exp
conE forall a b. (a -> b) -> a -> b
$ ConstructorInfo -> Name
constructorName forall a b. (a -> b) -> a -> b
$ 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 = forall (m :: * -> *). Quote m => [m Exp] -> m Exp
appsE
forall a b. (a -> b) -> a -> b
$ Q Exp
pickCon
forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *). Quote m => Name -> m Exp
varE (forall a. Int -> a -> [a]
replicate (ConstructorInfo -> Int
conArity forall a b. (a -> b) -> a -> b
$ 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 = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Name
boundedTypeName
classConstraint BoundedClass
_ Int
_ = 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