{-# LANGUAGE TemplateHaskell #-}
-- | Generate @generics-sop@ boilerplate instances using Template Haskell.
module Generics.SOP.TH
  ( deriveGeneric
  , deriveGenericOnly
  , deriveGenericSubst
  , deriveGenericOnlySubst
  , deriveGenericFunctions
  , deriveMetadataValue
  , deriveMetadataType
  ) where

import Control.Monad (join, replicateM)
import Data.List (foldl')
import Data.Maybe (fromMaybe)
import Data.Proxy
import Language.Haskell.TH
import Language.Haskell.TH.Syntax

import Generics.SOP.BasicFunctors
import qualified Generics.SOP.Metadata as SOP
import qualified Generics.SOP.Type.Metadata as SOP.T
import Generics.SOP.NP
import Generics.SOP.NS
import Generics.SOP.Universe

-- | Generate @generics-sop@ boilerplate for the given datatype.
--
-- This function takes the name of a datatype and generates:
--
--   * a 'Code' instance
--   * a 'Generic' instance
--   * a 'HasDatatypeInfo' instance
--
-- Note that the generated code will require the @TypeFamilies@ and
-- @DataKinds@ extensions to be enabled for the module.
--
-- /Example:/ If you have the datatype
--
-- > data Tree = Leaf Int | Node Tree Tree
--
-- and say
--
-- > deriveGeneric ''Tree
--
-- then you get code that is equivalent to:
--
-- > instance Generic Tree where
-- >
-- >   type Code Tree = '[ '[Int], '[Tree, Tree] ]
-- >
-- >   from (Leaf x)   = SOP (   Z (I x :* Nil))
-- >   from (Node l r) = SOP (S (Z (I l :* I r :* Nil)))
-- >
-- >   to (SOP    (Z (I x :* Nil)))         = Leaf x
-- >   to (SOP (S (Z (I l :* I r :* Nil)))) = Node l r
-- >   to (SOP (S (S x)))                   = x `seq` error "inaccessible"
-- >
-- > instance HasDatatypeInfo Tree where
-- >   type DatatypeInfoOf Tree =
-- >     T.ADT "Main" "Tree"
-- >       '[ T.Constructor "Leaf", T.Constructor "Node" ]
-- >
-- >   datatypeInfo _ =
-- >     T.demoteDatatypeInfo (Proxy :: Proxy (DatatypeInfoOf Tree))
--
-- /Limitations:/ Generation does not work for GADTs, for
-- datatypes that involve existential quantification, for
-- datatypes with unboxed fields.
--
deriveGeneric :: Name -> Q [Dec]
deriveGeneric :: Name -> Q [Dec]
deriveGeneric n :: Name
n =
  Name -> (Name -> Q Type) -> Q [Dec]
deriveGenericSubst Name
n Name -> Q Type
varT

-- | Like 'deriveGeneric', but omit the 'HasDatatypeInfo' instance.
deriveGenericOnly :: Name -> Q [Dec]
deriveGenericOnly :: Name -> Q [Dec]
deriveGenericOnly n :: Name
n =
  Name -> (Name -> Q Type) -> Q [Dec]
deriveGenericOnlySubst Name
n Name -> Q Type
varT

-- | Variant of 'deriveGeneric' that allows to restrict the type parameters.
--
-- Experimental function, exposed primarily for benchmarking.
--
deriveGenericSubst :: Name -> (Name -> Q Type) -> Q [Dec]
deriveGenericSubst :: Name -> (Name -> Q Type) -> Q [Dec]
deriveGenericSubst n :: Name
n f :: Name -> Q Type
f = do
  Dec
dec <- Name -> Q Dec
reifyDec Name
n
  [Dec]
ds1 <- Dec
-> (Bool
    -> Cxt -> Name -> [TyVarBndr] -> [Con] -> Derivings -> Q [Dec])
-> Q [Dec]
forall a.
Dec
-> (Bool
    -> Cxt -> Name -> [TyVarBndr] -> [Con] -> Derivings -> Q a)
-> Q a
withDataDec Dec
dec ((Name -> Q Type)
-> Bool
-> Cxt
-> Name
-> [TyVarBndr]
-> [Con]
-> Derivings
-> Q [Dec]
deriveGenericForDataDec  Name -> Q Type
f)
  [Dec]
ds2 <- Dec
-> (Bool
    -> Cxt -> Name -> [TyVarBndr] -> [Con] -> Derivings -> Q [Dec])
-> Q [Dec]
forall a.
Dec
-> (Bool
    -> Cxt -> Name -> [TyVarBndr] -> [Con] -> Derivings -> Q a)
-> Q a
withDataDec Dec
dec ((Name -> Q Type)
-> Bool
-> Cxt
-> Name
-> [TyVarBndr]
-> [Con]
-> Derivings
-> Q [Dec]
deriveMetadataForDataDec Name -> Q Type
f)
  [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Dec]
ds1 [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
ds2)

-- | Variant of 'deriveGenericOnly' that allows to restrict the type parameters.
--
-- Experimental function, exposed primarily for benchmarking.
--
deriveGenericOnlySubst :: Name -> (Name -> Q Type) -> Q [Dec]
deriveGenericOnlySubst :: Name -> (Name -> Q Type) -> Q [Dec]
deriveGenericOnlySubst n :: Name
n f :: Name -> Q Type
f = do
  Dec
dec <- Name -> Q Dec
reifyDec Name
n
  Dec
-> (Bool
    -> Cxt -> Name -> [TyVarBndr] -> [Con] -> Derivings -> Q [Dec])
-> Q [Dec]
forall a.
Dec
-> (Bool
    -> Cxt -> Name -> [TyVarBndr] -> [Con] -> Derivings -> Q a)
-> Q a
withDataDec Dec
dec ((Name -> Q Type)
-> Bool
-> Cxt
-> Name
-> [TyVarBndr]
-> [Con]
-> Derivings
-> Q [Dec]
deriveGenericForDataDec Name -> Q Type
f)

-- | Like 'deriveGenericOnly', but don't derive class instance, only functions.
--
-- /Example:/ If you say
--
-- > deriveGenericFunctions ''Tree "TreeCode" "fromTree" "toTree"
--
-- then you get code that is equivalent to:
--
-- > type TreeCode = '[ '[Int], '[Tree, Tree] ]
-- >
-- > fromTree :: Tree -> SOP I TreeCode
-- > fromTree (Leaf x)   = SOP (   Z (I x :* Nil))
-- > fromTree (Node l r) = SOP (S (Z (I l :* I r :* Nil)))
-- >
-- > toTree :: SOP I TreeCode -> Tree
-- > toTree (SOP    (Z (I x :* Nil)))         = Leaf x
-- > toTree (SOP (S (Z (I l :* I r :* Nil)))) = Node l r
-- > toTree (SOP (S (S x)))                   = x `seq` error "inaccessible"
--
-- @since 0.2
--
deriveGenericFunctions :: Name -> String -> String -> String -> Q [Dec]
deriveGenericFunctions :: Name -> String -> String -> String -> Q [Dec]
deriveGenericFunctions n :: Name
n codeName :: String
codeName fromName :: String
fromName toName :: String
toName = do
  let codeName' :: Name
codeName' = String -> Name
mkName String
codeName
  let fromName' :: Name
fromName' = String -> Name
mkName String
fromName
  let toName' :: Name
toName'   = String -> Name
mkName String
toName
  Dec
dec <- Name -> Q Dec
reifyDec Name
n
  Dec
-> (Bool
    -> Cxt -> Name -> [TyVarBndr] -> [Con] -> Derivings -> Q [Dec])
-> Q [Dec]
forall a.
Dec
-> (Bool
    -> Cxt -> Name -> [TyVarBndr] -> [Con] -> Derivings -> Q a)
-> Q a
withDataDec Dec
dec ((Bool
  -> Cxt -> Name -> [TyVarBndr] -> [Con] -> Derivings -> Q [Dec])
 -> Q [Dec])
-> (Bool
    -> Cxt -> Name -> [TyVarBndr] -> [Con] -> Derivings -> Q [Dec])
-> Q [Dec]
forall a b. (a -> b) -> a -> b
$ \_isNewtype :: Bool
_isNewtype _cxt :: Cxt
_cxt name :: Name
name bndrs :: [TyVarBndr]
bndrs cons :: [Con]
cons _derivs :: Derivings
_derivs -> do
    let codeType :: Q Type
codeType = (Name -> Q Type) -> [Con] -> Q Type
codeFor Name -> Q Type
varT [Con]
cons                     -- '[ '[Int], '[Tree, Tree] ]
    let origType :: Q Type
origType = (Name -> Q Type) -> Name -> [TyVarBndr] -> Q Type
appTyVars Name -> Q Type
varT Name
name [TyVarBndr]
bndrs             -- Tree
    let repType :: Q Type
repType  = [t| SOP I $(appTyVars varT codeName' bndrs) |] -- SOP I TreeCode
    [Q Dec] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
      [ Name -> [TyVarBndr] -> Q Type -> Q Dec
tySynD Name
codeName' [TyVarBndr]
bndrs Q Type
codeType                 -- type TreeCode = '[ '[Int], '[Tree, Tree] ]
      , Name -> Q Type -> Q Dec
sigD Name
fromName' [t| $origType -> $repType |]     -- fromTree :: Tree -> SOP I TreeCode
      , Name -> [Con] -> Q Dec
embedding Name
fromName' [Con]
cons                        -- fromTree ... =
      , Name -> Q Type -> Q Dec
sigD Name
toName' [t| $repType -> $origType |]       -- toTree :: SOP I TreeCode -> Tree
      , Name -> [Con] -> Q Dec
projection Name
toName' [Con]
cons                         -- toTree ... =
      ]

-- | Derive @DatatypeInfo@ value for the type.
--
-- /Example:/ If you say
--
-- > deriveMetadataValue ''Tree "TreeCode" "treeDatatypeInfo"
--
-- then you get code that is equivalent to:
--
-- > treeDatatypeInfo :: DatatypeInfo TreeCode
-- > treeDatatypeInfo = ADT "Main" "Tree"
-- >     (Constructor "Leaf" :* Constructor "Node" :* Nil)
--
-- /Note:/ CodeType needs to be derived with 'deriveGenericFunctions'.
--
-- @since 0.2
--
deriveMetadataValue :: Name -> String -> String -> Q [Dec]
deriveMetadataValue :: Name -> String -> String -> Q [Dec]
deriveMetadataValue n :: Name
n codeName :: String
codeName datatypeInfoName :: String
datatypeInfoName = do
  let codeName' :: Name
codeName'  = String -> Name
mkName String
codeName
  let datatypeInfoName' :: Name
datatypeInfoName' = String -> Name
mkName String
datatypeInfoName
  Dec
dec <- Name -> Q Dec
reifyDec Name
n
  Dec
-> (Bool
    -> Cxt -> Name -> [TyVarBndr] -> [Con] -> Derivings -> Q [Dec])
-> Q [Dec]
forall a.
Dec
-> (Bool
    -> Cxt -> Name -> [TyVarBndr] -> [Con] -> Derivings -> Q a)
-> Q a
withDataDec Dec
dec ((Bool
  -> Cxt -> Name -> [TyVarBndr] -> [Con] -> Derivings -> Q [Dec])
 -> Q [Dec])
-> (Bool
    -> Cxt -> Name -> [TyVarBndr] -> [Con] -> Derivings -> Q [Dec])
-> Q [Dec]
forall a b. (a -> b) -> a -> b
$ \isNewtype :: Bool
isNewtype _cxt :: Cxt
_cxt name :: Name
name _bndrs :: [TyVarBndr]
_bndrs cons :: [Con]
cons _derivs :: Derivings
_derivs -> do
    [Q Dec] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [ Name -> Q Type -> Q Dec
sigD Name
datatypeInfoName' [t| SOP.DatatypeInfo $(conT codeName') |]                -- treeDatatypeInfo :: DatatypeInfo TreeCode
             , Name -> [ClauseQ] -> Q Dec
funD Name
datatypeInfoName' [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [] (ExpQ -> BodyQ
normalB (ExpQ -> BodyQ) -> ExpQ -> BodyQ
forall a b. (a -> b) -> a -> b
$ Bool -> Name -> [Con] -> ExpQ
metadata' Bool
isNewtype Name
name [Con]
cons) []] -- treeDatatypeInfo = ...
             ]
{-# DEPRECATED deriveMetadataValue "Use 'deriveMetadataType' and 'demoteDatatypeInfo' instead." #-}

-- | Derive @DatatypeInfo@ type for the type.
--
-- /Example:/ If you say
--
-- > deriveMetadataType ''Tree "TreeDatatypeInfo"
--
-- then you get code that is equivalent to:
--
-- > type TreeDatatypeInfo =
-- >   T.ADT "Main" "Tree"
-- >     [ T.Constructor "Leaf", T.Constructor "Node" ]
--
-- @since 0.3.0.0
--
deriveMetadataType :: Name -> String -> Q [Dec]
deriveMetadataType :: Name -> String -> Q [Dec]
deriveMetadataType n :: Name
n datatypeInfoName :: String
datatypeInfoName = do
  let datatypeInfoName' :: Name
datatypeInfoName' = String -> Name
mkName String
datatypeInfoName
  Dec
dec <- Name -> Q Dec
reifyDec Name
n
  Dec
-> (Bool
    -> Cxt -> Name -> [TyVarBndr] -> [Con] -> Derivings -> Q [Dec])
-> Q [Dec]
forall a.
Dec
-> (Bool
    -> Cxt -> Name -> [TyVarBndr] -> [Con] -> Derivings -> Q a)
-> Q a
withDataDec Dec
dec ((Bool
  -> Cxt -> Name -> [TyVarBndr] -> [Con] -> Derivings -> Q [Dec])
 -> Q [Dec])
-> (Bool
    -> Cxt -> Name -> [TyVarBndr] -> [Con] -> Derivings -> Q [Dec])
-> Q [Dec]
forall a b. (a -> b) -> a -> b
$ \ isNewtype :: Bool
isNewtype _ctx :: Cxt
_ctx name :: Name
name _bndrs :: [TyVarBndr]
_bndrs cons :: [Con]
cons _derivs :: Derivings
_derivs ->
    [Q Dec] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence
      [ Name -> [TyVarBndr] -> Q Type -> Q Dec
tySynD Name
datatypeInfoName' [] (Bool -> Name -> [Con] -> Q Type
metadataType' Bool
isNewtype Name
name [Con]
cons) ]

deriveGenericForDataDec ::
  (Name -> Q Type) -> Bool -> Cxt -> Name -> [TyVarBndr] -> [Con] -> Derivings -> Q [Dec]
deriveGenericForDataDec :: (Name -> Q Type)
-> Bool
-> Cxt
-> Name
-> [TyVarBndr]
-> [Con]
-> Derivings
-> Q [Dec]
deriveGenericForDataDec f :: Name -> Q Type
f _isNewtype :: Bool
_isNewtype _cxt :: Cxt
_cxt name :: Name
name bndrs :: [TyVarBndr]
bndrs cons :: [Con]
cons _derivs :: Derivings
_derivs = do
  let typ :: Q Type
typ = (Name -> Q Type) -> Name -> [TyVarBndr] -> Q Type
appTyVars Name -> Q Type
f Name
name [TyVarBndr]
bndrs
  (Name -> Q Type) -> Q Type -> [Con] -> Q [Dec]
deriveGenericForDataType Name -> Q Type
f Q Type
typ [Con]
cons

deriveGenericForDataType :: (Name -> Q Type) -> Q Type -> [Con] -> Q [Dec]
deriveGenericForDataType :: (Name -> Q Type) -> Q Type -> [Con] -> Q [Dec]
deriveGenericForDataType f :: Name -> Q Type
f typ :: Q Type
typ cons :: [Con]
cons = do
#if MIN_VERSION_template_haskell(2,15,0)
  let codeSyn :: Q Dec
codeSyn = TySynEqnQ -> Q Dec
tySynInstD (Maybe [TyVarBndr] -> Q Type -> Q Type -> TySynEqnQ
tySynEqn Maybe [TyVarBndr]
forall a. Maybe a
Nothing [t| Code $typ |] ((Name -> Q Type) -> [Con] -> Q Type
codeFor Name -> Q Type
f [Con]
cons))
#else
  let codeSyn = tySynInstD ''Code $ tySynEqn [typ] (codeFor f cons)
#endif
  Dec
inst <- CxtQ -> Q Type -> [Q Dec] -> Q Dec
instanceD
            ([Q Type] -> CxtQ
cxt [])
            [t| Generic $typ |]
            [Q Dec
codeSyn, Name -> [Con] -> Q Dec
embedding 'from [Con]
cons, Name -> [Con] -> Q Dec
projection 'to [Con]
cons]
  [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return [Dec
inst]

deriveMetadataForDataDec ::
  (Name -> Q Type) -> Bool -> Cxt -> Name -> [TyVarBndr] -> [Con] -> Derivings -> Q [Dec]
deriveMetadataForDataDec :: (Name -> Q Type)
-> Bool
-> Cxt
-> Name
-> [TyVarBndr]
-> [Con]
-> Derivings
-> Q [Dec]
deriveMetadataForDataDec f :: Name -> Q Type
f isNewtype :: Bool
isNewtype _cxt :: Cxt
_cxt name :: Name
name bndrs :: [TyVarBndr]
bndrs cons :: [Con]
cons _derivs :: Derivings
_derivs = do
  let typ :: Q Type
typ = (Name -> Q Type) -> Name -> [TyVarBndr] -> Q Type
appTyVars Name -> Q Type
f Name
name [TyVarBndr]
bndrs
  Bool -> Name -> Q Type -> [Con] -> Q [Dec]
deriveMetadataForDataType Bool
isNewtype Name
name Q Type
typ [Con]
cons

deriveMetadataForDataType :: Bool -> Name -> Q Type -> [Con] -> Q [Dec]
deriveMetadataForDataType :: Bool -> Name -> Q Type -> [Con] -> Q [Dec]
deriveMetadataForDataType isNewtype :: Bool
isNewtype name :: Name
name typ :: Q Type
typ cons :: [Con]
cons = do
  Dec
md   <- CxtQ -> Q Type -> [Q Dec] -> Q Dec
instanceD ([Q Type] -> CxtQ
cxt [])
            [t| HasDatatypeInfo $typ |]
            [ Q Type -> Bool -> Name -> [Con] -> Q Dec
metadataType Q Type
typ Bool
isNewtype Name
name [Con]
cons
            , Name -> [ClauseQ] -> Q Dec
funD 'datatypeInfo
                [ [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [PatQ
wildP]
                  (ExpQ -> BodyQ
normalB [| SOP.T.demoteDatatypeInfo (Proxy :: Proxy (DatatypeInfoOf $typ)) |])
                  []
                ]
            ]
            -- [metadata isNewtype name cons]
  [Dec] -> Q [Dec]
forall (m :: * -> *) a. Monad m => a -> m a
return [Dec
md]

{-------------------------------------------------------------------------------
  Computing the code for a data type
-------------------------------------------------------------------------------}

codeFor :: (Name -> Q Type) -> [Con] -> Q Type
codeFor :: (Name -> Q Type) -> [Con] -> Q Type
codeFor f :: Name -> Q Type
f = [Q Type] -> Q Type
promotedTypeList ([Q Type] -> Q Type) -> ([Con] -> [Q Type]) -> [Con] -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Con -> Q Type) -> [Con] -> [Q Type]
forall a b. (a -> b) -> [a] -> [b]
map Con -> Q Type
go
  where
    go :: Con -> Q Type
    go :: Con -> Q Type
go c :: Con
c = do (_, ts :: [Q Type]
ts) <- Con -> Q (Name, [Q Type])
conInfo Con
c
              (Name -> Q Type) -> [Q Type] -> Q Type
promotedTypeListSubst Name -> Q Type
f [Q Type]
ts

{-------------------------------------------------------------------------------
  Computing the embedding/projection pair
-------------------------------------------------------------------------------}

embedding :: Name -> [Con] -> Q Dec
embedding :: Name -> [Con] -> Q Dec
embedding fromName :: Name
fromName = Name -> [ClauseQ] -> Q Dec
funD Name
fromName ([ClauseQ] -> Q Dec) -> ([Con] -> [ClauseQ]) -> [Con] -> Q Dec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ExpQ -> ExpQ) -> [Con] -> [ClauseQ]
go' (\e :: ExpQ
e -> [| Z $e |])
  where
    go' :: (Q Exp -> Q Exp) -> [Con] -> [Q Clause]
    go' :: (ExpQ -> ExpQ) -> [Con] -> [ClauseQ]
go' _ [] = (ClauseQ -> [ClauseQ] -> [ClauseQ]
forall a. a -> [a] -> [a]
:[]) (ClauseQ -> [ClauseQ]) -> ClauseQ -> [ClauseQ]
forall a b. (a -> b) -> a -> b
$ do
      Name
x <- String -> Q Name
newName "x"
      [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [Name -> PatQ
varP Name
x] (ExpQ -> BodyQ
normalB (ExpQ -> [MatchQ] -> ExpQ
caseE (Name -> ExpQ
varE Name
x) [])) []
    go' br :: ExpQ -> ExpQ
br cs :: [Con]
cs = (ExpQ -> ExpQ) -> [Con] -> [ClauseQ]
go ExpQ -> ExpQ
br [Con]
cs

    go :: (Q Exp -> Q Exp) -> [Con] -> [Q Clause]
    go :: (ExpQ -> ExpQ) -> [Con] -> [ClauseQ]
go _  []     = []
    go br :: ExpQ -> ExpQ
br (c :: Con
c:cs :: [Con]
cs) = (ExpQ -> ExpQ) -> Con -> ClauseQ
mkClause ExpQ -> ExpQ
br Con
c ClauseQ -> [ClauseQ] -> [ClauseQ]
forall a. a -> [a] -> [a]
: (ExpQ -> ExpQ) -> [Con] -> [ClauseQ]
go (\e :: ExpQ
e -> [| S $(br e) |]) [Con]
cs

    mkClause :: (Q Exp -> Q Exp) -> Con -> Q Clause
    mkClause :: (ExpQ -> ExpQ) -> Con -> ClauseQ
mkClause br :: ExpQ -> ExpQ
br c :: Con
c = do
      (n :: Name
n, ts :: [Q Type]
ts) <- Con -> Q (Name, [Q Type])
conInfo Con
c
      [Name]
vars    <- Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM ([Q Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Q Type]
ts) (String -> Q Name
newName "x")
      [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [Name -> [PatQ] -> PatQ
conP Name
n ((Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> PatQ
varP [Name]
vars)]
             (ExpQ -> BodyQ
normalB [| SOP $(br . npE . map (appE (conE 'I) . varE) $ vars) |])
             []

projection :: Name -> [Con] -> Q Dec
projection :: Name -> [Con] -> Q Dec
projection toName :: Name
toName = Name -> [ClauseQ] -> Q Dec
funD Name
toName ([ClauseQ] -> Q Dec) -> ([Con] -> [ClauseQ]) -> [Con] -> Q Dec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Con] -> [ClauseQ]
go'
  where
    go' :: [Con] -> [Q Clause]
    go' :: [Con] -> [ClauseQ]
go' [] = (ClauseQ -> [ClauseQ] -> [ClauseQ]
forall a. a -> [a] -> [a]
:[]) (ClauseQ -> [ClauseQ]) -> ClauseQ -> [ClauseQ]
forall a b. (a -> b) -> a -> b
$ do
      Name
x <- String -> Q Name
newName "x"
      [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [Name -> PatQ
varP Name
x] (ExpQ -> BodyQ
normalB (ExpQ -> [MatchQ] -> ExpQ
caseE (Name -> ExpQ
varE Name
x) [])) []
    go' cs :: [Con]
cs = (PatQ -> PatQ) -> [Con] -> [ClauseQ]
go PatQ -> PatQ
forall a. a -> a
id [Con]
cs

    go :: (Q Pat -> Q Pat) -> [Con] -> [Q Clause]
    go :: (PatQ -> PatQ) -> [Con] -> [ClauseQ]
go br :: PatQ -> PatQ
br [] = [(PatQ -> PatQ) -> ClauseQ
mkUnreachableClause PatQ -> PatQ
br]
    go br :: PatQ -> PatQ
br (c :: Con
c:cs :: [Con]
cs) = (PatQ -> PatQ) -> Con -> ClauseQ
mkClause PatQ -> PatQ
br Con
c ClauseQ -> [ClauseQ] -> [ClauseQ]
forall a. a -> [a] -> [a]
: (PatQ -> PatQ) -> [Con] -> [ClauseQ]
go (\p :: PatQ
p -> Name -> [PatQ] -> PatQ
conP 'S [PatQ -> PatQ
br PatQ
p]) [Con]
cs

    -- Generates a final clause of the form:
    --
    --   to (S (... (S x))) = x `seq` error "inaccessible"
    --
    -- An equivalent way of achieving this would be:
    --
    --   to (S (... (S x))) = case x of {}
    --
    -- This, however, would require clients to enable the EmptyCase extension
    -- in their own code, which is something which we have not previously
    -- required. Therefore, we do not generate this code at the moment.
    mkUnreachableClause :: (Q Pat -> Q Pat) -> Q Clause
    mkUnreachableClause :: (PatQ -> PatQ) -> ClauseQ
mkUnreachableClause br :: PatQ -> PatQ
br = do
      Name
var <- String -> Q Name
newName "x"
      [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [Name -> [PatQ] -> PatQ
conP 'SOP [PatQ -> PatQ
br (Name -> PatQ
varP Name
var)]]
             (ExpQ -> BodyQ
normalB [| $(varE var) `seq` error "inaccessible" |])
             []

    mkClause :: (Q Pat -> Q Pat) -> Con -> Q Clause
    mkClause :: (PatQ -> PatQ) -> Con -> ClauseQ
mkClause br :: PatQ -> PatQ
br c :: Con
c = do
      (n :: Name
n, ts :: [Q Type]
ts) <- Con -> Q (Name, [Q Type])
conInfo Con
c
      [Name]
vars    <- Int -> Q Name -> Q [Name]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM ([Q Type] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Q Type]
ts) (String -> Q Name
newName "x")
      [PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [Name -> [PatQ] -> PatQ
conP 'SOP [PatQ -> PatQ
br (PatQ -> PatQ) -> ([Name] -> PatQ) -> [Name] -> PatQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> [PatQ] -> PatQ
conP 'Z ([PatQ] -> PatQ) -> ([Name] -> [PatQ]) -> [Name] -> PatQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PatQ -> [PatQ] -> [PatQ]
forall a. a -> [a] -> [a]
:[]) (PatQ -> [PatQ]) -> ([Name] -> PatQ) -> [Name] -> [PatQ]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [PatQ] -> PatQ
npP ([PatQ] -> PatQ) -> ([Name] -> [PatQ]) -> [Name] -> PatQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> PatQ) -> [Name] -> [PatQ]
forall a b. (a -> b) -> [a] -> [b]
map (\v :: Name
v -> Name -> [PatQ] -> PatQ
conP 'I [Name -> PatQ
varP Name
v]) ([Name] -> PatQ) -> [Name] -> PatQ
forall a b. (a -> b) -> a -> b
$ [Name]
vars]]
             (ExpQ -> BodyQ
normalB (ExpQ -> BodyQ) -> ([ExpQ] -> ExpQ) -> [ExpQ] -> BodyQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ExpQ] -> ExpQ
appsE ([ExpQ] -> BodyQ) -> [ExpQ] -> BodyQ
forall a b. (a -> b) -> a -> b
$ Name -> ExpQ
conE Name
n ExpQ -> [ExpQ] -> [ExpQ]
forall a. a -> [a] -> [a]
: (Name -> ExpQ) -> [Name] -> [ExpQ]
forall a b. (a -> b) -> [a] -> [b]
map Name -> ExpQ
varE [Name]
vars)
             []

{-------------------------------------------------------------------------------
  Compute metadata
-------------------------------------------------------------------------------}

metadataType :: Q Type -> Bool -> Name -> [Con] -> Q Dec
metadataType :: Q Type -> Bool -> Name -> [Con] -> Q Dec
metadataType typ :: Q Type
typ isNewtype :: Bool
isNewtype typeName :: Name
typeName cs :: [Con]
cs =
#if MIN_VERSION_template_haskell(2,15,0)
  TySynEqnQ -> Q Dec
tySynInstD (Maybe [TyVarBndr] -> Q Type -> Q Type -> TySynEqnQ
tySynEqn Maybe [TyVarBndr]
forall a. Maybe a
Nothing [t| DatatypeInfoOf $typ |] (Bool -> Name -> [Con] -> Q Type
metadataType' Bool
isNewtype Name
typeName [Con]
cs))
#else
  tySynInstD ''DatatypeInfoOf (tySynEqn [typ] (metadataType' isNewtype typeName cs))
#endif

-- | Derive term-level metadata.
metadata' :: Bool -> Name -> [Con] -> Q Exp
metadata' :: Bool -> Name -> [Con] -> ExpQ
metadata' isNewtype :: Bool
isNewtype typeName :: Name
typeName cs :: [Con]
cs = ExpQ
md
  where
    md :: Q Exp
    md :: ExpQ
md | Bool
isNewtype = [| SOP.Newtype $(stringE (nameModule' typeName))
                                    $(stringE (nameBase typeName))
                                    $(mdCon (head cs))
                      |]
       | Bool
otherwise = [| SOP.ADT     $(stringE (nameModule' typeName))
                                    $(stringE (nameBase typeName))
                                    $(npE $ map mdCon cs)
                                    $(popE $ map mdStrictness cs)
                      |]

    mdStrictness :: Con -> Q [Q Exp]
    mdStrictness :: Con -> Q [ExpQ]
mdStrictness (NormalC n :: Name
n bts :: [BangType]
bts)            = Name -> [Bang] -> Q [ExpQ]
mdConStrictness Name
n ((BangType -> Bang) -> [BangType] -> [Bang]
forall a b. (a -> b) -> [a] -> [b]
map BangType -> Bang
forall a b. (a, b) -> a
fst [BangType]
bts)
    mdStrictness (RecC n :: Name
n vbts :: [VarBangType]
vbts)              = Name -> [Bang] -> Q [ExpQ]
mdConStrictness Name
n ((VarBangType -> Bang) -> [VarBangType] -> [Bang]
forall a b. (a -> b) -> [a] -> [b]
map (\ (_, b :: Bang
b, _) -> Bang
b) [VarBangType]
vbts)
    mdStrictness (InfixC (b1 :: Bang
b1, _) n :: Name
n (b2 :: Bang
b2, _)) = Name -> [Bang] -> Q [ExpQ]
mdConStrictness Name
n [Bang
b1, Bang
b2]
    mdStrictness (ForallC _ _ _)            = String -> Q [ExpQ]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Existentials not supported"
    mdStrictness (GadtC _ _ _)              = String -> Q [ExpQ]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "GADTs not supported"
    mdStrictness (RecGadtC _ _ _)           = String -> Q [ExpQ]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "GADTs not supported"

    mdConStrictness :: Name -> [Bang] -> Q [Q Exp]
    mdConStrictness :: Name -> [Bang] -> Q [ExpQ]
mdConStrictness n :: Name
n bs :: [Bang]
bs = do
      [DecidedStrictness]
dss <- Name -> Q [DecidedStrictness]
reifyConStrictness Name
n
      [ExpQ] -> Q [ExpQ]
forall (m :: * -> *) a. Monad m => a -> m a
return ((Bang -> DecidedStrictness -> ExpQ)
-> [Bang] -> [DecidedStrictness] -> [ExpQ]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\ (Bang su :: SourceUnpackedness
su ss :: SourceStrictness
ss) ds :: DecidedStrictness
ds ->
        [| SOP.StrictnessInfo
          $(mdSourceUnpackedness su)
          $(mdSourceStrictness   ss)
          $(mdDecidedStrictness  ds)
        |]) [Bang]
bs [DecidedStrictness]
dss)

    mdCon :: Con -> Q Exp
    mdCon :: Con -> ExpQ
mdCon (NormalC n :: Name
n _)   = [| SOP.Constructor $(stringE (nameBase n)) |]
    mdCon (RecC n :: Name
n ts :: [VarBangType]
ts)     = [| SOP.Record      $(stringE (nameBase n))
                                               $(npE (map mdField ts))
                             |]
    mdCon (InfixC _ n :: Name
n _)  = do
      Maybe Fixity
fixity <- Name -> Q (Maybe Fixity)
reifyFixity Name
n
      case Fixity -> Maybe Fixity -> Fixity
forall a. a -> Maybe a -> a
fromMaybe Fixity
defaultFixity Maybe Fixity
fixity of
        Fixity f :: Int
f a :: FixityDirection
a ->
                            [| SOP.Infix       $(stringE (nameBase n)) $(mdAssociativity a) f |]
    mdCon (ForallC _ _ _) = String -> ExpQ
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Existentials not supported"
    mdCon (GadtC _ _ _)    = String -> ExpQ
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "GADTs not supported"
    mdCon (RecGadtC _ _ _) = String -> ExpQ
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "GADTs not supported"

    mdField :: VarStrictType -> Q Exp
    mdField :: VarBangType -> ExpQ
mdField (n :: Name
n, _, _) = [| SOP.FieldInfo $(stringE (nameBase n)) |]

    mdSourceUnpackedness :: SourceUnpackedness -> Q Exp
    mdSourceUnpackedness :: SourceUnpackedness -> ExpQ
mdSourceUnpackedness NoSourceUnpackedness = [| SOP.NoSourceUnpackedness |]
    mdSourceUnpackedness SourceNoUnpack       = [| SOP.SourceNoUnpack       |]
    mdSourceUnpackedness SourceUnpack         = [| SOP.SourceUnpack         |]

    mdSourceStrictness :: SourceStrictness -> Q Exp
    mdSourceStrictness :: SourceStrictness -> ExpQ
mdSourceStrictness NoSourceStrictness = [| SOP.NoSourceStrictness |]
    mdSourceStrictness SourceLazy         = [| SOP.SourceLazy         |]
    mdSourceStrictness SourceStrict       = [| SOP.SourceStrict       |]

    mdDecidedStrictness :: DecidedStrictness -> Q Exp
    mdDecidedStrictness :: DecidedStrictness -> ExpQ
mdDecidedStrictness DecidedLazy   = [| SOP.DecidedLazy   |]
    mdDecidedStrictness DecidedStrict = [| SOP.DecidedStrict |]
    mdDecidedStrictness DecidedUnpack = [| SOP.DecidedUnpack |]

    mdAssociativity :: FixityDirection -> Q Exp
    mdAssociativity :: FixityDirection -> ExpQ
mdAssociativity InfixL = [| SOP.LeftAssociative  |]
    mdAssociativity InfixR = [| SOP.RightAssociative |]
    mdAssociativity InfixN = [| SOP.NotAssociative   |]

-- | Derive type-level metadata.
metadataType' :: Bool -> Name -> [Con] -> Q Type
metadataType' :: Bool -> Name -> [Con] -> Q Type
metadataType' isNewtype :: Bool
isNewtype typeName :: Name
typeName cs :: [Con]
cs = Q Type
md
  where
    md :: Q Type
    md :: Q Type
md | Bool
isNewtype = [t| 'SOP.T.Newtype $(stringT (nameModule' typeName))
                                        $(stringT (nameBase typeName))
                                        $(mdCon (head cs))
                       |]
       | Bool
otherwise = [t| 'SOP.T.ADT     $(stringT (nameModule' typeName))
                                        $(stringT (nameBase typeName))
                                        $(promotedTypeList $ map mdCon cs)
                                        $(promotedTypeListOfList $ map mdStrictness cs)
                       |]

    mdStrictness :: Con -> Q [Q Type]
    mdStrictness :: Con -> Q [Q Type]
mdStrictness (NormalC n :: Name
n bts :: [BangType]
bts)            = Name -> [Bang] -> Q [Q Type]
mdConStrictness Name
n ((BangType -> Bang) -> [BangType] -> [Bang]
forall a b. (a -> b) -> [a] -> [b]
map BangType -> Bang
forall a b. (a, b) -> a
fst [BangType]
bts)
    mdStrictness (RecC n :: Name
n vbts :: [VarBangType]
vbts)              = Name -> [Bang] -> Q [Q Type]
mdConStrictness Name
n ((VarBangType -> Bang) -> [VarBangType] -> [Bang]
forall a b. (a -> b) -> [a] -> [b]
map (\ (_, b :: Bang
b, _) -> Bang
b) [VarBangType]
vbts)
    mdStrictness (InfixC (b1 :: Bang
b1, _) n :: Name
n (b2 :: Bang
b2, _)) = Name -> [Bang] -> Q [Q Type]
mdConStrictness Name
n [Bang
b1, Bang
b2]
    mdStrictness (ForallC _ _ _)            = String -> Q [Q Type]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Existentials not supported"
    mdStrictness (GadtC _ _ _)              = String -> Q [Q Type]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "GADTs not supported"
    mdStrictness (RecGadtC _ _ _)           = String -> Q [Q Type]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "GADTs not supported"

    mdConStrictness :: Name -> [Bang] -> Q [Q Type]
    mdConStrictness :: Name -> [Bang] -> Q [Q Type]
mdConStrictness n :: Name
n bs :: [Bang]
bs = do
      [DecidedStrictness]
dss <- Name -> Q [DecidedStrictness]
reifyConStrictness Name
n
      [Q Type] -> Q [Q Type]
forall (m :: * -> *) a. Monad m => a -> m a
return ((Bang -> DecidedStrictness -> Q Type)
-> [Bang] -> [DecidedStrictness] -> [Q Type]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\ (Bang su :: SourceUnpackedness
su ss :: SourceStrictness
ss) ds :: DecidedStrictness
ds ->
        [t| 'SOP.T.StrictnessInfo
          $(mdSourceUnpackedness su)
          $(mdSourceStrictness   ss)
          $(mdDecidedStrictness  ds)
        |]) [Bang]
bs [DecidedStrictness]
dss)

    mdCon :: Con -> Q Type
    mdCon :: Con -> Q Type
mdCon (NormalC n :: Name
n _)   = [t| 'SOP.T.Constructor $(stringT (nameBase n)) |]
    mdCon (RecC n :: Name
n ts :: [VarBangType]
ts)     = [t| 'SOP.T.Record      $(stringT (nameBase n))
                                                   $(promotedTypeList (map mdField ts))
                              |]
    mdCon (InfixC _ n :: Name
n _)  = do
      Maybe Fixity
fixity <- Name -> Q (Maybe Fixity)
reifyFixity Name
n
      case Fixity -> Maybe Fixity -> Fixity
forall a. a -> Maybe a -> a
fromMaybe Fixity
defaultFixity Maybe Fixity
fixity of
        Fixity f :: Int
f a :: FixityDirection
a ->
                            [t| 'SOP.T.Infix       $(stringT (nameBase n)) $(mdAssociativity a) $(natT f) |]
    mdCon (ForallC _ _ _) = String -> Q Type
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Existentials not supported"
    mdCon (GadtC _ _ _)    = String -> Q Type
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "GADTs not supported"
    mdCon (RecGadtC _ _ _) = String -> Q Type
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "GADTs not supported"

    mdField :: VarStrictType -> Q Type
    mdField :: VarBangType -> Q Type
mdField (n :: Name
n, _, _) = [t| 'SOP.T.FieldInfo $(stringT (nameBase n)) |]

    mdSourceUnpackedness :: SourceUnpackedness -> Q Type
    mdSourceUnpackedness :: SourceUnpackedness -> Q Type
mdSourceUnpackedness NoSourceUnpackedness = [t| 'SOP.NoSourceUnpackedness |]
    mdSourceUnpackedness SourceNoUnpack       = [t| 'SOP.SourceNoUnpack       |]
    mdSourceUnpackedness SourceUnpack         = [t| 'SOP.SourceUnpack         |]

    mdSourceStrictness :: SourceStrictness -> Q Type
    mdSourceStrictness :: SourceStrictness -> Q Type
mdSourceStrictness NoSourceStrictness = [t| 'SOP.NoSourceStrictness |]
    mdSourceStrictness SourceLazy         = [t| 'SOP.SourceLazy         |]
    mdSourceStrictness SourceStrict       = [t| 'SOP.SourceStrict       |]

    mdDecidedStrictness :: DecidedStrictness -> Q Type
    mdDecidedStrictness :: DecidedStrictness -> Q Type
mdDecidedStrictness DecidedLazy   = [t| 'SOP.DecidedLazy   |]
    mdDecidedStrictness DecidedStrict = [t| 'SOP.DecidedStrict |]
    mdDecidedStrictness DecidedUnpack = [t| 'SOP.DecidedUnpack |]

    mdAssociativity :: FixityDirection -> Q Type
    mdAssociativity :: FixityDirection -> Q Type
mdAssociativity InfixL = [t| 'SOP.T.LeftAssociative  |]
    mdAssociativity InfixR = [t| 'SOP.T.RightAssociative |]
    mdAssociativity InfixN = [t| 'SOP.T.NotAssociative   |]

nameModule' :: Name -> String
nameModule' :: Name -> String
nameModule' = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe "" (Maybe String -> String)
-> (Name -> Maybe String) -> Name -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Maybe String
nameModule

{-------------------------------------------------------------------------------
  Constructing n-ary pairs
-------------------------------------------------------------------------------}

-- Given
--
-- > [a, b, c]
--
-- Construct
--
-- > a :* b :* c :* Nil
npE :: [Q Exp] -> Q Exp
npE :: [ExpQ] -> ExpQ
npE []     = [| Nil |]
npE (e :: ExpQ
e:es :: [ExpQ]
es) = [| $e :* $(npE es) |]

-- Construct a POP.
popE :: [Q [Q Exp]] -> Q Exp
popE :: [Q [ExpQ]] -> ExpQ
popE ess :: [Q [ExpQ]]
ess =
  [| POP $(npE (map (join . fmap npE) ess)) |]

-- Like npE, but construct a pattern instead
npP :: [Q Pat] -> Q Pat
npP :: [PatQ] -> PatQ
npP []     = Name -> [PatQ] -> PatQ
conP 'Nil []
npP (p :: PatQ
p:ps :: [PatQ]
ps) = Name -> [PatQ] -> PatQ
conP '(:*) [PatQ
p, [PatQ] -> PatQ
npP [PatQ]
ps]

{-------------------------------------------------------------------------------
  Some auxiliary definitions for working with TH
-------------------------------------------------------------------------------}

conInfo :: Con -> Q (Name, [Q Type])
conInfo :: Con -> Q (Name, [Q Type])
conInfo (NormalC n :: Name
n ts :: [BangType]
ts) = (Name, [Q Type]) -> Q (Name, [Q Type])
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
n, (BangType -> Q Type) -> [BangType] -> [Q Type]
forall a b. (a -> b) -> [a] -> [b]
map (Type -> Q Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Q Type) -> (BangType -> Type) -> BangType -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\(_, t :: Type
t)    -> Type
t)) [BangType]
ts)
conInfo (RecC    n :: Name
n ts :: [VarBangType]
ts) = (Name, [Q Type]) -> Q (Name, [Q Type])
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
n, (VarBangType -> Q Type) -> [VarBangType] -> [Q Type]
forall a b. (a -> b) -> [a] -> [b]
map (Type -> Q Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Q Type) -> (VarBangType -> Type) -> VarBangType -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\(_, _, t :: Type
t) -> Type
t)) [VarBangType]
ts)
conInfo (InfixC (_, t :: Type
t) n :: Name
n (_, t' :: Type
t')) = (Name, [Q Type]) -> Q (Name, [Q Type])
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
n, (Type -> Q Type) -> Cxt -> [Q Type]
forall a b. (a -> b) -> [a] -> [b]
map Type -> Q Type
forall (m :: * -> *) a. Monad m => a -> m a
return [Type
t, Type
t'])
conInfo (ForallC _ _ _) = String -> Q (Name, [Q Type])
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Existentials not supported"
conInfo (GadtC _ _ _)    = String -> Q (Name, [Q Type])
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "GADTs not supported"
conInfo (RecGadtC _ _ _) = String -> Q (Name, [Q Type])
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "GADTs not supported"

stringT :: String -> Q Type
stringT :: String -> Q Type
stringT = TyLitQ -> Q Type
litT (TyLitQ -> Q Type) -> (String -> TyLitQ) -> String -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> TyLitQ
strTyLit

natT :: Int -> Q Type
natT :: Int -> Q Type
natT = TyLitQ -> Q Type
litT (TyLitQ -> Q Type) -> (Int -> TyLitQ) -> Int -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> TyLitQ
numTyLit (Integer -> TyLitQ) -> (Int -> Integer) -> Int -> TyLitQ
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral

promotedTypeList :: [Q Type] -> Q Type
promotedTypeList :: [Q Type] -> Q Type
promotedTypeList []     = Q Type
promotedNilT
promotedTypeList (t :: Q Type
t:ts :: [Q Type]
ts) = [t| $promotedConsT $t $(promotedTypeList ts) |]

promotedTypeListOfList :: [Q [Q Type]] -> Q Type
promotedTypeListOfList :: [Q [Q Type]] -> Q Type
promotedTypeListOfList =
  [Q Type] -> Q Type
promotedTypeList ([Q Type] -> Q Type)
-> ([Q [Q Type]] -> [Q Type]) -> [Q [Q Type]] -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Q [Q Type] -> Q Type) -> [Q [Q Type]] -> [Q Type]
forall a b. (a -> b) -> [a] -> [b]
map (Q (Q Type) -> Q Type
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Q (Q Type) -> Q Type)
-> (Q [Q Type] -> Q (Q Type)) -> Q [Q Type] -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Q Type] -> Q Type) -> Q [Q Type] -> Q (Q Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Q Type] -> Q Type
promotedTypeList)

promotedTypeListSubst :: (Name -> Q Type) -> [Q Type] -> Q Type
promotedTypeListSubst :: (Name -> Q Type) -> [Q Type] -> Q Type
promotedTypeListSubst _ []     = Q Type
promotedNilT
promotedTypeListSubst f :: Name -> Q Type
f (t :: Q Type
t:ts :: [Q Type]
ts) = [t| $promotedConsT $(t >>= substType f) $(promotedTypeListSubst f ts) |]

appsT :: Name -> [Q Type] -> Q Type
appsT :: Name -> [Q Type] -> Q Type
appsT n :: Name
n = (Q Type -> Q Type -> Q Type) -> Q Type -> [Q Type] -> Q Type
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Q Type -> Q Type -> Q Type
appT (Name -> Q Type
conT Name
n)

bndrToName :: TyVarBndr -> Name
bndrToName :: TyVarBndr -> Name
bndrToName (PlainTV  v :: Name
v  ) = Name
v
bndrToName (KindedTV v :: Name
v _) = Name
v

appTyVars :: (Name -> Q Type) -> Name -> [TyVarBndr] -> Q Type
appTyVars :: (Name -> Q Type) -> Name -> [TyVarBndr] -> Q Type
appTyVars f :: Name -> Q Type
f n :: Name
n bndrs :: [TyVarBndr]
bndrs =
  Name -> [Q Type] -> Q Type
appsT Name
n ((TyVarBndr -> Q Type) -> [TyVarBndr] -> [Q Type]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> Q Type
f (Name -> Q Type) -> (TyVarBndr -> Name) -> TyVarBndr -> Q Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TyVarBndr -> Name
bndrToName) [TyVarBndr]
bndrs)

substType :: (Name -> Q Type) -> Type -> Q Type
substType :: (Name -> Q Type) -> Type -> Q Type
substType f :: Name -> Q Type
f = Type -> Q Type
go
  where
    go :: Type -> Q Type
go (VarT n :: Name
n)     = Name -> Q Type
f Name
n
    go (AppT t1 :: Type
t1 t2 :: Type
t2) = Type -> Type -> Type
AppT (Type -> Type -> Type) -> Q Type -> Q (Type -> Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> Q Type
go Type
t1 Q (Type -> Type) -> Q Type -> Q Type
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> Q Type
go Type
t2
    go ListT        = Type -> Q Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
ListT
    go (ConT n :: Name
n)     = Type -> Q Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Type
ConT Name
n)
    go ArrowT       = Type -> Q Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
ArrowT
    go (TupleT i :: Int
i)   = Type -> Q Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> Type
TupleT Int
i)
    go t :: Type
t            = Type -> Q Type
forall (m :: * -> *) a. Monad m => a -> m a
return Type
t -- error (show t)
      -- TODO: This is incorrect, but we only need substitution to work
      -- in simple cases for now. The reason is that substitution is normally
      -- the identity, except if we use TH derivation for the tagged datatypes
      -- in the benchmarking suite. So we can fall back on identity in all
      -- but the cases we need for the benchmarking suite.

reifyDec :: Name -> Q Dec
reifyDec :: Name -> Q Dec
reifyDec name :: Name
name =
  do Info
info <- Name -> Q Info
reify Name
name
     case Info
info of TyConI dec :: Dec
dec -> Dec -> Q Dec
forall (m :: * -> *) a. Monad m => a -> m a
return Dec
dec
                  _          -> String -> Q Dec
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Info must be type declaration type."

withDataDec :: Dec -> (Bool -> Cxt -> Name -> [TyVarBndr] -> [Con] -> Derivings -> Q a) -> Q a
withDataDec :: Dec
-> (Bool
    -> Cxt -> Name -> [TyVarBndr] -> [Con] -> Derivings -> Q a)
-> Q a
withDataDec (DataD    ctxt :: Cxt
ctxt name :: Name
name bndrs :: [TyVarBndr]
bndrs _ cons :: [Con]
cons derivs :: Derivings
derivs) f :: Bool -> Cxt -> Name -> [TyVarBndr] -> [Con] -> Derivings -> Q a
f = Bool -> Cxt -> Name -> [TyVarBndr] -> [Con] -> Derivings -> Q a
f Bool
False Cxt
ctxt Name
name [TyVarBndr]
bndrs [Con]
cons  Derivings
derivs
withDataDec (NewtypeD ctxt :: Cxt
ctxt name :: Name
name bndrs :: [TyVarBndr]
bndrs _ con :: Con
con  derivs :: Derivings
derivs) f :: Bool -> Cxt -> Name -> [TyVarBndr] -> [Con] -> Derivings -> Q a
f = Bool -> Cxt -> Name -> [TyVarBndr] -> [Con] -> Derivings -> Q a
f Bool
True  Cxt
ctxt Name
name [TyVarBndr]
bndrs [Con
con] Derivings
derivs
withDataDec _ _ = String -> Q a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "Can only derive labels for datatypes and newtypes."

-- | Utility type synonym to cover changes in the TH code
#if MIN_VERSION_template_haskell(2,12,0)
type Derivings = [DerivClause]
#else
type Derivings = Cxt
#endif