{- |
Module      :  Generics.Linear.TH.MetaData
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@.
-}

{-# LANGUAGE TemplateHaskellQuotes #-}

module Generics.Linear.TH.MetaData (
      mkMetaDataType
    , mkMetaConsType
    , mkMetaSelType
    , SelStrictInfo(..)
    , reifySelStrictInfo
  ) where

import Data.Maybe (fromMaybe)

import Generics.Linear.TH.Internal

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

-- For splices

import qualified Generics.Linear.Class as G

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 'G.MetaData
    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 'G.MetaCons
      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 'True
promoteBool Bool
False = Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
promotedT 'False

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 'G.InfixI
    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 'G.PrefixI

promoteAssociativity :: FixityDirection -> Q Type
promoteAssociativity :: FixityDirection -> Q Type
promoteAssociativity FixityDirection
InfixL = Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
promotedT 'G.LeftAssociative
promoteAssociativity FixityDirection
InfixR = Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
promotedT 'G.RightAssociative
promoteAssociativity FixityDirection
InfixN = Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
promotedT 'G.NotAssociative

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 'Just 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 'Nothing
    in Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
promotedT 'G.MetaSel
        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 'G.NoSourceUnpackedness
promoteUnpackedness Unpackedness
NoUnpack                = Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
promotedT 'G.SourceNoUnpack
promoteUnpackedness Unpackedness
Unpack                  = Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
promotedT 'G.SourceUnpack

promoteStrictness :: Strictness -> Q Type
promoteStrictness :: Strictness -> Q Type
promoteStrictness Strictness
UnspecifiedStrictness = Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
promotedT 'G.NoSourceStrictness
promoteStrictness Strictness
Lazy                  = Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
promotedT 'G.SourceLazy
promoteStrictness Strictness
THAbs.Strict          = Name -> Q Type
forall (m :: * -> *). Quote m => Name -> m Type
promotedT 'G.SourceStrict

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

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