{-# LANGUAGE CPP #-}

{-|
Module:      Data.Bounded.Deriving.Internal
Copyright:   (C) 2015-2017 Ryan Scott
License:     BSD-style (see the file LICENSE)
Maintainer:  Ryan Scott
Portability: Template Haskell

Exports functions to mechanically derive 'Bounded' instances.

Note: this is an internal module, and as such, the API presented here is not
guaranteed to be stable, even between minor releases of this library.
-}
module Data.Bounded.Deriving.Internal (
      -- * 'Bounded'
      deriveBounded
    , makeMinBound
    , makeMaxBound
    ) where

import Data.Deriving.Internal

import Language.Haskell.TH.Datatype
import Language.Haskell.TH.Lib
import Language.Haskell.TH.Syntax

-------------------------------------------------------------------------------
-- Code generation
-------------------------------------------------------------------------------

-- | Generates a 'Bounded' instance declaration for the given data type or data
-- family instance.
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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` CxtQ -> TypeQ -> [Q Dec] -> Q Dec
instanceD (Cxt -> CxtQ
forall (m :: * -> *) a. Monad m => a -> m a
return Cxt
instanceCxt)
                   (Type -> TypeQ
forall (m :: * -> *) a. Monad m => a -> m a
return Type
instanceType)
                   (Name -> [ConstructorInfo] -> [Q Dec]
boundedFunDecs Name
parentName [ConstructorInfo]
cons)

-- | Generates a lambda expression which behaves like 'minBound' (without
-- requiring a 'Bounded' instance).
makeMinBound :: Name -> Q Exp
makeMinBound :: Name -> Q Exp
makeMinBound = BoundedFun -> Name -> Q Exp
makeBoundedFun BoundedFun
MinBound

-- | Generates a lambda expression which behaves like 'maxBound' (without
-- requiring a 'Bounded' instance).
makeMaxBound :: Name -> Q Exp
makeMaxBound :: Name -> Q Exp
makeMaxBound = BoundedFun -> Name -> Q Exp
makeBoundedFun BoundedFun
MaxBound

-- | Generates 'minBound' and 'maxBound' method declarations.
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 -> [ClauseQ] -> Q Dec
funD (BoundedFun -> Name
boundedFunName BoundedFun
bf)
           [ [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause []
                    (Q Exp -> BodyQ
normalB (Q Exp -> BodyQ) -> Q Exp -> BodyQ
forall a b. (a -> b) -> a -> b
$ BoundedFun -> Name -> [ConstructorInfo] -> Q Exp
makeBoundedFunForCons BoundedFun
bf Name
tyName [ConstructorInfo]
cons)
                    []
           ]

-- | Generates a lambda expression which behaves like the BoundedFun argument.
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
      -- 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.
      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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> BoundedFun -> Name -> [ConstructorInfo] -> Q Exp
makeBoundedFunForCons BoundedFun
bf Name
parentName [ConstructorInfo]
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 :: BoundedFun -> Name -> [ConstructorInfo] -> Q Exp
makeBoundedFunForCons BoundedFun
_  Name
_      [] = Q Exp
forall a. Q a
noConstructorsError
makeBoundedFunForCons BoundedFun
bf Name
tyName [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 -- It's a product type
    = 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 = Name -> Q 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
$ [ConstructorInfo] -> ConstructorInfo
forall a. [a] -> a
head [ConstructorInfo]
cons
    conN :: Q Exp
conN = Name -> Q 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
$ [ConstructorInfo] -> ConstructorInfo
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 = [Q Exp] -> Q 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
varE (Int -> Name -> [Name]
forall a. Int -> a -> [a]
replicate (ConstructorInfo -> Int
conArity (ConstructorInfo -> Int) -> ConstructorInfo -> Int
forall a b. (a -> b) -> a -> b
$ [ConstructorInfo] -> ConstructorInfo
forall a. [a] -> a
head [ConstructorInfo]
cons) (BoundedFun -> Name
boundedFunName BoundedFun
bf))

-------------------------------------------------------------------------------
-- Class-specific constants
-------------------------------------------------------------------------------

-- There's only one Bounded variant!
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

-- | A representation of which function is being generated.
data BoundedFun = MinBound | MaxBound

boundedFunName :: BoundedFun -> Name
boundedFunName :: BoundedFun -> Name
boundedFunName BoundedFun
MinBound = Name
minBoundValName
boundedFunName BoundedFun
MaxBound = Name
maxBoundValName