module Data.Bounded.Deriving.Internal (
deriveBounded
, makeMinBound
, makeMaxBound
) where
import Data.Deriving.Internal
import Language.Haskell.TH.Lib
import Language.Haskell.TH.Syntax
deriveBounded :: Name -> Q [Dec]
deriveBounded name = withType name fromCons
where
fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q [Dec]
fromCons name' ctxt tvbs cons mbTys = (:[]) `fmap` do
(instanceCxt, instanceType)
<- buildTypeInstance BoundedClass name' ctxt tvbs mbTys
instanceD (return instanceCxt)
(return instanceType)
(boundedFunDecs name' cons)
makeMinBound :: Name -> Q Exp
makeMinBound = makeBoundedFun MinBound
makeMaxBound :: Name -> Q Exp
makeMaxBound = makeBoundedFun MaxBound
boundedFunDecs :: Name -> [Con] -> [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 = withType name fromCons where
fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q Exp
fromCons name' ctxt tvbs cons mbTys =
buildTypeInstance BoundedClass name' ctxt tvbs mbTys
`seq` makeBoundedFunForCons bf name' cons
makeBoundedFunForCons :: BoundedFun -> Name -> [Con] -> 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