    {-|
    Module:      Data.Enum.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 'Enum' 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.Enum.Deriving.Internal (
          -- * 'Enum'
          deriveEnum
        , makeSucc
        , makePred
        , makeToEnum
        , makeFromEnum
        , makeEnumFrom
        , makeEnumFromThen
        ) where

    import Data.Deriving.Internal

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

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

    -- | Generates an 'Enum' instance declaration for the given data type or data
    -- family instance.
    deriveEnum :: Name -> Q [Dec]
    deriveEnum :: Name -> Q [Dec]
    deriveEnum name :: 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
          (instanceCxt :: Cxt
    instanceCxt, instanceType :: Type
    instanceType)
              <- EnumClass -> Name -> Cxt -> Cxt -> DatatypeVariant -> Q (Cxt, Type)
    forall a.
    ClassRep a =>
    a -> Name -> Cxt -> Cxt -> DatatypeVariant -> Q (Cxt, Type)
    buildTypeInstance EnumClass
    EnumClass 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 -> Type -> [ConstructorInfo] -> [Q Dec]
    enumFunDecs Name
    parentName Type
    instanceType [ConstructorInfo]
    cons)

    -- | Generates a lambda expression which behaves like 'succ' (without
    -- requiring an 'Enum' instance).
    makeSucc :: Name -> Q Exp
    makeSucc :: Name -> Q Exp
    makeSucc = EnumFun -> Name -> Q Exp
    makeEnumFun EnumFun
    Succ

    -- | Generates a lambda expression which behaves like 'pred' (without
    -- requiring an 'Enum' instance).
    makePred :: Name -> Q Exp
    makePred :: Name -> Q Exp
    makePred = EnumFun -> Name -> Q Exp
    makeEnumFun EnumFun
    Pred

    -- | Generates a lambda expression which behaves like 'toEnum' (without
    -- requiring an 'Enum' instance).
    makeToEnum :: Name -> Q Exp
    makeToEnum :: Name -> Q Exp
    makeToEnum = EnumFun -> Name -> Q Exp
    makeEnumFun EnumFun
    ToEnum

    -- | Generates a lambda expression which behaves like 'fromEnum' (without
    -- requiring an 'Enum' instance).
    makeFromEnum :: Name -> Q Exp
    makeFromEnum :: Name -> Q Exp
    makeFromEnum = EnumFun -> Name -> Q Exp
    makeEnumFun EnumFun
    FromEnum

    -- | Generates a lambda expression which behaves like 'enumFrom' (without
    -- requiring an 'Enum' instance).
    makeEnumFrom :: Name -> Q Exp
    makeEnumFrom :: Name -> Q Exp
    makeEnumFrom = EnumFun -> Name -> Q Exp
    makeEnumFun EnumFun
    EnumFrom

    -- | Generates a lambda expression which behaves like 'enumFromThen' (without
    -- requiring an 'Enum' instance).
    makeEnumFromThen :: Name -> Q Exp
    makeEnumFromThen :: Name -> Q Exp
    makeEnumFromThen = EnumFun -> Name -> Q Exp
    makeEnumFun EnumFun
    EnumFromThen

    -- | Generates method declarations for an 'Enum' instance.
    enumFunDecs :: Name -> Type -> [ConstructorInfo] -> [Q Dec]
    enumFunDecs :: Name -> Type -> [ConstructorInfo] -> [Q Dec]
    enumFunDecs tyName :: Name
    tyName ty :: Type
    ty cons :: [ConstructorInfo]
    cons =
        (EnumFun -> Q Dec) -> [EnumFun] -> [Q Dec]
    forall a b. (a -> b) -> [a] -> [b]
    map EnumFun -> Q Dec
    makeFunD [ EnumFun
    Succ
                     , EnumFun
    Pred
                     , EnumFun
    ToEnum
                     , EnumFun
    EnumFrom
                     , EnumFun
    EnumFromThen
                     , EnumFun
    FromEnum
                     ]
      where
        makeFunD :: EnumFun -> Q Dec
        makeFunD :: EnumFun -> Q Dec
    makeFunD ef :: EnumFun
    ef =
          Name -> [ClauseQ] -> Q Dec
    funD (EnumFun -> Name
    enumFunName EnumFun
    ef)
               [ [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
    clause []
                        (Q Exp -> BodyQ
    normalB (Q Exp -> BodyQ) -> Q Exp -> BodyQ
    forall a b. (a -> b) -> a -> b
    $ EnumFun -> Name -> Type -> [ConstructorInfo] -> Q Exp
    makeEnumFunForCons EnumFun
    ef Name
    tyName Type
    ty [ConstructorInfo]
    cons)
                        []
               ]

    -- | Generates a lambda expression which behaves like the EnumFun argument.
    makeEnumFun :: EnumFun -> Name -> Q Exp
    makeEnumFun :: EnumFun -> Name -> Q Exp
    makeEnumFun ef :: EnumFun
    ef name :: 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
          (_, instanceType :: Type
    instanceType) <- EnumClass -> Name -> Cxt -> Cxt -> DatatypeVariant -> Q (Cxt, Type)
    forall a.
    ClassRep a =>
    a -> Name -> Cxt -> Cxt -> DatatypeVariant -> Q (Cxt, Type)
    buildTypeInstance EnumClass
    EnumClass Name
    parentName Cxt
    ctxt Cxt
    instTypes DatatypeVariant
    variant
          EnumFun -> Name -> Type -> [ConstructorInfo] -> Q Exp
    makeEnumFunForCons EnumFun
    ef Name
    parentName Type
    instanceType [ConstructorInfo]
    cons

    -- | Generates a lambda expression for fromEnum/toEnum/etc. for the
    -- given constructors. All constructors must be from the same type.
    makeEnumFunForCons :: EnumFun -> Name -> Type -> [ConstructorInfo] -> Q Exp
    makeEnumFunForCons :: EnumFun -> Name -> Type -> [ConstructorInfo] -> Q Exp
    makeEnumFunForCons _  _      _  [] = Q Exp
    forall a. Q a
    noConstructorsError
    makeEnumFunForCons ef :: EnumFun
    ef tyName :: Name
    tyName ty :: Type
    ty cons :: [ConstructorInfo]
    cons
        | Bool -> Bool
    not (Bool -> Bool) -> Bool -> Bool
    forall a b. (a -> b) -> a -> b
    $ [ConstructorInfo] -> Bool
    isEnumerationType [ConstructorInfo]
    cons
        = String -> Q Exp
    forall a. String -> Q a
    enumerationError String
    tyNameBase
        | Bool
    otherwise = case EnumFun
    ef of
            Succ -> (Name -> Q Exp) -> Q Exp
    lamOneHash ((Name -> Q Exp) -> Q Exp) -> (Name -> Q Exp) -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ \aHash :: Name
    aHash ->
              Q Exp -> Q Exp -> Q Exp -> Q Exp
    condE (Name -> Q Exp
    varE Name
    eqValName Q Exp -> Q Exp -> Q Exp
    `appE` Q Exp
    maxTagExpr Q Exp -> Q Exp -> Q Exp
    `appE`
                       (Name -> Q Exp
    conE Name
    iHashDataName Q Exp -> Q Exp -> Q Exp
    `appE` Name -> Q Exp
    varE Name
    aHash))
                    (String -> String -> String -> Q Exp
    illegalExpr "succ" String
    tyNameBase
                                 "tried to take `succ' of last tag in enumeration")
                    (Q Exp
    tag2Con Q Exp -> Q Exp -> Q Exp
    `appE` (Name -> Q Exp
    varE Name
    plusValName Q Exp -> Q Exp -> Q Exp
    `appE`
                      (Name -> Q Exp
    conE Name
    iHashDataName Q Exp -> Q Exp -> Q Exp
    `appE` Name -> Q Exp
    varE Name
    aHash) Q Exp -> Q Exp -> Q Exp
    `appE` Int -> Q Exp
    integerE 1))

            Pred -> (Name -> Q Exp) -> Q Exp
    lamOneHash ((Name -> Q Exp) -> Q Exp) -> (Name -> Q Exp) -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ \aHash :: Name
    aHash ->
              Q Exp -> Q Exp -> Q Exp -> Q Exp
    condE (Name -> Q Exp
    varE Name
    eqValName Q Exp -> Q Exp -> Q Exp
    `appE` Int -> Q Exp
    integerE 0 Q Exp -> Q Exp -> Q Exp
    `appE`
                       (Name -> Q Exp
    conE Name
    iHashDataName Q Exp -> Q Exp -> Q Exp
    `appE` Name -> Q Exp
    varE Name
    aHash))
                    (String -> String -> String -> Q Exp
    illegalExpr "pred" String
    tyNameBase
                                 "tried to take `pred' of first tag in enumeration")
                    (Q Exp
    tag2Con Q Exp -> Q Exp -> Q Exp
    `appE` (Name -> Q Exp
    varE Name
    plusValName Q Exp -> Q Exp -> Q Exp
    `appE`
                      (Name -> Q Exp
    conE Name
    iHashDataName Q Exp -> Q Exp -> Q Exp
    `appE` Name -> Q Exp
    varE Name
    aHash) Q Exp -> Q Exp -> Q Exp
    `appE` Int -> Q Exp
    integerE (-1)))

            ToEnum -> (Name -> Q Exp) -> Q Exp
    lamOne ((Name -> Q Exp) -> Q Exp) -> (Name -> Q Exp) -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ \a :: Name
    a ->
              Q Exp -> Q Exp -> Q Exp -> Q Exp
    condE ([Q Exp] -> Q Exp
    appsE [ Name -> Q Exp
    varE Name
    andValName
                           , Name -> Q Exp
    varE Name
    geValName Q Exp -> Q Exp -> Q Exp
    `appE` Name -> Q Exp
    varE Name
    a Q Exp -> Q Exp -> Q Exp
    `appE` Int -> Q Exp
    integerE 0
                           , Name -> Q Exp
    varE Name
    leValName Q Exp -> Q Exp -> Q Exp
    `appE` Name -> Q Exp
    varE Name
    a Q Exp -> Q Exp -> Q Exp
    `appE` Q Exp
    maxTagExpr
                           ])
                    (Q Exp
    tag2Con Q Exp -> Q Exp -> Q Exp
    `appE` Name -> Q Exp
    varE Name
    a)
                    (String -> Q Exp -> Name -> Q Exp
    illegalToEnumTag String
    tyNameBase Q Exp
    maxTagExpr Name
    a)

            EnumFrom -> (Name -> Q Exp) -> Q Exp
    lamOneHash ((Name -> Q Exp) -> Q Exp) -> (Name -> Q Exp) -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ \aHash :: Name
    aHash ->
              [Q Exp] -> Q Exp
    appsE [ Name -> Q Exp
    varE Name
    mapValName
                    , Q Exp
    tag2Con
                    , Q Exp -> Q Exp -> Q Exp
    enumFromToExpr (Name -> Q Exp
    conE Name
    iHashDataName Q Exp -> Q Exp -> Q Exp
    `appE` Name -> Q Exp
    varE Name
    aHash) Q Exp
    maxTagExpr
                    ]

            EnumFromThen -> do
              Name
    a     <- String -> Q Name
    newName "a"
              Name
    aHash <- String -> Q Name
    newName "a#"
              Name
    b     <- String -> Q Name
    newName "b"
              Name
    bHash <- String -> Q Name
    newName "b#"
              [PatQ] -> Q Exp -> Q Exp
    lamE [Name -> PatQ
    varP Name
    a, Name -> PatQ
    varP Name
    b] (Q Exp -> Q Exp) -> Q Exp -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ [(Name, Name)] -> Q Exp -> Q Exp
    untagExpr [(Name
    a, Name
    aHash), (Name
    b, Name
    bHash)] (Q Exp -> Q Exp) -> Q Exp -> Q Exp
    forall a b. (a -> b) -> a -> b
    $
                  Q Exp -> Q Exp -> Q Exp
    appE (Name -> Q Exp
    varE Name
    mapValName Q Exp -> Q Exp -> Q Exp
    `appE` Q Exp
    tag2Con) (Q Exp -> Q Exp) -> Q Exp -> Q Exp
    forall a b. (a -> b) -> a -> b
    $
                      Q Exp -> Q Exp -> Q Exp -> Q Exp
    enumFromThenToExpr
                        (Name -> Q Exp
    conE Name
    iHashDataName Q Exp -> Q Exp -> Q Exp
    `appE` Name -> Q Exp
    varE Name
    aHash)
                        (Name -> Q Exp
    conE Name
    iHashDataName Q Exp -> Q Exp -> Q Exp
    `appE` Name -> Q Exp
    varE Name
    bHash)
                        (Q Exp -> Q Exp -> Q Exp -> Q Exp
    condE ([Q Exp] -> Q Exp
    appsE [ Name -> Q Exp
    varE Name
    gtValName
                                      , Name -> Q Exp
    conE Name
    iHashDataName Q Exp -> Q Exp -> Q Exp
    `appE` Name -> Q Exp
    varE Name
    aHash
                                      , Name -> Q Exp
    conE Name
    iHashDataName Q Exp -> Q Exp -> Q Exp
    `appE` Name -> Q Exp
    varE Name
    bHash
                                      ])
                               (Int -> Q Exp
    integerE 0) Q Exp
    maxTagExpr)

            FromEnum -> (Name -> Q Exp) -> Q Exp
    lamOneHash ((Name -> Q Exp) -> Q Exp) -> (Name -> Q Exp) -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ \aHash :: Name
    aHash ->
              Name -> Q Exp
    conE Name
    iHashDataName Q Exp -> Q Exp -> Q Exp
    `appE` Name -> Q Exp
    varE Name
    aHash

      where
        tyNameBase :: String
        tyNameBase :: String
    tyNameBase = Name -> String
    nameBase Name
    tyName

        maxTagExpr :: Q Exp
        maxTagExpr :: Q Exp
    maxTagExpr = Int -> Q Exp
    integerE ([ConstructorInfo] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [ConstructorInfo]
    cons Int -> Int -> Int
    forall a. Num a => a -> a -> a
    - 1) Q Exp -> TypeQ -> Q Exp
    `sigE` Name -> TypeQ
    conT Name
    intTypeName

        lamOne :: (Name -> Q Exp) -> Q Exp
        lamOne :: (Name -> Q Exp) -> Q Exp
    lamOne f :: Name -> Q Exp
    f = do
            Name
    a <- String -> Q Name
    newName "a"
            PatQ -> Q Exp -> Q Exp
    lam1E (Name -> PatQ
    varP Name
    a) (Q Exp -> Q Exp) -> Q Exp -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ Name -> Q Exp
    f Name
    a

        lamOneHash :: (Name -> Q Exp) -> Q Exp
        lamOneHash :: (Name -> Q Exp) -> Q Exp
    lamOneHash f :: Name -> Q Exp
    f = (Name -> Q Exp) -> Q Exp
    lamOne ((Name -> Q Exp) -> Q Exp) -> (Name -> Q Exp) -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ \a :: Name
    a -> do
            Name
    aHash <- String -> Q Name
    newName "a#"
            [(Name, Name)] -> Q Exp -> Q Exp
    untagExpr [(Name
    a, Name
    aHash)] (Q Exp -> Q Exp) -> Q Exp -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ Name -> Q Exp
    f Name
    aHash

        tag2Con :: Q Exp
        tag2Con :: Q Exp
    tag2Con = Type -> Q Exp
    tag2ConExpr (Type -> Q Exp) -> Type -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ Type -> Type
    removeClassApp Type
    ty

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

    -- There's only one Enum variant!
    data EnumClass = EnumClass

    instance ClassRep EnumClass where
        arity :: EnumClass -> Int
    arity _ = 0

        allowExQuant :: EnumClass -> Bool
    allowExQuant _ = Bool
    True

        fullClassName :: EnumClass -> Name
    fullClassName _ = Name
    enumTypeName

        classConstraint :: EnumClass -> Int -> Maybe Name
    classConstraint _ 0 = Name -> Maybe Name
    forall a. a -> Maybe a
    Just (Name -> Maybe Name) -> Name -> Maybe Name
    forall a b. (a -> b) -> a -> b
    $ Name
    enumTypeName
        classConstraint _ _ = Maybe Name
    forall a. Maybe a
    Nothing

    -- | A representation of which function is being generated.
    data EnumFun = Succ
                 | Pred
                 | ToEnum
                 | FromEnum
                 | EnumFrom
                 | EnumFromThen
      deriving Int -> EnumFun -> ShowS
    [EnumFun] -> ShowS
    EnumFun -> String
    (Int -> EnumFun -> ShowS)
    -> (EnumFun -> String) -> ([EnumFun] -> ShowS) -> Show EnumFun
    forall a.
    (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
    showList :: [EnumFun] -> ShowS
    $cshowList :: [EnumFun] -> ShowS
    show :: EnumFun -> String
    $cshow :: EnumFun -> String
    showsPrec :: Int -> EnumFun -> ShowS
    $cshowsPrec :: Int -> EnumFun -> ShowS
    Show

    enumFunName :: EnumFun -> Name
    enumFunName :: EnumFun -> Name
    enumFunName Succ           = Name
    succValName
    enumFunName Pred           = Name
    predValName
    enumFunName ToEnum         = Name
    toEnumValName
    enumFunName FromEnum       = Name
    fromEnumValName
    enumFunName EnumFrom       = Name
    enumFromValName
    enumFunName EnumFromThen   = Name
    enumFromThenValName

    -------------------------------------------------------------------------------
    -- Assorted utilities
    -------------------------------------------------------------------------------

    enumFromThenToExpr :: Q Exp -> Q Exp -> Q Exp -> Q Exp
    enumFromThenToExpr :: Q Exp -> Q Exp -> Q Exp -> Q Exp
    enumFromThenToExpr f :: Q Exp
    f t1 :: Q Exp
    t1 t2 :: Q Exp
    t2 = Name -> Q Exp
    varE Name
    enumFromThenToValName Q Exp -> Q Exp -> Q Exp
    `appE` Q Exp
    f Q Exp -> Q Exp -> Q Exp
    `appE` Q Exp
    t1 Q Exp -> Q Exp -> Q Exp
    `appE` Q Exp
    t2

    illegalExpr :: String -> String -> String -> Q Exp
    illegalExpr :: String -> String -> String -> Q Exp
    illegalExpr meth :: String
    meth tp :: String
    tp msg :: String
    msg =
        Name -> Q Exp
    varE Name
    errorValName Q Exp -> Q Exp -> Q Exp
    `appE` String -> Q Exp
    stringE (String
    meth String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ '{'Char -> ShowS
    forall a. a -> [a] -> [a]
    :String
    tp String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ "}: " String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    msg)

    illegalToEnumTag :: String -> Q Exp -> Name -> Q Exp
    illegalToEnumTag :: String -> Q Exp -> Name -> Q Exp
    illegalToEnumTag tp :: String
    tp maxtag :: Q Exp
    maxtag a :: Name
    a =
        Q Exp -> Q Exp -> Q Exp
    appE (Name -> Q Exp
    varE Name
    errorValName)
             (Q Exp -> Q Exp -> Q Exp
    appE (Q Exp -> Q Exp -> Q Exp
    appE (Name -> Q Exp
    varE Name
    appendValName)
                         (String -> Q Exp
    stringE ("toEnum{" String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ String
    tp String -> ShowS
    forall a. [a] -> [a] -> [a]
    ++ "}: tag(")))
                   (Q Exp -> Q Exp -> Q Exp
    appE (Q Exp -> Q Exp -> Q Exp
    appE (Q Exp -> Q Exp -> Q Exp
    appE
                     (Name -> Q Exp
    varE Name
    showsPrecValName)
                     (Int -> Q Exp
    integerE 0))
                     (Name -> Q Exp
    varE Name
    a))
                     (Q Exp -> Q Exp -> Q Exp
    appE (Q Exp -> Q Exp -> Q Exp
    appE
                       (Name -> Q Exp
    varE Name
    appendValName)
                       (String -> Q Exp
    stringE ") is outside of enumeration's range (0,"))
                       (Q Exp -> Q Exp -> Q Exp
    appE (Q Exp -> Q Exp -> Q Exp
    appE (Q Exp -> Q Exp -> Q Exp
    appE
                             (Name -> Q Exp
    varE Name
    showsPrecValName)
                             (Int -> Q Exp
    integerE 0))
                             Q Exp
    maxtag)
                             (String -> Q Exp
    stringE ")")))))