content: -- Copyright (c) Facebook, Inc. and its affiliates.
  --
  -- This source code is licensed under the MIT license found in the
  -- LICENSE file in the root directory of this source tree.
  --
  {-# LANGUAGE CPP #-}
  {-# LANGUAGE DeriveFunctor #-}
  {-# LANGUAGE FlexibleInstances #-}
  {-# LANGUAGE InstanceSigs #-}
  {-# LANGUAGE OverloadedStrings #-}
  {-# LANGUAGE RankNTypes #-}
  {-# LANGUAGE RecordWildCards #-}
  {-# LANGUAGE TupleSections #-}
  {-# LANGUAGE TypeFamilies #-}
  {-# LANGUAGE ViewPatterns #-}
  -- NOTE: This was needed for GHC 9.4 due to
  -- type Key RFMap = LocatedA (HsRecField GhcPS (LocatedA (HsExpr GhcPs)))
  {-# LANGUAGE UndecidableInstances #-}
  module Retrie.PatternMap.Instances where
  
  import Control.Monad
  import Data.ByteString (ByteString)
  import Data.Maybe
  
  import Retrie.AlphaEnv
  import Retrie.ExactPrint
  import Retrie.GHC
  import Retrie.PatternMap.Bag
  import Retrie.PatternMap.Class
  import Retrie.Quantifiers
  import Retrie.Substitution
  import Retrie.Util
  
  ------------------------------------------------------------------------
  
  data TupArgMap a
    = TupArgMap { tamPresent :: EMap a, tamMissing :: MaybeMap a }
    deriving (Functor)
  
  instance PatternMap TupArgMap where
    -- type Key TupArgMap = Located (HsTupArg GhcPs)
    type Key TupArgMap = HsTupArg GhcPs
  
    mEmpty :: TupArgMap a
    mEmpty = TupArgMap mEmpty mEmpty
  
    mUnion :: TupArgMap a -> TupArgMap a -> TupArgMap a
    mUnion m1 m2 = TupArgMap
      { tamPresent = unionOn tamPresent m1 m2
      , tamMissing = unionOn tamMissing m1 m2
      }
  
    mAlter :: AlphaEnv -> Quantifiers -> Key TupArgMap -> A a -> TupArgMap a -> TupArgMap a
    mAlter env vs tupArg f m = go tupArg
      where
        go (Present _ e) = m { tamPresent = mAlter env vs e  f (tamPresent m) }
  #if __GLASGOW_HASKELL__ < 900
        go XTupArg{} = missingSyntax "XTupArg"
  #endif
        go (Missing _) = m { tamMissing = mAlter env vs () f (tamMissing m) }
  
    mMatch :: MatchEnv -> Key TupArgMap -> (Substitution, TupArgMap a) -> [(Substitution, a)]
    mMatch env = go
      where
        go (Present _ e) = mapFor tamPresent >=> mMatch env e
  #if __GLASGOW_HASKELL__ < 900
        go XTupArg{} = const []
  #endif
        go (Missing _) = mapFor tamMissing >=> mMatch env ()
  
  ------------------------------------------------------------------------
  
  data BoxityMap a
    = BoxityMap { boxBoxed :: MaybeMap a, boxUnboxed :: MaybeMap a }
    deriving (Functor)
  
  instance PatternMap BoxityMap where
    type Key BoxityMap = Boxity
  
    mEmpty :: BoxityMap a
    mEmpty = BoxityMap mEmpty mEmpty
  
    mUnion :: BoxityMap a -> BoxityMap a -> BoxityMap a
    mUnion m1 m2 = BoxityMap
      { boxBoxed = unionOn boxBoxed m1 m2
      , boxUnboxed = unionOn boxUnboxed m1 m2
      }
  
    mAlter :: AlphaEnv -> Quantifiers -> Key BoxityMap -> A a -> BoxityMap a -> BoxityMap a
    mAlter env vs Boxed   f m = m { boxBoxed   = mAlter env vs () f (boxBoxed m) }
    mAlter env vs Unboxed f m = m { boxUnboxed = mAlter env vs () f (boxUnboxed m) }
  
    mMatch :: MatchEnv -> Key BoxityMap -> (Substitution, BoxityMap a) -> [(Substitution, a)]
    mMatch env Boxed   = mapFor boxBoxed >=> mMatch env ()
    mMatch env Unboxed = mapFor boxUnboxed >=> mMatch env ()
  
  ------------------------------------------------------------------------
  
  data VMap a = VM { bvmap :: IntMap a, fvmap :: FSEnv a }
              | VMEmpty
    deriving (Functor)
  
  instance PatternMap VMap where
    type Key VMap = RdrName
  
    mEmpty :: VMap a
    mEmpty = VMEmpty
  
    mUnion :: VMap a -> VMap a -> VMap a
    mUnion VMEmpty m = m
    mUnion m VMEmpty = m
    mUnion m1 m2 = VM
      { bvmap = unionOn bvmap m1 m2
      , fvmap = unionOn fvmap m1 m2
      }
  
    mAlter :: AlphaEnv -> Quantifiers -> Key VMap -> A a -> VMap a -> VMap a
    mAlter env vs v f VMEmpty = mAlter env vs v f (VM mEmpty mEmpty)
    mAlter env vs v f m@VM{}
      | Just bv <- lookupAlphaEnv v env = m { bvmap = mAlter env vs bv f (bvmap m) }
      | otherwise                       = m { fvmap = mAlter env vs (rdrFS v) f (fvmap m) }
  
    mMatch :: MatchEnv -> Key VMap -> (Substitution, VMap a) -> [(Substitution, a)]
    mMatch _   _ (_,VMEmpty) = []
    mMatch env v (hs,m@VM{})
      | Just bv <- lookupAlphaEnv v (meAlphaEnv env) = mMatch env bv (hs, bvmap m)
      | otherwise = mMatch env (rdrFS v) (hs, fvmap m)
  
  ------------------------------------------------------------------------
  
  data LMap a
    = LMEmpty
    | LM { lmChar :: Map Char a
         , lmCharPrim :: Map Char a
         , lmString :: FSEnv a
         , lmStringPrim :: Map ByteString a
         , lmInt :: BoolMap (Map Integer a)
         , lmIntPrim :: Map Integer a
         , lmWordPrim :: Map Integer a
         , lmInt64Prim :: Map Integer a
         , lmWord64Prim :: Map Integer a
         }
    deriving (Functor)
  
  emptyLMapWrapper :: LMap a
  emptyLMapWrapper
    = LM mEmpty mEmpty mEmpty mEmpty mEmpty
         mEmpty mEmpty mEmpty mEmpty
  
  instance PatternMap LMap where
    type Key LMap = HsLit GhcPs
  
    mEmpty :: LMap a
    mEmpty = LMEmpty
  
    mUnion :: LMap a -> LMap a -> LMap a
    mUnion LMEmpty m = m
    mUnion m LMEmpty = m
    mUnion m1 m2 = LM
      { lmChar = unionOn lmChar m1 m2
      , lmCharPrim = unionOn lmCharPrim m1 m2
      , lmString = unionOn lmString m1 m2
      , lmStringPrim = unionOn lmStringPrim m1 m2
      , lmInt = unionOn lmInt m1 m2
      , lmIntPrim = unionOn lmIntPrim m1 m2
      , lmWordPrim = unionOn lmWordPrim m1 m2
      , lmInt64Prim = unionOn lmInt64Prim m1 m2
      , lmWord64Prim = unionOn lmWord64Prim m1 m2
      }
  
    mAlter :: AlphaEnv -> Quantifiers -> Key LMap -> A a -> LMap a -> LMap a
    mAlter env vs lit f LMEmpty = mAlter env vs lit f emptyLMapWrapper
    mAlter env vs lit f m@LM{}  = go lit
      where
        go (HsChar _ c)       = m { lmChar = mAlter env vs c f (lmChar m) }
        go (HsCharPrim _ c)   = m { lmCharPrim = mAlter env vs c f (lmCharPrim m) }
        go (HsString _ fs)    = m { lmString = mAlter env vs fs f (lmString m) }
        go (HsStringPrim _ bs) = m { lmStringPrim = mAlter env vs bs f (lmStringPrim m) }
        go (HsInt _ (IL _ b i)) =
          m { lmInt = mAlter env vs b (toA (mAlter env vs i f)) (lmInt m) }
        go (HsIntPrim _ i)    = m { lmIntPrim = mAlter env vs i f (lmIntPrim m) }
        go (HsWordPrim _ i)   = m { lmWordPrim = mAlter env vs i f (lmWordPrim m) }
        go (HsInt64Prim _ i)  = m { lmInt64Prim = mAlter env vs i f (lmInt64Prim m) }
        go (HsWord64Prim _ i) = m { lmWord64Prim = mAlter env vs i f (lmWord64Prim m) }
        go (HsInteger _ _ _) = missingSyntax "HsInteger"
        go HsRat{} = missingSyntax "HsRat"
        go HsFloatPrim{} = missingSyntax "HsFloatPrim"
        go HsDoublePrim{} = missingSyntax "HsDoublePrim"
  #if __GLASGOW_HASKELL__ < 900
        go XLit{} = missingSyntax "XLit"
  #endif
  
    mMatch :: MatchEnv -> Key LMap -> (Substitution, LMap a) -> [(Substitution, a)]
    mMatch _   _   (_,LMEmpty) = []
    mMatch env lit (hs,m@LM{}) = go lit (hs,m)
      where
        go (HsChar _ c)        = mapFor lmChar >=> mMatch env c
        go (HsCharPrim _ c)    = mapFor lmCharPrim >=> mMatch env c
        go (HsString _ fs)     = mapFor lmString >=> mMatch env fs
        go (HsStringPrim _ bs) = mapFor lmStringPrim >=> mMatch env bs
        go (HsInt _ (IL _ b i)) = mapFor lmInt >=> mMatch env b >=> mMatch env i
        go (HsIntPrim _ i)     = mapFor lmIntPrim >=> mMatch env i
        go (HsWordPrim _ i)    = mapFor lmWordPrim >=> mMatch env i
        go (HsInt64Prim _ i)   = mapFor lmInt64Prim >=> mMatch env i
        go (HsWord64Prim _ i)  = mapFor lmWord64Prim >=> mMatch env i
        go _ = const [] -- TODO
  
  ------------------------------------------------------------------------
  
  data OLMap a
    = OLMEmpty
    | OLM
      { olmIntegral :: BoolMap (Map Integer a)
      -- ++AZ++:TODO: Fractional has *much* more than Rational now
      , olmFractional :: Map Rational a
      , olmIsString :: FSEnv a
      }
    deriving (Functor)
  
  emptyOLMapWrapper :: OLMap a
  emptyOLMapWrapper = OLM mEmpty mEmpty mEmpty
  
  instance PatternMap OLMap where
    type Key OLMap = OverLitVal
  
    mEmpty :: OLMap a
    mEmpty = OLMEmpty
  
    mUnion :: OLMap a -> OLMap a -> OLMap a
    mUnion OLMEmpty m = m
    mUnion m OLMEmpty = m
    mUnion m1 m2 = OLM
      { olmIntegral = unionOn olmIntegral m1 m2
      , olmFractional = unionOn olmFractional m1 m2
      , olmIsString = unionOn olmIsString m1 m2
      }
  
    mAlter :: AlphaEnv -> Quantifiers -> Key OLMap -> A a -> OLMap a -> OLMap a
    mAlter env vs lv f OLMEmpty = mAlter env vs lv f emptyOLMapWrapper
    mAlter env vs lv f m@OLM{}  = go lv
      where
        go (HsIntegral (IL _ b i)) =
          m { olmIntegral = mAlter env vs b (toA (mAlter env vs i f)) (olmIntegral m) }
        go (HsFractional fl) = m { olmFractional = mAlter env vs (fl_signi fl) f (olmFractional m) }
        go (HsIsString _ fs) = m { olmIsString = mAlter env vs fs f (olmIsString m) }
  
    mMatch :: MatchEnv -> Key OLMap -> (Substitution, OLMap a) -> [(Substitution, a)]
    mMatch _   _  (_,OLMEmpty) = []
    mMatch env lv (hs,m@OLM{}) = go lv (hs,m)
      where
        go (HsIntegral (IL _ b i)) =
          mapFor olmIntegral >=> mMatch env b >=> mMatch env i
        go (HsFractional fl) = mapFor olmFractional >=> mMatch env (fl_signi fl)
        go (HsIsString _ fs) = mapFor olmIsString >=> mMatch env fs
  
  ------------------------------------------------------------------------
  
  -- Note [Holes]
  -- Holes are distinguished variables which can match any expression. (The
  -- universally quantified variables in an Equality.) Ideally, they would be
  -- stored as a TyMap, so the type of the expression can be checked against the
  -- type of the hole. Fixing this is a TODO. This wraps a map from RdrName to
  -- result. We use a regular map instead of a OccEnv so we can get the RdrName
  -- back, which allows us to assign it to the expression when building the
  -- result.
  
  -- Note [Lambdas]
  -- This currently stores both HsLam and HsLamCase
  
  -- Note [Stmt Lists]
  -- Statement lists bind to the right, so we need to extend the environment
  -- as we move down it. Thus we cannot simply store them as ListMap SMap a.
  
  data EMap a
    = EMEmpty
    | EM { emHole  :: Map RdrName a -- See Note [Holes]
         , emVar   :: VMap a
         , emIPVar :: FSEnv a
         , emOverLit :: OLMap a
         , emLit   :: LMap a
         , emLam   :: MGMap a -- See Note [Lambdas]
         , emApp   :: EMap (EMap a)
         , emOpApp :: EMap (EMap (EMap a)) -- op, lhs, rhs
         , emNegApp :: EMap a
         , emPar   :: EMap a
         , emExplicitTuple :: BoxityMap (ListMap TupArgMap a)
         , emCase  :: EMap (MGMap a)
         , emSecL  :: EMap (EMap a) -- operator, operand (flipped)
         , emSecR  :: EMap (EMap a) -- operator, operand
         , emIf    :: EMap (EMap (EMap a)) -- cond, true, false
         , emLet   :: LBMap (EMap a)
         , emDo    :: SCMap (SLMap a) -- See Note [Stmt Lists]
         , emExplicitList :: ListMap EMap a
         , emRecordCon :: VMap (ListMap RFMap a)
         , emRecordUpd :: EMap (ListMap RFMap a)
         , emExprWithTySig :: EMap (TyMap a)
         }
    deriving (Functor)
  
  emptyEMapWrapper :: EMap a
  emptyEMapWrapper =
    EM mEmpty mEmpty mEmpty mEmpty mEmpty
       mEmpty mEmpty mEmpty mEmpty mEmpty
       mEmpty mEmpty mEmpty mEmpty mEmpty
       mEmpty mEmpty mEmpty mEmpty mEmpty
       mEmpty
  
  instance PatternMap EMap where
    type Key EMap = LocatedA (HsExpr GhcPs)
  
    mEmpty :: EMap a
    mEmpty = EMEmpty
  
    mUnion :: EMap a -> EMap a -> EMap a
    mUnion EMEmpty m = m
    mUnion m EMEmpty = m
    mUnion m1 m2 = EM
      { emHole = unionOn emHole m1 m2
      , emVar = unionOn emVar m1 m2
      , emIPVar = unionOn emIPVar m1 m2
      , emOverLit = unionOn emOverLit m1 m2
      , emLit = unionOn emLit m1 m2
      , emLam = unionOn emLam m1 m2
      , emApp = unionOn emApp m1 m2
      , emOpApp = unionOn emOpApp m1 m2
      , emNegApp = unionOn emNegApp m1 m2
      , emPar = unionOn emPar m1 m2
      , emExplicitTuple = unionOn emExplicitTuple m1 m2
      , emCase = unionOn emCase m1 m2
      , emSecL = unionOn emSecL m1 m2
      , emSecR = unionOn emSecR m1 m2
      , emIf = unionOn emIf m1 m2
      , emLet = unionOn emLet m1 m2
      , emDo = unionOn emDo m1 m2
      , emExplicitList = unionOn emExplicitList m1 m2
      , emRecordCon = unionOn emRecordCon m1 m2
      , emRecordUpd = unionOn emRecordUpd m1 m2
      , emExprWithTySig = unionOn emExprWithTySig m1 m2
      }
  
    mAlter :: forall a. AlphaEnv -> Quantifiers -> Key EMap -> A a -> EMap a -> EMap a
    mAlter env vs e f EMEmpty = mAlter env vs e f emptyEMapWrapper
    mAlter env vs e f m@EM{} = go (unLoc e)
      where
        go (HsVar _ v)
          | unLoc v `isQ` vs = m { emHole  = mAlter env vs (unLoc v) f (emHole m) }
          | otherwise        = m { emVar   = mAlter env vs (unLoc v) f (emVar m) }
        go (ExplicitTuple _ as b) =
          m { emExplicitTuple = mAlter env vs b (toA (mAlter env vs as f)) (emExplicitTuple m) }
        go (HsApp _ l r) =
          m { emApp = mAlter env vs l (toA (mAlter env vs r f)) (emApp m) }
        go (HsCase _ s mg) =
          m { emCase = mAlter env vs s (toA (mAlter env vs mg f)) (emCase m) }
        go (HsDo _ sc ss) =
          m { emDo = mAlter env vs sc (toA (mAlter env vs (unLoc ss) f)) (emDo m) }
  #if __GLASGOW_HASKELL__ < 900
        go (HsIf _ _ c tr fl) =
  #else
        go (HsIf _ c tr fl) =
  #endif
          m { emIf = mAlter env vs c
                        (toA (mAlter env vs tr
                            (toA (mAlter env vs fl f)))) (emIf m) }
        go (HsIPVar _ (HsIPName ip)) = m { emIPVar = mAlter env vs ip f (emIPVar m) }
        go (HsLit _ l) = m { emLit   = mAlter env vs l f (emLit m) }
        go (HsLam _ mg) = m { emLam   = mAlter env vs mg f (emLam m) }
        go (HsOverLit _ ol) = m { emOverLit = mAlter env vs (ol_val ol) f (emOverLit m) }
        go (NegApp _ e' _) = m { emNegApp = mAlter env vs e' f (emNegApp m) }
  #if __GLASGOW_HASKELL__ < 904
        go (HsPar _ e') = m { emPar  = mAlter env vs e' f (emPar m) }
  #else
        go (HsPar _ _ e' _) = m { emPar  = mAlter env vs e' f (emPar m) }
  #endif
        go (OpApp _ l o r) =
          m { emOpApp = mAlter env vs o (toA (mAlter env vs l (toA (mAlter env vs r f)))) (emOpApp m) }
  #if __GLASGOW_HASKELL__ < 904
        go (RecordCon _ v fs) =
          m { emRecordCon = mAlter env vs (unLoc v) (toA (mAlter env vs (fieldsToRdrNames $ rec_flds fs) f)) (emRecordCon m) }
  #else
        go (RecordCon _ v fs) =
          m { emRecordCon = mAlter env vs (unLoc v :: RdrName) (toA (mAlter env vs (rec_flds fs) f)) (emRecordCon m) }
  #endif
        go (RecordUpd _ e' fs) =
          m { emRecordUpd = mAlter env vs e' (toA (mAlter env vs (fieldsToRdrNamesUpd fs) f)) (emRecordUpd m) }
        go (SectionL _ lhs o) =
          m { emSecL = mAlter env vs o (toA (mAlter env vs lhs f)) (emSecL m) }
        go (SectionR _ o rhs) =
          m { emSecR = mAlter env vs o (toA (mAlter env vs rhs f)) (emSecR m) }
  #if __GLASGOW_HASKELL__ < 904
        go (HsLet _ lbs e') =
  #else
        go (HsLet _ _ lbs _ e') =
  #endif
          let
            bs = collectLocalBinders CollNoDictBinders lbs
            env' = foldr extendAlphaEnvInternal env bs
            vs' = vs `exceptQ` bs
          in m { emLet = mAlter env vs lbs (toA (mAlter env' vs' e' f)) (emLet m) }
        go HsLamCase{} = missingSyntax "HsLamCase"
        go HsMultiIf{} = missingSyntax "HsMultiIf"
        go (ExplicitList _ es) = m { emExplicitList = mAlter env vs es f (emExplicitList m) }
        go ArithSeq{} = missingSyntax "ArithSeq"
        go (ExprWithTySig _ e' (HsWC _ (L _ (HsSig _ _ ty)))) =
          m { emExprWithTySig = mAlter env vs e' (toA (mAlter env vs ty f)) (emExprWithTySig m) }
  #if __GLASGOW_HASKELL__ < 900
        go XExpr{} = missingSyntax "XExpr"
        go ExprWithTySig{} = missingSyntax "ExprWithTySig"
        go HsSCC{} = missingSyntax "HsSCC"
        go HsCoreAnn{} = missingSyntax "HsCoreAnn"
        go HsTickPragma{} = missingSyntax "HsTickPragma"
        go HsWrap{} = missingSyntax "HsWrap"
  #else
        go HsPragE{} = missingSyntax "HsPragE"
  #endif
  #if __GLASGOW_HASKELL__ < 904
        go HsBracket{} = missingSyntax "HsBracket"
        go HsRnBracketOut{} = missingSyntax "HsRnBracketOut"
        go HsTcBracketOut{} = missingSyntax "HsTcBracketOut"
        go HsSpliceE{} = missingSyntax "HsSpliceE"
        go HsProc{} = missingSyntax "HsProc"
        go HsStatic{} = missingSyntax "HsStatic"
  #else
        go HsTypedBracket{} = missingSyntax "HsTypedBracket"
        go HsUntypedBracket{} = missingSyntax "HsUntypedBracket"
  #if __GLASGOW_HASKELL__ < 906
        go HsSpliceE{} = missingSyntax "HsSpliceE"
  #endif
  #endif
  #if __GLASGOW_HASKELL__ < 810
        go HsArrApp{} = missingSyntax "HsArrApp"
        go HsArrForm{} = missingSyntax "HsArrForm"
        go EWildPat{} = missingSyntax "EWildPat"
        go EAsPat{} = missingSyntax "EAsPat"
        go EViewPat{} = missingSyntax "EViewPat"
        go ELazyPat{} = missingSyntax "ELazyPat"
  #endif
  #if __GLASGOW_HASKELL__ < 904
        go HsTick{} = missingSyntax "HsTick"
        go HsBinTick{} = missingSyntax "HsBinTick"
  #endif
        go HsUnboundVar{} = missingSyntax "HsUnboundVar"
  #if __GLASGOW_HASKELL__ < 904
        go HsRecFld{} = missingSyntax "HsRecFld"
  #endif
        go HsOverLabel{} = missingSyntax "HsOverLabel"
        go HsAppType{} = missingSyntax "HsAppType"
  #if __GLASGOW_HASKELL__ < 904
        go HsConLikeOut{} = missingSyntax "HsConLikeOut"
  #endif
        go ExplicitSum{} = missingSyntax "ExplicitSum"
  
    mMatch :: MatchEnv -> Key EMap -> (Substitution, EMap a) -> [(Substitution, a)]
    mMatch _   _ (_,EMEmpty) = []
    mMatch env e (hs,m@EM{}) = hss ++ go (unLoc e) (hs,m)
      where
        hss = extendResult (emHole m) (HoleExpr $ mePruneA env e) hs
  
        go (ExplicitTuple _ as b) = mapFor emExplicitTuple >=> mMatch env b >=> mMatch env as
        go (HsApp _ l r) = mapFor emApp >=> mMatch env l >=> mMatch env r
        go (HsCase _ s mg) = mapFor emCase >=> mMatch env s >=> mMatch env mg
        go (HsDo _ sc ss) = mapFor emDo >=> mMatch env sc >=> mMatch env (unLoc ss)
  #if __GLASGOW_HASKELL__ < 900
        go (HsIf _ _ c tr fl) =
  #else
        go (HsIf _ c tr fl) =
  #endif
          mapFor emIf >=> mMatch env c >=> mMatch env tr >=> mMatch env fl
        go (HsIPVar _ (HsIPName ip)) = mapFor emIPVar >=> mMatch env ip
        go (HsLam _ mg) = mapFor emLam >=> mMatch env mg
        go (HsLit _ l) = mapFor emLit >=> mMatch env l
        go (HsOverLit _ ol) = mapFor emOverLit >=> mMatch env (ol_val ol)
  #if __GLASGOW_HASKELL__ < 904
        go (HsPar _ e') = mapFor emPar >=> mMatch env e'
  #else
        go (HsPar _ _ e' _) = mapFor emPar >=> mMatch env e'
  #endif
        go (HsVar _ v) = mapFor emVar >=> mMatch env (unLoc v)
        go (OpApp _ l o r) =
          mapFor emOpApp >=> mMatch env o >=> mMatch env l >=> mMatch env r
        go (NegApp _ e' _) = mapFor emNegApp >=> mMatch env e'
  #if __GLASGOW_HASKELL__ < 904
        go (RecordCon _ v fs) =
          mapFor emRecordCon >=> mMatch env (unLoc v) >=> mMatch env (fieldsToRdrNames $ rec_flds fs)
  #else
        go (RecordCon _ v fs) =
          mapFor emRecordCon >=> mMatch env (unLoc v) >=> mMatch env (rec_flds fs)
  #endif
        go (RecordUpd _ e' fs) =
          mapFor emRecordUpd >=> mMatch env e' >=> mMatch env (fieldsToRdrNamesUpd fs)
        go (SectionL _ lhs o) = mapFor emSecL >=> mMatch env o >=> mMatch env lhs
        go (SectionR _ o rhs) = mapFor emSecR >=> mMatch env o >=> mMatch env rhs
  #if __GLASGOW_HASKELL__ < 904
        go (HsLet _ lbs e') =
  #else
        go (HsLet _ _ lbs _ e') =
  #endif
          let
            bs = collectLocalBinders CollNoDictBinders lbs
            env' = extendMatchEnv env bs
          in mapFor emLet >=> mMatch env lbs >=> mMatch env' e'
        go (ExplicitList _ es) = mapFor emExplicitList >=> mMatch env es
        go (ExprWithTySig _ e' (HsWC _ (L _ (HsSig _ _ ty)))) =
          mapFor emExprWithTySig >=> mMatch env e' >=> mMatch env ty
        go _ = const [] -- TODO remove
  
  -- Add the matched expression to the holes map, fails if expression differs from one already in hole.
  extendResult :: Map RdrName a -> HoleVal -> Substitution -> [(Substitution, a)]
  extendResult hm v sub = catMaybes
    [ case lookupSubst n sub of
        Nothing -> return (extendSubst sub n v, x)
        Just v' -> sameHoleValue v v' >> return (sub, x)
    | (nm,x) <- mapAssocs hm, let n = rdrFS nm ]
  
  singleton :: [a] -> Maybe a
  singleton [x] = Just x
  singleton _  = Nothing
  
  -- | Determine if two expressions are alpha-equivalent.
  sameHoleValue :: HoleVal -> HoleVal -> Maybe ()
  sameHoleValue (HoleExpr e1)  (HoleExpr e2)  =
    alphaEquivalent (astA e1) (astA e2) EMEmpty
  sameHoleValue (HolePat p1)   (HolePat p2)   =
    alphaEquivalent (cLPat $ astA p1) (cLPat $ astA p2) PatEmpty
  sameHoleValue (HoleType ty1) (HoleType ty2) =
    alphaEquivalent (astA ty1) (astA ty2) TyEmpty
  sameHoleValue _              _              = Nothing
  
  alphaEquivalent :: PatternMap m => Key m -> Key m -> m () -> Maybe ()
  alphaEquivalent v1 v2 e = snd <$> singleton (findMatch env v2 m)
    where
      m = insertMatch emptyAlphaEnv emptyQs v1 () e
      env = ME emptyAlphaEnv err
      err _ = error "hole prune during alpha-equivalence check is impossible!"
  
  ------------------------------------------------------------------------
  
  data SCMap a
    = SCEmpty
    | SCM { scmListComp :: MaybeMap a
          , scmMonadComp :: MaybeMap a
  #if __GLASGOW_HASKELL__ < 900
          , scmDoExpr :: MaybeMap a
  #else
          , scmDoExpr :: FSEnv a -- We use empty string when modulename is Nothing
  #endif
          -- TODO: the rest
          }
    deriving (Functor)
  
  emptySCMapWrapper :: SCMap a
  emptySCMapWrapper = SCM mEmpty mEmpty mEmpty
  
  instance PatternMap SCMap where
  #if __GLASGOW_HASKELL__ < 900
    type Key SCMap = HsStmtContext Name -- see comment on HsDo in GHC
  #elif __GLASGOW_HASKELL__ < 902
    type Key SCMap = HsStmtContext GhcRn
  #elif __GLASGOW_HASKELL__ < 904
    type Key SCMap = HsStmtContext (HsDoRn GhcPs)
  #else
    type Key SCMap = HsDoFlavour
  #endif
  
    mEmpty :: SCMap a
    mEmpty = SCEmpty
  
    mUnion :: SCMap a -> SCMap a -> SCMap a
    mUnion SCEmpty m = m
    mUnion m SCEmpty = m
    mUnion m1 m2 = SCM
      { scmListComp = unionOn scmListComp m1 m2
      , scmMonadComp = unionOn scmMonadComp m1 m2
      , scmDoExpr = unionOn scmDoExpr m1 m2
      }
  
    mAlter :: AlphaEnv -> Quantifiers -> Key SCMap -> A a -> SCMap a -> SCMap a
    mAlter env vs sc f SCEmpty = mAlter env vs sc f emptySCMapWrapper
    mAlter env vs sc f m@SCM{} = go sc
      where
        go ListComp = m { scmListComp = mAlter env vs () f (scmListComp m) }
        go MonadComp = m { scmMonadComp = mAlter env vs () f (scmMonadComp m) }
  #if __GLASGOW_HASKELL__ < 900
        go DoExpr = m { scmDoExpr = mAlter env vs () f (scmDoExpr m) }
  #else
        go (DoExpr mname) = m { scmDoExpr = mAlter env vs (maybe "" moduleNameFS mname) f (scmDoExpr m) }
  #endif
        go MDoExpr{} = missingSyntax "MDoExpr"
  #if __GLASGOW_HASKELL__ < 904
        go ArrowExpr = missingSyntax "ArrowExpr"
        go (PatGuard _) = missingSyntax "PatGuard"
        go (ParStmtCtxt _) = missingSyntax "ParStmtCtxt"
        go (TransStmtCtxt _) = missingSyntax "TransStmtCtxt"
  #endif
        go GhciStmtCtxt = missingSyntax "GhciStmtCtxt"
  
    mMatch :: MatchEnv -> Key SCMap -> (Substitution, SCMap a) -> [(Substitution, a)]
    mMatch _   _  (_,SCEmpty)  = []
    mMatch env sc (hs,m@SCM{}) = go sc (hs,m)
      where
        go ListComp = mapFor scmListComp >=> mMatch env ()
        go MonadComp = mapFor scmMonadComp >=> mMatch env ()
  #if __GLASGOW_HASKELL__ < 900
        go DoExpr = mapFor scmDoExpr >=> mMatch env ()
  #else
        go (DoExpr mname) = mapFor scmDoExpr >=> mMatch env (maybe "" moduleNameFS mname)
  #endif
        go _ = const [] -- TODO
  
  ------------------------------------------------------------------------
  
  -- Note [MatchGroup]
  -- A MatchGroup contains a list of argument types and a result type, but
  -- these aren't available until after typechecking, so they are all placeholders
  -- at this point. Also, don't care about the origin.
  newtype MGMap a = MGMap { unMGMap :: ListMap MMap a }
    deriving (Functor)
  
  instance PatternMap MGMap where
    type Key MGMap = MatchGroup GhcPs (LocatedA (HsExpr GhcPs))
  
    mEmpty :: MGMap a
    mEmpty = MGMap mEmpty
  
    mUnion :: MGMap a -> MGMap a -> MGMap a
    mUnion (MGMap m1) (MGMap m2) = MGMap (mUnion m1 m2)
  
    mAlter :: AlphaEnv -> Quantifiers -> Key MGMap -> A a -> MGMap a -> MGMap a
    mAlter env vs mg f (MGMap m) = MGMap (mAlter env vs alts f m)
      where alts = map unLoc (unLoc $ mg_alts mg)
  
    mMatch :: MatchEnv -> Key MGMap -> (Substitution, MGMap a) -> [(Substitution, a)]
    mMatch env mg = mapFor unMGMap >=> mMatch env alts
      where alts = map unLoc (unLoc $ mg_alts mg)
  
  ------------------------------------------------------------------------
  
  newtype MMap a = MMap { unMMap :: ListMap PatMap (GRHSSMap a) }
    deriving (Functor)
  
  instance PatternMap MMap where
    type Key MMap = Match GhcPs (LocatedA (HsExpr GhcPs))
  
    mEmpty :: MMap a
    mEmpty = MMap mEmpty
  
    mUnion :: MMap a -> MMap a -> MMap a
    mUnion (MMap m1) (MMap m2) = MMap (mUnion m1 m2)
  
    mAlter :: AlphaEnv -> Quantifiers -> Key MMap -> A a -> MMap a -> MMap a
    mAlter env vs match f (MMap m) =
      let lpats = m_pats match
          pbs = collectPatsBinders CollNoDictBinders lpats
          env' = foldr extendAlphaEnvInternal env pbs
          vs' = vs `exceptQ` pbs
      in MMap (mAlter env vs lpats
                (toA (mAlter env' vs' (m_grhss match) f)) m)
  
    mMatch :: MatchEnv -> Key MMap -> (Substitution, MMap a) -> [(Substitution, a)]
    mMatch env match = mapFor unMMap >=> mMatch env lpats >=> mMatch env' (m_grhss match)
      where
        lpats = m_pats match
        pbs = collectPatsBinders CollNoDictBinders lpats
        env' = extendMatchEnv env pbs
  
  ------------------------------------------------------------------------
  
  data CDMap a
    = CDEmpty
    | CDMap { cdPrefixCon :: ListMap PatMap a
            -- TODO , cdRecCon    :: MaybeMap a
            , cdInfixCon  :: PatMap (PatMap a)
            }
    deriving (Functor)
  
  emptyCDMapWrapper :: CDMap a
  emptyCDMapWrapper = CDMap mEmpty mEmpty
  
  instance PatternMap CDMap where
  #if __GLASGOW_HASKELL__ < 810
    type Key CDMap = HsConDetails (LPat GhcPs) (HsRecFields GhcPs (LPat GhcPs))
  #elif __GLASGOW_HASKELL__ < 906
    -- We must manually expand 'LPat' to avoid UndecidableInstances in GHC 8.10+
    type Key CDMap = HsConDetails (HsPatSigType GhcPs) (LocatedA (Pat GhcPs)) (HsRecFields GhcPs (LocatedA (Pat GhcPs)))
    -- type HsConPatDetails p = HsConDetails (HsPatSigType (NoGhcTc p)) (LPat p) (HsRecFields p (LPat p))
  #else
    type Key CDMap = HsConDetails (HsConPatTyArg GhcPs) (LocatedA (Pat GhcPs)) (HsRecFields GhcPs (LocatedA (Pat GhcPs)))
  #endif
  
    mEmpty :: CDMap a
    mEmpty = CDEmpty
  
    mUnion :: CDMap a -> CDMap a -> CDMap a
    mUnion CDEmpty m = m
    mUnion m CDEmpty = m
    mUnion m1 m2 = CDMap
      { cdPrefixCon = unionOn cdPrefixCon m1 m2
      , cdInfixCon = unionOn cdInfixCon m1 m2
      }
  
    mAlter :: AlphaEnv -> Quantifiers -> Key CDMap -> A a -> CDMap a -> CDMap a
    mAlter env vs d f CDEmpty   = mAlter env vs d f emptyCDMapWrapper
    mAlter env vs d f m@CDMap{} = go d
      where
        go (PrefixCon tyargs ps) = m { cdPrefixCon = mAlter env vs ps f (cdPrefixCon m) }
        go (RecCon _) = missingSyntax "RecCon"
        go (InfixCon p1 p2) = m { cdInfixCon = mAlter env vs p1
                                                (toA (mAlter env vs p2 f))
                                                (cdInfixCon m) }
  
    mMatch :: MatchEnv -> Key CDMap -> (Substitution, CDMap a) -> [(Substitution, a)]
    mMatch _   _ (_ ,CDEmpty)   = []
    mMatch env d (hs,m@CDMap{}) = go d (hs,m)
      where
        go (PrefixCon tyargs ps) = mapFor cdPrefixCon >=> mMatch env ps
        go (InfixCon p1 p2) = mapFor cdInfixCon >=> mMatch env p1 >=> mMatch env p2
        go _ = const [] -- TODO
  
  ------------------------------------------------------------------------
  
  -- Note [Variable Binders]
  -- We don't actually care about the variable name, since we are checking for
  -- alpha-equivalence.
  
  data PatMap a
    = PatEmpty
    | PatMap { pmHole :: Map RdrName a -- See Note [Holes]
             , pmWild :: MaybeMap a
             , pmVar  :: MaybeMap a -- See Note [Variable Binders]
             , pmParPat :: PatMap a
             , pmTuplePat :: BoxityMap (ListMap PatMap a)
             , pmConPatIn :: FSEnv (CDMap a)
             -- TODO: the rest
             }
    deriving (Functor)
  
  emptyPatMapWrapper :: PatMap a
  emptyPatMapWrapper = PatMap mEmpty mEmpty mEmpty mEmpty mEmpty mEmpty
  
  instance PatternMap PatMap where
  #if __GLASGOW_HASKELL__ < 810
    type Key PatMap = LPat GhcPs
  #else
    -- We must manually expand 'LPat' to avoid UndecidableInstances in GHC 8.10+
    type Key PatMap = LocatedA (Pat GhcPs)
  #endif
  
    mEmpty :: PatMap a
    mEmpty = PatEmpty
  
    mUnion :: PatMap a -> PatMap a -> PatMap a
    mUnion PatEmpty m = m
    mUnion m PatEmpty = m
    mUnion m1 m2 = PatMap
      { pmHole = unionOn pmHole m1 m2
      , pmWild = unionOn pmWild m1 m2
      , pmVar = unionOn pmVar m1 m2
      , pmParPat = unionOn pmParPat m1 m2
      , pmTuplePat = unionOn pmTuplePat m1 m2
      , pmConPatIn = unionOn pmConPatIn m1 m2
      }
  
    mAlter :: AlphaEnv -> Quantifiers -> Key PatMap -> A a -> PatMap a -> PatMap a
    mAlter env vs pat f PatEmpty   = mAlter env vs pat f emptyPatMapWrapper
    mAlter env vs pat f m@PatMap{} = go (unLoc pat)
      where
        go (WildPat _) = m { pmWild = mAlter env vs () f (pmWild m) }
        go (VarPat _ v)
          | unLoc v `isQ` vs = m { pmHole  = mAlter env vs (unLoc v) f (pmHole m) }
          | otherwise        = m { pmVar   = mAlter env vs () f (pmVar m) } -- See Note [Variable Binders]
        go LazyPat{} = missingSyntax "LazyPat"
        go AsPat{} = missingSyntax "AsPat"
        go BangPat{} = missingSyntax "BangPat"
        go ListPat{} = missingSyntax "ListPat"
  #if __GLASGOW_HASKELL__ < 900
        go XPat{} = missingSyntax "XPat"
        go CoPat{} = missingSyntax "CoPat"
        go ConPatOut{} = missingSyntax "ConPatOut"
        go (ConPatIn c d) =
  #else
        go (ConPat _ c d) =
  #endif
          m { pmConPatIn = mAlter env vs (rdrFS (unLoc c)) (toA (mAlter env vs d f)) (pmConPatIn m) }
        go ViewPat{} = missingSyntax "ViewPat"
        go SplicePat{} = missingSyntax "SplicePat"
        go LitPat{} = missingSyntax "LitPat"
        go NPat{} = missingSyntax "NPat"
        go NPlusKPat{} = missingSyntax "NPlusKPat"
  #if __GLASGOW_HASKELL__ < 904
        go (ParPat _ p) = m { pmParPat = mAlter env vs p f (pmParPat m) }
  #else
        go (ParPat _ _ p _) = m { pmParPat = mAlter env vs p f (pmParPat m) }
  #endif
        go (TuplePat _ ps b) =
          m { pmTuplePat = mAlter env vs b (toA (mAlter env vs ps f)) (pmTuplePat m) }
        go SigPat{} = missingSyntax "SigPat"
        go SumPat{} = missingSyntax "SumPat"
  
    mMatch :: MatchEnv -> Key PatMap -> (Substitution, PatMap a) -> [(Substitution, a)]
    mMatch _   _   (_, PatEmpty)   = []
    mMatch env pat (hs,m@PatMap{})
      | Just lp@(L _ p) <- dLPat pat = hss lp ++ go p (hs,m)
      | otherwise = []
      where
        hss lp = extendResult (pmHole m) (HolePat $ mePruneA env lp) hs
  
        go (WildPat _) = mapFor pmWild >=> mMatch env ()
  #if __GLASGOW_HASKELL__ < 904
        go (ParPat _ p) = mapFor pmParPat >=> mMatch env p
  #else
        go (ParPat _ _ p _) = mapFor pmParPat >=> mMatch env p
  #endif
        go (TuplePat _ ps b) = mapFor pmTuplePat >=> mMatch env b >=> mMatch env ps
        go (VarPat _ _) = mapFor pmVar >=> mMatch env ()
  #if __GLASGOW_HASKELL__ < 900
        go (ConPatIn c d) =
  #else
        go (ConPat _ c d) =
  #endif
          mapFor pmConPatIn >=> mMatch env (rdrFS (unLoc c)) >=> mMatch env d
        go _ = const [] -- TODO
  
  ------------------------------------------------------------------------
  
  newtype GRHSSMap a = GRHSSMap { unGRHSSMap :: LBMap (ListMap GRHSMap a) }
    deriving (Functor)
  
  instance PatternMap GRHSSMap where
    type Key GRHSSMap = GRHSs GhcPs (LocatedA (HsExpr GhcPs))
  
    mEmpty :: GRHSSMap a
    mEmpty = GRHSSMap mEmpty
  
    mUnion :: GRHSSMap a -> GRHSSMap a -> GRHSSMap a
    mUnion (GRHSSMap m1) (GRHSSMap m2) = GRHSSMap (mUnion m1 m2)
  
    mAlter :: AlphaEnv -> Quantifiers -> Key GRHSSMap -> A a -> GRHSSMap a -> GRHSSMap a
    mAlter env vs grhss f (GRHSSMap m) =
      let lbs = grhssLocalBinds grhss
          bs = collectLocalBinders CollNoDictBinders lbs
          env' = foldr extendAlphaEnvInternal env bs
          vs' = vs `exceptQ` bs
      in GRHSSMap (mAlter env vs lbs
                    (toA (mAlter env' vs' (map unLoc $ grhssGRHSs grhss) f)) m)
  
    mMatch :: MatchEnv -> Key GRHSSMap -> (Substitution, GRHSSMap a) -> [(Substitution, a)]
    mMatch env grhss = mapFor unGRHSSMap >=> mMatch env lbs
                        >=> mMatch env' (map unLoc $ grhssGRHSs grhss)
      where
        lbs = grhssLocalBinds  grhss
        bs = collectLocalBinders CollNoDictBinders lbs
        env' = extendMatchEnv env bs
  
  ------------------------------------------------------------------------
  
  newtype GRHSMap a = GRHSMap { unGRHSMap :: SLMap (EMap a) }
    deriving (Functor)
  
  instance PatternMap GRHSMap where
    type Key GRHSMap = GRHS GhcPs (LocatedA (HsExpr GhcPs))
  
    mEmpty :: GRHSMap a
    mEmpty = GRHSMap mEmpty
  
    mUnion :: GRHSMap a -> GRHSMap a -> GRHSMap a
    mUnion (GRHSMap m1) (GRHSMap m2) = GRHSMap (mUnion m1 m2)
  
    mAlter :: AlphaEnv -> Quantifiers -> Key GRHSMap -> A a -> GRHSMap a -> GRHSMap a
  #if __GLASGOW_HASKELL__ < 900
    mAlter _ _ XGRHS{} _ _ = missingSyntax "XGRHS"
  #endif
    mAlter env vs (GRHS _ gs b) f (GRHSMap m) =
      let bs = collectLStmtsBinders CollNoDictBinders gs
          env' = foldr extendAlphaEnvInternal env bs
          vs' = vs `exceptQ` bs
      in GRHSMap (mAlter env vs gs (toA (mAlter env' vs' b f)) m)
  
    mMatch :: MatchEnv -> Key GRHSMap -> (Substitution, GRHSMap a) -> [(Substitution, a)]
  #if __GLASGOW_HASKELL__ < 900
    mMatch _ XGRHS{} = const []
  #endif
    mMatch env (GRHS _ gs b) =
      mapFor unGRHSMap >=> mMatch env gs >=> mMatch env' b
      where
        bs = collectLStmtsBinders CollNoDictBinders gs
        env' = extendMatchEnv env bs
  
  ------------------------------------------------------------------------
  
  data SLMap a
    = SLEmpty
    | SLM { slmNil :: MaybeMap a
          , slmCons :: SMap (SLMap a)
          }
    deriving (Functor)
  
  emptySLMapWrapper :: SLMap a
  emptySLMapWrapper = SLM mEmpty mEmpty
  
  instance PatternMap SLMap where
    type Key SLMap = [LocatedA (Stmt GhcPs (LocatedA (HsExpr GhcPs)))]
  
    mEmpty :: SLMap a
    mEmpty = SLEmpty
  
    mUnion :: SLMap a -> SLMap a -> SLMap a
    mUnion SLEmpty m = m
    mUnion m SLEmpty = m
    mUnion m1 m2 = SLM
      { slmNil = unionOn slmNil m1 m2
      , slmCons = unionOn slmCons m1 m2
      }
  
    mAlter :: AlphaEnv -> Quantifiers -> Key SLMap -> A a -> SLMap a -> SLMap a
    mAlter env vs ss f SLEmpty = mAlter env vs ss f emptySLMapWrapper
    mAlter env vs ss f m@SLM{} = go ss
      where
        go []      = m { slmNil = mAlter env vs () f (slmNil m) }
        go (s:ss') =
          let
            bs = collectLStmtBinders CollNoDictBinders s
            env' = foldr extendAlphaEnvInternal env bs
            vs' = vs `exceptQ` bs
          in m { slmCons = mAlter env vs s (toA (mAlter env' vs' ss' f)) (slmCons m) }
  
    mMatch :: MatchEnv -> Key SLMap -> (Substitution, SLMap a) -> [(Substitution, a)]
    mMatch _   _  (_,SLEmpty)  = []
    mMatch env ss (hs,m@SLM{}) = go ss (hs,m)
      where
        go [] = mapFor slmNil >=> mMatch env ()
        go (s:ss') =
          let
            bs = collectLStmtBinders CollNoDictBinders s
            env' = extendMatchEnv env bs
          in mapFor slmCons >=> mMatch env s >=> mMatch env' ss'
  
  ------------------------------------------------------------------------
  
  -- Note [Local Binds]
  -- We simplify this a bit here, assuming always ValBindsIn (because ValBindsOut
  -- only shows up after renaming. Also we ignore the [LSig] for now.
  
  data LBMap a
    = LBEmpty
    | LB { lbValBinds :: ListMap BMap a -- see Note [Local Binds]
         -- TODO: , lbIPBinds ::
         , lbEmpty :: MaybeMap a
         }
    deriving (Functor)
  
  emptyLBMapWrapper :: LBMap a
  emptyLBMapWrapper = LB mEmpty mEmpty
  
  instance PatternMap LBMap where
    type Key LBMap = HsLocalBinds GhcPs
  
    mEmpty :: LBMap a
    mEmpty = LBEmpty
  
    mUnion :: LBMap a -> LBMap a -> LBMap a
    mUnion LBEmpty m = m
    mUnion m LBEmpty = m
    mUnion m1 m2 = LB
      { lbValBinds = unionOn lbValBinds m1 m2
      , lbEmpty = unionOn lbEmpty m1 m2
      }
  
    mAlter :: AlphaEnv -> Quantifiers -> Key LBMap -> A a -> LBMap a -> LBMap a
    mAlter env vs lbs f LBEmpty = mAlter env vs lbs f emptyLBMapWrapper
    mAlter env vs lbs f m@LB{}  = go lbs
      where
        go (EmptyLocalBinds _) = m { lbEmpty = mAlter env vs () f (lbEmpty m) }
  #if __GLASGOW_HASKELL__ < 900
        go XHsLocalBindsLR{} = missingSyntax "XHsLocalBindsLR"
  #endif
        go (HsValBinds _ vbs) =
          let
            bs = collectHsValBinders CollNoDictBinders vbs
            env' = foldr extendAlphaEnvInternal env bs
            vs' = vs `exceptQ` bs
          in m { lbValBinds = mAlter env' vs' (deValBinds vbs) f (lbValBinds m) }
        go HsIPBinds{} = missingSyntax "HsIPBinds"
  
    mMatch :: MatchEnv -> Key LBMap -> (Substitution, LBMap a) -> [(Substitution, a)]
    mMatch _   _   (_,LBEmpty) = []
    mMatch env lbs (hs,m@LB{}) = go lbs (hs,m)
      where
        go (EmptyLocalBinds _) = mapFor lbEmpty >=> mMatch env ()
        go (HsValBinds _ vbs) =
          let
            bs = collectHsValBinders CollNoDictBinders vbs
            env' = extendMatchEnv env bs
          in mapFor lbValBinds >=> mMatch env' (deValBinds vbs)
        go _ = const [] -- TODO
  
  deValBinds :: HsValBinds GhcPs -> [HsBind GhcPs]
  deValBinds (ValBinds _ lbs _) = map unLoc (bagToList lbs)
  deValBinds _ = error "deValBinds ValBindsOut"
  
  ------------------------------------------------------------------------
  
  -- Note [Bind env]
  -- We don't extend the env because it was already done at the LBMap level
  -- (because all bindings are available to the recursive group).
  
  data BMap a
    = BMEmpty
    | BM { bmFunBind :: MGMap a
         , bmVarBind :: EMap a
         , bmPatBind :: PatMap (GRHSSMap a)
         -- TODO: rest
         }
    deriving (Functor)
  
  emptyBMapWrapper :: BMap a
  emptyBMapWrapper = BM mEmpty mEmpty mEmpty
  
  instance PatternMap BMap where
    type Key BMap = HsBind GhcPs
  
    mEmpty :: BMap a
    mEmpty = BMEmpty
  
    mUnion :: BMap a -> BMap a -> BMap a
    mUnion BMEmpty m = m
    mUnion m BMEmpty = m
    mUnion m1 m2 = BM
      { bmFunBind = unionOn bmFunBind m1 m2
      , bmVarBind = unionOn bmVarBind m1 m2
      , bmPatBind = unionOn bmPatBind m1 m2
      }
  
    mAlter :: AlphaEnv -> Quantifiers -> Key BMap -> A a -> BMap a -> BMap a
    mAlter env vs b f BMEmpty = mAlter env vs b f emptyBMapWrapper
    mAlter env vs b f m@BM{}  = go b
      where -- see Note [Bind env]
  #if __GLASGOW_HASKELL__ < 900
        go XHsBindsLR{} = missingSyntax "XHsBindsLR"
        go (FunBind _ _ mg _ _) = m { bmFunBind = mAlter env vs mg f (bmFunBind m) }
        go (VarBind _ _ e _) = m { bmVarBind = mAlter env vs e f (bmVarBind m) }
  #else
        go (FunBind{fun_matches = mg}) = m { bmFunBind = mAlter env vs mg f (bmFunBind m) }
        go (VarBind _ _ e) = m { bmVarBind = mAlter env vs e f (bmVarBind m) }
  #endif
        go (PatBind{pat_lhs=lhs, pat_rhs=rhs}) =
          m { bmPatBind = mAlter env vs lhs
                (toA $ mAlter env vs rhs f) (bmPatBind m) }
  #if __GLASGOW_HASKELL__ < 904
        go AbsBinds{} = missingSyntax "AbsBinds"
  #endif
        go PatSynBind{} = missingSyntax "PatSynBind"
  
    mMatch :: MatchEnv -> Key BMap -> (Substitution, BMap a) -> [(Substitution, a)]
    mMatch _   _ (_,BMEmpty) = []
    mMatch env b (hs,m@BM{}) = go b (hs,m)
      where
  #if __GLASGOW_HASKELL__ < 900
        go (FunBind _ _ mg _ _) = mapFor bmFunBind >=> mMatch env mg
        go (VarBind _ _ e _) = mapFor bmVarBind >=> mMatch env e
  #else
        go (FunBind{fun_matches = mg}) = mapFor bmFunBind >=> mMatch env mg
        go (VarBind _ _ e) = mapFor bmVarBind >=> mMatch env e
  #endif
        go (PatBind{pat_lhs=lhs, pat_rhs=rhs})
          = mapFor bmPatBind >=> mMatch env lhs >=> mMatch env rhs
        go _ = const [] -- TODO
  
  ------------------------------------------------------------------------
  
  data SMap a
    = SMEmpty
    | SM { smLastStmt :: EMap a
         , smBindStmt :: PatMap (EMap a)
         , smBodyStmt :: EMap a
           -- TODO: the rest
         }
    deriving (Functor)
  
  emptySMapWrapper :: SMap a
  emptySMapWrapper = SM mEmpty mEmpty mEmpty
  
  instance PatternMap SMap where
    type Key SMap = LocatedA (Stmt GhcPs (LocatedA (HsExpr GhcPs)))
  
    mEmpty :: SMap a
    mEmpty = SMEmpty
  
    mUnion :: SMap a -> SMap a -> SMap a
    mUnion SMEmpty m = m
    mUnion m SMEmpty = m
    mUnion m1 m2 = SM
      { smLastStmt = unionOn smLastStmt m1 m2
      , smBindStmt = unionOn smBindStmt m1 m2
      , smBodyStmt = unionOn smBodyStmt m1 m2
      }
  
    mAlter :: AlphaEnv -> Quantifiers -> Key SMap -> A a -> SMap a -> SMap a
    mAlter env vs s f SMEmpty = mAlter env vs s f emptySMapWrapper
    mAlter env vs s f m@(SM {}) = go (unLoc s)
      where
        go (BodyStmt _ e _ _) = m { smBodyStmt = mAlter env vs e f (smBodyStmt m) }
        go (LastStmt _ e _ _)   = m { smLastStmt = mAlter env vs e f (smLastStmt m) }
  #if __GLASGOW_HASKELL__ < 900
        go XStmtLR{} = missingSyntax "XStmtLR"
        go (BindStmt _ p e _ _) =
  #else
        go (BindStmt _ p e) =
  #endif
          let bs = collectPatBinders CollNoDictBinders p
              env' = foldr extendAlphaEnvInternal env bs
              vs' = vs `exceptQ` bs
          in m { smBindStmt = mAlter env vs p
                                (toA (mAlter env' vs' e f)) (smBindStmt m) }
        go LetStmt{} = missingSyntax "LetStmt"
        go ParStmt{} = missingSyntax "ParStmt"
        go TransStmt{} = missingSyntax "TransStmt"
        go RecStmt{} = missingSyntax "RecStmt"
        go ApplicativeStmt{} = missingSyntax "ApplicativeStmt"
  
    mMatch :: MatchEnv -> Key SMap -> (Substitution, SMap a) -> [(Substitution, a)]
    mMatch _   _   (_,SMEmpty) = []
    mMatch env s   (hs,m) = go (unLoc s) (hs,m)
      where
        go (BodyStmt _ e _ _) = mapFor smBodyStmt >=> mMatch env e
        go (LastStmt _ e _ _) = mapFor smLastStmt >=> mMatch env e
  #if __GLASGOW_HASKELL__ < 900
        go (BindStmt _ p e _ _) =
  #else
        go (BindStmt _ p e) =
  #endif
          let bs = collectPatBinders CollNoDictBinders p
              env' = extendMatchEnv env bs
          in mapFor smBindStmt >=> mMatch env p >=> mMatch env' e
        go _ = const [] -- TODO
  
  ------------------------------------------------------------------------
  
  data TyMap a
    = TyEmpty
    | TM { tyHole    :: Map RdrName a -- See Note [Holes]
         , tyHsTyVar :: VMap a
         , tyHsAppTy :: TyMap (TyMap a)
  #if __GLASGOW_HASKELL__ < 810
         , tyHsForAllTy :: ForAllTyMap a -- See Note [Telescope]
  #else
         , tyHsForAllTy :: ForallVisMap (ForAllTyMap a) -- See Note [Telescope]
  #endif
         , tyHsFunTy :: TyMap (TyMap a)
         , tyHsListTy :: TyMap a
         , tyHsParTy :: TyMap a
         , tyHsQualTy :: TyMap (ListMap TyMap a)
         , tyHsSumTy :: ListMap TyMap a
         , tyHsTupleTy :: TupleSortMap (ListMap TyMap a)
           -- TODO: the rest
         }
    deriving (Functor)
  
  emptyTyMapWrapper :: TyMap a
  emptyTyMapWrapper = TM
    mEmpty mEmpty mEmpty
    mEmpty mEmpty mEmpty mEmpty mEmpty mEmpty mEmpty
  
  instance PatternMap TyMap where
    type Key TyMap = LocatedA (HsType GhcPs)
  
    mEmpty :: TyMap a
    mEmpty = TyEmpty
  
    mUnion :: TyMap a -> TyMap a -> TyMap a
    mUnion TyEmpty m = m
    mUnion m TyEmpty = m
    mUnion m1 m2 = TM
      { tyHole = unionOn tyHole m1 m2
      , tyHsTyVar = unionOn tyHsTyVar m1 m2
      , tyHsAppTy = unionOn tyHsAppTy m1 m2
      , tyHsForAllTy = unionOn tyHsForAllTy m1 m2
      , tyHsFunTy = unionOn tyHsFunTy m1 m2
      , tyHsListTy = unionOn tyHsListTy m1 m2
      , tyHsParTy = unionOn tyHsParTy m1 m2
      , tyHsQualTy = unionOn tyHsQualTy m1 m2
      , tyHsSumTy = unionOn tyHsSumTy m1 m2
      , tyHsTupleTy = unionOn tyHsTupleTy m1 m2
      }
  
    mAlter :: AlphaEnv -> Quantifiers -> Key TyMap -> A a -> TyMap a -> TyMap a
    mAlter env vs ty f TyEmpty = mAlter env vs ty f emptyTyMapWrapper
    mAlter env vs ty f m@(TM {}) =
      go (unLoc ty) -- See Note [TyVar Quantifiers]
      where
        go (HsTyVar _ _ (L _ v))
          | v `isQ` vs = m { tyHole    = mAlter env vs v f (tyHole m) }
          | otherwise  = m { tyHsTyVar = mAlter env vs v f (tyHsTyVar m) }
        go HsOpTy{} = missingSyntax "HsOpTy"
        go HsIParamTy{} = missingSyntax "HsIParamTy"
        go HsKindSig{} = missingSyntax "HsKindSig"
        go HsSpliceTy{} = missingSyntax "HsSpliceTy"
        go HsDocTy{} = missingSyntax "HsDocTy"
        go HsBangTy{} = missingSyntax "HsBangTy"
        go HsRecTy{} = missingSyntax "HsRecTy"
        go (HsAppTy _ ty1 ty2) = m { tyHsAppTy = mAlter env vs ty1 (toA (mAlter env vs ty2 f)) (tyHsAppTy m) }
  #if __GLASGOW_HASKELL__ < 810
        go (HsForAllTy _ bndrs ty') = m { tyHsForAllTy = mAlter env vs (map extractBinderInfo bndrs, ty') f (tyHsForAllTy m) }
  #elif __GLASGOW_HASKELL__ < 900
        go (HsForAllTy _ vis bndrs ty') =
          m { tyHsForAllTy = mAlter env vs (vis == ForallVis) (toA (mAlter env vs (map extractBinderInfo bndrs, ty') f)) (tyHsForAllTy m) }
  #else
        go (HsForAllTy _ vis ty') | (isVisible, bndrs) <- splitVisBinders vis =
          m { tyHsForAllTy = mAlter env vs isVisible (toA (mAlter env vs (bndrs, ty') f)) (tyHsForAllTy m) }
  #endif
  #if __GLASGOW_HASKELL__ < 900
        go (HsFunTy _ ty1 ty2) = m { tyHsFunTy = mAlter env vs ty1 (toA (mAlter env vs ty2 f)) (tyHsFunTy m) }
  #else
        go (HsFunTy _ _ ty1 ty2) = m { tyHsFunTy = mAlter env vs ty1 (toA (mAlter env vs ty2 f)) (tyHsFunTy m) }
  #endif
        go (HsListTy _ ty') = m { tyHsListTy = mAlter env vs ty' f (tyHsListTy m) }
        go (HsParTy _ ty') = m { tyHsParTy = mAlter env vs ty' f (tyHsParTy m) }
        go (HsQualTy _ cons ty') =
  #if __GLASGOW_HASKELL__ < 904
          m { tyHsQualTy = mAlter env vs ty' (toA (mAlter env vs (fromMaybeContext cons) f)) (tyHsQualTy m) }
  #else
          m { tyHsQualTy = mAlter env vs ty' (toA (mAlter env vs (fromMaybeContext (Just cons)) f)) (tyHsQualTy m) }
  #endif
        go HsStarTy{} = missingSyntax "HsStarTy"
        go (HsSumTy _ tys) = m { tyHsSumTy = mAlter env vs tys f (tyHsSumTy m) }
        go (HsTupleTy _ ts tys) =
          m { tyHsTupleTy = mAlter env vs ts (toA (mAlter env vs tys f)) (tyHsTupleTy m) }
        go XHsType{} = missingSyntax "XHsType"
        go HsExplicitListTy{} = missingSyntax "HsExplicitListTy"
        go HsExplicitTupleTy{} = missingSyntax "HsExplicitTupleTy"
        go HsTyLit{} = missingSyntax "HsTyLit"
        go HsWildCardTy{} = missingSyntax "HsWildCardTy"
        go HsAppKindTy{} = missingSyntax "HsAppKindTy"
  
    mMatch :: MatchEnv -> Key TyMap -> (Substitution, TyMap a) -> [(Substitution, a)]
    mMatch _   _  (_,TyEmpty) = []
    mMatch env ty (hs,m@TM{}) =
      hss ++ go (unLoc ty) (hs,m) -- See Note [TyVar Quantifiers]
      where
        hss = extendResult (tyHole m) (HoleType $ mePruneA env ty) hs
  
        go (HsAppTy _ ty1 ty2) = mapFor tyHsAppTy >=> mMatch env ty1 >=> mMatch env ty2
  #if __GLASGOW_HASKELL__ < 810
        go (HsForAllTy _ bndrs ty') = mapFor tyHsForAllTy >=> mMatch env (map extractBinderInfo bndrs, ty')
  #elif __GLASGOW_HASKELL__ < 900
        go (HsForAllTy _ vis bndrs ty') =
          mapFor tyHsForAllTy >=> mMatch env (vis == ForallVis) >=> mMatch env (map extractBinderInfo bndrs, ty')
  #else
        go (HsForAllTy _ telescope ty') | (isVisible, bndrs) <- splitVisBinders telescope =
          mapFor tyHsForAllTy >=> mMatch env isVisible >=> mMatch env (bndrs, ty')
  #endif
  #if __GLASGOW_HASKELL__ < 900
        go (HsFunTy _ ty1 ty2) = mapFor tyHsFunTy >=> mMatch env ty1 >=> mMatch env ty2
  #else
        go (HsFunTy _ _ ty1 ty2) = mapFor tyHsFunTy >=> mMatch env ty1 >=> mMatch env ty2
  #endif
        go (HsListTy _ ty') = mapFor tyHsListTy >=> mMatch env ty'
        go (HsParTy _ ty') = mapFor tyHsParTy >=> mMatch env ty'
  #if __GLASGOW_HASKELL__ < 904
        go (HsQualTy _ cons ty') = mapFor tyHsQualTy >=> mMatch env ty' >=> mMatch env (fromMaybeContext cons)
  #else
        go (HsQualTy _ cons ty') = mapFor tyHsQualTy >=> mMatch env ty' >=> mMatch env (fromMaybeContext (Just cons))
  #endif
        go (HsSumTy _ tys) = mapFor tyHsSumTy >=> mMatch env tys
        go (HsTupleTy _ ts tys) = mapFor tyHsTupleTy >=> mMatch env ts >=> mMatch env tys
        go (HsTyVar _ _ v) = mapFor tyHsTyVar >=> mMatch env (unLoc v)
        go _                  = const [] -- TODO
  
  #if __GLASGOW_HASKELL__ < 900
  extractBinderInfo :: LHsTyVarBndr GhcPs -> (RdrName, Maybe (LHsKind GhcPs))
  extractBinderInfo = go . unLoc
    where
      go (UserTyVar _ v) = (unLoc v, Nothing)
      go (KindedTyVar _ v k) = (unLoc v, Just k)
      go XTyVarBndr{} = missingSyntax "XTyVarBndr"
  #else
  splitVisBinders :: HsForAllTelescope GhcPs -> (Bool, [(RdrName, Maybe (LHsKind GhcPs))])
  splitVisBinders HsForAllVis{..} = (True, map extractBinderInfo hsf_vis_bndrs)
  splitVisBinders HsForAllInvis{..} = (False, map extractBinderInfo hsf_invis_bndrs)
  
  extractBinderInfo :: LHsTyVarBndr flag GhcPs -> (RdrName, Maybe (LHsKind GhcPs))
  extractBinderInfo = go . unLoc
    where
      go (UserTyVar _ _ v) = (unLoc v, Nothing)
      go (KindedTyVar _ _ v k) = (unLoc v, Just k)
      go XTyVarBndr{} = missingSyntax "XTyVarBndr"
  #endif
  
  ------------------------------------------------------------------------
  
  newtype RFMap a = RFM { rfmField :: VMap (EMap a) }
    deriving (Functor)
  
  instance PatternMap RFMap where
  #if __GLASGOW_HASKELL__ < 904
    type Key RFMap = LocatedA (HsRecField' RdrName (LocatedA (HsExpr GhcPs)))
  #else
    type Key RFMap = LocatedA (HsRecField GhcPs (LocatedA (HsExpr GhcPs)))
  #endif
  
    mEmpty :: RFMap a
    mEmpty = RFM mEmpty
  
    mUnion :: RFMap a -> RFMap a -> RFMap a
    mUnion (RFM m1) (RFM m2) = RFM (mUnion m1 m2)
  
    mAlter :: AlphaEnv -> Quantifiers -> Key RFMap -> A a -> RFMap a -> RFMap a
    mAlter env vs lf f m = go (unLoc lf)
      where
  #if __GLASGOW_HASKELL__ < 904
        go (HsRecField _ lbl arg _pun) =
          m { rfmField = mAlter env vs (unLoc lbl) (toA (mAlter env vs arg f)) (rfmField m) }
  #else
        go (HsFieldBind _ lbl arg _pun) =
          m { rfmField = mAlter env vs (unLoc (foLabel (unLoc lbl))) (toA (mAlter env vs arg f)) (rfmField m) }
  #endif
  
    mMatch :: MatchEnv -> Key RFMap -> (Substitution, RFMap a) -> [(Substitution, a)]
    mMatch env lf (hs,m) = go (unLoc lf) (hs,m)
      where
  #if __GLASGOW_HASKELL__ < 904
        go (HsRecField _ lbl arg _pun) =
          mapFor rfmField >=> mMatch env (unLoc lbl) >=> mMatch env arg
  #else
        go (HsFieldBind _ lbl arg _pun) =
          mapFor rfmField >=> mMatch env (unLoc (foLabel (unLoc lbl))) >=> mMatch env arg
  #endif
  
  -- Helper class to collapse the complex encoding of record fields into RdrNames.
  -- (The complexity is to support punning/duplicate/overlapping fields, which
  -- all happens well after parsing, so is not needed here.)
  class RecordFieldToRdrName f where
    recordFieldToRdrName :: f -> RdrName
  
  instance RecordFieldToRdrName (AmbiguousFieldOcc GhcPs) where
  #if __GLASGOW_HASKELL__ < 908
    recordFieldToRdrName = rdrNameAmbiguousFieldOcc
  #else
    recordFieldToRdrName = ambiguousFieldOccRdrName
  #endif
  
  #if __GLASGOW_HASKELL__ < 904
  instance RecordFieldToRdrName (FieldOcc p) where
    recordFieldToRdrName = unLoc . rdrNameFieldOcc
  #else
  instance RecordFieldToRdrName (FieldOcc GhcPs) where
    recordFieldToRdrName = unLoc . foLabel
  #endif
  
  instance RecordFieldToRdrName (FieldLabelStrings GhcPs) where
    recordFieldToRdrName = error "TBD"
  
  #if __GLASGOW_HASKELL__ < 904
  -- Either [LHsRecUpdField GhcPs] [LHsRecUpdProj GhcPs]
  fieldsToRdrNamesUpd
    :: Either [LHsRecUpdField GhcPs] [LHsRecUpdProj GhcPs]
    -> [LHsRecField' GhcPs RdrName (LHsExpr GhcPs)]
  fieldsToRdrNamesUpd (Left fs) = map go fs
    where
      go (L l (HsRecField a (L l2 f) arg pun)) =
        L l (HsRecField a (L l2 (recordFieldToRdrName f)) arg pun)
  fieldsToRdrNamesUpd (Right fs) = map go fs
    where
      go (L l (HsRecField a (L l2 f) arg pun)) =
        L l (HsRecField a (L l2 (recordFieldToRdrName f)) arg pun)
  #elif __GLASGOW_HASKELL__ < 908
  fieldsToRdrNamesUpd :: Either [LHsRecUpdField GhcPs] [LHsRecUpdProj GhcPs]
    -> [LHsRecField GhcPs (LHsExpr GhcPs)]
  fieldsToRdrNamesUpd (Left xs) = map go xs
    where
      go (L l (HsFieldBind a (L l2 f) arg pun)) =
        let lrdrName = case f of
              Unambiguous _ n -> n
              Ambiguous _ n -> n
              XAmbiguousFieldOcc{} -> error "XAmbiguousFieldOcc"
            f' = FieldOcc NoExtField lrdrName
         in L l (HsFieldBind a (L l2 f') arg pun)
  fieldsToRdrNamesUpd (Right xs) = map go xs
    where
      go (L l (HsFieldBind a (L l2 _f) arg pun)) =
        let lrdrName = error "TBD" -- same as GHC 9.2
            f' = FieldOcc NoExtField lrdrName
         in L l (HsFieldBind a (L l2 f') arg pun)
  #else
  fieldsToRdrNamesUpd :: LHsRecUpdFields GhcPs
    -> [LHsRecField GhcPs (LHsExpr GhcPs)]
  fieldsToRdrNamesUpd (RegularRecUpdFields _ xs) = map go xs
    where
      go (L l (HsFieldBind a (L l2 f) arg pun)) =
        let lrdrName = case f of
              Unambiguous _ n -> n
              Ambiguous _ n -> n
              XAmbiguousFieldOcc{} -> error "XAmbiguousFieldOcc"
            f' = FieldOcc NoExtField lrdrName
         in L l (HsFieldBind a (L l2 f') arg pun)
  fieldsToRdrNamesUpd (OverloadedRecUpdFields _ xs) = map go xs
    where
      go (L l (HsFieldBind a (L l2 _f) arg pun)) =
        let lrdrName = error "TBD" -- same as GHC 9.2
            f' = FieldOcc NoExtField lrdrName
         in L l (HsFieldBind a (L l2 f') arg pun)
  #endif
  
  #if __GLASGOW_HASKELL__ < 904
  fieldsToRdrNames
    :: RecordFieldToRdrName f
    => [LHsRecField' GhcPs f arg]
    -> [LHsRecField' GhcPs RdrName arg]
  fieldsToRdrNames = map go
    where
      go (L l (HsRecField a (L l2 f) arg pun)) =
        L l (HsRecField a (L l2 (recordFieldToRdrName f)) arg pun)
  #endif
  
  ------------------------------------------------------------------------
  
  data TupleSortMap a = TupleSortMap
    { tsUnboxed :: MaybeMap a
    , tsBoxed :: MaybeMap a
    , tsConstraint :: MaybeMap a
    , tsBoxedOrConstraint :: MaybeMap a
    }
    deriving (Functor)
  
  instance PatternMap TupleSortMap where
    type Key TupleSortMap = HsTupleSort
  
    mEmpty :: TupleSortMap a
    mEmpty = TupleSortMap mEmpty mEmpty mEmpty mEmpty
  
    mUnion :: TupleSortMap a -> TupleSortMap a -> TupleSortMap a
    mUnion m1 m2 = TupleSortMap
      { tsUnboxed = unionOn tsUnboxed m1 m2
      , tsBoxed = unionOn tsBoxed m1 m2
      , tsConstraint = unionOn tsConstraint m1 m2
      , tsBoxedOrConstraint = unionOn tsBoxedOrConstraint m1 m2
      }
  
    mAlter :: AlphaEnv -> Quantifiers -> Key TupleSortMap -> A a -> TupleSortMap a -> TupleSortMap a
    mAlter env vs HsUnboxedTuple f m =
      m { tsUnboxed = mAlter env vs () f (tsUnboxed m) }
    -- mAlter env vs HsBoxedOrConstraintTuple f m =
    --   m { tsBoxed = mAlter env vs () f (tsBoxed m) }
    -- mAlter env vs HsConstraintTuple f m =
    --   m { tsConstraint = mAlter env vs () f (tsConstraint m) }
    mAlter env vs HsBoxedOrConstraintTuple f m =
      m { tsBoxedOrConstraint = mAlter env vs () f (tsBoxedOrConstraint m) }
  
    mMatch :: MatchEnv -> Key TupleSortMap -> (Substitution, TupleSortMap a) -> [(Substitution, a)]
    mMatch env HsUnboxedTuple = mapFor tsUnboxed >=> mMatch env ()
    -- mMatch env HsBoxedTuple = mapFor tsBoxed >=> mMatch env ()
    -- mMatch env HsConstraintTuple = mapFor tsConstraint >=> mMatch env ()
    mMatch env HsBoxedOrConstraintTuple = mapFor tsBoxedOrConstraint >=> mMatch env ()
  
  ------------------------------------------------------------------------
  
  -- Note [Telescope]
  -- Haskell's forall quantification is a telescope (type binders are in-scope
  -- to binders to the right. Example: forall r (a :: TYPE r). ...
  --
  -- To support this, we peel off the binders one at a time, extending the
  -- environment at each layer.
  
  data ForAllTyMap a = ForAllTyMap
    { fatNil :: TyMap a
    , fatUser :: ForAllTyMap a
    , fatKinded :: TyMap (ForAllTyMap a)
    }
    deriving (Functor)
  
  instance PatternMap ForAllTyMap where
    type Key ForAllTyMap = ([(RdrName, Maybe (LocatedA (HsKind GhcPs)))], LocatedA (HsType GhcPs))
  
    mEmpty :: ForAllTyMap a
    mEmpty = ForAllTyMap mEmpty mEmpty mEmpty
  
    mUnion :: ForAllTyMap a -> ForAllTyMap a -> ForAllTyMap a
    mUnion m1 m2 = ForAllTyMap
      { fatNil = unionOn fatNil m1 m2
      , fatUser = unionOn fatUser m1 m2
      , fatKinded = unionOn fatKinded m1 m2
      }
  
    mAlter :: AlphaEnv -> Quantifiers -> Key ForAllTyMap -> A a -> ForAllTyMap a -> ForAllTyMap a
    mAlter env vs ([], ty) f m = m { fatNil = mAlter env vs ty f (fatNil m) }
    mAlter env vs ((v,mbK):rest, ty) f m
      | Just k <- mbK = m { fatKinded = mAlter env vs k (toA (mAlter env' vs' (rest, ty) f)) (fatKinded m) }
      | otherwise = m { fatUser = mAlter env' vs' (rest, ty) f (fatUser m) }
      where
        env' = extendAlphaEnvInternal v env
        vs' = vs `exceptQ` [v]
  
    mMatch :: MatchEnv -> Key ForAllTyMap -> (Substitution, ForAllTyMap a) -> [(Substitution, a)]
    mMatch env ([],ty) = mapFor fatNil >=> mMatch env ty
    mMatch env ((v,mbK):rest, ty)
      | Just k <- mbK = mapFor fatKinded >=> mMatch env k >=> mMatch env' (rest, ty)
      | otherwise = mapFor fatUser >=> mMatch env' (rest, ty)
      where
        env' = extendMatchEnv env [v]
  
  #if __GLASGOW_HASKELL__ < 810
  #else
  newtype ForallVisMap a = ForallVisMap { favBoolMap :: BoolMap a }
    deriving (Functor)
  
  instance PatternMap ForallVisMap where
    type Key ForallVisMap = Bool
  
    mEmpty :: ForallVisMap a
    mEmpty = ForallVisMap mEmpty
  
    mUnion :: ForallVisMap a -> ForallVisMap a -> ForallVisMap a
    mUnion m1 m2 = ForallVisMap (unionOn favBoolMap m1 m2)
  
    mAlter :: AlphaEnv -> Quantifiers -> Key ForallVisMap -> A a -> ForallVisMap a -> ForallVisMap a
    mAlter env vs k f (ForallVisMap m) = ForallVisMap $ mAlter env vs k f m
  
    mMatch :: MatchEnv -> Key ForallVisMap -> (Substitution, ForallVisMap a) -> [(Substitution, a)]
    mMatch env b = mapFor favBoolMap >=> mMatch env b
  #endif
  