{-|
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 ")")))))