    {- |
    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 =
               Name -> Q Type
    forall (m :: * -> *). Quote m => Name -> m Type
    promotedT Name
    metaDataDataName
        Q Type -> Q Type -> Q Type
    forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
    `appT` Q TyLit -> Q Type
    forall (m :: * -> *). Quote m => m TyLit -> m Type
    litT (String -> Q TyLit
    forall (m :: * -> *). Quote m => String -> m TyLit
    strTyLit (Name -> String
    nameBase Name
    n))
        Q Type -> Q Type -> Q Type
    forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
    `appT` Q TyLit -> Q Type
    forall (m :: * -> *). Quote m => m TyLit -> m Type
    litT (String -> Q TyLit
    forall (m :: * -> *). Quote m => String -> m TyLit
    strTyLit String
    m)
        Q Type -> Q Type -> Q Type
    forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
    `appT` Q TyLit -> Q Type
    forall (m :: * -> *). Quote m => m TyLit -> m Type
    litT (String -> Q TyLit
    forall (m :: * -> *). Quote m => String -> m TyLit
    strTyLit String
    pkg)
        Q Type -> Q Type -> Q Type
    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   = String -> Maybe String -> String
    forall a. a -> Maybe a -> a
    fromMaybe (String -> String
    forall a. HasCallStack => String -> a
    error String
    "Cannot fetch module name!")  (Name -> Maybe String
    nameModule Name
    n)
        pkg :: String
    pkg = String -> Maybe String -> String
    forall a. a -> Maybe a -> a
    fromMaybe (String -> String
    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
        Name -> Q Type
    forall (m :: * -> *). Quote m => Name -> m Type
    promotedT Name
    metaConsDataName
          Q Type -> Q Type -> Q Type
    forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
    `appT` Q TyLit -> Q Type
    forall (m :: * -> *). Quote m => m TyLit -> m Type
    litT (String -> Q TyLit
    forall (m :: * -> *). Quote m => String -> m TyLit
    strTyLit (Name -> String
    nameBase Name
    n))
          Q Type -> Q Type -> Q Type
    forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
    `appT` Maybe Fixity -> Bool -> Q Type
    fixityIPromotedType Maybe Fixity
    mbFi Bool
    conIsInfix
          Q Type -> Q Type -> Q Type
    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  = Name -> Q Type
    forall (m :: * -> *). Quote m => Name -> m Type
    promotedT Name
    trueDataName
    promoteBool Bool
    False = Name -> Q Type
    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 =
               Name -> Q Type
    forall (m :: * -> *). Quote m => Name -> m Type
    promotedT Name
    infixIDataName
        Q Type -> Q Type -> Q Type
    forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
    `appT` FixityDirection -> Q Type
    promoteAssociativity FixityDirection
    a
        Q Type -> Q Type -> Q Type
    forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
    `appT` Q TyLit -> Q Type
    forall (m :: * -> *). Quote m => m TyLit -> m Type
    litT (Integer -> Q TyLit
    forall (m :: * -> *). Quote m => Integer -> m TyLit
    numTyLit (Int -> Integer
    forall a. Integral a => a -> Integer
    toInteger Int
    n))
      where
        Fixity Int
    n FixityDirection
    a = Fixity -> Maybe Fixity -> Fixity
    forall a. a -> Maybe a -> a
    fromMaybe Fixity
    defaultFixity Maybe Fixity
    mbFi
    fixityIPromotedType Maybe Fixity
    _ Bool
    False = Name -> Q Type
    forall (m :: * -> *). Quote m => Name -> m Type
    promotedT Name
    prefixIDataName

    promoteAssociativity :: FixityDirection -> Q Type
    promoteAssociativity :: FixityDirection -> Q Type
    promoteAssociativity FixityDirection
    InfixL = Name -> Q Type
    forall (m :: * -> *). Quote m => Name -> m Type
    promotedT Name
    leftAssociativeDataName
    promoteAssociativity FixityDirection
    InfixR = Name -> Q Type
    forall (m :: * -> *). Quote m => Name -> m Type
    promotedT Name
    rightAssociativeDataName
    promoteAssociativity FixityDirection
    InfixN = Name -> Q Type
    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  -> Name -> Q Type
    forall (m :: * -> *). Quote m => Name -> m Type
    promotedT Name
    justDataName Q Type -> Q Type -> Q Type
    forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
    `appT` Q TyLit -> Q Type
    forall (m :: * -> *). Quote m => m TyLit -> m Type
    litT (String -> Q TyLit
    forall (m :: * -> *). Quote m => String -> m TyLit
    strTyLit (Name -> String
    nameBase Name
    f))
                Maybe Name
    Nothing -> Name -> Q Type
    forall (m :: * -> *). Quote m => Name -> m Type
    promotedT Name
    nothingDataName
        in Name -> Q Type
    forall (m :: * -> *). Quote m => Name -> m Type
    promotedT Name
    metaSelDataName
            Q Type -> Q Type -> Q Type
    forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
    `appT` Q Type
    mbSelNameT
            Q Type -> Q Type -> Q Type
    forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
    `appT` Unpackedness -> Q Type
    promoteUnpackedness Unpackedness
    su
            Q Type -> Q Type -> Q Type
    forall (m :: * -> *). Quote m => m Type -> m Type -> m Type
    `appT` Strictness -> Q Type
    promoteStrictness Strictness
    ss
            Q Type -> Q Type -> Q Type
    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 = Name -> Q Type
    forall (m :: * -> *). Quote m => Name -> m Type
    promotedT Name
    noSourceUnpackednessDataName
    promoteUnpackedness Unpackedness
    NoUnpack                = Name -> Q Type
    forall (m :: * -> *). Quote m => Name -> m Type
    promotedT Name
    sourceNoUnpackDataName
    promoteUnpackedness Unpackedness
    Unpack                  = Name -> Q Type
    forall (m :: * -> *). Quote m => Name -> m Type
    promotedT Name
    sourceUnpackDataName

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

    promoteDecidedStrictness :: DecidedStrictness -> Q Type
    promoteDecidedStrictness :: DecidedStrictness -> Q Type
    promoteDecidedStrictness DecidedStrictness
    DecidedLazy   = Name -> Q Type
    forall (m :: * -> *). Quote m => Name -> m Type
    promotedT Name
    decidedLazyDataName
    promoteDecidedStrictness DecidedStrictness
    DecidedStrict = Name -> Q Type
    forall (m :: * -> *). Quote m => Name -> m Type
    promotedT Name
    decidedStrictDataName
    promoteDecidedStrictness DecidedStrictness
    DecidedUnpack = Name -> Q Type
    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 = (FieldStrictness -> Unpackedness)
    -> [FieldStrictness] -> [Unpackedness]
    forall a b. (a -> b) -> [a] -> [b]
    map FieldStrictness -> Unpackedness
    fieldUnpackedness [FieldStrictness]
    fs
            srcStrs :: [Strictness]
    srcStrs  = (FieldStrictness -> Strictness)
    -> [FieldStrictness] -> [Strictness]
    forall a b. (a -> b) -> [a] -> [b]
    map FieldStrictness -> Strictness
    fieldStrictness   [FieldStrictness]
    fs
        [SelStrictInfo] -> Q [SelStrictInfo]
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([SelStrictInfo] -> Q [SelStrictInfo])
    -> [SelStrictInfo] -> Q [SelStrictInfo]
    forall a b. (a -> b) -> a -> b
    $ (Unpackedness -> Strictness -> DecidedStrictness -> SelStrictInfo)
    -> [Unpackedness]
    -> [Strictness]
    -> [DecidedStrictness]
    -> [SelStrictInfo]
    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
    _ = [Dec] -> Q [Dec]
    forall a. a -> Q a
    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
    _ = [Dec] -> Q [Dec]
    forall a. a -> Q a
    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
    _ = [Dec] -> Q [Dec]
    forall a. a -> Q a
    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
    _ = [Dec] -> Q [Dec]
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return []