{-# 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 = do
info <- reifyDatatype name
case info of
DatatypeInfo { datatypeContext = ctxt
, datatypeName = parentName
, datatypeInstTypes = instTypes
, datatypeVariant = variant
, datatypeCons = cons
} -> do
(instanceCxt, instanceType)
<- buildTypeInstance BoundedClass parentName ctxt instTypes variant
(:[]) `fmap` instanceD (return instanceCxt)
(return instanceType)
(boundedFunDecs parentName cons)
makeMinBound :: Name -> Q Exp
makeMinBound = makeBoundedFun MinBound
makeMaxBound :: Name -> Q Exp
makeMaxBound = makeBoundedFun MaxBound
boundedFunDecs :: Name -> [ConstructorInfo] -> [Q Dec]
boundedFunDecs tyName cons = [makeFunD MinBound, makeFunD MaxBound]
where
makeFunD :: BoundedFun -> Q Dec
makeFunD bf =
funD (boundedFunName bf)
[ clause []
(normalB $ makeBoundedFunForCons bf tyName cons)
[]
]
makeBoundedFun :: BoundedFun -> Name -> Q Exp
makeBoundedFun bf name = do
info <- reifyDatatype name
case info of
DatatypeInfo { datatypeContext = ctxt
, datatypeName = parentName
, datatypeInstTypes = instTypes
, datatypeVariant = variant
, datatypeCons = cons
} -> do
buildTypeInstance BoundedClass parentName ctxt instTypes variant
>> makeBoundedFunForCons bf parentName cons
makeBoundedFunForCons :: BoundedFun -> Name -> [ConstructorInfo] -> Q Exp
makeBoundedFunForCons _ _ [] = noConstructorsError
makeBoundedFunForCons bf tyName cons
| not (isProduct || isEnumeration)
= enumerationOrProductError $ nameBase tyName
| isEnumeration
= pickCon
| otherwise
= pickConApp
where
isProduct, isEnumeration :: Bool
isProduct = isProductType cons
isEnumeration = isEnumerationType cons
con1, conN :: Q Exp
con1 = conE $ constructorName $ head cons
conN = conE $ constructorName $ last cons
pickCon :: Q Exp
pickCon = case bf of
MinBound -> con1
MaxBound -> conN
pickConApp :: Q Exp
pickConApp = appsE
$ pickCon
: map varE (replicate (conArity $ head cons) (boundedFunName bf))
data BoundedClass = BoundedClass
instance ClassRep BoundedClass where
arity _ = 0
allowExQuant _ = True
fullClassName _ = boundedTypeName
classConstraint _ 0 = Just $ boundedTypeName
classConstraint _ _ = Nothing
data BoundedFun = MinBound | MaxBound
boundedFunName :: BoundedFun -> Name
boundedFunName MinBound = minBoundValName
boundedFunName MaxBound = maxBoundValName