    {-# LANGUAGE CPP #-}
    {-# 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, unless)
    import Data.List (foldl')
    import Data.Maybe (fromMaybe)
    import Data.Proxy

    -- importing in this order to avoid unused import warning
    import Language.Haskell.TH.Datatype.TyVarBndr
    import Language.Haskell.TH
    import Language.Haskell.TH.Datatype as TH
    import Language.Haskell.TH.Datatype.TyVarBndr

    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 Name
    n =
      Name -> (Name -> Q Type) -> Q [Dec]
    deriveGenericSubst Name
    n Name -> Q Type
    forall (m :: * -> *). Quote m => Name -> m Type
    varT

    -- | Like 'deriveGeneric', but omit the 'HasDatatypeInfo' instance.
    deriveGenericOnly :: Name -> Q [Dec]
    deriveGenericOnly :: Name -> Q [Dec]
    deriveGenericOnly Name
    n =
      Name -> (Name -> Q Type) -> Q [Dec]
    deriveGenericOnlySubst Name
    n Name -> Q Type
    forall (m :: * -> *). Quote m => Name -> m 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 Name
    n Name -> Q Type
    f = do
      dec <- Name -> Q DatatypeInfo
    reifyDatatype Name
    n
      ds1 <- withDataDec dec (deriveGenericForDataDec  f)
      ds2 <- withDataDec dec (deriveMetadataForDataDec f)
      return (ds1 ++ 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 Name
    n Name -> Q Type
    f = do
      dec <- Name -> Q DatatypeInfo
    reifyDatatype Name
    n
      withDataDec dec (deriveGenericForDataDec 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 Name
    n String
    codeName String
    fromName 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 <- Name -> Q DatatypeInfo
    reifyDatatype Name
    n
      withDataDec dec $ \DatatypeVariant
    _variant Cxt
    _cxt Name
    name [TyVarBndrVis]
    bndrs Cxt
    instTys [ConstructorInfo]
    cons -> do
        let codeType :: Q Type
    codeType = (Name -> Q Type) -> [ConstructorInfo] -> Q Type
    codeFor Name -> Q Type
    forall (m :: * -> *). Quote m => Name -> m Type
    varT [ConstructorInfo]
    cons                     -- '[ '[Int], '[Tree, Tree] ]
        let origType :: Q Type
    origType = (Name -> Q Type) -> Name -> Cxt -> Q Type
    appTysSubst Name -> Q Type
    forall (m :: * -> *). Quote m => Name -> m Type
    varT Name
    name Cxt
    instTys         -- Tree
        let repType :: Q Type
    repType  = [t| SOP I $((Name -> Q Type) -> Name -> [TyVarBndrVis] -> Q Type
    appTyVars Name -> Q Type
    forall (m :: * -> *). Quote m => Name -> m Type
    varT Name
    codeName' [TyVarBndrVis]
    bndrs) |] -- SOP I TreeCode
        [Q Dec] -> Q [Dec]
    forall (t :: * -> *) (m :: * -> *) a.
    (Traversable t, Monad m) =>
    t (m a) -> m (t a)
    forall (m :: * -> *) a. Monad m => [m a] -> m [a]
    sequence
          [ Name -> [TyVarBndrVis] -> Q Type -> Q Dec
    forall (m :: * -> *).
    Quote m =>
    Name -> [TyVarBndrVis] -> m Type -> m Dec
    tySynD Name
    codeName' [TyVarBndrVis]
    bndrs Q Type
    codeType                 -- type TreeCode = '[ '[Int], '[Tree, Tree] ]
          , Name -> Q Type -> Q Dec
    forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
    sigD Name
    fromName' [t| $Q Type
    origType -> $Q Type
    repType |]     -- fromTree :: Tree -> SOP I TreeCode
          , Name -> [ConstructorInfo] -> Q Dec
    embedding Name
    fromName' [ConstructorInfo]
    cons                        -- fromTree ... =
          , Name -> Q Type -> Q Dec
    forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
    sigD Name
    toName' [t| $Q Type
    repType -> $Q Type
    origType |]       -- toTree :: SOP I TreeCode -> Tree
          , Name -> [ConstructorInfo] -> Q Dec
    projection Name
    toName' [ConstructorInfo]
    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 Name
    n String
    codeName String
    datatypeInfoName = do
      let codeName' :: Name
    codeName'  = String -> Name
    mkName String
    codeName
      let datatypeInfoName' :: Name
    datatypeInfoName' = String -> Name
    mkName String
    datatypeInfoName
      dec <- Name -> Q DatatypeInfo
    reifyDatatype Name
    n
      withDataDec dec $ \DatatypeVariant
    variant Cxt
    _cxt Name
    name [TyVarBndrVis]
    bndrs Cxt
    _instTys [ConstructorInfo]
    cons -> do
        [Q Dec] -> Q [Dec]
    forall (t :: * -> *) (m :: * -> *) a.
    (Traversable t, Monad m) =>
    t (m a) -> m (t a)
    forall (m :: * -> *) a. Monad m => [m a] -> m [a]
    sequence [ Name -> Q Type -> Q Dec
    forall (m :: * -> *). Quote m => Name -> m Type -> m Dec
    sigD Name
    datatypeInfoName' [t| SOP.DatatypeInfo $((Name -> Q Type) -> Name -> [TyVarBndrVis] -> Q Type
    appTyVars Name -> Q Type
    forall (m :: * -> *). Quote m => Name -> m Type
    varT Name
    codeName' [TyVarBndrVis]
    bndrs) |] -- treeDatatypeInfo :: DatatypeInfo TreeCode
                 , Name -> [Q Clause] -> Q Dec
    forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
    funD Name
    datatypeInfoName' [[Q Pat] -> Q Body -> [Q Dec] -> Q Clause
    forall (m :: * -> *).
    Quote m =>
    [m Pat] -> m Body -> [m Dec] -> m Clause
    clause [] (Q Exp -> Q Body
    forall (m :: * -> *). Quote m => m Exp -> m Body
    normalB (Q Exp -> Q Body) -> Q Exp -> Q Body
    forall a b. (a -> b) -> a -> b
    $ DatatypeVariant -> Name -> [ConstructorInfo] -> Q Exp
    metadata' DatatypeVariant
    variant Name
    name [ConstructorInfo]
    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 Name
    n String
    datatypeInfoName = do
      let datatypeInfoName' :: Name
    datatypeInfoName' = String -> Name
    mkName String
    datatypeInfoName
      dec <- Name -> Q DatatypeInfo
    reifyDatatype Name
    n
      withDataDec dec $ \ DatatypeVariant
    variant Cxt
    _ctx Name
    name [TyVarBndrVis]
    _bndrs Cxt
    _instTys [ConstructorInfo]
    cons ->
        [Q Dec] -> Q [Dec]
    forall (t :: * -> *) (m :: * -> *) a.
    (Traversable t, Monad m) =>
    t (m a) -> m (t a)
    forall (m :: * -> *) a. Monad m => [m a] -> m [a]
    sequence
          [ Name -> [TyVarBndrVis] -> Q Type -> Q Dec
    forall (m :: * -> *).
    Quote m =>
    Name -> [TyVarBndrVis] -> m Type -> m Dec
    tySynD Name
    datatypeInfoName' [] (DatatypeVariant -> Name -> [ConstructorInfo] -> Q Type
    metadataType' DatatypeVariant
    variant Name
    name [ConstructorInfo]
    cons) ]

    deriveGenericForDataDec ::
      (Name -> Q Type) -> DatatypeVariant -> Cxt -> Name -> [TyVarBndrVis] -> [Type] -> [TH.ConstructorInfo] -> Q [Dec]
    deriveGenericForDataDec :: (Name -> Q Type)
    -> DatatypeVariant
    -> Cxt
    -> Name
    -> [TyVarBndrVis]
    -> Cxt
    -> [ConstructorInfo]
    -> Q [Dec]
    deriveGenericForDataDec Name -> Q Type
    f DatatypeVariant
    _variant Cxt
    _cxt Name
    name [TyVarBndrVis]
    _bndrs Cxt
    instTys [ConstructorInfo]
    cons = do
      let typ :: Q Type
    typ = (Name -> Q Type) -> Name -> Cxt -> Q Type
    appTysSubst Name -> Q Type
    f Name
    name Cxt
    instTys
      (Name -> Q Type) -> Q Type -> [ConstructorInfo] -> Q [Dec]
    deriveGenericForDataType Name -> Q Type
    f Q Type
    typ [ConstructorInfo]
    cons

    deriveGenericForDataType :: (Name -> Q Type) -> Q Type -> [TH.ConstructorInfo] -> Q [Dec]
    deriveGenericForDataType :: (Name -> Q Type) -> Q Type -> [ConstructorInfo] -> Q [Dec]
    deriveGenericForDataType Name -> Q Type
    f Q Type
    typ [ConstructorInfo]
    cons = do
      let codeSyn :: Q Dec
    codeSyn = Name -> Maybe [Q TyVarBndrUnit] -> [Q Type] -> Q Type -> Q Dec
    tySynInstDCompat ''Generics.SOP.Universe.Code Maybe [Q TyVarBndrUnit]
    forall a. Maybe a
    Nothing [Q Type
    typ] ((Name -> Q Type) -> [ConstructorInfo] -> Q Type
    codeFor Name -> Q Type
    f [ConstructorInfo]
    cons)
      inst <- Q Cxt -> Q Type -> [Q Dec] -> Q Dec
    forall (m :: * -> *).
    Quote m =>
    m Cxt -> m Type -> [m Dec] -> m Dec
    instanceD
                ([Q Type] -> Q Cxt
    forall (m :: * -> *). Quote m => [m Type] -> m Cxt
    cxt [])
                [t| Generic $Q Type
    typ |]
                [Q Dec
    codeSyn, Name -> [ConstructorInfo] -> Q Dec
    embedding 'from [ConstructorInfo]
    cons, Name -> [ConstructorInfo] -> Q Dec
    projection 'to [ConstructorInfo]
    cons]
      return [inst]

    deriveMetadataForDataDec ::
      (Name -> Q Type) -> DatatypeVariant -> Cxt -> Name -> [TyVarBndrVis] -> [Type] -> [TH.ConstructorInfo] -> Q [Dec]
    deriveMetadataForDataDec :: (Name -> Q Type)
    -> DatatypeVariant
    -> Cxt
    -> Name
    -> [TyVarBndrVis]
    -> Cxt
    -> [ConstructorInfo]
    -> Q [Dec]
    deriveMetadataForDataDec Name -> Q Type
    f DatatypeVariant
    variant Cxt
    _cxt Name
    name [TyVarBndrVis]
    _bndrs Cxt
    instTys [ConstructorInfo]
    cons = do
      let typ :: Q Type
    typ = (Name -> Q Type) -> Name -> Cxt -> Q Type
    appTysSubst Name -> Q Type
    f Name
    name Cxt
    instTys
      DatatypeVariant -> Name -> Q Type -> [ConstructorInfo] -> Q [Dec]
    deriveMetadataForDataType DatatypeVariant
    variant Name
    name Q Type
    typ [ConstructorInfo]
    cons

    deriveMetadataForDataType :: DatatypeVariant -> Name -> Q Type -> [TH.ConstructorInfo] -> Q [Dec]
    deriveMetadataForDataType :: DatatypeVariant -> Name -> Q Type -> [ConstructorInfo] -> Q [Dec]
    deriveMetadataForDataType DatatypeVariant
    variant Name
    name Q Type
    typ [ConstructorInfo]
    cons = do
      md   <- Q Cxt -> Q Type -> [Q Dec] -> Q Dec
    forall (m :: * -> *).
    Quote m =>
    m Cxt -> m Type -> [m Dec] -> m Dec
    instanceD ([Q Type] -> Q Cxt
    forall (m :: * -> *). Quote m => [m Type] -> m Cxt
    cxt [])
                [t| HasDatatypeInfo $Q Type
    typ |]
                [ Q Type -> DatatypeVariant -> Name -> [ConstructorInfo] -> Q Dec
    metadataType Q Type
    typ DatatypeVariant
    variant Name
    name [ConstructorInfo]
    cons
                , Name -> [Q Clause] -> Q Dec
    forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
    funD 'datatypeInfo
                    [ [Q Pat] -> Q Body -> [Q Dec] -> Q Clause
    forall (m :: * -> *).
    Quote m =>
    [m Pat] -> m Body -> [m Dec] -> m Clause
    clause [Q Pat
    forall (m :: * -> *). Quote m => m Pat
    wildP]
                      (Q Exp -> Q Body
    forall (m :: * -> *). Quote m => m Exp -> m Body
    normalB [| SOP.T.demoteDatatypeInfo (Proxy :: Proxy (DatatypeInfoOf $Q Type
    typ)) |])
                      []
                    ]
                ]
                -- [metadata variant name cons]
      return [md]

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

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

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

    embedding :: Name -> [TH.ConstructorInfo] -> Q Dec
    embedding :: Name -> [ConstructorInfo] -> Q Dec
    embedding Name
    fromName = Name -> [Q Clause] -> Q Dec
    forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
    funD Name
    fromName ([Q Clause] -> Q Dec)
    -> ([ConstructorInfo] -> [Q Clause]) -> [ConstructorInfo] -> Q Dec
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Q Exp -> Q Exp) -> [ConstructorInfo] -> [Q Clause]
    go' (\Q Exp
    e -> [| Z $Q Exp
    e |])
      where
        go' :: (Q Exp -> Q Exp) -> [TH.ConstructorInfo] -> [Q Clause]
        go' :: (Q Exp -> Q Exp) -> [ConstructorInfo] -> [Q Clause]
    go' Q Exp -> Q Exp
    _ [] = (Q Clause -> [Q Clause] -> [Q Clause]
    forall a. a -> [a] -> [a]
    :[]) (Q Clause -> [Q Clause]) -> Q Clause -> [Q Clause]
    forall a b. (a -> b) -> a -> b
    $ do
          x <- String -> Q Name
    forall (m :: * -> *). Quote m => String -> m Name
    newName String
    "x"
          clause [varP x] (normalB (caseE (varE x) [])) []
        go' Q Exp -> Q Exp
    br [ConstructorInfo]
    cs = (Q Exp -> Q Exp) -> [ConstructorInfo] -> [Q Clause]
    go Q Exp -> Q Exp
    br [ConstructorInfo]
    cs

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

        mkClause :: (Q Exp -> Q Exp) -> TH.ConstructorInfo -> Q Clause
        mkClause :: (Q Exp -> Q Exp) -> ConstructorInfo -> Q Clause
    mkClause Q Exp -> Q Exp
    br ConstructorInfo
    c = do
          (n, ts) <- ConstructorInfo -> Q (Name, [Q Type])
    conInfo ConstructorInfo
    c
          vars    <- replicateM (length ts) (newName "x")
          clause [conP n (map varP vars)]
                 (normalB [| SOP $(br . npE . map (appE (conE 'I) . varE) $ vars) |])
                 []

    projection :: Name -> [TH.ConstructorInfo] -> Q Dec
    projection :: Name -> [ConstructorInfo] -> Q Dec
    projection Name
    toName = Name -> [Q Clause] -> Q Dec
    forall (m :: * -> *). Quote m => Name -> [m Clause] -> m Dec
    funD Name
    toName ([Q Clause] -> Q Dec)
    -> ([ConstructorInfo] -> [Q Clause]) -> [ConstructorInfo] -> Q Dec
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . [ConstructorInfo] -> [Q Clause]
    go'
      where
        go' :: [TH.ConstructorInfo] -> [Q Clause]
        go' :: [ConstructorInfo] -> [Q Clause]
    go' [] = (Q Clause -> [Q Clause] -> [Q Clause]
    forall a. a -> [a] -> [a]
    :[]) (Q Clause -> [Q Clause]) -> Q Clause -> [Q Clause]
    forall a b. (a -> b) -> a -> b
    $ do
          x <- String -> Q Name
    forall (m :: * -> *). Quote m => String -> m Name
    newName String
    "x"
          clause [varP x] (normalB (caseE (varE x) [])) []
        go' [ConstructorInfo]
    cs = (Q Pat -> Q Pat) -> [ConstructorInfo] -> [Q Clause]
    go Q Pat -> Q Pat
    forall a. a -> a
    id [ConstructorInfo]
    cs

        go :: (Q Pat -> Q Pat) -> [TH.ConstructorInfo] -> [Q Clause]
        go :: (Q Pat -> Q Pat) -> [ConstructorInfo] -> [Q Clause]
    go Q Pat -> Q Pat
    br [] = [(Q Pat -> Q Pat) -> Q Clause
    mkUnreachableClause Q Pat -> Q Pat
    br]
        go Q Pat -> Q Pat
    br (ConstructorInfo
    c:[ConstructorInfo]
    cs) = (Q Pat -> Q Pat) -> ConstructorInfo -> Q Clause
    mkClause Q Pat -> Q Pat
    br ConstructorInfo
    c Q Clause -> [Q Clause] -> [Q Clause]
    forall a. a -> [a] -> [a]
    : (Q Pat -> Q Pat) -> [ConstructorInfo] -> [Q Clause]
    go (\Q Pat
    p -> Name -> [Q Pat] -> Q Pat
    forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
    conP 'S [Q Pat -> Q Pat
    br Q Pat
    p]) [ConstructorInfo]
    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 :: (Q Pat -> Q Pat) -> Q Clause
    mkUnreachableClause Q Pat -> Q Pat
    br = do
          var <- String -> Q Name
    forall (m :: * -> *). Quote m => String -> m Name
    newName String
    "x"
          clause [conP 'SOP [br (varP var)]]
                 (normalB [| $(varE var) `seq` error "inaccessible" |])
                 []

        mkClause :: (Q Pat -> Q Pat) -> TH.ConstructorInfo -> Q Clause
        mkClause :: (Q Pat -> Q Pat) -> ConstructorInfo -> Q Clause
    mkClause Q Pat -> Q Pat
    br ConstructorInfo
    c = do
          (n, ts) <- ConstructorInfo -> Q (Name, [Q Type])
    conInfo ConstructorInfo
    c
          vars    <- replicateM (length ts) (newName "x")
          clause [conP 'SOP [br . conP 'Z . (:[]) . npP . map (\Name
    v -> Name -> [Q Pat] -> Q Pat
    forall (m :: * -> *). Quote m => Name -> [m Pat] -> m Pat
    conP 'I [Name -> Q Pat
    forall (m :: * -> *). Quote m => Name -> m Pat
    varP Name
    v]) $ vars]]
                 (normalB . appsE $ conE n : map varE vars)
                 []

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

    metadataType :: Q Type -> DatatypeVariant -> Name -> [TH.ConstructorInfo] -> Q Dec
    metadataType :: Q Type -> DatatypeVariant -> Name -> [ConstructorInfo] -> Q Dec
    metadataType Q Type
    typ DatatypeVariant
    variant Name
    typeName [ConstructorInfo]
    cs =
      Name -> Maybe [Q TyVarBndrUnit] -> [Q Type] -> Q Type -> Q Dec
    tySynInstDCompat ''DatatypeInfoOf Maybe [Q TyVarBndrUnit]
    forall a. Maybe a
    Nothing [Q Type
    typ] (DatatypeVariant -> Name -> [ConstructorInfo] -> Q Type
    metadataType' DatatypeVariant
    variant Name
    typeName [ConstructorInfo]
    cs)

    -- | Derive term-level metadata.
    metadata' :: DatatypeVariant -> Name -> [TH.ConstructorInfo] -> Q Exp
    metadata' :: DatatypeVariant -> Name -> [ConstructorInfo] -> Q Exp
    metadata' DatatypeVariant
    dataVariant Name
    typeName [ConstructorInfo]
    cs = Q Exp
    md
      where
        md :: Q Exp
        md :: Q Exp
    md | DatatypeVariant -> Bool
    isNewtypeVariant DatatypeVariant
    dataVariant
           = [| SOP.Newtype $(String -> Q Exp
    forall (m :: * -> *). Quote m => String -> m Exp
    stringE (Name -> String
    nameModule' Name
    typeName))
                            $(String -> Q Exp
    forall (m :: * -> *). Quote m => String -> m Exp
    stringE (Name -> String
    nameBase Name
    typeName))
                            $(ConstructorInfo -> Q Exp
    mdCon ([ConstructorInfo] -> ConstructorInfo
    forall a. HasCallStack => [a] -> a
    head [ConstructorInfo]
    cs))
              |]

           | Bool
    otherwise
           = [| SOP.ADT     $(String -> Q Exp
    forall (m :: * -> *). Quote m => String -> m Exp
    stringE (Name -> String
    nameModule' Name
    typeName))
                            $(String -> Q Exp
    forall (m :: * -> *). Quote m => String -> m Exp
    stringE (Name -> String
    nameBase Name
    typeName))
                            $([Q Exp] -> Q Exp
    npE ([Q Exp] -> Q Exp) -> [Q Exp] -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ (ConstructorInfo -> Q Exp) -> [ConstructorInfo] -> [Q Exp]
    forall a b. (a -> b) -> [a] -> [b]
    map ConstructorInfo -> Q Exp
    mdCon [ConstructorInfo]
    cs)
                            $([Q [Q Exp]] -> Q Exp
    popE ([Q [Q Exp]] -> Q Exp) -> [Q [Q Exp]] -> Q Exp
    forall a b. (a -> b) -> a -> b
    $ (ConstructorInfo -> Q [Q Exp]) -> [ConstructorInfo] -> [Q [Q Exp]]
    forall a b. (a -> b) -> [a] -> [b]
    map ConstructorInfo -> Q [Q Exp]
    mdStrictness [ConstructorInfo]
    cs)
              |]

        mdStrictness :: TH.ConstructorInfo -> Q [Q Exp]
        mdStrictness :: ConstructorInfo -> Q [Q Exp]
    mdStrictness ci :: ConstructorInfo
    ci@(ConstructorInfo { constructorName :: ConstructorInfo -> Name
    constructorName       = Name
    n
                                         , constructorStrictness :: ConstructorInfo -> [FieldStrictness]
    constructorStrictness = [FieldStrictness]
    bs }) =
          ConstructorInfo -> Q [Q Exp] -> Q [Q Exp]
    forall a. ConstructorInfo -> Q a -> Q a
    checkForGADTs ConstructorInfo
    ci (Q [Q Exp] -> Q [Q Exp]) -> Q [Q Exp] -> Q [Q Exp]
    forall a b. (a -> b) -> a -> b
    $ Name -> [FieldStrictness] -> Q [Q Exp]
    mdConStrictness Name
    n [FieldStrictness]
    bs

        mdConStrictness :: Name -> [FieldStrictness] -> Q [Q Exp]
        mdConStrictness :: Name -> [FieldStrictness] -> Q [Q Exp]
    mdConStrictness Name
    n [FieldStrictness]
    bs = do
          dss <- Name -> Q [DecidedStrictness]
    reifyConStrictness Name
    n
          return (zipWith (\ (FieldStrictness Unpackedness
    su Strictness
    ss) DecidedStrictness
    ds ->
            [| SOP.StrictnessInfo
              $(Unpackedness -> Q Exp
    mdTHUnpackedness     Unpackedness
    su)
              $(Strictness -> Q Exp
    mdTHStrictness       Strictness
    ss)
              $(DecidedStrictness -> Q Exp
    mdDecidedStrictness  DecidedStrictness
    ds)
            |]) bs dss)

        mdCon :: TH.ConstructorInfo -> Q Exp
        mdCon :: ConstructorInfo -> Q Exp
    mdCon ci :: ConstructorInfo
    ci@(ConstructorInfo { constructorName :: ConstructorInfo -> Name
    constructorName    = Name
    n
                                  , constructorVariant :: ConstructorInfo -> ConstructorVariant
    constructorVariant = ConstructorVariant
    conVariant }) =
          ConstructorInfo -> Q Exp -> Q Exp
    forall a. ConstructorInfo -> Q a -> Q a
    checkForGADTs ConstructorInfo
    ci (Q Exp -> Q Exp) -> Q Exp -> Q Exp
    forall a b. (a -> b) -> a -> b
    $
          case ConstructorVariant
    conVariant of
            ConstructorVariant
    NormalConstructor    -> [| SOP.Constructor $(String -> Q Exp
    forall (m :: * -> *). Quote m => String -> m Exp
    stringE (Name -> String
    nameBase Name
    n)) |]
            RecordConstructor [Name]
    ts -> [| SOP.Record      $(String -> Q Exp
    forall (m :: * -> *). Quote m => String -> m Exp
    stringE (Name -> String
    nameBase Name
    n))
                                                       $([Q Exp] -> Q Exp
    npE ((Name -> Q Exp) -> [Name] -> [Q Exp]
    forall a b. (a -> b) -> [a] -> [b]
    map Name -> Q Exp
    mdField [Name]
    ts))
                                     |]
            ConstructorVariant
    InfixConstructor     -> do
              fixity <- Name -> Q (Maybe Fixity)
    reifyFixity Name
    n
              case fromMaybe defaultFixity fixity of
                Fixity Int
    f FixityDirection
    a ->       [| SOP.Infix       $(String -> Q Exp
    forall (m :: * -> *). Quote m => String -> m Exp
    stringE (Name -> String
    nameBase Name
    n))
                                                       $(FixityDirection -> Q Exp
    mdAssociativity FixityDirection
    a)
                                                       f
                                     |]

        mdField :: Name -> Q Exp
        mdField :: Name -> Q Exp
    mdField Name
    n = [| SOP.FieldInfo $(String -> Q Exp
    forall (m :: * -> *). Quote m => String -> m Exp
    stringE (Name -> String
    nameBase Name
    n)) |]

        mdTHUnpackedness :: TH.Unpackedness -> Q Exp
        mdTHUnpackedness :: Unpackedness -> Q Exp
    mdTHUnpackedness Unpackedness
    UnspecifiedUnpackedness = [| SOP.NoSourceUnpackedness |]
        mdTHUnpackedness Unpackedness
    NoUnpack                = [| SOP.SourceNoUnpack       |]
        mdTHUnpackedness Unpackedness
    Unpack                  = [| SOP.SourceUnpack         |]

        mdTHStrictness :: TH.Strictness -> Q Exp
        mdTHStrictness :: Strictness -> Q Exp
    mdTHStrictness Strictness
    UnspecifiedStrictness = [| SOP.NoSourceStrictness |]
        mdTHStrictness Strictness
    Lazy                  = [| SOP.SourceLazy         |]
        mdTHStrictness Strictness
    TH.Strict             = [| SOP.SourceStrict       |]

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

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

    -- | Derive type-level metadata.
    metadataType' :: DatatypeVariant -> Name -> [TH.ConstructorInfo] -> Q Type
    metadataType' :: DatatypeVariant -> Name -> [ConstructorInfo] -> Q Type
    metadataType' DatatypeVariant
    dataVariant Name
    typeName [ConstructorInfo]
    cs = Q Type
    md
      where
        md :: Q Type
        md :: Q Type
    md | DatatypeVariant -> Bool
    isNewtypeVariant DatatypeVariant
    dataVariant
           = [t| 'SOP.T.Newtype $(String -> Q Type
    stringT (Name -> String
    nameModule' Name
    typeName))
                                $(String -> Q Type
    stringT (Name -> String
    nameBase Name
    typeName))
                                $(ConstructorInfo -> Q Type
    mdCon ([ConstructorInfo] -> ConstructorInfo
    forall a. HasCallStack => [a] -> a
    head [ConstructorInfo]
    cs))
               |]

           | Bool
    otherwise
           = [t| 'SOP.T.ADT     $(String -> Q Type
    stringT (Name -> String
    nameModule' Name
    typeName))
                                $(String -> Q Type
    stringT (Name -> String
    nameBase Name
    typeName))
                                $([Q Type] -> Q Type
    promotedTypeList ([Q Type] -> Q Type) -> [Q Type] -> Q Type
    forall a b. (a -> b) -> a -> b
    $ (ConstructorInfo -> Q Type) -> [ConstructorInfo] -> [Q Type]
    forall a b. (a -> b) -> [a] -> [b]
    map ConstructorInfo -> Q Type
    mdCon [ConstructorInfo]
    cs)
                                $([Q [Q Type]] -> Q Type
    promotedTypeListOfList ([Q [Q Type]] -> Q Type) -> [Q [Q Type]] -> Q Type
    forall a b. (a -> b) -> a -> b
    $ (ConstructorInfo -> Q [Q Type])
    -> [ConstructorInfo] -> [Q [Q Type]]
    forall a b. (a -> b) -> [a] -> [b]
    map ConstructorInfo -> Q [Q Type]
    mdStrictness [ConstructorInfo]
    cs)
               |]

        mdStrictness :: TH.ConstructorInfo -> Q [Q Type]
        mdStrictness :: ConstructorInfo -> Q [Q Type]
    mdStrictness ci :: ConstructorInfo
    ci@(ConstructorInfo { constructorName :: ConstructorInfo -> Name
    constructorName       = Name
    n
                                         , constructorStrictness :: ConstructorInfo -> [FieldStrictness]
    constructorStrictness = [FieldStrictness]
    bs }) =
          ConstructorInfo -> Q [Q Type] -> Q [Q Type]
    forall a. ConstructorInfo -> Q a -> Q a
    checkForGADTs ConstructorInfo
    ci (Q [Q Type] -> Q [Q Type]) -> Q [Q Type] -> Q [Q Type]
    forall a b. (a -> b) -> a -> b
    $ Name -> [FieldStrictness] -> Q [Q Type]
    mdConStrictness Name
    n [FieldStrictness]
    bs

        mdConStrictness :: Name -> [FieldStrictness] -> Q [Q Type]
        mdConStrictness :: Name -> [FieldStrictness] -> Q [Q Type]
    mdConStrictness Name
    n [FieldStrictness]
    bs = do
          dss <- Name -> Q [DecidedStrictness]
    reifyConStrictness Name
    n
          return (zipWith (\ (FieldStrictness Unpackedness
    su Strictness
    ss) DecidedStrictness
    ds ->
            [t| 'SOP.T.StrictnessInfo
              $(Unpackedness -> Q Type
    mdTHUnpackedness     Unpackedness
    su)
              $(Strictness -> Q Type
    mdTHStrictness       Strictness
    ss)
              $(DecidedStrictness -> Q Type
    mdDecidedStrictness  DecidedStrictness
    ds)
            |]) bs dss)

        mdCon :: TH.ConstructorInfo -> Q Type
        mdCon :: ConstructorInfo -> Q Type
    mdCon ci :: ConstructorInfo
    ci@(ConstructorInfo { constructorName :: ConstructorInfo -> Name
    constructorName    = Name
    n
                                  , constructorVariant :: ConstructorInfo -> ConstructorVariant
    constructorVariant = ConstructorVariant
    conVariant }) =
          ConstructorInfo -> Q Type -> Q Type
    forall a. ConstructorInfo -> Q a -> Q a
    checkForGADTs ConstructorInfo
    ci (Q Type -> Q Type) -> Q Type -> Q Type
    forall a b. (a -> b) -> a -> b
    $
          case ConstructorVariant
    conVariant of
            ConstructorVariant
    NormalConstructor    -> [t| 'SOP.T.Constructor $(String -> Q Type
    stringT (Name -> String
    nameBase Name
    n)) |]
            RecordConstructor [Name]
    ts -> [t| 'SOP.T.Record      $(String -> Q Type
    stringT (Name -> String
    nameBase Name
    n))
                                                           $([Q Type] -> Q Type
    promotedTypeList ((Name -> Q Type) -> [Name] -> [Q Type]
    forall a b. (a -> b) -> [a] -> [b]
    map Name -> Q Type
    mdField [Name]
    ts))
                                      |]
            ConstructorVariant
    InfixConstructor     -> do
              fixity <- Name -> Q (Maybe Fixity)
    reifyFixity Name
    n
              case fromMaybe defaultFixity fixity of
                Fixity Int
    f FixityDirection
    a ->       [t| 'SOP.T.Infix       $(String -> Q Type
    stringT (Name -> String
    nameBase Name
    n))
                                                           $(FixityDirection -> Q Type
    mdAssociativity FixityDirection
    a)
                                                           $(Int -> Q Type
    natT Int
    f)
                                      |]

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

        mdTHUnpackedness :: TH.Unpackedness -> Q Type
        mdTHUnpackedness :: Unpackedness -> Q Type
    mdTHUnpackedness Unpackedness
    UnspecifiedUnpackedness = [t| 'SOP.NoSourceUnpackedness |]
        mdTHUnpackedness Unpackedness
    NoUnpack                = [t| 'SOP.SourceNoUnpack       |]
        mdTHUnpackedness Unpackedness
    Unpack                  = [t| 'SOP.SourceUnpack         |]

        mdTHStrictness :: TH.Strictness -> Q Type
        mdTHStrictness :: Strictness -> Q Type
    mdTHStrictness Strictness
    UnspecifiedStrictness = [t| 'SOP.NoSourceStrictness |]
        mdTHStrictness Strictness
    Lazy                  = [t| 'SOP.SourceLazy         |]
        mdTHStrictness Strictness
    TH.Strict             = [t| 'SOP.SourceStrict       |]

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

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

    nameModule' :: Name -> String
    nameModule' :: Name -> String
    nameModule' = String -> Maybe String -> String
    forall a. a -> Maybe a -> a
    fromMaybe String
    "" (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 :: [Q Exp] -> Q Exp
    npE []     = [| Nil |]
    npE (Q Exp
    e:[Q Exp]
    es) = [| $Q Exp
    e :* $([Q Exp] -> Q Exp
    npE [Q Exp]
    es) |]

    -- Construct a POP.
    popE :: [Q [Q Exp]] -> Q Exp
    popE :: [Q [Q Exp]] -> Q Exp
    popE [Q [Q Exp]]
    ess =
      [| POP $([Q Exp] -> Q Exp
    npE ((Q [Q Exp] -> Q Exp) -> [Q [Q Exp]] -> [Q Exp]
    forall a b. (a -> b) -> [a] -> [b]
    map (Q (Q Exp) -> Q Exp
    forall (m :: * -> *) a. Monad m => m (m a) -> m a
    join (Q (Q Exp) -> Q Exp)
    -> (Q [Q Exp] -> Q (Q Exp)) -> Q [Q Exp] -> Q Exp
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ([Q Exp] -> Q Exp) -> Q [Q Exp] -> Q (Q Exp)
    forall a b. (a -> b) -> Q a -> Q b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    fmap [Q Exp] -> Q Exp
    npE) [Q [Q Exp]]
    ess)) |]

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

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

    conInfo :: TH.ConstructorInfo -> Q (Name, [Q Type])
    conInfo :: ConstructorInfo -> Q (Name, [Q Type])
    conInfo ci :: ConstructorInfo
    ci@(ConstructorInfo { constructorName :: ConstructorInfo -> Name
    constructorName    = Name
    n
                                , constructorFields :: ConstructorInfo -> Cxt
    constructorFields  = Cxt
    ts }) =
      ConstructorInfo -> Q (Name, [Q Type]) -> Q (Name, [Q Type])
    forall a. ConstructorInfo -> Q a -> Q a
    checkForGADTs ConstructorInfo
    ci (Q (Name, [Q Type]) -> Q (Name, [Q Type]))
    -> Q (Name, [Q Type]) -> Q (Name, [Q Type])
    forall a b. (a -> b) -> a -> b
    $ (Name, [Q Type]) -> Q (Name, [Q Type])
    forall a. a -> Q a
    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 a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Cxt
    ts)

    stringT :: String -> Q Type
    stringT :: String -> Q Type
    stringT = Q TyLit -> Q Type
    forall (m :: * -> *). Quote m => m TyLit -> m Type
    litT (Q TyLit -> Q Type) -> (String -> Q TyLit) -> String -> Q Type
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> Q TyLit
    forall (m :: * -> *). Quote m => String -> m TyLit
    strTyLit

    natT :: Int -> Q Type
    natT :: Int -> Q Type
    natT = Q TyLit -> Q Type
    forall (m :: * -> *). Quote m => m TyLit -> m Type
    litT (Q TyLit -> Q Type) -> (Int -> Q TyLit) -> Int -> Q Type
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Integer -> Q TyLit
    forall (m :: * -> *). Quote m => Integer -> m TyLit
    numTyLit (Integer -> Q TyLit) -> (Int -> Integer) -> Int -> Q TyLit
    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
    forall (m :: * -> *). Quote m => m Type
    promotedNilT
    promotedTypeList (Q Type
    t:[Q Type]
    ts) = [t| $Q Type
    forall (m :: * -> *). Quote m => m Type
    promotedConsT $Q Type
    t $([Q Type] -> Q Type
    promotedTypeList [Q Type]
    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 a b. (a -> b) -> Q a -> Q b
    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 Name -> Q Type
    _ []     = Q Type
    forall (m :: * -> *). Quote m => m Type
    promotedNilT
    promotedTypeListSubst Name -> Q Type
    f (Q Type
    t:[Q Type]
    ts) = [t| $Q Type
    forall (m :: * -> *). Quote m => m Type
    promotedConsT $(Q Type
    t Q Type -> (Type -> Q Type) -> Q Type
    forall a b. Q a -> (a -> Q b) -> Q b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= (Name -> Q Type) -> Type -> Q Type
    substType Name -> Q Type
    f) $((Name -> Q Type) -> [Q Type] -> Q Type
    promotedTypeListSubst Name -> Q Type
    f [Q Type]
    ts) |]

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

    appTyVars :: (Name -> Q Type) -> Name -> [TyVarBndrVis] -> Q Type
    appTyVars :: (Name -> Q Type) -> Name -> [TyVarBndrVis] -> Q Type
    appTyVars Name -> Q Type
    f Name
    n [TyVarBndrVis]
    bndrs =
      Name -> [Q Type] -> Q Type
    appsT Name
    n ((TyVarBndrVis -> Q Type) -> [TyVarBndrVis] -> [Q Type]
    forall a b. (a -> b) -> [a] -> [b]
    map (Name -> Q Type
    f (Name -> Q Type)
    -> (TyVarBndrVis -> Name) -> TyVarBndrVis -> Q Type
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . TyVarBndrVis -> Name
    forall flag. TyVarBndr_ flag -> Name
    tvName) [TyVarBndrVis]
    bndrs)

    appTysSubst :: (Name -> Q Type) -> Name -> [Type] -> Q Type
    appTysSubst :: (Name -> Q Type) -> Name -> Cxt -> Q Type
    appTysSubst Name -> Q Type
    f Name
    n Cxt
    args =
      Name -> [Q Type] -> Q Type
    appsT Name
    n ((Type -> Q Type) -> Cxt -> [Q Type]
    forall a b. (a -> b) -> [a] -> [b]
    map ((Name -> Q Type) -> Type -> Q Type
    substType Name -> Q Type
    f (Type -> Q Type) -> (Type -> Type) -> Type -> Q Type
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Type -> Type
    unSigType) Cxt
    args)

    unSigType :: Type -> Type
    unSigType :: Type -> Type
    unSigType (SigT Type
    t Type
    _) = Type
    t
    unSigType Type
    t          = Type
    t

    substType :: (Name -> Q Type) -> Type -> Q Type
    substType :: (Name -> Q Type) -> Type -> Q Type
    substType Name -> Q Type
    f = Type -> Q Type
    go
      where
        go :: Type -> Q Type
    go (VarT Name
    n)     = Name -> Q Type
    f Name
    n
        go (AppT Type
    t1 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 a b. Q (a -> b) -> Q a -> Q b
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
    <*> Type -> Q Type
    go Type
    t2
        go Type
    ListT        = Type -> Q Type
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Type
    ListT
        go (ConT Name
    n)     = Type -> Q Type
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Name -> Type
    ConT Name
    n)
        go Type
    ArrowT       = Type -> Q Type
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Type
    ArrowT
        go (TupleT Int
    i)   = Type -> Q Type
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Int -> Type
    TupleT Int
    i)
        go Type
    t            = Type -> Q Type
    forall a. a -> Q a
    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.

    -- Process a DatatypeInfo using continuation-passing style.
    withDataDec :: TH.DatatypeInfo
                -> (DatatypeVariant
                       -- The variety of data type
                       -- (@data@, @newtype@, @data instance@, or @newtype instance@)
                    -> Cxt
                       -- The datatype context
                    -> Name
                       -- The data type's name
                    -> [TyVarBndrVis]
                       -- The datatype's type variable binders, both implicit and explicit.
                       -- Examples:
                       --
                       -- - For `data Maybe a = Nothing | Just a`, the binders are
                       --   [PlainTV a]
                       -- - For `data Proxy (a :: k) = Proxy`, the binders are
                       --   [PlainTV k, KindedTV a (VarT k)]
                       -- - For `data instance DF Int (Maybe b) = DF b`, the binders are
                       --   [PlainTV b]
                    -> [Type]
                       -- For vanilla data types, these are the explicitly bound
                       -- type variable binders, but in Type form.
                       -- For data family instances, these are the type arguments.
                       -- Examples:
                       --
                       -- - For `data Maybe a = Nothing | Just a`, the types are
                       --   [VarT a]
                       -- - For `data Proxy (a :: k) = Proxy`, the types are
                       --   [SigT (VarT a) (VarT k)]
                       -- - For `data instance DF Int (Maybe b) = DF b`, the binders are
                       --   [ConT ''Int, ConT ''Maybe `AppT` VarT b]
                    -> [TH.ConstructorInfo]
                       -- The data type's constructors
                    -> Q a)
                -> Q a
    withDataDec :: forall a.
    DatatypeInfo
    -> (DatatypeVariant
        -> Cxt
        -> Name
        -> [TyVarBndrVis]
        -> Cxt
        -> [ConstructorInfo]
        -> Q a)
    -> Q a
    withDataDec (TH.DatatypeInfo { datatypeContext :: DatatypeInfo -> Cxt
    datatypeContext   = Cxt
    ctxt
                                 , datatypeName :: DatatypeInfo -> Name
    datatypeName      = Name
    name
                                 , datatypeVars :: DatatypeInfo -> [TyVarBndrUnit]
    datatypeVars      = [TyVarBndrUnit]
    bndrs
                                 , datatypeInstTypes :: DatatypeInfo -> Cxt
    datatypeInstTypes = Cxt
    instTypes
                                 , datatypeVariant :: DatatypeInfo -> DatatypeVariant
    datatypeVariant   = DatatypeVariant
    variant
                                 , datatypeCons :: DatatypeInfo -> [ConstructorInfo]
    datatypeCons      = [ConstructorInfo]
    cons }) DatatypeVariant
    -> Cxt -> Name -> [TyVarBndrVis] -> Cxt -> [ConstructorInfo] -> Q a
    f =
      DatatypeVariant -> Q a -> Q a
    forall a. DatatypeVariant -> Q a -> Q a
    checkForTypeData DatatypeVariant
    variant (Q a -> Q a) -> Q a -> Q a
    forall a b. (a -> b) -> a -> b
    $
      DatatypeVariant
    -> Cxt -> Name -> [TyVarBndrVis] -> Cxt -> [ConstructorInfo] -> Q a
    f DatatypeVariant
    variant Cxt
    ctxt Name
    name (BndrVis -> [TyVarBndrUnit] -> [TyVarBndrVis]
    forall newFlag oldFlag.
    newFlag -> [TyVarBndr_ oldFlag] -> [TyVarBndr_ newFlag]
    changeTVFlags BndrVis
    bndrReq [TyVarBndrUnit]
    bndrs) Cxt
    instTypes [ConstructorInfo]
    cons

    checkForTypeData :: DatatypeVariant -> Q a -> Q a
    checkForTypeData :: forall a. DatatypeVariant -> Q a -> Q a
    checkForTypeData DatatypeVariant
    variant Q a
    q = do
      case DatatypeVariant
    variant of
    #if MIN_VERSION_th_abstraction(0,5,0)
        DatatypeVariant
    TH.TypeData -> String -> Q ()
    forall a. String -> Q a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> Q ()) -> String -> Q ()
    forall a b. (a -> b) -> a -> b
    $ String
    "`type data` declarations not supported"
    #endif
        DatatypeVariant
    _ -> () -> Q ()
    forall a. a -> Q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ()
      Q a
    q

    checkForGADTs :: TH.ConstructorInfo -> Q a -> Q a
    checkForGADTs :: forall a. ConstructorInfo -> Q a -> Q a
    checkForGADTs (ConstructorInfo { constructorVars :: ConstructorInfo -> [TyVarBndrUnit]
    constructorVars    = [TyVarBndrUnit]
    exVars
                                   , constructorContext :: ConstructorInfo -> Cxt
    constructorContext = Cxt
    exCxt }) Q a
    q = do
      Bool -> Q () -> Q ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    unless ([TyVarBndrUnit] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [TyVarBndrUnit]
    exVars) (Q () -> Q ()) -> Q () -> Q ()
    forall a b. (a -> b) -> a -> b
    $ String -> Q ()
    forall a. String -> Q a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail String
    "Existentials not supported"
      Bool -> Q () -> Q ()
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
    unless (Cxt -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null Cxt
    exCxt)  (Q () -> Q ()) -> Q () -> Q ()
    forall a b. (a -> b) -> a -> b
    $ String -> Q ()
    forall a. String -> Q a
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail String
    "GADTs not supported"
      Q a
    q

    isNewtypeVariant :: DatatypeVariant -> Bool
    isNewtypeVariant :: DatatypeVariant -> Bool
    isNewtypeVariant DatatypeVariant
    Datatype        = Bool
    False
    isNewtypeVariant DatatypeVariant
    DataInstance    = Bool
    False
    isNewtypeVariant DatatypeVariant
    Newtype         = Bool
    True
    isNewtypeVariant DatatypeVariant
    NewtypeInstance = Bool
    True
    #if MIN_VERSION_th_abstraction(0,5,0)
    isNewtypeVariant DatatypeVariant
    TH.TypeData     = Bool
    False
    #endif