{- |
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.Lib
import Language.Haskell.TH.Syntax

mkMetaDataType :: DataVariety -> Name -> Bool -> Q Type
mkMetaDataType _ n isNewtype =
           promotedT metaDataDataName
    `appT` litT (strTyLit (nameBase n))
    `appT` litT (strTyLit m)
    `appT` litT (strTyLit pkg)
    `appT` promoteBool isNewtype
  where
    m, pkg :: String
    m   = fromMaybe (error "Cannot fetch module name!")  (nameModule n)
    pkg = fromMaybe (error "Cannot fetch package name!") (namePackage n)

mkMetaConsType :: DataVariety -> Name -> Name -> Bool -> Bool -> Q Type
mkMetaConsType _ _ n conIsRecord conIsInfix = do
    mbFi <- reifyFixity n
    promotedT metaConsDataName
      `appT` litT (strTyLit (nameBase n))
      `appT` fixityIPromotedType mbFi conIsInfix
      `appT` promoteBool conIsRecord

promoteBool :: Bool -> Q Type
promoteBool True  = promotedT trueDataName
promoteBool False = promotedT falseDataName

fixityIPromotedType :: Maybe Fixity -> Bool -> Q Type
fixityIPromotedType mbFi True =
           promotedT infixIDataName
    `appT` promoteAssociativity a
    `appT` litT (numTyLit (toInteger n))
  where
    Fixity n a = fromMaybe defaultFixity mbFi
fixityIPromotedType _ False = promotedT prefixIDataName

promoteAssociativity :: FixityDirection -> Q Type
promoteAssociativity InfixL = promotedT leftAssociativeDataName
promoteAssociativity InfixR = promotedT rightAssociativeDataName
promoteAssociativity InfixN = promotedT notAssociativeDataName

mkMetaSelType :: DataVariety -> Name -> Name -> Maybe Name -> SelStrictInfo -> Q Type
mkMetaSelType _ _ _ mbF (SelStrictInfo su ss ds) =
    let mbSelNameT = case mbF of
            Just f  -> promotedT justDataName `appT` litT (strTyLit (nameBase f))
            Nothing -> promotedT nothingDataName
    in promotedT metaSelDataName
        `appT` mbSelNameT
        `appT` promoteSourceUnpackedness su
        `appT` promoteSourceStrictness ss
        `appT` promoteDecidedStrictness ds

data SelStrictInfo = SelStrictInfo SourceUnpackedness SourceStrictness DecidedStrictness

promoteSourceUnpackedness :: SourceUnpackedness -> Q Type
promoteSourceUnpackedness NoSourceUnpackedness = promotedT noSourceUnpackednessDataName
promoteSourceUnpackedness SourceNoUnpack       = promotedT sourceNoUnpackDataName
promoteSourceUnpackedness SourceUnpack         = promotedT sourceUnpackDataName

promoteSourceStrictness :: SourceStrictness -> Q Type
promoteSourceStrictness NoSourceStrictness = promotedT noSourceStrictnessDataName
promoteSourceStrictness SourceLazy         = promotedT sourceLazyDataName
promoteSourceStrictness SourceStrict       = promotedT sourceStrictDataName

promoteDecidedStrictness :: DecidedStrictness -> Q Type
promoteDecidedStrictness DecidedLazy   = promotedT decidedLazyDataName
promoteDecidedStrictness DecidedStrict = promotedT decidedStrictDataName
promoteDecidedStrictness DecidedUnpack = promotedT decidedUnpackDataName

reifySelStrictInfo :: Name -> [Bang] -> Q [SelStrictInfo]
reifySelStrictInfo conName bangs = do
    dcdStrs <- reifyConStrictness conName
    let (srcUnpks, srcStrs) = unzip $ map splitBang bangs
    return $ zipWith3 SelStrictInfo srcUnpks srcStrs dcdStrs

splitBang :: Bang -> (SourceUnpackedness, SourceStrictness)
splitBang (Bang su ss) = (su, ss)

-- | 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 _ = 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 _ = 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 _ = 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 _ = return []