{-|
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 = 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)
          <- forall a.
ClassRep a =>
a -> Name -> Cxt -> Cxt -> DatatypeVariant -> Q (Cxt, Type)
buildTypeInstance EnumClass
EnumClass Name
parentName Cxt
ctxt Cxt
instTypes DatatypeVariant
variant
      (forall a. a -> [a] -> [a]
:[]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` forall (m :: * -> *).
Quote m =>
m Cxt -> m Type -> [m Dec] -> m Dec
instanceD (forall (m :: * -> *) a. Monad m => a -> m a
return Cxt
instanceCxt)
                             (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 Name
tyName Type
ty [ConstructorInfo]
cons =
    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 EnumFun
ef =
      forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
funD (EnumFun -> Name
enumFunName EnumFun
ef)
           [ forall (m :: * -> *).
Quote m =>
[m Pat] -> m Body -> [m Dec] -> m Clause
clause []
                    (forall (m :: * -> *). Quote m => m Exp -> m Body
normalB 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 EnumFun
ef 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
_, Type
instanceType) <- 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 EnumFun
_  Name
_      Type
_  [] = forall a. Q a
noConstructorsError
makeEnumFunForCons EnumFun
ef Name
tyName Type
ty [ConstructorInfo]
cons
    | Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ [ConstructorInfo] -> Bool
isEnumerationType [ConstructorInfo]
cons
    = forall a. String -> Q a
enumerationError String
tyNameBase
    | Bool
otherwise = case EnumFun
ef of
        EnumFun
Succ -> (Name -> Q Exp) -> Q Exp
lamOneHash forall a b. (a -> b) -> a -> b
$ \Name
aHash ->
          forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp -> m Exp
condE (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
eqValName forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
maxTagExpr forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE`
                   (forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
iHashDataName forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
aHash))
                (String -> String -> String -> Q Exp
illegalExpr String
"succ" String
tyNameBase
                             String
"tried to take `succ' of last tag in enumeration")
                (Q Exp
tag2Con forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` (forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
plusValName forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE`
                  (forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
iHashDataName forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
aHash) forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Int -> Q Exp
integerE Int
1))

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

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

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

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

        EnumFun
FromEnum -> (Name -> Q Exp) -> Q Exp
lamOneHash forall a b. (a -> b) -> a -> b
$ \Name
aHash ->
          forall (m :: * -> *). Quote m => Name -> m Exp
conE Name
iHashDataName forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` forall (m :: * -> *). Quote m => Name -> m 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 (forall (t :: * -> *) a. Foldable t => t a -> Int
length [ConstructorInfo]
cons forall a. Num a => a -> a -> a
- Int
1) forall (m :: * -> *). Quote m => m Exp -> m Type -> m Exp
`sigE` forall (m :: * -> *). Quote m => Name -> m Type
conT Name
intTypeName

    lamOne :: (Name -> Q Exp) -> Q Exp
    lamOne :: (Name -> Q Exp) -> Q Exp
lamOne Name -> Q Exp
f = do
        Name
a <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"a"
        forall (m :: * -> *). Quote m => m Pat -> m Exp -> m Exp
lam1E (forall (m :: * -> *). Quote m => Name -> m Pat
varP Name
a) 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 Name -> Q Exp
f = (Name -> Q Exp) -> Q Exp
lamOne forall a b. (a -> b) -> a -> b
$ \Name
a -> do
        Name
aHash <- forall (m :: * -> *). Quote m => String -> m Name
newName String
"a#"
        [(Name, Name)] -> Q Exp -> Q Exp
untagExpr [(Name
a, Name
aHash)] forall a b. (a -> b) -> a -> b
$ Name -> Q Exp
f Name
aHash

    tag2Con :: Q Exp
    tag2Con :: Q Exp
tag2Con = Type -> Q Exp
tag2ConExpr 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 EnumClass
_ = Int
0

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

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

    classConstraint :: EnumClass -> Int -> Maybe Name
classConstraint EnumClass
_ Int
0 = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Name
enumTypeName
    classConstraint EnumClass
_ Int
_ = 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
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 EnumFun
Succ           = Name
succValName
enumFunName EnumFun
Pred           = Name
predValName
enumFunName EnumFun
ToEnum         = Name
toEnumValName
enumFunName EnumFun
FromEnum       = Name
fromEnumValName
enumFunName EnumFun
EnumFrom       = Name
enumFromValName
enumFunName EnumFun
EnumFromThen   = Name
enumFromThenValName

-------------------------------------------------------------------------------

-- Assorted utilities

-------------------------------------------------------------------------------


enumFromThenToExpr :: Q Exp -> Q Exp -> Q Exp -> Q Exp
enumFromThenToExpr :: Q Exp -> Q Exp -> Q Exp -> Q Exp
enumFromThenToExpr Q Exp
f Q Exp
t1 Q Exp
t2 = forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
enumFromThenToValName forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
f forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
t1 forall (m :: * -> *). Quote m => m Exp -> m Exp -> m Exp
`appE` Q Exp
t2

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

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