    {-# 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 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

    -------------------------------------------------------------------------------
    -- 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
      info <- Name -> Q DatatypeInfo
    reifyDatatype Name
    name
      case 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
          (instanceCxt, 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
          (:[]) `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 :: 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 -> [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)
                        []
               ]

    -- | 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
      info <- Name -> Q DatatypeInfo
    reifyDatatype Name
    name
      case 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 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

    -- | 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
    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 -- It's a product type
        = 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))

    -------------------------------------------------------------------------------
    -- 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