{-# OPTIONS_HADDOCK not-home #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE StandaloneKindSignatures #-}
{-# LANGUAGE Trustworthy #-}

-- |
-- GHC.Internal.TH.Lib exposes some additional functionality that
-- is used internally in GHC's integration with Template Haskell. This is not a
-- part of the public API, and as such, there are no API guarantees for this
-- module from version to version.

-- Why do we have both GHC.Internal.TH.Lib and
-- Language.Haskell.TH.Lib? Ultimately, it's because the functions in the
-- former (which are tailored for GHC's use) need different type signatures
-- than the ones in the latter. Syncing up the Internal type signatures would
-- involve a massive amount of breaking changes, so for the time being, we
-- relegate as many changes as we can to just the Internal module, where it
-- is safe to break things.

module GHC.Internal.TH.Lib where

import GHC.Internal.TH.Syntax hiding (Role, InjectivityAnn)
import qualified GHC.Internal.TH.Syntax as TH

#ifdef BOOTSTRAP_TH
import Control.Applicative(liftA, Applicative(..))
import qualified Data.Kind as Kind (Type)
import Data.Word( Word8 )
import Data.List.NonEmpty ( NonEmpty(..) )
import GHC.Exts (TYPE)
import Prelude hiding (Applicative(..))
#else
import GHC.Internal.Base hiding (NonEmpty (..), Type, Module, inline)
import GHC.Internal.Data.Foldable
import GHC.Internal.Data.Functor
import GHC.Internal.Data.Maybe
import GHC.Internal.Data.NonEmpty (NonEmpty(..))
import GHC.Internal.Data.Traversable (traverse, sequenceA)
import GHC.Internal.Integer
import GHC.Internal.List (zip)
import GHC.Internal.Real
import GHC.Internal.Show
import GHC.Internal.Word
import qualified GHC.Internal.Types as Kind (Type)
#endif

----------------------------------------------------------
-- * Type synonyms
----------------------------------------------------------

-- | Representation-polymorphic since /template-haskell-2.17.0.0/.
type TExpQ :: TYPE r -> Kind.Type
type TExpQ a = Q (TExp a)

type CodeQ :: TYPE r -> Kind.Type
type CodeQ = Code Q

type InfoQ               = Q Info
type PatQ                = Q Pat
type FieldPatQ           = Q FieldPat
type ExpQ                = Q Exp
type DecQ                = Q Dec
type DecsQ               = Q [Dec]
type Decs                = [Dec] -- Defined as it is more convenient to wire-in
type ConQ                = Q Con
type TypeQ               = Q Type
type KindQ               = Q Kind
type TyLitQ              = Q TyLit
type CxtQ                = Q Cxt
type PredQ               = Q Pred
type DerivClauseQ        = Q DerivClause
type MatchQ              = Q Match
type ClauseQ             = Q Clause
type BodyQ               = Q Body
type GuardQ              = Q Guard
type StmtQ               = Q Stmt
type RangeQ              = Q Range
type SourceStrictnessQ   = Q SourceStrictness
type SourceUnpackednessQ = Q SourceUnpackedness
type BangQ               = Q Bang
type BangTypeQ           = Q BangType
type VarBangTypeQ        = Q VarBangType
type StrictTypeQ         = Q StrictType
type VarStrictTypeQ      = Q VarStrictType
type FieldExpQ           = Q FieldExp
type RuleBndrQ           = Q RuleBndr
type TySynEqnQ           = Q TySynEqn
type PatSynDirQ          = Q PatSynDir
type PatSynArgsQ         = Q PatSynArgs
type FamilyResultSigQ    = Q FamilyResultSig
type DerivStrategyQ      = Q DerivStrategy

-- must be defined here for DsMeta to find it
type Role                = TH.Role
type InjectivityAnn      = TH.InjectivityAnn

type TyVarBndrUnit       = TyVarBndr ()
type TyVarBndrSpec       = TyVarBndr Specificity
type TyVarBndrVis        = TyVarBndr BndrVis

----------------------------------------------------------
-- * Lowercase pattern syntax functions
----------------------------------------------------------

intPrimL    :: Integer -> Lit
intPrimL    = IntPrimL
wordPrimL    :: Integer -> Lit
wordPrimL    = WordPrimL
floatPrimL  :: Rational -> Lit
floatPrimL  = FloatPrimL
doublePrimL :: Rational -> Lit
doublePrimL = DoublePrimL
integerL    :: Integer -> Lit
integerL    = IntegerL
charL       :: Char -> Lit
charL       = CharL
charPrimL   :: Char -> Lit
charPrimL   = CharPrimL
stringL     :: String -> Lit
stringL     = StringL
stringPrimL :: [Word8] -> Lit
stringPrimL = StringPrimL
bytesPrimL :: Bytes -> Lit
bytesPrimL = BytesPrimL
rationalL   :: Rational -> Lit
rationalL   = RationalL

litP :: Quote m => Lit -> m Pat
litP l = pure (LitP l)

varP :: Quote m => Name -> m Pat
varP v = pure (VarP v)

tupP :: Quote m => [m Pat] -> m Pat
tupP ps = do { ps1 <- sequenceA ps; pure (TupP ps1)}

unboxedTupP :: Quote m => [m Pat] -> m Pat
unboxedTupP ps = do { ps1 <- sequenceA ps; pure (UnboxedTupP ps1)}

unboxedSumP :: Quote m => m Pat -> SumAlt -> SumArity -> m Pat
unboxedSumP p alt arity = do { p1 <- p; pure (UnboxedSumP p1 alt arity) }

conP :: Quote m => Name -> [m Type] -> [m Pat] -> m Pat
conP n ts ps = do ps' <- sequenceA ps
                  ts' <- sequenceA ts
                  pure (ConP n ts' ps')
infixP :: Quote m => m Pat -> Name -> m Pat -> m Pat
infixP p1 n p2 = do p1' <- p1
                    p2' <- p2
                    pure (InfixP p1' n p2')
uInfixP :: Quote m => m Pat -> Name -> m Pat -> m Pat
uInfixP p1 n p2 = do p1' <- p1
                     p2' <- p2
                     pure (UInfixP p1' n p2')
parensP :: Quote m => m Pat -> m Pat
parensP p = do p' <- p
               pure (ParensP p')

tildeP :: Quote m => m Pat -> m Pat
tildeP p = do p' <- p
              pure (TildeP p')
bangP :: Quote m => m Pat -> m Pat
bangP p = do p' <- p
             pure (BangP p')
asP :: Quote m => Name -> m Pat -> m Pat
asP n p = do p' <- p
             pure (AsP n p')
wildP :: Quote m => m Pat
wildP = pure WildP
recP :: Quote m => Name -> [m FieldPat] -> m Pat
recP n fps = do fps' <- sequenceA fps
                pure (RecP n fps')
listP :: Quote m => [m Pat] -> m Pat
listP ps = do ps' <- sequenceA ps
              pure (ListP ps')
sigP :: Quote m => m Pat -> m Type -> m Pat
sigP p t = do p' <- p
              t' <- t
              pure (SigP p' t')
typeP :: Quote m => m Type -> m Pat
typeP t = do t' <- t
             pure (TypeP t')
invisP :: Quote m => m Type -> m Pat
invisP t = do t' <- t
              pure (InvisP t')
viewP :: Quote m => m Exp -> m Pat -> m Pat
viewP e p = do e' <- e
               p' <- p
               pure (ViewP e' p')

orP :: Quote m => (NonEmpty (m Pat)) -> m Pat
orP ps = do ps' <- sequenceA ps
            pure (OrP ps')

fieldPat :: Quote m => Name -> m Pat -> m FieldPat
fieldPat n p = do p' <- p
                  pure (n, p')


-------------------------------------------------------------------------------
-- *   Stmt

bindS :: Quote m => m Pat -> m Exp -> m Stmt
bindS p e = liftA2 BindS p e

letS :: Quote m => [m Dec] -> m Stmt
letS ds = do { ds1 <- sequenceA ds; pure (LetS ds1) }

noBindS :: Quote m => m Exp -> m Stmt
noBindS e = do { e1 <- e; pure (NoBindS e1) }

parS :: Quote m => [[m Stmt]] -> m Stmt
parS sss = do { sss1 <- traverse sequenceA sss; pure (ParS sss1) }

recS :: Quote m => [m Stmt] -> m Stmt
recS ss = do { ss1 <- sequenceA ss; pure (RecS ss1) }

-------------------------------------------------------------------------------
-- *   Range

fromR :: Quote m => m Exp -> m Range
fromR x = do { a <- x; pure (FromR a) }

fromThenR :: Quote m => m Exp -> m Exp -> m Range
fromThenR x y = do { a <- x; b <- y; pure (FromThenR a b) }

fromToR :: Quote m => m Exp -> m Exp -> m Range
fromToR x y = do { a <- x; b <- y; pure (FromToR a b) }

fromThenToR :: Quote m => m Exp -> m Exp -> m Exp -> m Range
fromThenToR x y z = do { a <- x; b <- y; c <- z;
                         pure (FromThenToR a b c) }
-------------------------------------------------------------------------------
-- *   Body

normalB :: Quote m => m Exp -> m Body
normalB e = do { e1 <- e; pure (NormalB e1) }

guardedB :: Quote m => [m (Guard,Exp)] -> m Body
guardedB ges = do { ges' <- sequenceA ges; pure (GuardedB ges') }

-------------------------------------------------------------------------------
-- *   Guard

normalG :: Quote m => m Exp -> m Guard
normalG e = do { e1 <- e; pure (NormalG e1) }

normalGE :: Quote m => m Exp -> m Exp -> m (Guard, Exp)
normalGE g e = do { g1 <- g; e1 <- e; pure (NormalG g1, e1) }

patG :: Quote m => [m Stmt] -> m Guard
patG ss = do { ss' <- sequenceA ss; pure (PatG ss') }

patGE :: Quote m => [m Stmt] -> m Exp -> m (Guard, Exp)
patGE ss e = do { ss' <- sequenceA ss;
                  e'  <- e;
                  pure (PatG ss', e') }

-------------------------------------------------------------------------------
-- *   Match and Clause

-- | Use with 'caseE'
match :: Quote m => m Pat -> m Body -> [m Dec] -> m Match
match p rhs ds = do { p' <- p;
                      r' <- rhs;
                      ds' <- sequenceA ds;
                      pure (Match p' r' ds') }

-- | Use with 'funD'
clause :: Quote m => [m Pat] -> m Body -> [m Dec] -> m Clause
clause ps r ds = do { ps' <- sequenceA ps;
                      r' <- r;
                      ds' <- sequenceA ds;
                      pure (Clause ps' r' ds') }

---------------------------------------------------------------------------
-- *   Exp

-- | Dynamically binding a variable (unhygienic)
dyn :: Quote m => String -> m Exp
dyn s = pure (VarE (mkName s))

varE :: Quote m => Name -> m Exp
varE s = pure (VarE s)

conE :: Quote m => Name -> m Exp
conE s =  pure (ConE s)

litE :: Quote m => Lit -> m Exp
litE c = pure (LitE c)

appE :: Quote m => m Exp -> m Exp -> m Exp
appE x y = do { a <- x; b <- y; pure (AppE a b)}

appTypeE :: Quote m => m Exp -> m Type -> m Exp
appTypeE x t = do { a <- x; s <- t; pure (AppTypeE a s) }

parensE :: Quote m => m Exp -> m Exp
parensE x = do { x' <- x; pure (ParensE x') }

uInfixE :: Quote m => m Exp -> m Exp -> m Exp -> m Exp
uInfixE x s y = do { x' <- x; s' <- s; y' <- y;
                     pure (UInfixE x' s' y') }

infixE :: Quote m => Maybe (m Exp) -> m Exp -> Maybe (m Exp) -> m Exp
infixE (Just x) s (Just y) = do { a <- x; s' <- s; b <- y;
                                  pure (InfixE (Just a) s' (Just b))}
infixE Nothing  s (Just y) = do { s' <- s; b <- y;
                                  pure (InfixE Nothing s' (Just b))}
infixE (Just x) s Nothing  = do { a <- x; s' <- s;
                                  pure (InfixE (Just a) s' Nothing)}
infixE Nothing  s Nothing  = do { s' <- s; pure (InfixE Nothing s' Nothing) }

infixApp :: Quote m => m Exp -> m Exp -> m Exp -> m Exp
infixApp x y z = infixE (Just x) y (Just z)
sectionL :: Quote m => m Exp -> m Exp -> m Exp
sectionL x y = infixE (Just x) y Nothing
sectionR :: Quote m => m Exp -> m Exp -> m Exp
sectionR x y = infixE Nothing x (Just y)

lamE :: Quote m => [m Pat] -> m Exp -> m Exp
lamE ps e = do ps' <- sequenceA ps
               e' <- e
               pure (LamE ps' e')

-- | Single-arg lambda
lam1E :: Quote m => m Pat -> m Exp -> m Exp
lam1E p e = lamE [p] e

-- | Lambda-case (@\case@)
lamCaseE :: Quote m => [m Match] -> m Exp
lamCaseE ms = LamCaseE <$> sequenceA ms

-- | Lambda-cases (@\cases@)
lamCasesE :: Quote m => [m Clause] -> m Exp
lamCasesE ms = LamCasesE <$> sequenceA ms

tupE :: Quote m => [Maybe (m Exp)] -> m Exp
tupE es = do { es1 <- traverse sequenceA es; pure (TupE es1)}

unboxedTupE :: Quote m => [Maybe (m Exp)] -> m Exp
unboxedTupE es = do { es1 <- traverse sequenceA es; pure (UnboxedTupE es1)}

unboxedSumE :: Quote m => m Exp -> SumAlt -> SumArity -> m Exp
unboxedSumE e alt arity = do { e1 <- e; pure (UnboxedSumE e1 alt arity) }

condE :: Quote m => m Exp -> m Exp -> m Exp -> m Exp
condE x y z =  do { a <- x; b <- y; c <- z; pure (CondE a b c)}

multiIfE :: Quote m => [m (Guard, Exp)] -> m Exp
multiIfE alts = MultiIfE <$> sequenceA alts

letE :: Quote m => [m Dec] -> m Exp -> m Exp
letE ds e = do { ds2 <- sequenceA ds; e2 <- e; pure (LetE ds2 e2) }

caseE :: Quote m => m Exp -> [m Match] -> m Exp
caseE e ms = do { e1 <- e; ms1 <- sequenceA ms; pure (CaseE e1 ms1) }

doE :: Quote m => Maybe ModName -> [m Stmt] -> m Exp
doE m ss = do { ss1 <- sequenceA ss; pure (DoE m ss1) }

mdoE :: Quote m => Maybe ModName -> [m Stmt] -> m Exp
mdoE m ss = do { ss1 <- sequenceA ss; pure (MDoE m ss1) }

compE :: Quote m => [m Stmt] -> m Exp
compE ss = do { ss1 <- sequenceA ss; pure (CompE ss1) }

arithSeqE :: Quote m => m Range -> m Exp
arithSeqE r = do { r' <- r; pure (ArithSeqE r') }

listE :: Quote m => [m Exp] -> m Exp
listE es = do { es1 <- sequenceA es; pure (ListE es1) }

sigE :: Quote m => m Exp -> m Type -> m Exp
sigE e t = do { e1 <- e; t1 <- t; pure (SigE e1 t1) }

recConE :: Quote m => Name -> [m (Name,Exp)] -> m Exp
recConE c fs = do { flds <- sequenceA fs; pure (RecConE c flds) }

recUpdE :: Quote m => m Exp -> [m (Name,Exp)] -> m Exp
recUpdE e fs = do { e1 <- e; flds <- sequenceA fs; pure (RecUpdE e1 flds) }

stringE :: Quote m => String -> m Exp
stringE = litE . stringL

fieldExp :: Quote m => Name -> m Exp -> m (Name, Exp)
fieldExp s e = do { e' <- e; pure (s,e') }

-- | @staticE x = [| static x |]@
staticE :: Quote m => m Exp -> m Exp
staticE = fmap StaticE

unboundVarE :: Quote m => Name -> m Exp
unboundVarE s = pure (UnboundVarE s)

labelE :: Quote m => String -> m Exp
labelE s = pure (LabelE s)

implicitParamVarE :: Quote m => String -> m Exp
implicitParamVarE n = pure (ImplicitParamVarE n)

getFieldE :: Quote m => m Exp -> String -> m Exp
getFieldE e f = do
  e' <- e
  pure (GetFieldE e' f)

projectionE :: Quote m => NonEmpty String -> m Exp
projectionE xs = pure (ProjectionE xs)

typedSpliceE :: Quote m => m Exp -> m Exp
typedSpliceE = fmap TypedSpliceE

typedBracketE :: Quote m => m Exp -> m Exp
typedBracketE = fmap TypedBracketE

-- ** 'arithSeqE' Shortcuts
fromE :: Quote m => m Exp -> m Exp
fromE x = do { a <- x; pure (ArithSeqE (FromR a)) }

fromThenE :: Quote m => m Exp -> m Exp -> m Exp
fromThenE x y = do { a <- x; b <- y; pure (ArithSeqE (FromThenR a b)) }

fromToE :: Quote m => m Exp -> m Exp -> m Exp
fromToE x y = do { a <- x; b <- y; pure (ArithSeqE (FromToR a b)) }

fromThenToE :: Quote m => m Exp -> m Exp -> m Exp -> m Exp
fromThenToE x y z = do { a <- x; b <- y; c <- z;
                         pure (ArithSeqE (FromThenToR a b c)) }

typeE :: Quote m => m Type -> m Exp
typeE = fmap TypeE

forallE :: Quote m => [m (TyVarBndr Specificity)] -> m Exp -> m Exp
forallE tvars body = ForallE <$> sequenceA tvars <*> body

forallVisE :: Quote m => [m (TyVarBndr ())] -> m Exp -> m Exp
forallVisE tvars body = ForallVisE <$> sequenceA tvars <*> body

constrainedE :: Quote m => [m Exp] -> m Exp -> m Exp
constrainedE ctx body = ConstrainedE <$> sequenceA ctx <*> body

-------------------------------------------------------------------------------
-- *   Dec

valD :: Quote m => m Pat -> m Body -> [m Dec] -> m Dec
valD p b ds =
  do { p' <- p
     ; ds' <- sequenceA ds
     ; b' <- b
     ; pure (ValD p' b' ds')
     }

funD :: Quote m => Name -> [m Clause] -> m Dec
funD nm cs =
 do { cs1 <- sequenceA cs
    ; pure (FunD nm cs1)
    }

tySynD :: Quote m => Name -> [m (TyVarBndr BndrVis)] -> m Type -> m Dec
tySynD tc tvs rhs =
  do { tvs1 <- sequenceA tvs
     ; rhs1 <- rhs
     ; pure (TySynD tc tvs1 rhs1)
     }

dataD :: Quote m => m Cxt -> Name -> [m (TyVarBndr BndrVis)] -> Maybe (m Kind) -> [m Con]
      -> [m DerivClause] -> m Dec
dataD ctxt tc tvs ksig cons derivs =
  do
    ctxt1   <- ctxt
    tvs1    <- sequenceA tvs
    ksig1   <- sequenceA ksig
    cons1   <- sequenceA cons
    derivs1 <- sequenceA derivs
    pure (DataD ctxt1 tc tvs1 ksig1 cons1 derivs1)

newtypeD :: Quote m => m Cxt -> Name -> [m (TyVarBndr BndrVis)] -> Maybe (m Kind) -> m Con
         -> [m DerivClause] -> m Dec
newtypeD ctxt tc tvs ksig con derivs =
  do
    ctxt1   <- ctxt
    tvs1    <- sequenceA tvs
    ksig1   <- sequenceA ksig
    con1    <- con
    derivs1 <- sequenceA derivs
    pure (NewtypeD ctxt1 tc tvs1 ksig1 con1 derivs1)

typeDataD :: Quote m => Name -> [m (TyVarBndr BndrVis)] -> Maybe (m Kind) -> [m Con]
      -> m Dec
typeDataD tc tvs ksig cons =
  do
    tvs1    <- sequenceA tvs
    ksig1   <- sequenceA ksig
    cons1   <- sequenceA cons
    pure (TypeDataD tc tvs1 ksig1 cons1)

classD :: Quote m => m Cxt -> Name -> [m (TyVarBndr BndrVis)] -> [FunDep] -> [m Dec] -> m Dec
classD ctxt cls tvs fds decs =
  do
    tvs1  <- sequenceA tvs
    decs1 <- sequenceA decs
    ctxt1 <- ctxt
    pure $ ClassD ctxt1 cls tvs1 fds decs1

instanceD :: Quote m => m Cxt -> m Type -> [m Dec] -> m Dec
instanceD = instanceWithOverlapD Nothing

instanceWithOverlapD :: Quote m => Maybe Overlap -> m Cxt -> m Type -> [m Dec] -> m Dec
instanceWithOverlapD o ctxt ty decs =
  do
    ctxt1 <- ctxt
    decs1 <- sequenceA decs
    ty1   <- ty
    pure $ InstanceD o ctxt1 ty1 decs1



sigD :: Quote m => Name -> m Type -> m Dec
sigD fun ty = liftA (SigD fun) $ ty

kiSigD :: Quote m => Name -> m Kind -> m Dec
kiSigD fun ki = liftA (KiSigD fun) $ ki

forImpD :: Quote m => Callconv -> Safety -> String -> Name -> m Type -> m Dec
forImpD cc s str n ty
 = do ty' <- ty
      pure $ ForeignD (ImportF cc s str n ty')

infixLD :: Quote m => Int -> Name -> m Dec
infixLD prec = infixLWithSpecD prec NoNamespaceSpecifier

infixRD :: Quote m => Int -> Name -> m Dec
infixRD prec = infixRWithSpecD prec NoNamespaceSpecifier

infixND :: Quote m => Int -> Name -> m Dec
infixND prec = infixNWithSpecD prec NoNamespaceSpecifier

infixLWithSpecD :: Quote m => Int -> NamespaceSpecifier -> Name -> m Dec
infixLWithSpecD prec ns_spec nm = pure (InfixD (Fixity prec InfixL) ns_spec nm)

infixRWithSpecD :: Quote m => Int -> NamespaceSpecifier -> Name -> m Dec
infixRWithSpecD prec ns_spec nm = pure (InfixD (Fixity prec InfixR) ns_spec nm)

infixNWithSpecD :: Quote m => Int -> NamespaceSpecifier -> Name -> m Dec
infixNWithSpecD prec ns_spec nm = pure (InfixD (Fixity prec InfixN) ns_spec nm)

defaultD :: Quote m => [m Type] -> m Dec
defaultD tys = DefaultD <$> sequenceA tys

pragInlD :: Quote m => Name -> Inline -> RuleMatch -> Phases -> m Dec
pragInlD name inline rm phases
  = pure $ PragmaD $ InlineP name inline rm phases

pragOpaqueD :: Quote m => Name -> m Dec
pragOpaqueD name = pure $ PragmaD $ OpaqueP name

pragSpecED :: Quote m
           => Maybe [m (TyVarBndr ())] -> [m RuleBndr]
           -> m Exp
           -> Phases
           -> m Dec
pragSpecED ty_bndrs tm_bndrs expr phases
  = do
      ty_bndrs1    <- traverse sequenceA ty_bndrs
      tm_bndrs1    <- sequenceA tm_bndrs
      expr1        <- expr
      pure $ PragmaD $ SpecialiseEP ty_bndrs1 tm_bndrs1 expr1 Nothing phases

pragSpecInlED :: Quote m
              => Maybe [m (TyVarBndr ())] -> [m RuleBndr]
              -> m Exp
              -> Inline
              -> Phases
              -> m Dec
pragSpecInlED ty_bndrs tm_bndrs expr inl phases
  = do
      ty_bndrs1    <- traverse sequenceA ty_bndrs
      tm_bndrs1    <- sequenceA tm_bndrs
      expr1        <- expr
      pure $ PragmaD $ SpecialiseEP ty_bndrs1 tm_bndrs1 expr1 (Just inl) phases

pragSpecInstD :: Quote m => m Type -> m Dec
pragSpecInstD ty
  = do
      ty1    <- ty
      pure $ PragmaD $ SpecialiseInstP ty1

pragRuleD :: Quote m => String -> Maybe [m (TyVarBndr ())] -> [m RuleBndr] -> m Exp -> m Exp
          -> Phases -> m Dec
pragRuleD n ty_bndrs tm_bndrs lhs rhs phases
  = do
      ty_bndrs1 <- traverse sequenceA ty_bndrs
      tm_bndrs1 <- sequenceA tm_bndrs
      lhs1   <- lhs
      rhs1   <- rhs
      pure $ PragmaD $ RuleP n ty_bndrs1 tm_bndrs1 lhs1 rhs1 phases

pragAnnD :: Quote m => AnnTarget -> m Exp -> m Dec
pragAnnD target expr
  = do
      exp1 <- expr
      pure $ PragmaD $ AnnP target exp1

pragLineD :: Quote m => Int -> String -> m Dec
pragLineD line file = pure $ PragmaD $ LineP line file

pragCompleteD :: Quote m => [Name] -> Maybe Name -> m Dec
pragCompleteD cls mty = pure $ PragmaD $ CompleteP cls mty

pragSCCFunD :: Quote m => Name -> m Dec
pragSCCFunD nm = pure $ PragmaD $ SCCP nm Nothing

pragSCCFunNamedD :: Quote m => Name -> String -> m Dec
pragSCCFunNamedD nm str = pure $ PragmaD $ SCCP nm (Just str)

dataInstD :: Quote m => m Cxt -> (Maybe [m (TyVarBndr ())]) -> m Type -> Maybe (m Kind) -> [m Con]
          -> [m DerivClause] -> m Dec
dataInstD ctxt mb_bndrs ty ksig cons derivs =
  do
    ctxt1   <- ctxt
    mb_bndrs1 <- traverse sequenceA mb_bndrs
    ty1    <- ty
    ksig1   <- sequenceA ksig
    cons1   <- sequenceA cons
    derivs1 <- sequenceA derivs
    pure (DataInstD ctxt1 mb_bndrs1 ty1 ksig1 cons1 derivs1)

newtypeInstD :: Quote m => m Cxt -> (Maybe [m (TyVarBndr ())]) -> m Type -> Maybe (m Kind) -> m Con
             -> [m DerivClause] -> m Dec
newtypeInstD ctxt mb_bndrs ty ksig con derivs =
  do
    ctxt1   <- ctxt
    mb_bndrs1 <- traverse sequenceA mb_bndrs
    ty1    <- ty
    ksig1   <- sequenceA ksig
    con1    <- con
    derivs1 <- sequenceA derivs
    pure (NewtypeInstD ctxt1 mb_bndrs1 ty1 ksig1 con1 derivs1)

tySynInstD :: Quote m => m TySynEqn -> m Dec
tySynInstD eqn =
  do
    eqn1 <- eqn
    pure (TySynInstD eqn1)

dataFamilyD :: Quote m => Name -> [m (TyVarBndr BndrVis)] -> Maybe (m Kind) -> m Dec
dataFamilyD tc tvs kind =
  do tvs'  <- sequenceA tvs
     kind' <- sequenceA kind
     pure $ DataFamilyD tc tvs' kind'

openTypeFamilyD :: Quote m => Name -> [m (TyVarBndr BndrVis)] -> m FamilyResultSig
                -> Maybe InjectivityAnn -> m Dec
openTypeFamilyD tc tvs res inj =
  do tvs' <- sequenceA tvs
     res' <- res
     pure $ OpenTypeFamilyD (TypeFamilyHead tc tvs' res' inj)

closedTypeFamilyD :: Quote m => Name -> [m (TyVarBndr BndrVis)] -> m FamilyResultSig
                  -> Maybe InjectivityAnn -> [m TySynEqn] -> m Dec
closedTypeFamilyD tc tvs result injectivity eqns =
  do tvs1    <- sequenceA tvs
     result1 <- result
     eqns1   <- sequenceA eqns
     pure (ClosedTypeFamilyD (TypeFamilyHead tc tvs1 result1 injectivity) eqns1)

roleAnnotD :: Quote m => Name -> [Role] -> m Dec
roleAnnotD name roles = pure $ RoleAnnotD name roles

standaloneDerivD :: Quote m => m Cxt -> m Type -> m Dec
standaloneDerivD = standaloneDerivWithStrategyD Nothing

standaloneDerivWithStrategyD :: Quote m => Maybe (m DerivStrategy) -> m Cxt -> m Type -> m Dec
standaloneDerivWithStrategyD mdsq ctxtq tyq =
  do
    mds  <- sequenceA mdsq
    ctxt <- ctxtq
    ty   <- tyq
    pure $ StandaloneDerivD mds ctxt ty

defaultSigD :: Quote m => Name -> m Type -> m Dec
defaultSigD n tyq =
  do
    ty <- tyq
    pure $ DefaultSigD n ty

-- | Pattern synonym declaration
patSynD :: Quote m => Name -> m PatSynArgs -> m PatSynDir -> m Pat -> m Dec
patSynD name args dir pat = do
  args'    <- args
  dir'     <- dir
  pat'     <- pat
  pure (PatSynD name args' dir' pat')

-- | Pattern synonym type signature
patSynSigD :: Quote m => Name -> m Type -> m Dec
patSynSigD nm ty =
  do ty' <- ty
     pure $ PatSynSigD nm ty'

-- | Implicit parameter binding declaration. Can only be used in let
-- and where clauses which consist entirely of implicit bindings.
implicitParamBindD :: Quote m => String -> m Exp -> m Dec
implicitParamBindD n e =
  do
    e' <- e
    pure $ ImplicitParamBindD n e'

tySynEqn :: Quote m => (Maybe [m (TyVarBndr ())]) -> m Type -> m Type -> m TySynEqn
tySynEqn mb_bndrs lhs rhs =
  do
    mb_bndrs1 <- traverse sequenceA mb_bndrs
    lhs1 <- lhs
    rhs1 <- rhs
    pure (TySynEqn mb_bndrs1 lhs1 rhs1)

cxt :: Quote m => [m Pred] -> m Cxt
cxt = sequenceA

derivClause :: Quote m => Maybe (m DerivStrategy) -> [m Pred] -> m DerivClause
derivClause mds p = do mds' <- sequenceA mds
                       p'   <- cxt p
                       pure $ DerivClause mds' p'

stockStrategy :: Quote m => m DerivStrategy
stockStrategy = pure StockStrategy

anyclassStrategy :: Quote m => m DerivStrategy
anyclassStrategy = pure AnyclassStrategy

newtypeStrategy :: Quote m => m DerivStrategy
newtypeStrategy = pure NewtypeStrategy

viaStrategy :: Quote m => m Type -> m DerivStrategy
viaStrategy = fmap ViaStrategy

normalC :: Quote m => Name -> [m BangType] -> m Con
normalC con strtys = liftA (NormalC con) $ sequenceA strtys

recC :: Quote m => Name -> [m VarBangType] -> m Con
recC con varstrtys = liftA (RecC con) $ sequenceA varstrtys

infixC :: Quote m => m (Bang, Type) -> Name -> m (Bang, Type) -> m Con
infixC st1 con st2 = do st1' <- st1
                        st2' <- st2
                        pure $ InfixC st1' con st2'

forallC :: Quote m => [m (TyVarBndr Specificity)] -> m Cxt -> m Con -> m Con
forallC ns ctxt con = do
  ns'   <- sequenceA ns
  ctxt' <- ctxt
  con'  <- con
  pure $ ForallC ns' ctxt' con'

gadtC :: Quote m => [Name] -> [m StrictType] -> m Type -> m Con
gadtC cons strtys ty = liftA2 (GadtC cons) (sequenceA strtys) ty

recGadtC :: Quote m => [Name] -> [m VarStrictType] -> m Type -> m Con
recGadtC cons varstrtys ty = liftA2 (RecGadtC cons) (sequenceA varstrtys) ty

-------------------------------------------------------------------------------
-- *   Type

forallT :: Quote m => [m (TyVarBndr Specificity)] -> m Cxt -> m Type -> m Type
forallT tvars ctxt ty = do
    tvars1 <- sequenceA tvars
    ctxt1  <- ctxt
    ty1    <- ty
    pure $ ForallT tvars1 ctxt1 ty1

forallVisT :: Quote m => [m (TyVarBndr ())] -> m Type -> m Type
forallVisT tvars ty = ForallVisT <$> sequenceA tvars <*> ty

varT :: Quote m => Name -> m Type
varT = pure . VarT

conT :: Quote m => Name -> m Type
conT = pure . ConT

infixT :: Quote m => m Type -> Name -> m Type -> m Type
infixT t1 n t2 = do t1' <- t1
                    t2' <- t2
                    pure (InfixT t1' n t2')

uInfixT :: Quote m => m Type -> Name -> m Type -> m Type
uInfixT t1 n t2 = do t1' <- t1
                     t2' <- t2
                     pure (UInfixT t1' n t2')

promotedInfixT :: Quote m => m Type -> Name -> m Type -> m Type
promotedInfixT t1 n t2 = do t1' <- t1
                            t2' <- t2
                            pure (PromotedInfixT t1' n t2')

promotedUInfixT :: Quote m => m Type -> Name -> m Type -> m Type
promotedUInfixT t1 n t2 = do t1' <- t1
                             t2' <- t2
                             pure (PromotedUInfixT t1' n t2')

parensT :: Quote m => m Type -> m Type
parensT t = do t' <- t
               pure (ParensT t')

appT :: Quote m => m Type -> m Type -> m Type
appT t1 t2 = do
           t1' <- t1
           t2' <- t2
           pure $ AppT t1' t2'

appKindT :: Quote m => m Type -> m Kind -> m Type
appKindT ty ki = do
               ty' <- ty
               ki' <- ki
               pure $ AppKindT ty' ki'

arrowT :: Quote m => m Type
arrowT = pure ArrowT

mulArrowT :: Quote m => m Type
mulArrowT = pure MulArrowT

listT :: Quote m => m Type
listT = pure ListT

litT :: Quote m => m TyLit -> m Type
litT l = fmap LitT l

tupleT :: Quote m => Int -> m Type
tupleT i = pure (TupleT i)

unboxedTupleT :: Quote m => Int -> m Type
unboxedTupleT i = pure (UnboxedTupleT i)

unboxedSumT :: Quote m => SumArity -> m Type
unboxedSumT arity = pure (UnboxedSumT arity)

sigT :: Quote m => m Type -> m Kind -> m Type
sigT t k
  = do
      t' <- t
      k' <- k
      pure $ SigT t' k'

equalityT :: Quote m => m Type
equalityT = pure EqualityT

wildCardT :: Quote m => m Type
wildCardT = pure WildCardT

implicitParamT :: Quote m => String -> m Type -> m Type
implicitParamT n t
  = do
      t' <- t
      pure $ ImplicitParamT n t'

promotedT :: Quote m => Name -> m Type
promotedT = pure . PromotedT

promotedTupleT :: Quote m => Int -> m Type
promotedTupleT i = pure (PromotedTupleT i)

promotedNilT :: Quote m => m Type
promotedNilT = pure PromotedNilT

promotedConsT :: Quote m => m Type
promotedConsT = pure PromotedConsT

noSourceUnpackedness, sourceNoUnpack, sourceUnpack :: Quote m => m SourceUnpackedness
noSourceUnpackedness = pure NoSourceUnpackedness
sourceNoUnpack       = pure SourceNoUnpack
sourceUnpack         = pure SourceUnpack

noSourceStrictness, sourceLazy, sourceStrict :: Quote m => m SourceStrictness
noSourceStrictness = pure NoSourceStrictness
sourceLazy         = pure SourceLazy
sourceStrict       = pure SourceStrict

bang :: Quote m => m SourceUnpackedness -> m SourceStrictness -> m Bang
bang u s = do u' <- u
              s' <- s
              pure (Bang u' s')

bangType :: Quote m => m Bang -> m Type -> m BangType
bangType = liftA2 (,)

varBangType :: Quote m => Name -> m BangType -> m VarBangType
varBangType v bt = (\(b, t) -> (v, b, t)) <$> bt

-- * Type Literals

-- MonadFail here complicates things (a lot) because it would mean we would
-- have to emit a MonadFail constraint during typechecking if there was any
-- chance the desugaring would use numTyLit, which in general is hard to
-- predict.
numTyLit :: Quote m => Integer -> m TyLit
numTyLit n = if n >= 0 then pure (NumTyLit n)
                       else error ("Negative type-level number: " ++ show n)

strTyLit :: Quote m => String -> m TyLit
strTyLit s = pure (StrTyLit s)

charTyLit :: Quote m => Char -> m TyLit
charTyLit c = pure (CharTyLit c)

-------------------------------------------------------------------------------
-- *   Kind

plainTV :: Quote m => Name -> m (TyVarBndr ())
plainTV n = pure $ PlainTV n ()

plainInvisTV :: Quote m => Name -> Specificity -> m (TyVarBndr Specificity)
plainInvisTV n s = pure $ PlainTV n s

plainBndrTV :: Quote m => Name -> BndrVis -> m (TyVarBndr BndrVis)
plainBndrTV n v = pure $ PlainTV n v

kindedTV :: Quote m => Name -> m Kind -> m (TyVarBndr ())
kindedTV n = fmap (KindedTV n ())

kindedInvisTV :: Quote m => Name -> Specificity -> m Kind -> m (TyVarBndr Specificity)
kindedInvisTV n s = fmap (KindedTV n s)

kindedBndrTV :: Quote m => Name -> BndrVis -> m Kind -> m (TyVarBndr BndrVis)
kindedBndrTV n v = fmap (KindedTV n v)

specifiedSpec :: Specificity
specifiedSpec = SpecifiedSpec

inferredSpec :: Specificity
inferredSpec = InferredSpec

bndrReq :: BndrVis
bndrReq = BndrReq

bndrInvis :: BndrVis
bndrInvis = BndrInvis

varK :: Name -> Kind
varK = VarT

conK :: Name -> Kind
conK = ConT

tupleK :: Int -> Kind
tupleK = TupleT

arrowK ::  Kind
arrowK = ArrowT

listK ::  Kind
listK = ListT

appK :: Kind -> Kind -> Kind
appK = AppT

starK :: Quote m => m Kind
starK = pure StarT

constraintK :: Quote m => m Kind
constraintK = pure ConstraintT

-------------------------------------------------------------------------------
-- *   Type family result

noSig :: Quote m => m FamilyResultSig
noSig = pure NoSig

kindSig :: Quote m => m Kind -> m FamilyResultSig
kindSig = fmap KindSig

tyVarSig :: Quote m => m (TyVarBndr ()) -> m FamilyResultSig
tyVarSig = fmap TyVarSig

-------------------------------------------------------------------------------
-- *   Injectivity annotation

injectivityAnn :: Name -> [Name] -> InjectivityAnn
injectivityAnn = TH.InjectivityAnn

-------------------------------------------------------------------------------
-- *   Role

nominalR, representationalR, phantomR, inferR :: Role
nominalR          = NominalR
representationalR = RepresentationalR
phantomR          = PhantomR
inferR            = InferR

-------------------------------------------------------------------------------
-- *   Callconv

cCall, stdCall, cApi, prim, javaScript :: Callconv
cCall      = CCall
stdCall    = StdCall
cApi       = CApi
prim       = Prim
javaScript = JavaScript

-------------------------------------------------------------------------------
-- *   Safety

unsafe, safe, interruptible :: Safety
unsafe = Unsafe
safe = Safe
interruptible = Interruptible

-------------------------------------------------------------------------------
-- *   FunDep

funDep ::  [Name] -> [Name] -> FunDep
funDep = FunDep

-------------------------------------------------------------------------------
-- *   RuleBndr
ruleVar :: Quote m => Name -> m RuleBndr
ruleVar = pure . RuleVar

typedRuleVar :: Quote m => Name -> m Type -> m RuleBndr
typedRuleVar n ty = TypedRuleVar n <$> ty

-------------------------------------------------------------------------------
-- *   AnnTarget
valueAnnotation ::  Name -> AnnTarget
valueAnnotation = ValueAnnotation

typeAnnotation ::  Name -> AnnTarget
typeAnnotation = TypeAnnotation

moduleAnnotation :: AnnTarget
moduleAnnotation = ModuleAnnotation

-------------------------------------------------------------------------------
-- * Pattern Synonyms (sub constructs)

unidir, implBidir :: Quote m => m PatSynDir
unidir    = pure Unidir
implBidir = pure ImplBidir

explBidir :: Quote m => [m Clause] -> m PatSynDir
explBidir cls = do
  cls' <- sequenceA cls
  pure (ExplBidir cls')

prefixPatSyn :: Quote m => [Name] -> m PatSynArgs
prefixPatSyn args = pure $ PrefixPatSyn args

recordPatSyn :: Quote m => [Name] -> m PatSynArgs
recordPatSyn sels = pure $ RecordPatSyn sels

infixPatSyn :: Quote m => Name -> Name -> m PatSynArgs
infixPatSyn arg1 arg2 = pure $ InfixPatSyn arg1 arg2

--------------------------------------------------------------
-- * Useful helper function

appsE :: Quote m => [m Exp] -> m Exp
appsE [] = error "appsE []"
appsE [x] = x
appsE (x:y:zs) = appsE ( (appE x y) : zs )

-- | pure the Module at the place of splicing.  Can be used as an
-- input for 'reifyModule'.
thisModule :: Q Module
thisModule = do
  loc <- location
  pure $ Module (mkPkgName $ loc_package loc) (mkModName $ loc_module loc)

--------------------------------------------------------------
-- * Documentation combinators

-- | Attaches Haddock documentation to the declaration provided. Unlike
-- 'putDoc', the names do not need to be in scope when calling this function so
-- it can be used for quoted declarations and anything else currently being
-- spliced.
-- Not all declarations can have documentation attached to them. For those that
-- can't, 'withDecDoc' will return it unchanged without any side effects.
withDecDoc :: String -> Q Dec -> Q Dec
withDecDoc doc dec = do
  dec' <- dec
  case doc_loc dec' of
    Just loc -> qAddModFinalizer $ qPutDoc loc doc
    Nothing  -> pure ()
  pure dec'
  where
    doc_loc (FunD n _)                                     = Just $ DeclDoc n
    doc_loc (ValD (VarP n) _ _)                            = Just $ DeclDoc n
    doc_loc (DataD _ n _ _ _ _)                            = Just $ DeclDoc n
    doc_loc (NewtypeD _ n _ _ _ _)                         = Just $ DeclDoc n
    doc_loc (TypeDataD n _ _ _)                            = Just $ DeclDoc n
    doc_loc (TySynD n _ _)                                 = Just $ DeclDoc n
    doc_loc (ClassD _ n _ _ _)                             = Just $ DeclDoc n
    doc_loc (SigD n _)                                     = Just $ DeclDoc n
    doc_loc (ForeignD (ImportF _ _ _ n _))                 = Just $ DeclDoc n
    doc_loc (ForeignD (ExportF _ _ n _))                   = Just $ DeclDoc n
    doc_loc (InfixD _ _ n)                                 = Just $ DeclDoc n
    doc_loc (DataFamilyD n _ _)                            = Just $ DeclDoc n
    doc_loc (OpenTypeFamilyD (TypeFamilyHead n _ _ _))     = Just $ DeclDoc n
    doc_loc (ClosedTypeFamilyD (TypeFamilyHead n _ _ _) _) = Just $ DeclDoc n
    doc_loc (PatSynD n _ _ _)                              = Just $ DeclDoc n
    doc_loc (PatSynSigD n _)                               = Just $ DeclDoc n

    -- For instances we just pass along the full type
    doc_loc (InstanceD _ _ t _)           = Just $ InstDoc t
    doc_loc (DataInstD _ _ t _ _ _)       = Just $ InstDoc t
    doc_loc (NewtypeInstD _ _ t _ _ _)    = Just $ InstDoc t
    doc_loc (TySynInstD (TySynEqn _ t _)) = Just $ InstDoc t

    -- Declarations that can't have documentation attached to
    -- ValDs that aren't a simple variable pattern
    doc_loc (ValD _ _ _)             = Nothing
    doc_loc (KiSigD _ _)             = Nothing
    doc_loc (PragmaD _)              = Nothing
    doc_loc (RoleAnnotD _ _)         = Nothing
    doc_loc (StandaloneDerivD _ _ _) = Nothing
    doc_loc (DefaultSigD _ _)        = Nothing
    doc_loc (ImplicitParamBindD _ _) = Nothing
    doc_loc (DefaultD _)             = Nothing

-- | Variant of 'withDecDoc' that applies the same documentation to
-- multiple declarations. Useful for documenting quoted declarations.
withDecsDoc :: String -> Q [Dec] -> Q [Dec]
withDecsDoc doc decs = decs >>= mapM (withDecDoc doc . pure)

-- | Variant of 'funD' that attaches Haddock documentation.
funD_doc :: Name -> [Q Clause]
         -> Maybe String -- ^ Documentation to attach to function
         -> [Maybe String] -- ^ Documentation to attach to arguments
         -> Q Dec
funD_doc nm cs mfun_doc arg_docs = do
  qAddModFinalizer $ sequence_
    [putDoc (ArgDoc nm i) s | (i, Just s) <- zip [0..] arg_docs]
  let dec = funD nm cs
  case mfun_doc of
    Just fun_doc -> withDecDoc fun_doc dec
    Nothing -> funD nm cs

-- | Variant of 'dataD' that attaches Haddock documentation.
dataD_doc :: Q Cxt -> Name -> [Q (TyVarBndr BndrVis)] -> Maybe (Q Kind)
          -> [(Q Con, Maybe String, [Maybe String])]
          -- ^ List of constructors, documentation for the constructor, and
          -- documentation for the arguments
          -> [Q DerivClause]
          -> Maybe String
          -- ^ Documentation to attach to the data declaration
          -> Q Dec
dataD_doc ctxt tc tvs ksig cons_with_docs derivs mdoc = do
  qAddModFinalizer $ mapM_ docCons cons_with_docs
  let dec = dataD ctxt tc tvs ksig (map (\(con, _, _) -> con) cons_with_docs) derivs
  maybe dec (flip withDecDoc dec) mdoc

-- | Variant of 'newtypeD' that attaches Haddock documentation.
newtypeD_doc :: Q Cxt -> Name -> [Q (TyVarBndr BndrVis)] -> Maybe (Q Kind)
             -> (Q Con, Maybe String, [Maybe String])
             -- ^ The constructor, documentation for the constructor, and
             -- documentation for the arguments
             -> [Q DerivClause]
             -> Maybe String
             -- ^ Documentation to attach to the newtype declaration
             -> Q Dec
newtypeD_doc ctxt tc tvs ksig con_with_docs@(con, _, _) derivs mdoc = do
  qAddModFinalizer $ docCons con_with_docs
  let dec = newtypeD ctxt tc tvs ksig con derivs
  maybe dec (flip withDecDoc dec) mdoc

-- | Variant of 'typeDataD' that attaches Haddock documentation.
typeDataD_doc :: Name -> [Q (TyVarBndr BndrVis)] -> Maybe (Q Kind)
          -> [(Q Con, Maybe String, [Maybe String])]
          -- ^ List of constructors, documentation for the constructor, and
          -- documentation for the arguments
          -> Maybe String
          -- ^ Documentation to attach to the data declaration
          -> Q Dec
typeDataD_doc tc tvs ksig cons_with_docs mdoc = do
  qAddModFinalizer $ mapM_ docCons cons_with_docs
  let dec = typeDataD tc tvs ksig (map (\(con, _, _) -> con) cons_with_docs)
  maybe dec (flip withDecDoc dec) mdoc

-- | Variant of 'dataInstD' that attaches Haddock documentation.
dataInstD_doc :: Q Cxt -> (Maybe [Q (TyVarBndr ())]) -> Q Type -> Maybe (Q Kind)
              -> [(Q Con, Maybe String, [Maybe String])]
              -- ^ List of constructors, documentation for the constructor, and
              -- documentation for the arguments
              -> [Q DerivClause]
              -> Maybe String
              -- ^ Documentation to attach to the instance declaration
              -> Q Dec
dataInstD_doc ctxt mb_bndrs ty ksig cons_with_docs derivs mdoc = do
  qAddModFinalizer $ mapM_ docCons cons_with_docs
  let dec = dataInstD ctxt mb_bndrs ty ksig (map (\(con, _, _) -> con) cons_with_docs)
              derivs
  maybe dec (flip withDecDoc dec) mdoc

-- | Variant of 'newtypeInstD' that attaches Haddock documentation.
newtypeInstD_doc :: Q Cxt -> (Maybe [Q (TyVarBndr ())]) -> Q Type
                 -> Maybe (Q Kind)
                 -> (Q Con, Maybe String, [Maybe String])
                 -- ^ The constructor, documentation for the constructor, and
                 -- documentation for the arguments
                 -> [Q DerivClause]
                 -> Maybe String
                 -- ^ Documentation to attach to the instance declaration
                 -> Q Dec
newtypeInstD_doc ctxt mb_bndrs ty ksig con_with_docs@(con, _, _) derivs mdoc = do
  qAddModFinalizer $ docCons con_with_docs
  let dec = newtypeInstD ctxt mb_bndrs ty ksig con derivs
  maybe dec (flip withDecDoc dec) mdoc

-- | Variant of 'patSynD' that attaches Haddock documentation.
patSynD_doc :: Name -> Q PatSynArgs -> Q PatSynDir -> Q Pat
            -> Maybe String   -- ^ Documentation to attach to the pattern synonym
            -> [Maybe String] -- ^ Documentation to attach to the pattern arguments
            -> Q Dec
patSynD_doc name args dir pat mdoc arg_docs = do
  qAddModFinalizer $ sequence_
    [putDoc (ArgDoc name i) s | (i, Just s) <- zip [0..] arg_docs]
  let dec = patSynD name args dir pat
  maybe dec (flip withDecDoc dec) mdoc

-- | Document a data/newtype constructor with its arguments.
docCons :: (Q Con, Maybe String, [Maybe String]) -> Q ()
docCons (c, md, arg_docs) = do
  c' <- c
  -- Attach docs to the constructors
  sequence_ [ putDoc (DeclDoc nm) d | Just d <- [md], nm <- get_cons_names c' ]
  -- Attach docs to the arguments
  case c' of
    -- Record selector documentation isn't stored in the argument map,
    -- but in the declaration map instead
    RecC _ var_bang_types ->
      sequence_ [ putDoc (DeclDoc nm) arg_doc
                  | (Just arg_doc, (nm, _, _)) <- zip arg_docs var_bang_types
                ]
    _ ->
      sequence_ [ putDoc (ArgDoc nm i) arg_doc
                    | nm <- get_cons_names c'
                    , (i, Just arg_doc) <- zip [0..] arg_docs
                ]