{-# LANGUAGE CPP #-}
module Data.Bounded.Deriving.Internal (
deriveBounded
, makeMinBound
, makeMaxBound
) where
import Data.Deriving.Internal
import qualified Data.List.NonEmpty as NE
import Data.List.NonEmpty (NonEmpty(..))
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 a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Q Cxt -> Q Type -> [Q Dec] -> Q Dec
forall (m :: * -> *).
Quote m =>
m Cxt -> m Type -> [m Dec] -> m Dec
instanceD (Cxt -> Q Cxt
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Cxt
instanceCxt)
(Type -> Q Type
forall a. a -> Q a
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 -> [Q Clause] -> Q Dec
forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD (BoundedFun -> Name
boundedFunName BoundedFun
bf)
[ [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause []
(Q Exp -> Q Body
forall (m :: * -> *). Quote m => m Exp -> m Body
normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
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 a b. Q a -> Q b -> Q b
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
con:[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 = NonEmpty ConstructorInfo -> Bool
isProductType NonEmpty ConstructorInfo
cons
isEnumeration :: Bool
isEnumeration = NonEmpty ConstructorInfo -> Bool
isEnumerationType NonEmpty ConstructorInfo
cons
cons :: NonEmpty ConstructorInfo
cons :: NonEmpty ConstructorInfo
cons = ConstructorInfo
con ConstructorInfo -> [ConstructorInfo] -> NonEmpty ConstructorInfo
forall a. a -> [a] -> NonEmpty a
:| [ConstructorInfo]
cons'
con1, conN :: Q Exp
con1 :: Q Exp
con1 = Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
conE (Name -> Q Exp) -> Name -> Q Exp
forall a b. (a -> b) -> a -> b
$ ConstructorInfo -> Name
constructorName ConstructorInfo
con
conN :: Q Exp
conN = Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m 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
$ NonEmpty ConstructorInfo -> ConstructorInfo
forall a. NonEmpty a -> a
NE.last NonEmpty 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
forall (m :: * -> *). Quote m => [m Exp] -> m 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
forall (m :: * -> *). Quote m => Name -> m Exp
varE (Int -> Name -> [Name]
forall a. Int -> a -> [a]
replicate (ConstructorInfo -> Int
conArity ConstructorInfo
con) (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