    {- Language/Haskell/TH/Desugar.hs

    (c) Richard Eisenberg 2013
    rae@cs.brynmawr.edu
    -}

    {-# LANGUAGE CPP, MultiParamTypeClasses, FunctionalDependencies,
                 TypeSynonymInstances, FlexibleInstances, LambdaCase,
                 ScopedTypeVariables #-}

    -----------------------------------------------------------------------------

    -- |

    -- Module      :  Language.Haskell.TH.Desugar

    -- Copyright   :  (C) 2014 Richard Eisenberg

    -- License     :  BSD-style (see LICENSE)

    -- Maintainer  :  Ryan Scott

    -- Stability   :  experimental

    -- Portability :  non-portable

    --

    -- Desugars full Template Haskell syntax into a smaller core syntax for further

    -- processing.

    --

    ----------------------------------------------------------------------------

    module Language.Haskell.TH.Desugar (
      -- * Desugared data types

      DExp(..), DLetDec(..), DPat(..),
      DType(..), DForallTelescope(..), DKind, DCxt, DPred,
      DTyVarBndr(..), DTyVarBndrSpec, DTyVarBndrUnit, Specificity(..),
      DMatch(..), DClause(..), DDec(..),
      DDerivClause(..), DDerivStrategy(..), DPatSynDir(..), DPatSynType,
      Overlap(..), PatSynArgs(..), DataFlavor(..),
      DTypeFamilyHead(..), DFamilyResultSig(..), InjectivityAnn(..),
      DCon(..), DConFields(..), DDeclaredInfix, DBangType, DVarBangType,
      Bang(..), SourceUnpackedness(..), SourceStrictness(..),
      DForeign(..),
      DPragma(..), DRuleBndr(..), DTySynEqn(..), DInfo(..), DInstanceDec,
      Role(..), AnnTarget(..),

      -- * The 'Desugar' class

      Desugar(..),

      -- * Main desugaring functions

      dsExp, dsDecs, dsType, dsInfo,
      dsPatOverExp, dsPatsOverExp, dsPatX,
      dsLetDecs, dsTvb, dsTvbSpec, dsTvbUnit, dsCxt,
      dsCon, dsForeign, dsPragma, dsRuleBndr,

      -- ** Secondary desugaring functions

      PatM, dsPred, dsPat, dsDec, dsDataDec, dsDataInstDec,
      DerivingClause, dsDerivClause, dsLetDec,
      dsMatches, dsBody, dsGuards, dsDoStmts, dsComp, dsClauses,
      dsBangType, dsVarBangType,
      dsTypeFamilyHead, dsFamilyResultSig,
    #if __GLASGOW_HASKELL__ >= 801
      dsPatSynDir,
    #endif
      dsTypeArg,

      -- * Converting desugared AST back to TH AST

      module Language.Haskell.TH.Desugar.Sweeten,

      -- * Expanding type synonyms

      expand, expandType,

      -- * Reification

      reifyWithWarning,

      -- ** Local reification

      -- $localReification

      withLocalDeclarations, dsReify, dsReifyType,
      reifyWithLocals_maybe, reifyWithLocals, reifyFixityWithLocals,
      reifyTypeWithLocals_maybe, reifyTypeWithLocals,
      lookupValueNameWithLocals, lookupTypeNameWithLocals,
      mkDataNameWithLocals, mkTypeNameWithLocals,
      reifyNameSpace,
      DsMonad(..), DsM,

      -- * Nested pattern flattening

      scExp, scLetDec,

      -- * Capture-avoiding substitution and utilities

      module Language.Haskell.TH.Desugar.Subst,

      -- * Free variable calculation

      module Language.Haskell.TH.Desugar.FV,

      -- * Utility functions

      applyDExp,
      dPatToDExp, removeWilds,
      getDataD, dataConNameToDataName, dataConNameToCon,
      nameOccursIn, allNamesIn, flattenDValD, getRecordSelectors,
      mkTypeName, mkDataName, newUniqueName,
      mkTupleDExp, mkTupleDPat, maybeDLetE, maybeDCaseE, mkDLamEFromDPats,
      tupleDegree_maybe, tupleNameDegree_maybe,
      unboxedSumDegree_maybe, unboxedSumNameDegree_maybe,
      unboxedTupleDegree_maybe, unboxedTupleNameDegree_maybe,
      isTypeKindName, typeKindName, bindIP,
      mkExtraDKindBinders, dTyVarBndrToDType, changeDTVFlags, toposortTyVarsOf,

      -- ** 'FunArgs' and 'VisFunArg'

      FunArgs(..), ForallTelescope(..), VisFunArg(..),
      filterVisFunArgs, ravelType, unravelType,

      -- ** 'DFunArgs' and 'DVisFunArg'

      DFunArgs(..), DVisFunArg(..),
      filterDVisFunArgs, ravelDType, unravelDType,

      -- ** 'TypeArg'

      TypeArg(..), applyType, filterTANormals, unfoldType,

      -- ** 'DTypeArg'

      DTypeArg(..), applyDType, filterDTANormals, unfoldDType,

      -- ** Extracting bound names

      extractBoundNamesStmt, extractBoundNamesDec, extractBoundNamesPat
      ) where

    import Language.Haskell.TH.Datatype.TyVarBndr
    import Language.Haskell.TH.Desugar.AST
    import Language.Haskell.TH.Desugar.Core
    import Language.Haskell.TH.Desugar.Expand
    import Language.Haskell.TH.Desugar.FV
    import Language.Haskell.TH.Desugar.Match
    import Language.Haskell.TH.Desugar.Reify
    import Language.Haskell.TH.Desugar.Subst
    import Language.Haskell.TH.Desugar.Sweeten
    import Language.Haskell.TH.Desugar.Util
    import Language.Haskell.TH.Syntax

    import Control.Monad
    import qualified Data.Foldable as F
    import Data.Function
    import qualified Data.Map as M
    import qualified Data.Set as S
    import Prelude hiding ( exp )

    -- | This class relates a TH type with its th-desugar type and allows

    -- conversions back and forth. The functional dependency goes only one

    -- way because we define the following instances on old versions of GHC:

    --

    -- @

    -- instance 'Desugar' 'TyVarBndrSpec' 'DTyVarBndrSpec'

    -- instance 'Desugar' 'TyVarBndrUnit' 'DTyVarBndrUnit'

    -- @

    --

    -- Prior to GHC 9.0, 'TyVarBndrSpec' and 'TyVarBndrUnit' are simply type

    -- synonyms for 'TyVarBndr', so making the functional dependencies

    -- bidirectional would cause these instances to be rejected.

    class Desugar th ds | ds -> th where
      desugar :: DsMonad q => th -> q ds
      sweeten :: ds -> th

    instance Desugar Exp DExp where
      desugar :: forall (q :: * -> *). DsMonad q => Exp -> q DExp
    desugar = Exp -> q DExp
    forall (q :: * -> *). DsMonad q => Exp -> q DExp
    dsExp
      sweeten :: DExp -> Exp
    sweeten = DExp -> Exp
    expToTH

    instance Desugar Type DType where
      desugar :: forall (q :: * -> *). DsMonad q => Type -> q DType
    desugar = Type -> q DType
    forall (q :: * -> *). DsMonad q => Type -> q DType
    dsType
      sweeten :: DType -> Type
    sweeten = DType -> Type
    typeToTH

    instance Desugar Cxt DCxt where
      desugar :: forall (q :: * -> *). DsMonad q => Cxt -> q DCxt
    desugar = Cxt -> q DCxt
    forall (q :: * -> *). DsMonad q => Cxt -> q DCxt
    dsCxt
      sweeten :: DCxt -> Cxt
    sweeten = DCxt -> Cxt
    cxtToTH

    #if __GLASGOW_HASKELL__ >= 900
    -- | This instance is only @flag@-polymorphic on GHC 9.0 or later, since

    -- previous versions of GHC do not equip 'TyVarBndr' with a @flag@ type

    -- parameter. As a result, we define two separate instances for 'DTyVarBndr'

    -- on older GHCs:

    --

    -- @

    -- instance 'Desugar' 'TyVarBndrSpec' 'DTyVarBndrSpec'

    -- instance 'Desugar' 'TyVarBndrUnit' 'DTyVarBndrUnit'

    -- @

    instance Desugar (TyVarBndr flag) (DTyVarBndr flag) where
      desugar :: forall (q :: * -> *).
    DsMonad q =>
    TyVarBndr flag -> q (DTyVarBndr flag)
    desugar = TyVarBndr flag -> q (DTyVarBndr flag)
    forall (q :: * -> *) flag.
    DsMonad q =>
    TyVarBndr_ flag -> q (DTyVarBndr flag)
    dsTvb
      sweeten :: DTyVarBndr flag -> TyVarBndr flag
    sweeten = DTyVarBndr flag -> TyVarBndr flag
    forall flag. DTyVarBndr flag -> TyVarBndr flag
    tvbToTH
    #else
    -- | This instance monomorphizes the @flag@ parameter of 'DTyVarBndr' since

    -- pre-9.0 versions of GHC do not equip 'TyVarBndr' with a @flag@ type

    -- parameter. There is also a corresponding instance for

    -- 'TyVarBndrUnit'/'DTyVarBndrUnit'.

    instance Desugar TyVarBndrSpec DTyVarBndrSpec where
      desugar = dsTvbSpec
      sweeten = tvbToTH

    -- | This instance monomorphizes the @flag@ parameter of 'DTyVarBndr' since

    -- pre-9.0 versions of GHC do not equip 'TyVarBndr' with a @flag@ type

    -- parameter. There is also a corresponding instance for

    -- 'TyVarBndrSpec'/'DTyVarBndrSpec'.

    instance Desugar TyVarBndrUnit DTyVarBndrUnit where
      desugar = dsTvbUnit
      sweeten = tvbToTH
    #endif

    instance Desugar [Dec] [DDec] where
      desugar :: forall (q :: * -> *). DsMonad q => [Dec] -> q [DDec]
    desugar = [Dec] -> q [DDec]
    forall (q :: * -> *). DsMonad q => [Dec] -> q [DDec]
    dsDecs
      sweeten :: [DDec] -> [Dec]
    sweeten = [DDec] -> [Dec]
    decsToTH

    instance Desugar TypeArg DTypeArg where
      desugar :: forall (q :: * -> *). DsMonad q => TypeArg -> q DTypeArg
    desugar = TypeArg -> q DTypeArg
    forall (q :: * -> *). DsMonad q => TypeArg -> q DTypeArg
    dsTypeArg
      sweeten :: DTypeArg -> TypeArg
    sweeten = DTypeArg -> TypeArg
    typeArgToTH

    -- | If the declaration passed in is a 'DValD', creates new, equivalent

    -- declarations such that the 'DPat' in all 'DValD's is just a plain

    -- 'DVarPa'. Other declarations are passed through unchanged.

    -- Note that the declarations that come out of this function are rather

    -- less efficient than those that come in: they have many more pattern

    -- matches.

    flattenDValD :: Quasi q => DLetDec -> q [DLetDec]
    flattenDValD :: forall (q :: * -> *). Quasi q => DLetDec -> q [DLetDec]
    flattenDValD dec :: DLetDec
    dec@(DValD (DVarP Name
    _) DExp
    _) = [DLetDec] -> q [DLetDec]
    forall a. a -> q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return [DLetDec
    dec]
    flattenDValD (DValD DPat
    pat DExp
    exp) = do
      Name
    x <- String -> q Name
    forall (q :: * -> *). Quasi q => String -> q Name
    newUniqueName String
    "x" -- must use newUniqueName here because we might be top-level

      let top_val_d :: DLetDec
    top_val_d = DPat -> DExp -> DLetDec
    DValD (Name -> DPat
    DVarP Name
    x) DExp
    exp
          bound_names :: [Name]
    bound_names = OSet Name -> [Name]
    forall a. OSet a -> [a]
    forall (t :: * -> *) a. Foldable t => t a -> [a]
    F.toList (OSet Name -> [Name]) -> OSet Name -> [Name]
    forall a b. (a -> b) -> a -> b
    $ DPat -> OSet Name
    extractBoundNamesDPat DPat
    pat
      [DLetDec]
    other_val_ds <- (Name -> q DLetDec) -> [Name] -> q [DLetDec]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
    mapM (Name -> Name -> q DLetDec
    forall {m :: * -> *}. Quasi m => Name -> Name -> m DLetDec
    mk_val_d Name
    x) [Name]
    bound_names
      [DLetDec] -> q [DLetDec]
    forall a. a -> q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([DLetDec] -> q [DLetDec]) -> [DLetDec] -> q [DLetDec]
    forall a b. (a -> b) -> a -> b
    $ DLetDec
    top_val_d DLetDec -> [DLetDec] -> [DLetDec]
    forall a. a -> [a] -> [a]
    : [DLetDec]
    other_val_ds
      where
        mk_val_d :: Name -> Name -> m DLetDec
    mk_val_d Name
    x Name
    name = do
          Name
    y <- String -> m Name
    forall (q :: * -> *). Quasi q => String -> q Name
    newUniqueName String
    "y"
          let pat' :: DPat
    pat'  = Name -> Name -> DPat -> DPat
    wildify Name
    name Name
    y DPat
    pat
              match :: DMatch
    match = DPat -> DExp -> DMatch
    DMatch DPat
    pat' (Name -> DExp
    DVarE Name
    y)
              cas :: DExp
    cas   = DExp -> [DMatch] -> DExp
    DCaseE (Name -> DExp
    DVarE Name
    x) [DMatch
    match]
          DLetDec -> m DLetDec
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return (DLetDec -> m DLetDec) -> DLetDec -> m DLetDec
    forall a b. (a -> b) -> a -> b
    $ DPat -> DExp -> DLetDec
    DValD (Name -> DPat
    DVarP Name
    name) DExp
    cas

        wildify :: Name -> Name -> DPat -> DPat
    wildify Name
    name Name
    y DPat
    p =
          case DPat
    p of
            DLitP Lit
    lit -> Lit -> DPat
    DLitP Lit
    lit
            DVarP Name
    n
              | Name
    n Name -> Name -> Bool
    forall a. Eq a => a -> a -> Bool
    == Name
    name -> Name -> DPat
    DVarP Name
    y
              | Bool
    otherwise -> DPat
    DWildP
            DConP Name
    con DCxt
    ts [DPat]
    ps -> Name -> DCxt -> [DPat] -> DPat
    DConP Name
    con DCxt
    ts ((DPat -> DPat) -> [DPat] -> [DPat]
    forall a b. (a -> b) -> [a] -> [b]
    map (Name -> Name -> DPat -> DPat
    wildify Name
    name Name
    y) [DPat]
    ps)
            DTildeP DPat
    pa -> DPat -> DPat
    DTildeP (Name -> Name -> DPat -> DPat
    wildify Name
    name Name
    y DPat
    pa)
            DBangP DPat
    pa -> DPat -> DPat
    DBangP (Name -> Name -> DPat -> DPat
    wildify Name
    name Name
    y DPat
    pa)
            DSigP DPat
    pa DType
    ty -> DPat -> DType -> DPat
    DSigP (Name -> Name -> DPat -> DPat
    wildify Name
    name Name
    y DPat
    pa) DType
    ty
            DPat
    DWildP -> DPat
    DWildP

    flattenDValD DLetDec
    other_dec = [DLetDec] -> q [DLetDec]
    forall a. a -> q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return [DLetDec
    other_dec]

    -- | Produces 'DLetDec's representing the record selector functions from

    -- the provided 'DCon's.

    --

    -- Note that if the same record selector appears in multiple constructors,

    -- 'getRecordSelectors' will return only one binding for that selector.

    -- For example, if you had:

    --

    -- @

    -- data X = X1 {y :: Symbol} | X2 {y :: Symbol}

    -- @

    --

    -- Then calling 'getRecordSelectors' on @[X1, X2]@ will return:

    --

    -- @

    -- [ DSigD y (DAppT (DAppT DArrowT (DConT X)) (DConT Symbol))

    -- , DFunD y [ DClause [DConP X1 [DVarP field]] (DVarE field)

    --           , DClause [DConP X2 [DVarP field]] (DVarE field) ] ]

    -- @

    --

    -- instead of returning one binding for @X1@ and another binding for @X2@.

    --

    -- 'getRecordSelectors' does not attempt to filter out \"naughty\" record

    -- selectors—that is, records whose field types mention existentially

    -- quantified type variables that do not appear in the constructor's return

    -- type. Here is an example of a naughty record selector:

    --

    -- @

    -- data Some :: (Type -> Type) -> Type where

    --   MkSome :: { getSome :: f a } -> Some f

    -- @

    --

    -- GHC itself will not allow the use of @getSome@ as a top-level function due

    -- to its type @f a@ mentioning the existential variable @a@, but

    -- 'getRecordSelectors' will return it nonetheless. Ultimately, this design

    -- choice is a practical one, as detecting which type variables are existential

    -- in Template Haskell is difficult in the general case.

    getRecordSelectors :: DsMonad q => [DCon] -> q [DLetDec]
    getRecordSelectors :: forall (q :: * -> *). DsMonad q => [DCon] -> q [DLetDec]
    getRecordSelectors [DCon]
    cons = [DLetDec] -> [DLetDec]
    merge_let_decs ([DLetDec] -> [DLetDec]) -> q [DLetDec] -> q [DLetDec]
    forall a b. (a -> b) -> q a -> q b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    `fmap` (DCon -> q [DLetDec]) -> [DCon] -> q [DLetDec]
    forall (monad :: * -> *) monoid (t :: * -> *) a.
    (Monad monad, Monoid monoid, Traversable t) =>
    (a -> monad monoid) -> t a -> monad monoid
    concatMapM DCon -> q [DLetDec]
    forall {m :: * -> *}. Quasi m => DCon -> m [DLetDec]
    get_record_sels [DCon]
    cons
      where
        get_record_sels :: DCon -> m [DLetDec]
    get_record_sels (DCon [DTyVarBndrSpec]
    con_tvbs DCxt
    _ Name
    con_name DConFields
    con_fields DType
    con_ret_ty) =
          case DConFields
    con_fields of
            DRecC [DVarBangType]
    fields -> [DVarBangType] -> m [DLetDec]
    forall {m :: * -> *} {b}.
    Quasi m =>
    [(Name, b, DType)] -> m [DLetDec]
    go [DVarBangType]
    fields
            DNormalC{}   -> [DLetDec] -> m [DLetDec]
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return []
            where
              go :: [(Name, b, DType)] -> m [DLetDec]
    go [(Name, b, DType)]
    fields = do
                Name
    varName <- String -> m Name
    forall (q :: * -> *). Quasi q => String -> q Name
    qNewName String
    "field"
                [DLetDec] -> m [DLetDec]
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return ([DLetDec] -> m [DLetDec]) -> [DLetDec] -> m [DLetDec]
    forall a b. (a -> b) -> a -> b
    $ [[DLetDec]] -> [DLetDec]
    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
    concat
                  [ [ Name -> DType -> DLetDec
    DSigD Name
    name (DType -> DLetDec) -> DType -> DLetDec
    forall a b. (a -> b) -> a -> b
    $ DForallTelescope -> DType -> DType
    DForallT ([DTyVarBndrSpec] -> DForallTelescope
    DForallInvis [DTyVarBndrSpec]
    con_tvbs)
                                 (DType -> DType) -> DType -> DType
    forall a b. (a -> b) -> a -> b
    $ DType
    DArrowT DType -> DType -> DType
    `DAppT` DType
    con_ret_ty DType -> DType -> DType
    `DAppT` DType
    field_ty
                    , Name -> [DClause] -> DLetDec
    DFunD Name
    name [[DPat] -> DExp -> DClause
    DClause [Name -> DCxt -> [DPat] -> DPat
    DConP Name
    con_name []
                                             (Int -> Int -> Name -> [DPat]
    mk_field_pats Int
    n ([(Name, b, DType)] -> Int
    forall a. [a] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [(Name, b, DType)]
    fields) Name
    varName)]
                                          (Name -> DExp
    DVarE Name
    varName)] ]
                  | ((Name
    name, b
    _strict, DType
    field_ty), Int
    n) <- [(Name, b, DType)] -> [Int] -> [((Name, b, DType), Int)]
    forall a b. [a] -> [b] -> [(a, b)]
    zip [(Name, b, DType)]
    fields [Int
    0..]
                  ]

        mk_field_pats :: Int -> Int -> Name -> [DPat]
        mk_field_pats :: Int -> Int -> Name -> [DPat]
    mk_field_pats Int
    0 Int
    total Name
    name = Name -> DPat
    DVarP Name
    name DPat -> [DPat] -> [DPat]
    forall a. a -> [a] -> [a]
    : (Int -> DPat -> [DPat]
    forall a. Int -> a -> [a]
    replicate (Int
    totalInt -> Int -> Int
    forall a. Num a => a -> a -> a
    -Int
    1) DPat
    DWildP)
        mk_field_pats Int
    n Int
    total Name
    name = DPat
    DWildP DPat -> [DPat] -> [DPat]
    forall a. a -> [a] -> [a]
    : Int -> Int -> Name -> [DPat]
    mk_field_pats (Int
    nInt -> Int -> Int
    forall a. Num a => a -> a -> a
    -Int
    1) (Int
    totalInt -> Int -> Int
    forall a. Num a => a -> a -> a
    -Int
    1) Name
    name

        merge_let_decs :: [DLetDec] -> [DLetDec]
        merge_let_decs :: [DLetDec] -> [DLetDec]
    merge_let_decs [DLetDec]
    decs =
          let (Map Name [DClause]
    name_clause_map, [DLetDec]
    decs') = Map Name [DClause]
    -> Set Name -> [DLetDec] -> (Map Name [DClause], [DLetDec])
    gather_decs Map Name [DClause]
    forall k a. Map k a
    M.empty Set Name
    forall a. Set a
    S.empty [DLetDec]
    decs
           in Map Name [DClause] -> [DLetDec] -> [DLetDec]
    augment_clauses Map Name [DClause]
    name_clause_map [DLetDec]
    decs'
            -- First, for each record selector-related declarations, do the following:

            --

            -- 1. If it's a DFunD...

            --   a. If we haven't encountered it before, add a mapping from its Name

            --      to its associated DClauses, and continue.

            --   b. If we have encountered it before, augment the existing Name's

            --      mapping with the new clauses. Then remove the DFunD from the list

            --      and continue.

            -- 2. If it's a DSigD...

            --   a. If we haven't encountered it before, remember its Name and continue.

            --   b. If we have encountered it before, remove the DSigD from the list

            --      and continue.

            -- 3. Otherwise, continue.

            --

            -- After this, scan over the resulting list once more with the mapping

            -- that we accumulated. For every DFunD, replace its DClauses with the

            -- ones corresponding to its Name in the mapping.

            --

            -- Note that this algorithm combines all of the DClauses for each unique

            -- Name, while preserving the order in which the DFunDs were originally

            -- found. Moreover, it removes duplicate DSigD entries. Using Maps and

            -- Sets avoid quadratic blowup for data types with many record selectors.

          where
            gather_decs :: M.Map Name [DClause] -> S.Set Name -> [DLetDec]
                        -> (M.Map Name [DClause], [DLetDec])
            gather_decs :: Map Name [DClause]
    -> Set Name -> [DLetDec] -> (Map Name [DClause], [DLetDec])
    gather_decs Map Name [DClause]
    name_clause_map Set Name
    _ [] = (Map Name [DClause]
    name_clause_map, [])
            gather_decs Map Name [DClause]
    name_clause_map Set Name
    type_sig_names (DLetDec
    x:[DLetDec]
    xs)
              -- 1.

              | DFunD Name
    n [DClause]
    clauses <- DLetDec
    x
              = let name_clause_map' :: Map Name [DClause]
    name_clause_map' = ([DClause] -> [DClause] -> [DClause])
    -> Name -> [DClause] -> Map Name [DClause] -> Map Name [DClause]
    forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
    M.insertWith (\[DClause]
    new [DClause]
    old -> [DClause]
    old [DClause] -> [DClause] -> [DClause]
    forall a. [a] -> [a] -> [a]
    ++ [DClause]
    new)
                                                    Name
    n [DClause]
    clauses Map Name [DClause]
    name_clause_map
                 in if Name
    n Name -> Map Name [DClause] -> Bool
    forall k a. Ord k => k -> Map k a -> Bool
    `M.member` Map Name [DClause]
    name_clause_map
                    then Map Name [DClause]
    -> Set Name -> [DLetDec] -> (Map Name [DClause], [DLetDec])
    gather_decs Map Name [DClause]
    name_clause_map' Set Name
    type_sig_names [DLetDec]
    xs
                    else let (Map Name [DClause]
    map', [DLetDec]
    decs') = Map Name [DClause]
    -> Set Name -> [DLetDec] -> (Map Name [DClause], [DLetDec])
    gather_decs Map Name [DClause]
    name_clause_map'
                                               Set Name
    type_sig_names [DLetDec]
    xs
                          in (Map Name [DClause]
    map', DLetDec
    xDLetDec -> [DLetDec] -> [DLetDec]
    forall a. a -> [a] -> [a]
    :[DLetDec]
    decs')

              -- 2.

              | DSigD Name
    n DType
    _ <- DLetDec
    x
              = if Name
    n Name -> Set Name -> Bool
    forall a. Ord a => a -> Set a -> Bool
    `S.member` Set Name
    type_sig_names
                then Map Name [DClause]
    -> Set Name -> [DLetDec] -> (Map Name [DClause], [DLetDec])
    gather_decs Map Name [DClause]
    name_clause_map Set Name
    type_sig_names [DLetDec]
    xs
                else let (Map Name [DClause]
    map', [DLetDec]
    decs') = Map Name [DClause]
    -> Set Name -> [DLetDec] -> (Map Name [DClause], [DLetDec])
    gather_decs Map Name [DClause]
    name_clause_map
                                           (Name
    n Name -> Set Name -> Set Name
    forall a. Ord a => a -> Set a -> Set a
    `S.insert` Set Name
    type_sig_names) [DLetDec]
    xs
                      in (Map Name [DClause]
    map', DLetDec
    xDLetDec -> [DLetDec] -> [DLetDec]
    forall a. a -> [a] -> [a]
    :[DLetDec]
    decs')

              -- 3.

              | Bool
    otherwise =
                  let (Map Name [DClause]
    map', [DLetDec]
    decs') = Map Name [DClause]
    -> Set Name -> [DLetDec] -> (Map Name [DClause], [DLetDec])
    gather_decs Map Name [DClause]
    name_clause_map Set Name
    type_sig_names [DLetDec]
    xs
                   in (Map Name [DClause]
    map', DLetDec
    xDLetDec -> [DLetDec] -> [DLetDec]
    forall a. a -> [a] -> [a]
    :[DLetDec]
    decs')

            augment_clauses :: M.Map Name [DClause] -> [DLetDec] -> [DLetDec]
            augment_clauses :: Map Name [DClause] -> [DLetDec] -> [DLetDec]
    augment_clauses Map Name [DClause]
    _ [] = []
            augment_clauses Map Name [DClause]
    name_clause_map (DLetDec
    x:[DLetDec]
    xs)
              | DFunD Name
    n [DClause]
    _ <- DLetDec
    x, Just [DClause]
    merged_clauses <- Name
    n Name -> Map Name [DClause] -> Maybe [DClause]
    forall k a. Ord k => k -> Map k a -> Maybe a
    `M.lookup` Map Name [DClause]
    name_clause_map
              = Name -> [DClause] -> DLetDec
    DFunD Name
    n [DClause]
    merged_clausesDLetDec -> [DLetDec] -> [DLetDec]
    forall a. a -> [a] -> [a]
    :Map Name [DClause] -> [DLetDec] -> [DLetDec]
    augment_clauses Map Name [DClause]
    name_clause_map [DLetDec]
    xs
              | Bool
    otherwise = DLetDec
    xDLetDec -> [DLetDec] -> [DLetDec]
    forall a. a -> [a] -> [a]
    :Map Name [DClause] -> [DLetDec] -> [DLetDec]
    augment_clauses Map Name [DClause]
    name_clause_map [DLetDec]
    xs

    -- | Create new kind variable binder names corresponding to the return kind of

    -- a data type. This is useful when you have a data type like:

    --

    -- @

    -- data Foo :: forall k. k -> Type -> Type where ...

    -- @

    --

    -- But you want to be able to refer to the type @Foo a b@.

    -- 'mkExtraDKindBinders' will take the kind @forall k. k -> Type -> Type@,

    -- discover that is has two visible argument kinds, and return as a result

    -- two new kind variable binders @[a :: k, b :: Type]@, where @a@ and @b@

    -- are fresh type variable names.

    --

    -- This expands kind synonyms if necessary.

    mkExtraDKindBinders :: forall q. DsMonad q => DKind -> q [DTyVarBndrUnit]
    mkExtraDKindBinders :: forall (q :: * -> *). DsMonad q => DType -> q [DTyVarBndrUnit]
    mkExtraDKindBinders DType
    k = do
      DType
    k' <- DType -> q DType
    forall (q :: * -> *). DsMonad q => DType -> q DType
    expandType DType
    k
      let (DFunArgs
    fun_args, DType
    _) = DType -> (DFunArgs, DType)
    unravelDType DType
    k'
          vis_fun_args :: [DVisFunArg]
    vis_fun_args  = DFunArgs -> [DVisFunArg]
    filterDVisFunArgs DFunArgs
    fun_args
      (DVisFunArg -> q DTyVarBndrUnit)
    -> [DVisFunArg] -> q [DTyVarBndrUnit]
    forall (t :: * -> *) (m :: * -> *) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
    mapM DVisFunArg -> q DTyVarBndrUnit
    mk_tvb [DVisFunArg]
    vis_fun_args
      where
        mk_tvb :: DVisFunArg -> q DTyVarBndrUnit
        mk_tvb :: DVisFunArg -> q DTyVarBndrUnit
    mk_tvb (DVisFADep DTyVarBndrUnit
    tvb) = DTyVarBndrUnit -> q DTyVarBndrUnit
    forall a. a -> q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return DTyVarBndrUnit
    tvb
        mk_tvb (DVisFAAnon DType
    ki) = Name -> () -> DType -> DTyVarBndrUnit
    forall flag. Name -> flag -> DType -> DTyVarBndr flag
    DKindedTV (Name -> () -> DType -> DTyVarBndrUnit)
    -> q Name -> q (() -> DType -> DTyVarBndrUnit)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    <$> String -> q Name
    forall (q :: * -> *). Quasi q => String -> q Name
    qNewName String
    "a" q (() -> DType -> DTyVarBndrUnit)
    -> q () -> q (DType -> DTyVarBndrUnit)
    forall a b. q (a -> b) -> q a -> q b
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
    <*> () -> q ()
    forall a. a -> q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return () q (DType -> DTyVarBndrUnit) -> q DType -> q DTyVarBndrUnit
    forall a b. q (a -> b) -> q a -> q b
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
    <*> DType -> q DType
    forall a. a -> q a
    forall (m :: * -> *) a. Monad m => a -> m a
    return DType
    ki

    {- $localReification

    @template-haskell@ reification functions like 'reify' and 'qReify', as well as
    @th-desugar@'s 'reifyWithWarning', only look through declarations that either
    (1) have already been typechecked in the current module, or (2) are in scope
    because of imports. We refer to this as /global/ reification. Sometimes,
    however, you may wish to reify declarations that have been quoted but not
    yet been typechecked, such as in the following example:

    @
    example :: IO ()
    example = putStrLn
      $(do decs <- [d| data Foo = MkFoo |]
           info <- 'reify' (mkName \"Foo\")
           stringE $ pprint info)
    @

    Because @Foo@ only exists in a TH quote, it is not available globally. As a
    result, the call to @'reify' (mkName \"Foo\")@ will fail.

    To make this sort of example possible, @th-desugar@ extends global reification
    with /local/ reification. A function that performs local reification (such
    as 'dsReify', 'reifyWithLocals', or similar functions that have a 'DsMonad'
    context) looks through both typechecked (or imported) declarations /and/ quoted
    declarations that are currently in scope. One can add quoted declarations in
    the current scope by using the 'withLocalDeclarations' function. Here is an
    example of how to repair the example above using 'withLocalDeclarations':

    @
    example2 :: IO ()
    example2 = putStrLn
      $(do decs <- [d| data Foo = MkFoo |]
           info <- 'withLocalDeclarations' decs $
                     'reifyWithLocals' (mkName \"Foo\")
           stringE $ pprint info)
    @

    Note that 'withLocalDeclarations' should only be used to add quoted
    declarations with names that are not duplicates of existing global or local
    declarations. Adding duplicate declarations through 'withLocalDeclarations'
    is undefined behavior and should be avoided. This is unlikely to happen if
    you are only using 'withLocalDeclarations' in conjunction with TH quotes,
    however. For instance, this is /not/ an example of duplicate declarations:

    @
    data T = MkT1

    $(do decs <- [d| data T = MkT2 |]
         info <- 'withLocalDeclarations' decs ...
         ...)
    @

    The quoted @data T = MkT2@ does not conflict with the top-level @data T = Mk1@
    since declaring a data type within TH quotes gives it a fresh, unique name that
    distinguishes it from any other data types already in scope.
    -}