{-# 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
#if MIN_VERSION_th_abstraction(0,3,0)
, datatypeInstTypes = instTypes
#else
, datatypeVars = instTypes
#endif
, datatypeVariant = variant
, datatypeCons = cons
} -> do
(instanceCxt, instanceType)
<- buildTypeInstance BoundedClass parentName ctxt instTypes variant
(:[]) `fmap` instanceD (return instanceCxt)
(return instanceType)
(boundedFunDecs parentName cons)
-- | Generates a lambda expression which behaves like 'minBound' (without
-- requiring a 'Bounded' instance).
makeMinBound :: Name -> Q Exp
makeMinBound = makeBoundedFun MinBound
-- | Generates a lambda expression which behaves like 'maxBound' (without
-- requiring a 'Bounded' instance).
makeMaxBound :: Name -> Q Exp
makeMaxBound = makeBoundedFun MaxBound
-- | Generates 'minBound' and 'maxBound' method declarations.
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)
[]
]
-- | Generates a lambda expression which behaves like the BoundedFun argument.
makeBoundedFun :: BoundedFun -> Name -> Q Exp
makeBoundedFun bf name = do
info <- reifyDatatype name
case info of
DatatypeInfo { datatypeContext = ctxt
, datatypeName = parentName
#if MIN_VERSION_th_abstraction(0,3,0)
, datatypeInstTypes = instTypes
#else
, datatypeVars = instTypes
#endif
, datatypeVariant = variant
, datatypeCons = cons
} -> do
-- We force buildTypeInstance here since it performs some checks for whether
-- or not the provided datatype can actually have minBound/maxBound
-- implemented for it, and produces errors if it can't.
buildTypeInstance BoundedClass parentName ctxt instTypes variant
>> makeBoundedFunForCons bf parentName cons
-- | Generates a lambda expression for minBound/maxBound. for the
-- given constructors. All constructors must be from the same type.
makeBoundedFunForCons :: BoundedFun -> Name -> [ConstructorInfo] -> Q Exp
makeBoundedFunForCons _ _ [] = noConstructorsError
makeBoundedFunForCons bf tyName cons
| not (isProduct || isEnumeration)
= enumerationOrProductError $ nameBase tyName
| isEnumeration
= pickCon
| otherwise -- It's a product type
= 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))
-------------------------------------------------------------------------------
-- Class-specific constants
-------------------------------------------------------------------------------
-- There's only one Bounded variant!
data BoundedClass = BoundedClass
instance ClassRep BoundedClass where
arity _ = 0
allowExQuant _ = True
fullClassName _ = boundedTypeName
classConstraint _ 0 = Just $ boundedTypeName
classConstraint _ _ = Nothing
-- | A representation of which function is being generated.
data BoundedFun = MinBound | MaxBound
boundedFunName :: BoundedFun -> Name
boundedFunName MinBound = minBoundValName
boundedFunName MaxBound = maxBoundValName