{- |
Module      :  Generics.Deriving.TH.Post4_9
Copyright   :  (c) 2008--2009 Universiteit Utrecht
License     :  BSD3

Maintainer  :  generics@haskell.org
Stability   :  experimental
Portability :  non-portable

Template Haskell machinery for the type-literal-based variant of GHC
generics introduced in @base-4.9@.
-}

module Generics.Deriving.TH.Post4_9 (
      deriveMeta
    , deriveData
    , deriveConstructors
    , deriveSelectors
    , mkMetaDataType
    , mkMetaConsType
    , mkMetaSelType
    , SelStrictInfo(..)
    , reifySelStrictInfo
  ) where

import Data.Maybe (fromMaybe)

import Generics.Deriving.TH.Internal

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

mkMetaDataType :: DatatypeVariant_ -> Name -> Q Type
mkMetaDataType :: DatatypeVariant_ -> Name -> Q Type
mkMetaDataType DatatypeVariant_
dv Name
n =
           forall (m :: * -> *). Quote m => Name -> m Type
promotedT Name
metaDataDataName
    forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` forall (m :: * -> *). Quote m => m TyLit -> m Type
litT (forall (m :: * -> *). Quote m => String -> m TyLit
strTyLit (Name -> String
nameBase Name
n))
    forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` forall (m :: * -> *). Quote m => m TyLit -> m Type
litT (forall (m :: * -> *). Quote m => String -> m TyLit
strTyLit String
m)
    forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` forall (m :: * -> *). Quote m => m TyLit -> m Type
litT (forall (m :: * -> *). Quote m => String -> m TyLit
strTyLit String
pkg)
    forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Bool -> Q Type
promoteBool (DatatypeVariant_ -> Bool
isNewtypeVariant DatatypeVariant_
dv)
  where
    m, pkg :: String
    m :: String
m   = forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => String -> a
error String
"Cannot fetch module name!")  (Name -> Maybe String
nameModule Name
n)
    pkg :: String
pkg = forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => String -> a
error String
"Cannot fetch package name!") (Name -> Maybe String
namePackage Name
n)

mkMetaConsType :: DatatypeVariant_ -> Name -> Name -> Bool -> Bool -> Q Type
mkMetaConsType :: DatatypeVariant_ -> Name -> Name -> Bool -> Bool -> Q Type
mkMetaConsType DatatypeVariant_
_ Name
_ Name
n Bool
conIsRecord Bool
conIsInfix = do
    Maybe Fixity
mbFi <- Name -> Q (Maybe Fixity)
reifyFixity Name
n
    forall (m :: * -> *). Quote m => Name -> m Type
promotedT Name
metaConsDataName
      forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` forall (m :: * -> *). Quote m => m TyLit -> m Type
litT (forall (m :: * -> *). Quote m => String -> m TyLit
strTyLit (Name -> String
nameBase Name
n))
      forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Maybe Fixity -> Bool -> Q Type
fixityIPromotedType Maybe Fixity
mbFi Bool
conIsInfix
      forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Bool -> Q Type
promoteBool Bool
conIsRecord

promoteBool :: Bool -> Q Type
promoteBool :: Bool -> Q Type
promoteBool Bool
True  = forall (m :: * -> *). Quote m => Name -> m Type
promotedT Name
trueDataName
promoteBool Bool
False = forall (m :: * -> *). Quote m => Name -> m Type
promotedT Name
falseDataName

fixityIPromotedType :: Maybe Fixity -> Bool -> Q Type
fixityIPromotedType :: Maybe Fixity -> Bool -> Q Type
fixityIPromotedType Maybe Fixity
mbFi Bool
True =
           forall (m :: * -> *). Quote m => Name -> m Type
promotedT Name
infixIDataName
    forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` FixityDirection -> Q Type
promoteAssociativity FixityDirection
a
    forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` forall (m :: * -> *). Quote m => m TyLit -> m Type
litT (forall (m :: * -> *). Quote m => Integer -> m TyLit
numTyLit (forall a. Integral a => a -> Integer
toInteger Int
n))
  where
    Fixity Int
n FixityDirection
a = forall a. a -> Maybe a -> a
fromMaybe Fixity
defaultFixity Maybe Fixity
mbFi
fixityIPromotedType Maybe Fixity
_ Bool
False = forall (m :: * -> *). Quote m => Name -> m Type
promotedT Name
prefixIDataName

promoteAssociativity :: FixityDirection -> Q Type
promoteAssociativity :: FixityDirection -> Q Type
promoteAssociativity FixityDirection
InfixL = forall (m :: * -> *). Quote m => Name -> m Type
promotedT Name
leftAssociativeDataName
promoteAssociativity FixityDirection
InfixR = forall (m :: * -> *). Quote m => Name -> m Type
promotedT Name
rightAssociativeDataName
promoteAssociativity FixityDirection
InfixN = forall (m :: * -> *). Quote m => Name -> m Type
promotedT Name
notAssociativeDataName

mkMetaSelType :: DatatypeVariant_ -> Name -> Name -> Maybe Name
              -> SelStrictInfo -> Q Type
mkMetaSelType :: DatatypeVariant_
-> Name -> Name -> Maybe Name -> SelStrictInfo -> Q Type
mkMetaSelType DatatypeVariant_
_ Name
_ Name
_ Maybe Name
mbF (SelStrictInfo Unpackedness
su Strictness
ss DecidedStrictness
ds) =
    let mbSelNameT :: Q Type
mbSelNameT = case Maybe Name
mbF of
            Just Name
f  -> forall (m :: * -> *). Quote m => Name -> m Type
promotedT Name
justDataName forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` forall (m :: * -> *). Quote m => m TyLit -> m Type
litT (forall (m :: * -> *). Quote m => String -> m TyLit
strTyLit (Name -> String
nameBase Name
f))
            Maybe Name
Nothing -> forall (m :: * -> *). Quote m => Name -> m Type
promotedT Name
nothingDataName
    in forall (m :: * -> *). Quote m => Name -> m Type
promotedT Name
metaSelDataName
        forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Q Type
mbSelNameT
        forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Unpackedness -> Q Type
promoteUnpackedness Unpackedness
su
        forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` Strictness -> Q Type
promoteStrictness Strictness
ss
        forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
`appT` DecidedStrictness -> Q Type
promoteDecidedStrictness DecidedStrictness
ds

data SelStrictInfo = SelStrictInfo Unpackedness Strictness DecidedStrictness

promoteUnpackedness :: Unpackedness -> Q Type
promoteUnpackedness :: Unpackedness -> Q Type
promoteUnpackedness Unpackedness
UnspecifiedUnpackedness = forall (m :: * -> *). Quote m => Name -> m Type
promotedT Name
noSourceUnpackednessDataName
promoteUnpackedness Unpackedness
NoUnpack                = forall (m :: * -> *). Quote m => Name -> m Type
promotedT Name
sourceNoUnpackDataName
promoteUnpackedness Unpackedness
Unpack                  = forall (m :: * -> *). Quote m => Name -> m Type
promotedT Name
sourceUnpackDataName

promoteStrictness :: Strictness -> Q Type
promoteStrictness :: Strictness -> Q Type
promoteStrictness Strictness
UnspecifiedStrictness = forall (m :: * -> *). Quote m => Name -> m Type
promotedT Name
noSourceStrictnessDataName
promoteStrictness Strictness
Lazy                  = forall (m :: * -> *). Quote m => Name -> m Type
promotedT Name
sourceLazyDataName
promoteStrictness Strictness
THAbs.Strict          = forall (m :: * -> *). Quote m => Name -> m Type
promotedT Name
sourceStrictDataName

promoteDecidedStrictness :: DecidedStrictness -> Q Type
promoteDecidedStrictness :: DecidedStrictness -> Q Type
promoteDecidedStrictness DecidedStrictness
DecidedLazy   = forall (m :: * -> *). Quote m => Name -> m Type
promotedT Name
decidedLazyDataName
promoteDecidedStrictness DecidedStrictness
DecidedStrict = forall (m :: * -> *). Quote m => Name -> m Type
promotedT Name
decidedStrictDataName
promoteDecidedStrictness DecidedStrictness
DecidedUnpack = forall (m :: * -> *). Quote m => Name -> m Type
promotedT Name
decidedUnpackDataName

reifySelStrictInfo :: Name -> [FieldStrictness] -> Q [SelStrictInfo]
reifySelStrictInfo :: Name -> [FieldStrictness] -> Q [SelStrictInfo]
reifySelStrictInfo Name
conName [FieldStrictness]
fs = do
    [DecidedStrictness]
dcdStrs <- Name -> Q [DecidedStrictness]
reifyConStrictness Name
conName
    let srcUnpks :: [Unpackedness]
srcUnpks = forall a b. (a -> b) -> [a] -> [b]
map FieldStrictness -> Unpackedness
fieldUnpackedness [FieldStrictness]
fs
        srcStrs :: [Strictness]
srcStrs  = forall a b. (a -> b) -> [a] -> [b]
map FieldStrictness -> Strictness
fieldStrictness   [FieldStrictness]
fs
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 Unpackedness -> Strictness -> DecidedStrictness -> SelStrictInfo
SelStrictInfo [Unpackedness]
srcUnpks [Strictness]
srcStrs [DecidedStrictness]
dcdStrs

-- | Given the type and the name (as string) for the type to derive,
-- generate the 'Data' instance, the 'Constructor' instances, and the 'Selector'
-- instances.
--
-- On GHC 7.11 and up, this functionality is no longer used in GHC generics,
-- so this function generates no declarations.
deriveMeta :: Name -> Q [Dec]
deriveMeta :: Name -> Q [Dec]
deriveMeta Name
_ = forall (m :: * -> *) a. Monad m => a -> m a
return []

-- | Given a datatype name, derive a datatype and instance of class 'Datatype'.
--
-- On GHC 7.11 and up, this functionality is no longer used in GHC generics,
-- so this function generates no declarations.
deriveData :: Name -> Q [Dec]
deriveData :: Name -> Q [Dec]
deriveData Name
_ = forall (m :: * -> *) a. Monad m => a -> m a
return []

-- | Given a datatype name, derive datatypes and
-- instances of class 'Constructor'.
--
-- On GHC 7.11 and up, this functionality is no longer used in GHC generics,
-- so this function generates no declarations.
deriveConstructors :: Name -> Q [Dec]
deriveConstructors :: Name -> Q [Dec]
deriveConstructors Name
_ = forall (m :: * -> *) a. Monad m => a -> m a
return []

-- | Given a datatype name, derive datatypes and instances of class 'Selector'.
--
-- On GHC 7.11 and up, this functionality is no longer used in GHC generics,
-- so this function generates no declarations.
deriveSelectors :: Name -> Q [Dec]
deriveSelectors :: Name -> Q [Dec]
deriveSelectors Name
_ = forall (m :: * -> *) a. Monad m => a -> m a
return []