    {- Language/Haskell/TH/Desugar.hs

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

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

    -----------------------------------------------------------------------------
    -- |
    -- 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(..), DKind, DCxt, DPred,
      DTyVarBndr(..), DMatch(..), DClause(..), DDec(..),
      DDerivClause(..), DDerivStrategy(..), DPatSynDir(..), DPatSynType,
      Overlap(..), PatSynArgs(..), NewOrData(..),
      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, 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,
    #if __GLASGOW_HASKELL__ > 710
      dsTypeFamilyHead, dsFamilyResultSig,
    #endif
    #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,

      -- | The following definitions allow you to register a list of
      -- @Dec@s to be used in reification queries.
      withLocalDeclarations, dsReify,
      reifyWithLocals_maybe, reifyWithLocals, reifyFixityWithLocals,
      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,
      strictToBang, isTypeKindName, typeKindName,
    #if __GLASGOW_HASKELL__ >= 800
      bindIP,
    #endif
      unravel, conExistentialTvbs, mkExtraDKindBinders,
      dTyVarBndrToDType, toposortTyVarsOf,

      -- ** 'TypeArg'
      TypeArg(..), applyType, filterTANormals, unfoldType,

      -- ** 'DTypeArg'
      DTypeArg(..), applyDType, filterDTANormals, unfoldDType,

      -- ** Extracting bound names
      extractBoundNamesStmt, extractBoundNamesDec, extractBoundNamesPat
      ) where

    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 qualified Language.Haskell.TH.Desugar.OSet as OS
    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 Data.List
    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 `Type` and `Kind` are type synonyms, but they desugar
    -- to different types.
    class Desugar th ds | ds -> th where
      desugar :: DsMonad q => th -> q ds
      sweeten :: ds -> th

    instance Desugar Exp DExp where
      desugar :: 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 :: 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 :: Cxt -> q DCxt
    desugar = Cxt -> q DCxt
    forall (q :: * -> *). DsMonad q => Cxt -> q DCxt
    dsCxt
      sweeten :: DCxt -> Cxt
    sweeten = DCxt -> Cxt
    cxtToTH

    instance Desugar TyVarBndr DTyVarBndr where
      desugar :: TyVarBndr -> q DTyVarBndr
    desugar = TyVarBndr -> q DTyVarBndr
    forall (q :: * -> *). DsMonad q => TyVarBndr -> q DTyVarBndr
    dsTvb
      sweeten :: DTyVarBndr -> TyVarBndr
    sweeten = DTyVarBndr -> TyVarBndr
    tvbToTH

    instance Desugar [Dec] [DDec] where
      desugar :: [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 :: 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 :: DLetDec -> q [DLetDec]
    flattenDValD dec :: DLetDec
    dec@(DValD (DVarP _) _) = [DLetDec] -> q [DLetDec]
    forall (m :: * -> *) a. Monad m => a -> m a
    return [DLetDec
    dec]
    flattenDValD (DValD pat :: DPat
    pat exp :: DExp
    exp) = do
      Name
    x <- String -> q Name
    forall (q :: * -> *). Quasi q => String -> q Name
    newUniqueName "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 (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)
    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 (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 x :: Name
    x name :: Name
    name = do
          Name
    y <- String -> m Name
    forall (q :: * -> *). Quasi q => String -> q Name
    newUniqueName "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 (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 :: Name
    y p :: DPat
    p =
          case DPat
    p of
            DLitP lit :: Lit
    lit -> Lit -> DPat
    DLitP Lit
    lit
            DVarP n :: 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 con :: Name
    con ps :: [DPat]
    ps -> Name -> [DPat] -> DPat
    DConP Name
    con ((DPat -> DPat) -> [DPat] -> [DPat]
    forall a b. (a -> b) -> [a] -> [b]
    map (Name -> Name -> DPat -> DPat
    wildify Name
    name Name
    y) [DPat]
    ps)
            DTildeP pa :: DPat
    pa -> DPat -> DPat
    DTildeP (Name -> Name -> DPat -> DPat
    wildify Name
    name Name
    y DPat
    pa)
            DBangP pa :: DPat
    pa -> DPat -> DPat
    DBangP (Name -> Name -> DPat -> DPat
    wildify Name
    name Name
    y DPat
    pa)
            DSigP pa :: DPat
    pa ty :: DType
    ty -> DPat -> DType -> DPat
    DSigP (Name -> Name -> DPat -> DPat
    wildify Name
    name Name
    y DPat
    pa) DType
    ty
            DWildP -> DPat
    DWildP

    flattenDValD other_dec :: DLetDec
    other_dec = [DLetDec] -> q [DLetDec]
    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' attempts to filter out \"naughty\" record selectors
    -- whose types mention existentially quantified type variables. But see the
    -- documentation for 'conExistentialTvbs' for limitations to this approach.

    -- See https://github.com/goldfirere/singletons/issues/180 for an example where
    -- the latter behavior can bite you.

    getRecordSelectors :: DsMonad q
                       => DType        -- ^ the type of the argument
                       -> [DCon]
                       -> q [DLetDec]
    getRecordSelectors :: DType -> [DCon] -> q [DLetDec]
    getRecordSelectors arg_ty :: DType
    arg_ty cons :: [DCon]
    cons = [DLetDec] -> [DLetDec]
    merge_let_decs ([DLetDec] -> [DLetDec]) -> q [DLetDec] -> q [DLetDec]
    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 :: * -> *). DsMonad m => DCon -> m [DLetDec]
    get_record_sels [DCon]
    cons
      where
        get_record_sels :: DCon -> m [DLetDec]
    get_record_sels con :: DCon
    con@(DCon con_tvbs :: [DTyVarBndr]
    con_tvbs _ con_name :: Name
    con_name con_fields :: DConFields
    con_fields con_ret_ty :: DType
    con_ret_ty) =
          case DConFields
    con_fields of
            DRecC fields :: [DVarBangType]
    fields -> [DVarBangType] -> m [DLetDec]
    forall (m :: * -> *) b.
    DsMonad m =>
    [(Name, b, DType)] -> m [DLetDec]
    go [DVarBangType]
    fields
            DNormalC{}   -> [DLetDec] -> m [DLetDec]
    forall (m :: * -> *) a. Monad m => a -> m a
    return []
            where
              go :: [(Name, b, DType)] -> m [DLetDec]
    go fields :: [(Name, b, DType)]
    fields = do
                Name
    varName <- String -> m Name
    forall (q :: * -> *). Quasi q => String -> q Name
    qNewName "field"
                [DTyVarBndr]
    con_ex_tvbs <- DType -> DCon -> m [DTyVarBndr]
    forall (q :: * -> *). DsMonad q => DType -> DCon -> q [DTyVarBndr]
    conExistentialTvbs DType
    arg_ty DCon
    con
                let con_univ_tvbs :: [DTyVarBndr]
    con_univ_tvbs  = (DTyVarBndr -> DTyVarBndr -> Bool)
    -> [DTyVarBndr] -> [DTyVarBndr] -> [DTyVarBndr]
    forall a. (a -> a -> Bool) -> [a] -> [a] -> [a]
    deleteFirstsBy (Name -> Name -> Bool
    forall a. Eq a => a -> a -> Bool
    (==) (Name -> Name -> Bool)
    -> (DTyVarBndr -> Name) -> DTyVarBndr -> DTyVarBndr -> Bool
    forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
    `on` DTyVarBndr -> Name
    dtvbName) [DTyVarBndr]
    con_tvbs [DTyVarBndr]
    con_ex_tvbs
                    con_ex_tvb_set :: OSet Name
    con_ex_tvb_set = [Name] -> OSet Name
    forall a. Ord a => [a] -> OSet a
    OS.fromList ([Name] -> OSet Name) -> [Name] -> OSet Name
    forall a b. (a -> b) -> a -> b
    $ (DTyVarBndr -> Name) -> [DTyVarBndr] -> [Name]
    forall a b. (a -> b) -> [a] -> [b]
    map DTyVarBndr -> Name
    dtvbName [DTyVarBndr]
    con_ex_tvbs
                    forall' :: DType -> DType
    forall'        = [DTyVarBndr] -> DCxt -> DType -> DType
    DForallT [DTyVarBndr]
    con_univ_tvbs []
                    num_pats :: Int
    num_pats       = [(Name, b, DType)] -> Int
    forall (t :: * -> *) a. Foldable t => t a -> Int
    length [(Name, b, DType)]
    fields
                [DLetDec] -> m [DLetDec]
    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 -> DType
    forall' (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 -> [DPat] -> DPat
    DConP Name
    con_name (Int -> Int -> Name -> [DPat]
    mk_field_pats Int
    n Int
    num_pats Name
    varName)]
                                          (Name -> DExp
    DVarE Name
    varName)] ]
                  | ((name :: Name
    name, _strict :: b
    _strict, field_ty :: DType
    field_ty), n :: Int
    n) <- [(Name, b, DType)] -> [Int] -> [((Name, b, DType), Int)]
    forall a b. [a] -> [b] -> [(a, b)]
    zip [(Name, b, DType)]
    fields [0..]
                  , OSet Name -> Bool
    forall a. OSet a -> Bool
    OS.null (DType -> OSet Name
    fvDType DType
    field_ty OSet Name -> OSet Name -> OSet Name
    forall a. Ord a => OSet a -> OSet a -> OSet a
    `OS.intersection` OSet Name
    con_ex_tvb_set)
                      -- exclude "naughty" selectors
                  ]

        mk_field_pats :: Int -> Int -> Name -> [DPat]
        mk_field_pats :: Int -> Int -> Name -> [DPat]
    mk_field_pats 0 total :: Int
    total name :: 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
    -1) DPat
    DWildP)
        mk_field_pats n :: Int
    n total :: Int
    total name :: 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
    -1) (Int
    totalInt -> Int -> Int
    forall a. Num a => a -> a -> a
    -1) Name
    name

        merge_let_decs :: [DLetDec] -> [DLetDec]
        merge_let_decs :: [DLetDec] -> [DLetDec]
    merge_let_decs decs :: [DLetDec]
    decs =
          let (name_clause_map :: Map Name [DClause]
    name_clause_map, decs' :: [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 name_clause_map :: Map Name [DClause]
    name_clause_map _ [] = (Map Name [DClause]
    name_clause_map, [])
            gather_decs name_clause_map :: Map Name [DClause]
    name_clause_map type_sig_names :: Set Name
    type_sig_names (x :: DLetDec
    x:xs :: [DLetDec]
    xs)
              -- 1.
              | DFunD n :: Name
    n clauses :: [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 (\new :: [DClause]
    new old :: [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' :: Map Name [DClause]
    map', decs' :: [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 n :: Name
    n _ <- 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' :: Map Name [DClause]
    map', decs' :: [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' :: Map Name [DClause]
    map', decs' :: [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 _ [] = []
            augment_clauses name_clause_map :: Map Name [DClause]
    name_clause_map (x :: DLetDec
    x:xs :: [DLetDec]
    xs)
              | DFunD n :: Name
    n _ <- DLetDec
    x, Just merged_clauses :: [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 :: DsMonad q => DKind -> q [DTyVarBndr]
    mkExtraDKindBinders :: DType -> q [DTyVarBndr]
    mkExtraDKindBinders = DType -> q DType
    forall (q :: * -> *). DsMonad q => DType -> q DType
    expandType (DType -> q DType)
    -> (DType -> q [DTyVarBndr]) -> DType -> q [DTyVarBndr]
    forall (m :: * -> *) a b c.
    Monad m =>
    (a -> m b) -> (b -> m c) -> a -> m c
    >=> DType -> q [DTyVarBndr]
    forall (q :: * -> *). Quasi q => DType -> q [DTyVarBndr]
    mkExtraDKindBinders'

    -- | Returns all of a constructor's existentially quantified type variable
    -- binders.
    --
    -- Detecting the presence of existentially quantified type variables in the
    -- context of Template Haskell is quite involved. Here is an example that
    -- we will use to explain how this works:
    --
    -- @
    -- data family Foo a b
    -- data instance Foo (Maybe a) b where
    --   MkFoo :: forall x y z. x -> y -> z -> Foo (Maybe x) [z]
    -- @
    --
    -- In @MkFoo@, @x@ is universally quantified, whereas @y@ and @z@ are
    -- existentially quantified. Note that @MkFoo@ desugars (in Core) to
    -- something like this:
    --
    -- @
    -- data instance Foo (Maybe a) b where
    --   MkFoo :: forall a b y z. (b ~ [z]). a -> y -> z -> Foo (Maybe a) b
    -- @
    --
    -- Here, we can see that @a@ appears in the desugared return type (it is a
    -- simple alpha-renaming of @x@), so it is universally quantified. On the other
    -- hand, neither @y@ nor @z@ appear in the desugared return type, so they are
    -- existentially quantified.
    --
    -- This analysis would not have been possible without knowing what the original
    -- data declaration's type was (in this case, @Foo (Maybe a) b@), which is why
    -- we require it as an argument. Our algorithm for detecting existentially
    -- quantified variables is not too different from what was described above:
    -- we match the constructor's return type with the original data type, forming
    -- a substitution, and check which quantified variables are not part of the
    -- domain of the substitution.
    --
    -- Be warned: this may overestimate which variables are existentially
    -- quantified when kind variables are involved. For instance, consider this
    -- example:
    --
    -- @
    -- data S k (a :: k)
    -- data T a where
    --   MkT :: forall k (a :: k). { foo :: Proxy (a :: k), bar :: S k a } -> T a
    -- @
    --
    -- Here, the kind variable @k@ does not appear syntactically in the return type
    -- @T a@, so 'conExistentialTvbs' would mistakenly flag @k@ as existential.
    --
    -- There are various tricks we could employ to improve this, but ultimately,
    -- making this behave correctly with respect to @PolyKinds@ 100% of the time
    -- would amount to performing kind inference in Template Haskell, which is
    -- quite difficult. For the sake of simplicity, we have decided to stick with
    -- a dumb-but-predictable syntactic check.
    conExistentialTvbs :: DsMonad q
                       => DType -- ^ The type of the original data declaration
                       -> DCon
                       -> q [DTyVarBndr]
    conExistentialTvbs :: DType -> DCon -> q [DTyVarBndr]
    conExistentialTvbs data_ty :: DType
    data_ty (DCon tvbs :: [DTyVarBndr]
    tvbs _ _ _ ret_ty :: DType
    ret_ty) = do
      DType
    data_ty' <- DType -> q DType
    forall (q :: * -> *). DsMonad q => DType -> q DType
    expandType DType
    data_ty
      DType
    ret_ty'  <- DType -> q DType
    forall (q :: * -> *). DsMonad q => DType -> q DType
    expandType DType
    ret_ty
      case IgnoreKinds -> DType -> DType -> Maybe DSubst
    matchTy IgnoreKinds
    YesIgnore DType
    ret_ty' DType
    data_ty' of
        Nothing -> String -> q [DTyVarBndr]
    forall (m :: * -> *) a. MonadFail m => String -> m a
    fail (String -> q [DTyVarBndr]) -> String -> q [DTyVarBndr]
    forall a b. (a -> b) -> a -> b
    $ String -> ShowS
    showString "Unable to match type "
                        ShowS -> ShowS -> ShowS
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Int -> DType -> ShowS
    forall a. Show a => Int -> a -> ShowS
    showsPrec 11 DType
    ret_ty'
                        ShowS -> ShowS -> ShowS
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> ShowS
    showString " with "
                        ShowS -> ShowS -> ShowS
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Int -> DType -> ShowS
    forall a. Show a => Int -> a -> ShowS
    showsPrec 11 DType
    data_ty'
                        ShowS -> ShowS
    forall a b. (a -> b) -> a -> b
    $ ""
        Just gadtSubt :: DSubst
    gadtSubt -> [DTyVarBndr] -> q [DTyVarBndr]
    forall (m :: * -> *) a. Monad m => a -> m a
    return [ DTyVarBndr
    tvb
                                | DTyVarBndr
    tvb <- [DTyVarBndr]
    tvbs
                                , Name -> DSubst -> Bool
    forall k a. Ord k => k -> Map k a -> Bool
    M.notMember (DTyVarBndr -> Name
    dtvbName DTyVarBndr
    tvb) DSubst
    gadtSubt
                                ]