diff --git a/CHANGELOG.md b/CHANGELOG.md
--- a/CHANGELOG.md
+++ b/CHANGELOG.md
@@ -1,3 +1,11 @@
+1.0.0.0 (April 9, 2021)
+
+* Added --adhoc-type flag (#13)
+* Added --adhoc-pattern, --pattern-forward, --pattern-backward (#15)
+* Speed up file search when large number of files match.
+* Removed support for GHC 8.4 and 8.8
+* Added support for GHC 9.0.1
+
 0.1.1.1 (June 1, 2020)
 
 * Remove dependency on haskell-src-exts from library (#9)
@@ -15,7 +23,7 @@
 
 * Don't fail if 'git' or 'hg' commands cannot be found.
 * Better error message when syntax support needs to be extended.
-* Add support for following type syntax: lists, tuples, constraints, 
+* Add support for following type syntax: lists, tuples, constraints,
   unboxed sums, and forall.
 
 0.1.0.0 (March 16, 2020)
diff --git a/Retrie/CPP.hs b/Retrie/CPP.hs
--- a/Retrie/CPP.hs
+++ b/Retrie/CPP.hs
@@ -116,7 +116,7 @@
     sorted = sortOn fst
       [ (r, replReplacement)
       | Replacement{..} <- repls
-      , RealSrcSpan r <- [replLocation]
+      , Just r <- [getRealSpan replLocation]
       ]
 
     origLines = Text.lines orig
@@ -319,8 +319,8 @@
 insertImports
   :: Monad m
   => [AnnotatedImports]   -- ^ imports and their annotations
-  -> Located (HsModule GhcPs)    -- ^ target module
-  -> TransformT m (Located (HsModule GhcPs))
+  -> Located HsModule     -- ^ target module
+  -> TransformT m (Located HsModule)
 insertImports is (L l m) = do
   imps <- graftA $ filterAndFlatten (unLoc <$> hsmodName m) is
   let
diff --git a/Retrie/Context.hs b/Retrie/Context.hs
--- a/Retrie/Context.hs
+++ b/Retrie/Context.hs
@@ -43,13 +43,11 @@
   const (return c)
     `extQ` (return . updExp)
     `extQ` (return . updType)
-#if __GLASGOW_HASKELL__ < 806
-    `extQ` (return . updTypeList)
-#endif
     `extQ` (return . updMatch)
     `extQ` (return . updGRHSs)
     `extQ` (return . updGRHS)
     `extQ` (return . updStmt)
+    `extQ` (return . updPat)
     `extQ` updStmtList
     `extQ` (return . updHsBind)
     `extQ` (return . updTyClDecl)
@@ -62,47 +60,30 @@
     -- Reason for 10 + i: (i is index of child, 0 = left, 1 = right)
     -- In left child, prec is 10, so HsApp child will NOT get paren'd
     -- In right child, prec is 11, so every child gets paren'd (unless atomic)
-#if __GLASGOW_HASKELL__ < 806
-    updExp (OpApp _ op _ _) = c { ctxtParentPrec = HasPrec $ lookupOp op (ctxtFixityEnv c) }
-    updExp (HsLet lbs _) = addInScope neverParen $ collectLocalBinders $ unLoc lbs
-#else
     updExp (OpApp _ _ op _) = c { ctxtParentPrec = HasPrec $ lookupOp op (ctxtFixityEnv c) }
     updExp (HsLet _ lbs _) = addInScope neverParen $ collectLocalBinders $ unLoc lbs
-#endif
     updExp _ = neverParen
 
     updType :: HsType GhcPs -> Context
-#if __GLASGOW_HASKELL__ < 806
-    updType (HsAppsTy _) = c { ctxtParentPrec = IsHsAppsTy }
-#else
     updType HsAppTy{}
       | i > firstChild = c { ctxtParentPrec = IsHsAppsTy }
-#endif
     updType _ = neverParen
 
-#if __GLASGOW_HASKELL__ < 806
-    updTypeList :: [LHsAppType GhcPs] -> Context
-    updTypeList _ =
-      case ctxtParentPrec c of
-        IsHsAppsTy
-          | i > 0 -> c { ctxtParentPrec = HasPrec $ Fixity (SourceText "HsAppsTy") 11 InfixL }
-          | otherwise -> neverParen
-        _ -> c -- leave prec as is
-#endif
-
     updMatch :: Match GhcPs (LHsExpr GhcPs) -> Context
-    updMatch = addInScope neverParen . collectPatsBinders . m_pats
+    updMatch
+      | i == 2  -- m_pats field
+      = addInScope c{ctxtParentPrec = IsLhs} . collectPatsBinders . m_pats
+      | otherwise = addInScope neverParen . collectPatsBinders . m_pats
+      where
 
     updGRHSs :: GRHSs GhcPs (LHsExpr GhcPs) -> Context
     updGRHSs = addInScope neverParen . collectLocalBinders . unLoc . grhssLocalBinds
 
     updGRHS :: GRHS GhcPs (LHsExpr GhcPs) -> Context
-#if __GLASGOW_HASKELL__ < 806
-    updGRHS (GRHS gs _)
-#else
+#if __GLASGOW_HASKELL__ < 900
     updGRHS XGRHS{} = neverParen
-    updGRHS (GRHS _ gs _)
 #endif
+    updGRHS (GRHS _ gs _)
         -- binders are in scope over the body (right child) only
       | i > firstChild = addInScope neverParen bs
       | otherwise = fst $ updateSubstitution neverParen bs
@@ -118,11 +99,7 @@
         -- binders are in scope over tail of list (right child)
       | i > 0 = insertDependentRewrites neverParen bs ls
         -- lets are recursive in do-blocks
-#if __GLASGOW_HASKELL__ < 806
-      | L _ (LetStmt (L _ bnds)) <- ls =
-#else
       | L _ (LetStmt _ (L _ bnds)) <- ls =
-#endif
           return $ addInScope neverParen $ collectLocalBinders bnds
       | otherwise = return $ fst $ updateSubstitution neverParen bs
       where
@@ -140,6 +117,9 @@
     updTyClDecl ClassDecl{..} = addInScope neverParen [unLoc tcdLName]
     updTyClDecl _ = neverParen
 
+    updPat :: Pat GhcPs -> Context
+    updPat _ = neverParen
+
 -- | Create an empty 'Context' with given 'FixityEnv', rewriter, and dependent
 -- rewrite generator.
 emptyContext :: FixityEnv -> Rewriter -> Rewriter -> Context
@@ -153,11 +133,7 @@
 -- Deal with Trees-That-Grow adding extension points
 -- as the first child everywhere.
 firstChild :: Int
-#if __GLASGOW_HASKELL__ < 806
-firstChild = 0
-#else
 firstChild = 1
-#endif
 
 -- | Add dependent rewrites to 'ctxtRewriter' if necessary.
 insertDependentRewrites
diff --git a/Retrie/ExactPrint.hs b/Retrie/ExactPrint.hs
--- a/Retrie/ExactPrint.hs
+++ b/Retrie/ExactPrint.hs
@@ -29,6 +29,7 @@
   , transferAnnsT
   , transferEntryAnnsT
   , transferEntryDPT
+  , tryTransferEntryDPT
     -- * Utils
   , debugDump
   , debugParse
@@ -74,8 +75,10 @@
 import Retrie.ExactPrint.Annotated
 import Retrie.Fixity
 import Retrie.GHC
-import Retrie.SYB
+import Retrie.SYB hiding (ext1)
 
+import GHC.Stack
+
 -- Fixity traversal -----------------------------------------------------------
 
 -- | Re-associate AST using given 'FixityEnv'. (The GHC parser has no knowledge
@@ -100,15 +103,6 @@
   => FixityEnv
   -> LHsExpr GhcPs
   -> TransformT m (LHsExpr GhcPs)
-#if __GLASGOW_HASKELL__ < 806
-fixOneExpr env (L l2 (OpApp ap1@(L l1 (OpApp x op1 f1 y)) op2 f2 z))
-  | associatesRight (lookupOp op1 env) (lookupOp op2 env) = do
-    let ap2' = L l2 $ OpApp y op2 f2 z
-    swapEntryDPT ap1 ap2'
-    transferAnnsT isComma ap2' ap1
-    rhs <- fixOneExpr env ap2'
-    return $ L l1 $ OpApp x op1 f1 rhs
-#else
 fixOneExpr env (L l2 (OpApp x2 ap1@(L l1 (OpApp x1 x op1 y)) op2 z))
   | associatesRight (lookupOp op1 env) (lookupOp op2 env) = do
     let ap2' = L l2 $ OpApp x2 y op2 z
@@ -116,26 +110,25 @@
     transferAnnsT isComma ap2' ap1
     rhs <- fixOneExpr env ap2'
     return $ L l1 $ OpApp x1 x op1 rhs
-#endif
 fixOneExpr _ e = return e
 
 fixOnePat :: Monad m => FixityEnv -> LPat GhcPs -> TransformT m (LPat GhcPs)
-#if __GLASGOW_HASKELL__ == 808
-fixOnePat env (dL -> L l2 (ConPatIn op2 (InfixCon (dL -> ap1@(L l1 (ConPatIn op1 (InfixCon x y)))) z)))
+#if __GLASGOW_HASKELL__ < 900
+fixOnePat env (dLPat -> Just (L l2 (ConPatIn op2 (InfixCon (dLPat -> Just ap1@(L l1 (ConPatIn op1 (InfixCon x y)))) z))))
   | associatesRight (lookupOpRdrName op1 env) (lookupOpRdrName op2 env) = do
     let ap2' = L l2 (ConPatIn op2 (InfixCon y z))
     swapEntryDPT ap1 ap2'
     transferAnnsT isComma ap2' ap1
-    rhs <- fixOnePat env (composeSrcSpan ap2')
-    return $ cL l1 (ConPatIn op1 (InfixCon x rhs))
+    rhs <- fixOnePat env (cLPat ap2')
+    return $ cLPat $ L l1 (ConPatIn op1 (InfixCon x rhs))
 #else
-fixOnePat env (L l2 (ConPatIn op2 (InfixCon ap1@(L l1 (ConPatIn op1 (InfixCon x y))) z)))
+fixOnePat env (dLPat -> Just (L l2 (ConPat ext2 op2 (InfixCon (dLPat -> Just ap1@(L l1 (ConPat ext1 op1 (InfixCon x y)))) z))))
   | associatesRight (lookupOpRdrName op1 env) (lookupOpRdrName op2 env) = do
-    let ap2' = L l2 (ConPatIn op2 (InfixCon y z))
+    let ap2' = L l2 (ConPat ext2 op2 (InfixCon y z))
     swapEntryDPT ap1 ap2'
     transferAnnsT isComma ap2' ap1
-    rhs <- fixOnePat env ap2'
-    return $ L l1 (ConPatIn op1 (InfixCon x rhs))
+    rhs <- fixOnePat env (cLPat ap2')
+    return $ cLPat $ L l1 (ConPat ext1 op1 (InfixCon x rhs))
 #endif
 fixOnePat _ e = return e
 
@@ -164,21 +157,18 @@
   return e
 
 fixOneEntryExpr :: Monad m => LHsExpr GhcPs -> TransformT m (LHsExpr GhcPs)
-#if __GLASGOW_HASKELL__ < 806
-fixOneEntryExpr e@(L _ (OpApp x _ _ _)) = fixOneEntry e x
-#else
 fixOneEntryExpr e@(L _ (OpApp _ x _ _)) = fixOneEntry e x
-#endif
 fixOneEntryExpr e = return e
 
 fixOneEntryPat :: Monad m => LPat GhcPs -> TransformT m (LPat GhcPs)
-#if __GLASGOW_HASKELL__ == 808
-fixOneEntryPat p@(ConPatIn _ (InfixCon x _)) =
-  composeSrcSpan <$> fixOneEntry (dL p) (dL x)
+fixOneEntryPat pat
+#if __GLASGOW_HASKELL__ < 900
+  | Just p@(L _ (ConPatIn _ (InfixCon x _))) <- dLPat pat =
 #else
-fixOneEntryPat p@(L _ (ConPatIn _ (InfixCon x _))) = fixOneEntry p x
+  | Just p@(L _ (ConPat _ _ (InfixCon x _))) <- dLPat pat =
 #endif
-fixOneEntryPat p = return p
+    cLPat <$> fixOneEntry p (dLPatUnsafe x)
+  | otherwise = return pat
 
 -------------------------------------------------------------------------------
 
@@ -240,11 +230,7 @@
 parsePattern :: String -> IO AnnotatedPat
 parsePattern = parseHelper "parsePattern" p
   where
-#if __GLASGOW_HASKELL__ < 808
-    p = Parsers.parsePattern
-#else
-    p flags fp str = fmap dL <$> Parsers.parsePattern flags fp str
-#endif
+    p flags fp str = fmap dLPatUnsafe <$> Parsers.parsePattern flags fp str
 
 -- | Parse a 'Stmt'.
 parseStmt :: String -> IO AnnotatedStmt
@@ -289,7 +275,7 @@
 -- The following definitions are all the same as the ones from ghc-exactprint,
 -- but the types are liberalized from 'Transform a' to 'TransformT m a'.
 transferEntryAnnsT
-  :: (Data a, Data b, Monad m)
+  :: (HasCallStack, Data a, Data b, Monad m)
   => (KeywordId -> Bool)        -- transfer Anns matching predicate
   -> Located a                  -- from
   -> Located b                  -- to
@@ -300,13 +286,20 @@
 
 -- | 'Transform' monad version of 'transferEntryDP'
 transferEntryDPT
+  :: (HasCallStack, Data a, Data b, Monad m)
+  => Located a -> Located b -> TransformT m ()
+transferEntryDPT a b = modifyAnnsT (transferEntryDP a b)
+
+tryTransferEntryDPT
   :: (Data a, Data b, Monad m)
   => Located a -> Located b -> TransformT m ()
-transferEntryDPT a b =
-  modifyAnnsT (transferEntryDP a b)
+tryTransferEntryDPT a b = modifyAnnsT $ \anns ->
+  if M.member (mkAnnKey a) anns
+    then transferEntryDP a b anns
+    else anns
 
 -- This function fails if b is not in Anns, which seems dumb, since we are inserting it.
-transferEntryDP :: (Data a, Data b) => Located a -> Located b -> Anns -> Anns
+transferEntryDP :: (HasCallStack, Data a, Data b) => Located a -> Located b -> Anns -> Anns
 transferEntryDP a b anns = setEntryDP b dp anns'
   where
     maybeAnns = do -- Maybe monad
@@ -319,12 +312,11 @@
                   maybeAnns
 
 addAllAnnsT
-  :: (Data a, Data b, Monad m)
+  :: (HasCallStack, Data a, Data b, Monad m)
   => Located a -> Located b -> TransformT m ()
-addAllAnnsT a b =
-  modifyAnnsT (addAllAnns a b)
+addAllAnnsT a b = modifyAnnsT (addAllAnns a b)
 
-addAllAnns :: (Data a, Data b) => Located a -> Located b -> Anns -> Anns
+addAllAnns :: (HasCallStack, Data a, Data b) => Located a -> Located b -> Anns -> Anns
 addAllAnns a b anns =
   fromMaybe
     (error $ "addAllAnns: lookup failed: " ++ show (mkAnnKey a)
@@ -375,16 +367,19 @@
       let anB' = anB { annsDP = annsDP anB ++ filter (p . fst) (annsDP anA) }
       return $ M.insert bKey anB' anns
 
--- | 'Transform' monad version of 'getEntryDP'
+-- | 'Transform' monad version of 'setEntryDP',
+--   which sets the entry 'DeltaPos' for an annotation.
 setEntryDPT
   :: (Data a, Monad m)
   => Located a -> DeltaPos -> TransformT m ()
 setEntryDPT ast dp = do
   modifyAnnsT (setEntryDP ast dp)
 
--- | The setEntryDP that comes with exactprint does some really confusing
--- entry math around comments that I'm not convinced is either correct or useful.
+-- | Set the true entry 'DeltaPos' from the annotation of a
+--   given AST element.
 setEntryDP :: Data a => Located a -> DeltaPos -> Anns -> Anns
+--  The setEntryDP that comes with exactprint does some really confusing
+--  entry math around comments that I'm unconvinced is either correct or useful.
 setEntryDP x dp anns = M.alter (Just . f . fromMaybe annNone) k anns
   where
     k = mkAnnKey x
diff --git a/Retrie/ExactPrint/Annotated.hs b/Retrie/ExactPrint/Annotated.hs
--- a/Retrie/ExactPrint/Annotated.hs
+++ b/Retrie/ExactPrint/Annotated.hs
@@ -55,7 +55,7 @@
 type AnnotatedHsType = Annotated (LHsType GhcPs)
 type AnnotatedImport = Annotated (LImportDecl GhcPs)
 type AnnotatedImports = Annotated [LImportDecl GhcPs]
-type AnnotatedModule = Annotated (Located (HsModule GhcPs))
+type AnnotatedModule = Annotated (Located HsModule)
 type AnnotatedPat = Annotated (Located (Pat GhcPs))
 type AnnotatedStmt = Annotated (LStmt GhcPs (LHsExpr GhcPs))
 
diff --git a/Retrie/Expr.hs b/Retrie/Expr.hs
--- a/Retrie/Expr.hs
+++ b/Retrie/Expr.hs
@@ -9,19 +9,25 @@
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE ViewPatterns #-}
 module Retrie.Expr
-  ( grhsToExpr
+  ( bitraverseHsConDetails
+  , grhsToExpr
   , mkApps
+  , mkConPatIn
   , mkHsAppsTy
   , mkLams
   , mkLet
   , mkLoc
   , mkLocatedHsVar
+  , mkVarPat
   , mkTyVar
   , parenify
   , parenifyT
+  , parenifyP
   , patToExpr
   , patToExprA
+  , setAnnsFor
   , unparen
+  , unparenP
   , unparenT
   , wildSupply
   ) where
@@ -49,17 +55,9 @@
           "[]" -> [(G AnnOpenS, DP (0,0)), (G AnnCloseS, DP (0,0))]
           _    -> [(G AnnVal, DP (0,0))]
   r <- setAnnsFor v anns
-#if __GLASGOW_HASKELL__ < 806
-  lv@(L _ v') <- cloneT (noLoc (HsVar r))
-#else
   lv@(L _ v') <- cloneT (noLoc (HsVar noExtField r))
-#endif
   case v' of
-#if __GLASGOW_HASKELL__ < 806
-    HsVar x ->
-#else
     HsVar _ x ->
-#endif
       swapEntryDPT x lv
     _ -> return ()
   return lv
@@ -89,64 +87,55 @@
 mkLams vs e = do
   let
     mg =
-#if __GLASGOW_HASKELL__ < 806
-      mkMatchGroup Generated [mkMatch LambdaExpr vs e (noLoc EmptyLocalBinds)]
-#else
-      mkMatchGroup Generated [mkMatch LambdaExpr vs e (noLoc (EmptyLocalBinds noExtField))]
-#endif
+      mkMatchGroup Generated [mkMatch LambdaExpr vs e (noLoc emptyLocalBinds)]
   m' <- case unLoc $ mg_alts mg of
     [m] -> setAnnsFor m [(G AnnLam, DP (0,0)),(G AnnRarrow, DP (0,1))]
     _   -> fail "mkLams: lambda expression can only have a single match!"
-#if __GLASGOW_HASKELL__ < 806
-  cloneT $ noLoc $ HsLam mg { mg_alts = noLoc [m'] }
-#else
   cloneT $ noLoc $ HsLam noExtField mg { mg_alts = noLoc [m'] }
-#endif
 
 mkLet :: Monad m => HsLocalBinds GhcPs -> LHsExpr GhcPs -> TransformT m (LHsExpr GhcPs)
 mkLet EmptyLocalBinds{} e = return e
 mkLet lbs e = do
   llbs <- mkLoc lbs
-#if __GLASGOW_HASKELL__ < 806
-  le <- mkLoc $ HsLet llbs e
-#else
   le <- mkLoc $ HsLet noExtField llbs e
-#endif
   setAnnsFor le [(G AnnLet, DP (0,0)), (G AnnIn, DP (1,1))]
 
 mkApps :: Monad m => LHsExpr GhcPs -> [LHsExpr GhcPs] -> TransformT m (LHsExpr GhcPs)
 mkApps e []     = return e
 mkApps f (a:as) = do
-#if __GLASGOW_HASKELL__ < 806
-  f' <- mkLoc (HsApp f a)
-#else
   f' <- mkLoc (HsApp noExtField f a)
-#endif
   mkApps f' as
 
 -- GHC never generates HsAppTy in the parser, using HsAppsTy to keep a list
 -- of types.
 mkHsAppsTy :: Monad m => [LHsType GhcPs] -> TransformT m (LHsType GhcPs)
-#if __GLASGOW_HASKELL__ < 806
-mkHsAppsTy ts = do
-  ts' <- mapM (mkLoc . HsAppPrefix) ts
-  mkLoc (HsAppsTy ts')
-#else
 mkHsAppsTy [] = error "mkHsAppsTy: empty list"
 mkHsAppsTy (t:ts) = foldM (\t1 t2 -> mkLoc (HsAppTy noExtField t1 t2)) t ts
-#endif
 
 mkTyVar :: Monad m => Located RdrName -> TransformT m (LHsType GhcPs)
 mkTyVar nm = do
-#if __GLASGOW_HASKELL__ < 806
-  tv <- mkLoc (HsTyVar NotPromoted nm)
-#else
   tv <- mkLoc (HsTyVar noExtField NotPromoted nm)
-#endif
   _ <- setAnnsFor nm [(G AnnVal, DP (0,0))]
   swapEntryDPT tv nm
   return tv
 
+mkVarPat :: Monad m => Located RdrName -> TransformT m (LPat GhcPs)
+mkVarPat nm = cLPat <$> mkLoc (VarPat noExtField nm)
+
+mkConPatIn
+  :: Monad m
+  => Located RdrName
+  -> HsConPatDetails GhcPs
+  -> TransformT m (Located (Pat GhcPs))
+mkConPatIn patName params = do
+#if __GLASGOW_HASKELL__ < 900
+  p <- mkLoc $ ConPatIn patName params
+#else
+  p <- mkLoc $ ConPat noExtField patName params
+#endif
+  setEntryDPT p (DP (0,0))
+  return p
+
 -------------------------------------------------------------------------------
 
 -- Note [Wildcards]
@@ -183,54 +172,25 @@
 
 patToExprA :: AlphaEnv -> AnnotatedPat -> AnnotatedHsExpr
 patToExprA env pat = runIdentity $ transformA pat $ \ p ->
-  fst <$> runStateT
-#if __GLASGOW_HASKELL__ < 808
-    (patToExpr p)
-#else
-    (patToExpr (composeSrcSpan p))
-#endif
-    (wildSupplyAlphaEnv env, [])
+  fst <$> runStateT (patToExpr $ cLPat p) (wildSupplyAlphaEnv env, [])
 
 patToExpr :: Monad m => LPat GhcPs -> PatQ m (LHsExpr GhcPs)
-#if __GLASGOW_HASKELL__ < 808
-patToExpr lp@(L _ p) = do
-#else
-patToExpr (dL -> lp@(L _ p)) = do
-#endif
-  e <- go p
-  lift $ transferEntryDPT lp e
-  return e
+patToExpr orig = case dLPat orig of
+  Nothing -> error "patToExpr: called on unlocated Pat!"
+  Just lp@(L _ p) -> do
+    e <- go p
+    lift $ transferEntryDPT lp e
+    return e
   where
     go WildPat{} = newWildVar >>= lift . mkLocatedHsVar . noLoc
+#if __GLASGOW_HASKELL__ < 900
+    go XPat{} = error "patToExpr XPat"
+    go CoPat{} = error "patToExpr CoPat"
     go (ConPatIn con ds) = conPatHelper con ds
-#if __GLASGOW_HASKELL__ < 806
-    go (LazyPat pat) = patToExpr pat
-    go (BangPat pat) = patToExpr pat
-    go (ListPat ps ty mb) = do
-      ps' <- mapM patToExpr ps
-      lift $ do
-        el <- mkLoc $ ExplicitList ty (snd <$> mb) ps'
-        setAnnsFor el [(G AnnOpenS, DP (0,0)), (G AnnCloseS, DP (0,0))]
-    go (LitPat lit) = lift $ do
-      lit' <- cloneT lit
-      mkLoc $ HsLit lit'
-    go (NPat llit mbNeg _ _) = lift $ do
-      L _ lit <- cloneT llit
-      e <- mkLoc $ HsOverLit lit
-      negE <- maybe (return e) (mkLoc . NegApp e) mbNeg
-      addAllAnnsT llit negE
-      return negE
-    go PArrPat{} = error "patToExpr PArrPat"
-    go (ParPat p') = lift . mkParen HsPar =<< patToExpr p'
-    go SigPatIn{} = error "patToExpr SigPatIn"
-    go SigPatOut{} = error "patToExpr SigPatOut"
-    go (TuplePat ps boxity _) = do
-      es <- forM ps $ \pat -> do
-        e <- patToExpr pat
-        lift $ mkLoc $ Present e
-      lift $ mkLoc $ ExplicitTuple es boxity
-    go (VarPat i) = lift $ mkLocatedHsVar i
+    go ConPatOut{} = error "patToExpr ConPatOut" -- only exists post-tc
 #else
+    go (ConPat _ con ds) = conPatHelper con ds
+#endif
     go (LazyPat _ pat) = patToExpr pat
     go (BangPat _ pat) = patToExpr pat
     go (ListPat _ ps) = do
@@ -255,11 +215,7 @@
         lift $ mkLoc $ Present noExtField e
       lift $ mkLoc $ ExplicitTuple noExtField es boxity
     go (VarPat _ i) = lift $ mkLocatedHsVar i
-    go XPat{} = error "patToExpr XPat"
-#endif
     go AsPat{} = error "patToExpr AsPat"
-    go ConPatOut{} = error "patToExpr ConPatOut" -- only exists post-tc
-    go CoPat{} = error "patToExpr CoPat"
     go NPlusKPat{} = error "patToExpr NPlusKPat"
     go SplicePat{} = error "patToExpr SplicePat"
     go SumPat{} = error "patToExpr SumPat"
@@ -270,17 +226,10 @@
              -> HsConPatDetails GhcPs
              -> PatQ m (LHsExpr GhcPs)
 conPatHelper con (InfixCon x y) =
-#if __GLASGOW_HASKELL__ < 806
-  lift . mkLoc =<< OpApp <$> patToExpr x
-                         <*> lift (mkLocatedHsVar con)
-                         <*> pure PlaceHolder
-                         <*> patToExpr y
-#else
   lift . mkLoc =<< OpApp <$> pure noExtField
                          <*> patToExpr x
                          <*> lift (mkLocatedHsVar con)
                          <*> patToExpr y
-#endif
 conPatHelper con (PrefixCon xs) = do
   f <- lift $ mkLocatedHsVar con
   as <- mapM patToExpr xs
@@ -290,35 +239,22 @@
 -------------------------------------------------------------------------------
 
 grhsToExpr :: LGRHS p (LHsExpr p) -> LHsExpr p
-#if __GLASGOW_HASKELL__ < 806
-grhsToExpr (L _ (GRHS [] e)) = e
-grhsToExpr (L _ (GRHS (_:_) e)) = e -- not sure about this
-#else
 grhsToExpr (L _ (GRHS _ [] e)) = e
 grhsToExpr (L _ (GRHS _ (_:_) e)) = e -- not sure about this
 grhsToExpr _ = error "grhsToExpr"
-#endif
 
 -------------------------------------------------------------------------------
 
 precedence :: FixityEnv -> HsExpr GhcPs -> Maybe Fixity
 precedence _        (HsApp {})       = Just $ Fixity (SourceText "HsApp") 10 InfixL
-#if __GLASGOW_HASKELL__ < 806
-precedence fixities (OpApp _ op _ _) = Just $ lookupOp op fixities
-#else
 precedence fixities (OpApp _ _ op _) = Just $ lookupOp op fixities
-#endif
 precedence _        _                = Nothing
 
 parenify
   :: Monad m => Context -> LHsExpr GhcPs -> TransformT m (LHsExpr GhcPs)
 parenify Context{..} le@(L _ e)
   | needed ctxtParentPrec (precedence ctxtFixityEnv e) && needsParens e =
-#if __GLASGOW_HASKELL__ < 806
-    mkParen HsPar le
-#else
     mkParen (HsPar noExtField) le
-#endif
   | otherwise = return le
   where
            {- parent -}               {- child -}
@@ -329,24 +265,12 @@
     needed _ _ = False
 
 unparen :: LHsExpr GhcPs -> LHsExpr GhcPs
-#if __GLASGOW_HASKELL__ < 806
-unparen (L _ (HsPar e)) = e
-#else
 unparen (L _ (HsPar _ e)) = e
-#endif
 unparen e = e
 
 -- | hsExprNeedsParens is not always up-to-date, so this allows us to override
 needsParens :: HsExpr GhcPs -> Bool
-#if __GLASGOW_HASKELL__ < 806
-needsParens RecordCon{} = False
-needsParens RecordUpd{} = False
-needsParens HsSpliceE{} = False
-needsParens (HsWrap _ e) = hsExprNeedsParens e
-needsParens e = hsExprNeedsParens e
-#else
 needsParens = hsExprNeedsParens (PprPrec 10)
-#endif
 
 mkParen :: (Data x, Monad m) => (Located x -> x) -> Located x -> TransformT m (Located x)
 mkParen k e = do
@@ -355,38 +279,68 @@
   swapEntryDPT e pe
   return pe
 
+-- This explicitly operates on 'Located (Pat GhcPs)' instead of 'LPat GhcPs'
+-- because it is applied at that type by SYB.
+parenifyP
+  :: Monad m
+  => Context
+  -> Located (Pat GhcPs)
+  -> TransformT m (Located (Pat GhcPs))
+parenifyP Context{..} p@(L _ pat)
+  | IsLhs <- ctxtParentPrec
+  , needed pat =
+    mkParen (ParPat noExtField . cLPat) p
+  | otherwise = return p
+  where
+    needed BangPat{}                          = False
+    needed LazyPat{}                          = False
+    needed ListPat{}                          = False
+    needed LitPat{}                           = False
+    needed ParPat{}                           = False
+    needed SumPat{}                           = False
+    needed TuplePat{}                         = False
+    needed VarPat{}                           = False
+    needed WildPat{}                          = False
+#if __GLASGOW_HASKELL__ < 900
+    needed (ConPatIn _ (PrefixCon []))        = False
+    needed ConPatOut{pat_args = PrefixCon []} = False
+#else
+    needed (ConPat _ _ (PrefixCon []))        = False
+#endif
+    needed _                                  = True
+
 parenifyT
   :: Monad m => Context -> LHsType GhcPs -> TransformT m (LHsType GhcPs)
 parenifyT Context{..} lty@(L _ ty)
-#if __GLASGOW_HASKELL__ < 806
-  | needed ty = mkParen HsParTy lty
-#else
   | needed ty = mkParen (HsParTy noExtField) lty
-#endif
   | otherwise = return lty
   where
-#if __GLASGOW_HASKELL__ < 806
-    needed HsTyVar{}   = False
-    needed HsListTy{}  = False
-    needed HsPArrTy{}  = False
-    needed HsTupleTy{} = False
-    needed HsParTy{}   = False
-    needed HsTyLit{}   = False
-    needed (HsAppsTy tys)
-      | HasPrec _ <- ctxtParentPrec = length tys > 1
-      | otherwise = False
-    needed _           = True
-#else
     needed HsAppTy{}
       | IsHsAppsTy <- ctxtParentPrec = True
       | otherwise = False
     needed t = hsTypeNeedsParens (PprPrec 10) t
-#endif
 
 unparenT :: LHsType GhcPs -> LHsType GhcPs
-#if __GLASGOW_HASKELL__ < 806
-unparenT (L _ (HsParTy ty)) = ty
-#else
 unparenT (L _ (HsParTy _ ty)) = ty
-#endif
 unparenT ty = ty
+
+-- This explicitly operates on 'Located (Pat GhcPs)' instead of 'LPat GhcPs'
+-- to ensure 'dLPat' was called on the input.
+unparenP :: Located (Pat GhcPs) -> Located (Pat GhcPs)
+unparenP (L _ (ParPat _ p)) | Just lp <- dLPat p = lp
+unparenP p = p
+
+--------------------------------------------------------------------
+
+bitraverseHsConDetails
+  :: Applicative m
+  => (arg -> m arg')
+  -> (rec -> m rec')
+  -> HsConDetails arg rec
+  -> m (HsConDetails arg' rec')
+bitraverseHsConDetails argf _ (PrefixCon args) =
+  PrefixCon <$> (argf `traverse` args)
+bitraverseHsConDetails _ recf (RecCon r) =
+  RecCon <$> recf r
+bitraverseHsConDetails argf _ (InfixCon a1 a2) =
+  InfixCon <$> argf a1 <*> argf a2
diff --git a/Retrie/GHC.hs b/Retrie/GHC.hs
--- a/Retrie/GHC.hs
+++ b/Retrie/GHC.hs
@@ -7,6 +7,7 @@
 {-# LANGUAGE RecordWildCards #-}
 module Retrie.GHC
   ( module Retrie.GHC
+#if __GLASGOW_HASKELL__ < 900
   , module ApiAnnotation
   , module Bag
   , module BasicTypes
@@ -28,8 +29,26 @@
   , module Unique
   , module UniqFM
   , module UniqSet
+#else
+  -- GHC >= 9.0
+  , module GHC.Data.Bag
+  , module GHC.Data.FastString
+  , module GHC.Data.FastString.Env
+  , module GHC.Utils.Error
+  , module GHC.Hs
+  , module GHC.Parser.Annotation
+  , module GHC.Types.Basic
+  , module GHC.Types.Name
+  , module GHC.Types.Name.Reader
+  , module GHC.Types.SrcLoc
+  , module GHC.Types.Unique
+  , module GHC.Types.Unique.FM
+  , module GHC.Types.Unique.Set
+  , module GHC.Unit
+#endif
   ) where
 
+#if __GLASGOW_HASKELL__ < 900
 import ApiAnnotation
 import Bag
 import BasicTypes
@@ -37,15 +56,13 @@
 import FastStringEnv
 #if __GLASGOW_HASKELL__ < 810
 import HsExpr
-#if __GLASGOW_HASKELL__ < 806
-import HsSyn hiding (HasDefault(..))
-#else
-import HsSyn
-#endif
+import HsSyn hiding (HsModule)
+import qualified HsSyn as HS
 #else
 import ErrUtils
 import GHC.Hs.Expr
-import GHC.Hs
+import GHC.Hs hiding (HsModule)
+import qualified GHC.Hs as HS
 #endif
 import Module
 import Name
@@ -55,10 +72,61 @@
 import Unique
 import UniqFM
 import UniqSet
+#else
+-- GHC >= 9.0
+import GHC.Data.Bag
+import GHC.Data.FastString
+import GHC.Data.FastString.Env
+import GHC.Utils.Error
+import GHC.Hs
+import GHC.Parser.Annotation
+import GHC.Types.Basic
+import GHC.Types.Name
+import GHC.Types.Name.Reader
+import GHC.Types.SrcLoc
+import GHC.Types.Unique
+import GHC.Types.Unique.FM
+import GHC.Types.Unique.Set
+import GHC.Unit
+#endif
 
 import Data.Bifunctor (second)
 import Data.Maybe
 
+#if __GLASGOW_HASKELL__ < 900
+type HsModule = HS.HsModule GhcPs
+#endif
+
+cLPat :: Located (Pat (GhcPass p)) -> LPat (GhcPass p)
+#if __GLASGOW_HASKELL__ == 808
+cLPat = composeSrcSpan
+#else
+cLPat = id
+#endif
+
+-- | Only returns located pat if there is a genuine location available.
+dLPat :: LPat (GhcPass p) -> Maybe (Located (Pat (GhcPass p)))
+#if __GLASGOW_HASKELL__ == 808
+dLPat (XPat (L s p)) = Just $ L s $ stripSrcSpanPat p
+dLPat _ = Nothing
+#else
+dLPat = Just
+#endif
+
+-- | Will always give a location, but it may be noSrcSpan.
+dLPatUnsafe :: LPat (GhcPass p) -> Located (Pat (GhcPass p))
+#if __GLASGOW_HASKELL__ == 808
+dLPatUnsafe = dL
+#else
+dLPatUnsafe = id
+#endif
+
+#if __GLASGOW_HASKELL__ == 808
+stripSrcSpanPat :: LPat (GhcPass p) -> Pat (GhcPass p)
+stripSrcSpanPat (XPat (L _  p)) = stripSrcSpanPat p
+stripSrcSpanPat p = p
+#endif
+
 rdrFS :: RdrName -> FastString
 rdrFS (Qual m n) = mconcat [moduleNameFS m, fsDot, occNameFS n]
 rdrFS rdr = occNameFS (occName rdr)
@@ -67,77 +135,56 @@
 fsDot = mkFastString "."
 
 varRdrName :: HsExpr p -> Maybe (Located (IdP p))
-#if __GLASGOW_HASKELL__ < 806
-varRdrName (HsVar n) = Just n
-#else
 varRdrName (HsVar _ n) = Just n
-#endif
 varRdrName _ = Nothing
 
 tyvarRdrName :: HsType p -> Maybe (Located (IdP p))
-#if __GLASGOW_HASKELL__ < 806
-tyvarRdrName (HsTyVar _ n) = Just n
-#else
 tyvarRdrName (HsTyVar _ _ n) = Just n
-#endif
 tyvarRdrName _ = Nothing
 
-fixityDecls :: HsModule p -> [(Located (IdP p), Fixity)]
+fixityDecls :: HsModule -> [(Located RdrName, Fixity)]
 fixityDecls m =
   [ (nm, fixity)
-#if __GLASGOW_HASKELL__ < 806
-  | L _ (SigD (FixSig (FixitySig nms fixity))) <- hsmodDecls m
-#else
   | L _ (SigD _ (FixSig _ (FixitySig _ nms fixity))) <- hsmodDecls m
-#endif
   , nm <- nms
   ]
 
 ruleInfo :: RuleDecl GhcPs -> [RuleInfo]
-#if __GLASGOW_HASKELL__ < 808
-
-#if __GLASGOW_HASKELL__ < 806
-ruleInfo (HsRule (L _ (_, riName)) _ bs riLHS _ riRHS _) =
-#else
-ruleInfo XRuleDecl{} = []
-ruleInfo (HsRule _ (L _ (_, riName)) _ bs riLHS riRHS) =
-#endif
-  [ RuleInfo { riQuantifiers = ruleBindersToQs bs, .. } ]
-
-#else
 ruleInfo (HsRule _ (L _ (_, riName)) _ tyBs valBs riLHS riRHS) =
   let
     riQuantifiers =
       map unLoc (tyBindersToLocatedRdrNames (fromMaybe [] tyBs)) ++
       ruleBindersToQs valBs
   in [ RuleInfo{..} ]
+#if __GLASGOW_HASKELL__ < 900
 ruleInfo XRuleDecl{} = []
 #endif
 
 ruleBindersToQs :: [LRuleBndr GhcPs] -> [RdrName]
 ruleBindersToQs bs = catMaybes
   [ case b of
-#if __GLASGOW_HASKELL__ < 806
-      RuleBndr (L _ v) -> Just v
-      RuleBndrSig (L _ v) _ -> Just v
-#else
       RuleBndr _ (L _ v) -> Just v
       RuleBndrSig _ (L _ v) _ -> Just v
+#if __GLASGOW_HASKELL__ < 900
       XRuleBndr{} -> Nothing
 #endif
   | L _ b <- bs
   ]
 
+#if __GLASGOW_HASKELL__ < 900
 tyBindersToLocatedRdrNames :: [LHsTyVarBndr GhcPs] -> [Located RdrName]
+#else
+tyBindersToLocatedRdrNames :: [LHsTyVarBndr () GhcPs] -> [Located RdrName]
+#endif
 tyBindersToLocatedRdrNames vars = catMaybes
   [ case var of
-#if __GLASGOW_HASKELL__ < 806
-      UserTyVar v -> Just v
-      KindedTyVar v _ -> Just v
-#else
+#if __GLASGOW_HASKELL__ < 900
       UserTyVar _ v -> Just v
       KindedTyVar _ v _ -> Just v
       XTyVarBndr{} -> Nothing
+#else
+      UserTyVar _ _ v -> Just v
+      KindedTyVar _ _ v _ -> Just v
 #endif
   | L _ var <- vars ]
 
@@ -148,17 +195,17 @@
   , riRHS :: LHsExpr GhcPs
   }
 
-#if __GLASGOW_HASKELL__ < 806
-#elif __GLASGOW_HASKELL__ < 810
+#if __GLASGOW_HASKELL__ < 810
 noExtField :: NoExt
 noExtField = noExt
 #endif
 
 overlaps :: SrcSpan -> SrcSpan -> Bool
-overlaps (RealSrcSpan s1) (RealSrcSpan s2) =
-     srcSpanFile s1 == srcSpanFile s2 &&
-     ((srcSpanStartLine s1, srcSpanStartCol s1) `within` s2 ||
-      (srcSpanEndLine s1, srcSpanEndCol s1) `within` s2)
+overlaps ss1 ss2
+  | Just s1 <- getRealSpan ss1, Just s2 <- getRealSpan ss2 =
+    srcSpanFile s1 == srcSpanFile s2 &&
+    ((srcSpanStartLine s1, srcSpanStartCol s1) `within` s2 ||
+     (srcSpanEndLine s1, srcSpanEndCol s1) `within` s2)
 overlaps _ _ = False
 
 within :: (Int, Int) -> RealSrcSpan -> Bool
@@ -171,11 +218,31 @@
 lineCount :: [SrcSpan] -> Int
 lineCount ss = sum
   [ srcSpanEndLine s - srcSpanStartLine s + 1
-  | RealSrcSpan s <- ss
+  | Just s <- map getRealSpan ss
   ]
 
 showRdrs :: [RdrName] -> String
 showRdrs = show . map (occNameString . occName)
 
+#if __GLASGOW_HASKELL__ < 900
 uniqBag :: Uniquable a => [(a,b)] -> UniqFM [b]
+#else
+uniqBag :: Uniquable a => [(a,b)] -> UniqFM a [b]
+#endif
 uniqBag = listToUFM_C (++) . map (second pure)
+
+getRealLoc :: SrcLoc -> Maybe RealSrcLoc
+#if __GLASGOW_HASKELL__ < 900
+getRealLoc (RealSrcLoc l) = Just l
+#else
+getRealLoc (RealSrcLoc l _) = Just l
+#endif
+getRealLoc _ = Nothing
+
+getRealSpan :: SrcSpan -> Maybe RealSrcSpan
+#if __GLASGOW_HASKELL__ < 900
+getRealSpan (RealSrcSpan s) = Just s
+#else
+getRealSpan (RealSrcSpan s _) = Just s
+#endif
+getRealSpan _ = Nothing
diff --git a/Retrie/Options.hs b/Retrie/Options.hs
--- a/Retrie/Options.hs
+++ b/Retrie/Options.hs
@@ -242,6 +242,26 @@
       , metavar "EQUATION"
       , help "Apply an adhoc equation of the form: forall vs. lhs = rhs"
       ]
+  , fmap AdhocType $ option str $ mconcat
+      [ long "adhoc-type"
+      , metavar "EQUATION"
+      , help "Apply an adhoc type equation of the form: lhs = rhs"
+      ]
+  , fmap PatternForward $ option str $ mconcat
+      [ long "pattern-forward"
+      , metavar "NAME"
+      , help "Apply fully-qualified pattern synonym name left-to-right."
+      ]
+  , fmap PatternBackward $ option str $ mconcat
+      [ long "pattern-backward"
+      , metavar "NAME"
+      , help "Apply fully-qualified pattern synonym name right-to-left."
+      ]
+  , fmap AdhocPattern $ option str $ mconcat
+      [ long "adhoc-pattern"
+      , metavar "EQUATION"
+      , help "Apply an adhoc pattern equation of the form: lhs = rhs"
+      ]
   ]
 
 parseMode :: Parser ExecutionMode
diff --git a/Retrie/PatternMap/Bag.hs b/Retrie/PatternMap/Bag.hs
--- a/Retrie/PatternMap/Bag.hs
+++ b/Retrie/PatternMap/Bag.hs
@@ -3,6 +3,7 @@
 -- 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 InstanceSigs #-}
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeFamilies #-}
@@ -139,7 +140,11 @@
 
 ------------------------------------------------------------------------
 
+#if __GLASGOW_HASKELL__ < 900
 newtype UniqFM a = UniqFM { unUniqFM :: GHC.UniqFM [a] }
+#else
+newtype UniqFM a = UniqFM { unUniqFM :: GHC.UniqFM (Key UniqFM) [a] }
+#endif
   deriving (Functor)
 
 instance PatternMap UniqFM where
diff --git a/Retrie/PatternMap/Class.hs b/Retrie/PatternMap/Class.hs
--- a/Retrie/PatternMap/Class.hs
+++ b/Retrie/PatternMap/Class.hs
@@ -11,6 +11,7 @@
 module Retrie.PatternMap.Class where
 
 import Control.Monad
+import Data.Kind
 import Data.Maybe
 
 import Retrie.AlphaEnv
@@ -38,13 +39,6 @@
 -- TODO: Maybe a -> a ??? -- we never need to delete
 type A a = Maybe a -> Maybe a
 
-missingSyntax :: String -> a
-missingSyntax constructor = error $ unlines
-  [ "Missing syntax support: " ++ constructor
-  , "Please file an issue at https://github.com/facebookincubator/retrie/issues"
-  , "with an example of the rewrite you are attempting and we'll add it."
-  ]
-
 toA :: PatternMap m => (m a -> m a) -> A (m a)
 toA f = Just . f . fromMaybe mEmpty
 
@@ -58,7 +52,7 @@
 ------------------------------------------------------------------------
 
 class PatternMap m where
-  type Key m :: *
+  type Key m :: Type
 
   mEmpty :: m a
   mUnion :: m a -> m a -> m a
diff --git a/Retrie/PatternMap/Instances.hs b/Retrie/PatternMap/Instances.hs
--- a/Retrie/PatternMap/Instances.hs
+++ b/Retrie/PatternMap/Instances.hs
@@ -7,6 +7,8 @@
 {-# LANGUAGE DeriveFunctor #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE ViewPatterns #-}
@@ -23,6 +25,7 @@
 import Retrie.PatternMap.Class
 import Retrie.Quantifiers
 import Retrie.Substitution
+import Retrie.Util
 
 ------------------------------------------------------------------------
 
@@ -45,10 +48,8 @@
   mAlter :: AlphaEnv -> Quantifiers -> Key TupArgMap -> A a -> TupArgMap a -> TupArgMap a
   mAlter env vs tupArg f m = go (unLoc tupArg)
     where
-#if __GLASGOW_HASKELL__ < 806
-      go (Present e) = m { tamPresent = mAlter env vs e  f (tamPresent m) }
-#else
       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) }
@@ -56,10 +57,8 @@
   mMatch :: MatchEnv -> Key TupArgMap -> (Substitution, TupArgMap a) -> [(Substitution, a)]
   mMatch env = go . unLoc
     where
-#if __GLASGOW_HASKELL__ < 806
-      go (Present e) = mapFor tamPresent >=> mMatch env e
-#else
       go (Present _ e) = mapFor tamPresent >=> mMatch env e
+#if __GLASGOW_HASKELL__ < 900
       go XTupArg{} = const []
 #endif
       go (Missing _) = mapFor tamMissing >=> mMatch env ()
@@ -182,8 +181,7 @@
       go HsRat{} = missingSyntax "HsRat"
       go HsFloatPrim{} = missingSyntax "HsFloatPrim"
       go HsDoublePrim{} = missingSyntax "HsDoublePrim"
-#if __GLASGOW_HASKELL__ < 806
-#else
+#if __GLASGOW_HASKELL__ < 900
       go XLit{} = missingSyntax "XLit"
 #endif
 
@@ -353,47 +351,9 @@
       dollarFork v@HsVar{} l r
         | Just (L _ rdr) <- varRdrName v
         , occNameString (occName rdr) == "$" =
-#if __GLASGOW_HASKELL__ < 806
-          go (HsApp l (noLoc (HsPar r)))
-#else
           go (HsApp noExtField l (noLoc (HsPar noExtField r)))
-#endif
       dollarFork _ _ _ = m
 
-#if __GLASGOW_HASKELL__ < 806
-      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) }
-      go (HsIf _ c tr fl) =
-        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) }
-      go (HsPar e') = m { emPar  = mAlter env vs e' f (emPar m) }
-      go (OpApp l o _ r) = (dollarFork (unLoc o) l r)
-        { emOpApp = mAlter env vs o (toA (mAlter env vs l (toA (mAlter env vs r f)))) (emOpApp m) }
-      go (RecordCon v _ _ fs) =
-        m { emRecordCon = mAlter env vs (unLoc v) (toA (mAlter env vs (fieldsToRdrNames $ rec_flds fs) f)) (emRecordCon m) }
-      go (RecordUpd e' fs _ _ _ _) =
-        m { emRecordUpd = mAlter env vs e' (toA (mAlter env vs (fieldsToRdrNames 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) }
-      go (HsLet lbs e') =
-#else
       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) }
@@ -405,7 +365,11 @@
         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) }
@@ -425,9 +389,7 @@
         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) }
-      go XExpr{} = missingSyntax "XExpr"
       go (HsLet _ lbs e') =
-#endif
         let
           bs = collectLocalBinders $ unLoc lbs
           env' = foldr extendAlphaEnvInternal env bs
@@ -437,20 +399,18 @@
       go HsMultiIf{} = missingSyntax "HsMultiIf"
       go (ExplicitList _ _ es) = m { emExplicitList = mAlter env vs es f (emExplicitList m) }
       go ArithSeq{} = missingSyntax "ArithSeq"
-#if __GLASGOW_HASKELL__ < 806
-      go (ExprWithTySig e' (HsWC _ (HsIB _ ty _))) =
-        m { emExprWithTySig = mAlter env vs e' (toA (mAlter env vs ty f)) (emExprWithTySig m) }
-#else
-#if __GLASGOW_HASKELL__ < 808
-      go (ExprWithTySig (HsWC _ (HsIB _ ty)) e') =
-#else
       go (ExprWithTySig _ e' (HsWC _ (HsIB _ ty))) =
-#endif
         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"
-#endif
       go HsSCC{} = missingSyntax "HsSCC"
       go HsCoreAnn{} = missingSyntax "HsCoreAnn"
+      go HsTickPragma{} = missingSyntax "HsTickPragma"
+      go HsWrap{} = missingSyntax "HsWrap"
+#else
+      go HsPragE{} = missingSyntax "HsPragE"
+#endif
       go HsBracket{} = missingSyntax "HsBracket"
       go HsRnBracketOut{} = missingSyntax "HsRnBracketOut"
       go HsTcBracketOut{} = missingSyntax "HsTcBracketOut"
@@ -467,20 +427,12 @@
 #endif
       go HsTick{} = missingSyntax "HsTick"
       go HsBinTick{} = missingSyntax "HsBinTick"
-      go HsTickPragma{} = missingSyntax "HsTickPragma"
-      go HsWrap{} = missingSyntax "HsWrap"
       go HsUnboundVar{} = missingSyntax "HsUnboundVar"
       go HsRecFld{} = missingSyntax "HsRecFld"
       go HsOverLabel{} = missingSyntax "HsOverLabel"
       go HsAppType{} = missingSyntax "HsAppType"
       go HsConLikeOut{} = missingSyntax "HsConLikeOut"
       go ExplicitSum{} = missingSyntax "ExplicitSum"
-#if __GLASGOW_HASKELL__ < 806
-      go ExplicitPArr{} = missingSyntax "ExplicitPArr"
-      go ExprWithTySigOut{} = missingSyntax "ExprWithTySigOut"
-      go HsAppTypeOut{} = missingSyntax "HsAppTypeOut"
-      go PArrSeq{} = missingSyntax "PArrSeq"
-#endif
 
   mMatch :: MatchEnv -> Key EMap -> (Substitution, EMap a) -> [(Substitution, a)]
   mMatch _   _ (_,EMEmpty) = []
@@ -488,35 +440,15 @@
     where
       hss = extendResult (emHole m) (HoleExpr $ mePruneA env e) hs
 
-#if __GLASGOW_HASKELL__ < 806
-      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)
-      go (HsIf _ c tr fl) =
-        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)
-      go (HsPar e') = mapFor emPar >=> mMatch env e'
-      go (HsVar v) = mapFor emVar >=> mMatch env (unLoc v)
-      go (NegApp e' _) = mapFor emNegApp >=> mMatch env e'
-      go (OpApp l o _ r) =
-        mapFor emOpApp >=> mMatch env o >=> mMatch env l >=> mMatch env r
-      go (RecordCon v _ _ fs) =
-        mapFor emRecordCon >=> mMatch env (unLoc v) >=> mMatch env (fieldsToRdrNames $ rec_flds fs)
-      go (RecordUpd e' fs _ _ _ _) =
-        mapFor emRecordUpd >=> mMatch env e' >=> mMatch env (fieldsToRdrNames 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
-      go (HsLet lbs e') =
-#else
       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
@@ -534,19 +466,12 @@
       go (SectionL _ lhs o) = mapFor emSecL >=> mMatch env o >=> mMatch env lhs
       go (SectionR _ o rhs) = mapFor emSecR >=> mMatch env o >=> mMatch env rhs
       go (HsLet _ lbs e') =
-#endif
         let
           bs = collectLocalBinders (unLoc lbs)
           env' = extendMatchEnv env bs
         in mapFor emLet >=> mMatch env (unLoc lbs) >=> mMatch env' e'
       go (ExplicitList _ _ es) = mapFor emExplicitList >=> mMatch env es
-#if __GLASGOW_HASKELL__ < 806
-      go (ExprWithTySig e' (HsWC _ (HsIB _ ty _))) =
-#elif __GLASGOW_HASKELL__ < 808
-      go (ExprWithTySig (HsWC _ (HsIB _ ty)) e') =
-#else
       go (ExprWithTySig _ e' (HsWC _ (HsIB _ ty))) =
-#endif
         mapFor emExprWithTySig >=> mMatch env e' >=> mMatch env ty
       go _ = const [] -- TODO remove
 
@@ -567,15 +492,7 @@
 sameHoleValue (HoleExpr e1)  (HoleExpr e2)  =
   alphaEquivalent (astA e1) (astA e2) EMEmpty
 sameHoleValue (HolePat p1)   (HolePat p2)   =
-  alphaEquivalent
-#if __GLASGOW_HASKELL__ < 808
-    (astA p1)
-    (astA p2)
-#else
-    (composeSrcSpan $ astA p1)
-    (composeSrcSpan $ astA p2)
-#endif
-    PatEmpty
+  alphaEquivalent (cLPat $ astA p1) (cLPat $ astA p2) PatEmpty
 sameHoleValue (HoleType ty1) (HoleType ty2) =
   alphaEquivalent (astA ty1) (astA ty2) TyEmpty
 sameHoleValue _              _              = Nothing
@@ -593,7 +510,11 @@
   = 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)
@@ -602,7 +523,13 @@
 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__ < 920
+  type Key SCMap = HsStmtContext GhcRn
+#else
+  type Key SCMap = HsStmtContext (HsDoRn GhcPs)
+#endif
 
   mEmpty :: SCMap a
   mEmpty = SCEmpty
@@ -622,11 +549,12 @@
     where
       go ListComp = m { scmListComp = mAlter env vs () f (scmListComp m) }
       go MonadComp = m { scmMonadComp = mAlter env vs () f (scmMonadComp m) }
-#if __GLASGOW_HASKELL__ < 806
-      go PArrComp = missingSyntax "PArrComp"
-#endif
+#if __GLASGOW_HASKELL__ < 900
       go DoExpr = m { scmDoExpr = mAlter env vs () f (scmDoExpr m) }
-      go MDoExpr = missingSyntax "MDoExpr"
+#else
+      go (DoExpr mname) = m { scmDoExpr = mAlter env vs (maybe "" moduleNameFS mname) f (scmDoExpr m) }
+#endif
+      go MDoExpr{} = missingSyntax "MDoExpr"
       go ArrowExpr = missingSyntax "ArrowExpr"
       go GhciStmtCtxt = missingSyntax "GhciStmtCtxt"
       go (PatGuard _) = missingSyntax "PatGuard"
@@ -639,7 +567,11 @@
     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
 
 ------------------------------------------------------------------------
@@ -797,63 +729,51 @@
   mAlter env vs pat f m@PatMap{} = go (unLoc pat)
     where
       go (WildPat _) = m { pmWild = mAlter env vs () f (pmWild m) }
-#if __GLASGOW_HASKELL__ < 806
-      go (VarPat v)
-#else
       go (VarPat _ v)
-#endif
         | 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"
-      go (ConPatIn c d) = m { pmConPatIn = mAlter env vs (rdrFS (unLoc c)) (toA (mAlter env vs d f)) (pmConPatIn m) }
+#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__ < 806
-      go (PArrPat _ _) = missingSyntax "PArrPat"
-      go (ParPat p) = m { pmParPat = mAlter env vs p f (pmParPat m) }
-      go (SigPatIn _ _) = missingSyntax "SigPatIn"
-      go (SigPatOut _ _) = missingSyntax "SigPatOut"
-      go (TuplePat ps b _tys) =
-        m { pmTuplePat = mAlter env vs b (toA (mAlter env vs ps f)) (pmTuplePat m) }
-#else
       go (ParPat _ p) = m { pmParPat = mAlter env vs p f (pmParPat m) }
       go (TuplePat _ ps b) =
         m { pmTuplePat = mAlter env vs b (toA (mAlter env vs ps f)) (pmTuplePat m) }
       go SigPat{} = missingSyntax "SigPat"
-      go XPat{} = missingSyntax "XPat"
-#endif
-      go CoPat{} = missingSyntax "CoPat"
       go SumPat{} = missingSyntax "SumPat"
 
   mMatch :: MatchEnv -> Key PatMap -> (Substitution, PatMap a) -> [(Substitution, a)]
-  mMatch _   _   (_ ,PatEmpty)   = []
-#if __GLASGOW_HASKELL__ < 808
-  mMatch env pat (hs,m@PatMap{}) =
-#else
-  mMatch env (dL -> pat) (hs,m@PatMap{}) =
-#endif
-    hss ++ go (unLoc pat) (hs,m)
+  mMatch _   _   (_, PatEmpty)   = []
+  mMatch env pat (hs,m@PatMap{})
+    | Just lp@(L _ p) <- dLPat pat = hss lp ++ go p (hs,m)
+    | otherwise = []
     where
-      hss = extendResult (pmHole m) (HolePat $ mePruneA env pat) hs
+      hss lp = extendResult (pmHole m) (HolePat $ mePruneA env lp) hs
 
       go (WildPat _) = mapFor pmWild >=> mMatch env ()
-#if __GLASGOW_HASKELL__ < 806
-      go (ParPat p) = mapFor pmParPat >=> mMatch env p
-      go (TuplePat ps b _) = mapFor pmTuplePat >=> mMatch env b >=> mMatch env ps
-      go (VarPat _) = mapFor pmVar >=> mMatch env ()
-#else
       go (ParPat _ p) = mapFor pmParPat >=> mMatch env p
       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
-      go (ConPatIn c d) = mapFor pmConPatIn >=> mMatch env (rdrFS (unLoc c)) >=> mMatch env d
+        mapFor pmConPatIn >=> mMatch env (rdrFS (unLoc c)) >=> mMatch env d
       go _ = const [] -- TODO
 
 ------------------------------------------------------------------------
@@ -902,24 +822,20 @@
   mUnion (GRHSMap m1) (GRHSMap m2) = GRHSMap (mUnion m1 m2)
 
   mAlter :: AlphaEnv -> Quantifiers -> Key GRHSMap -> A a -> GRHSMap a -> GRHSMap a
-#if __GLASGOW_HASKELL__ < 806
-  mAlter env vs (GRHS gs b) f (GRHSMap m) =
-#else
+#if __GLASGOW_HASKELL__ < 900
   mAlter _ _ XGRHS{} _ _ = missingSyntax "XGRHS"
-  mAlter env vs (GRHS _ gs b) f (GRHSMap m) =
 #endif
+  mAlter env vs (GRHS _ gs b) f (GRHSMap m) =
     let bs = collectLStmtsBinders 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__ < 806
-  mMatch env (GRHS gs b) =
-#else
+#if __GLASGOW_HASKELL__ < 900
   mMatch _ XGRHS{} = const []
-  mMatch env (GRHS _ gs b) =
 #endif
+  mMatch env (GRHS _ gs b) =
     mapFor unGRHSMap >=> mMatch env gs >=> mMatch env' b
     where
       bs = collectLStmtsBinders gs
@@ -1009,14 +925,11 @@
   mAlter env vs lbs f LBEmpty = mAlter env vs lbs f emptyLBMapWrapper
   mAlter env vs lbs f m@LB{}  = go lbs
     where
-#if __GLASGOW_HASKELL__ < 806
-      go EmptyLocalBinds = m { lbEmpty = mAlter env vs () f (lbEmpty m) }
-      go (HsValBinds vbs) =
-#else
       go (EmptyLocalBinds _) = m { lbEmpty = mAlter env vs () f (lbEmpty m) }
+#if __GLASGOW_HASKELL__ < 900
       go XHsLocalBindsLR{} = missingSyntax "XHsLocalBindsLR"
-      go (HsValBinds _ vbs) =
 #endif
+      go (HsValBinds _ vbs) =
         let
           bs = collectHsValBinders vbs
           env' = foldr extendAlphaEnvInternal env bs
@@ -1028,13 +941,8 @@
   mMatch _   _   (_,LBEmpty) = []
   mMatch env lbs (hs,m@LB{}) = go lbs (hs,m)
     where
-#if __GLASGOW_HASKELL__ < 806
-      go EmptyLocalBinds = mapFor lbEmpty >=> mMatch env ()
-      go (HsValBinds vbs) =
-#else
       go (EmptyLocalBinds _) = mapFor lbEmpty >=> mMatch env ()
       go (HsValBinds _ vbs) =
-#endif
         let
           bs = collectHsValBinders vbs
           env' = extendMatchEnv env bs
@@ -1042,11 +950,7 @@
       go _ = const [] -- TODO
 
 deValBinds :: HsValBinds GhcPs -> [HsBind GhcPs]
-#if __GLASGOW_HASKELL__ < 806
-deValBinds (ValBindsIn lbs _) = map unLoc (bagToList lbs)
-#else
 deValBinds (ValBinds _ lbs _) = map unLoc (bagToList lbs)
-#endif
 deValBinds _ = error "deValBinds ValBindsOut"
 
 ------------------------------------------------------------------------
@@ -1086,16 +990,15 @@
   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__ < 806
-      go (FunBind _ mg _ _ _) = m { bmFunBind = mAlter env vs mg f (bmFunBind m) }
-      go (VarBind _ e _) = m { bmVarBind = mAlter env vs e f (bmVarBind m) }
-      go (PatBind lhs rhs _ _ _) =
-#else
+#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) }
-      go XHsBindsLR{} = missingSyntax "XHsBindsLR"
-      go (PatBind _ lhs rhs _) =
+#else
+      go (FunBind _ _ 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 _ lhs rhs _) =
         m { bmPatBind = mAlter env vs lhs
               (toA $ mAlter env vs rhs f) (bmPatBind m) }
       go AbsBinds{} = missingSyntax "AbsBinds"
@@ -1105,15 +1008,14 @@
   mMatch _   _ (_,BMEmpty) = []
   mMatch env b (hs,m@BM{}) = go b (hs,m)
     where
-#if __GLASGOW_HASKELL__ < 806
-      go (FunBind _ mg _ _ _) = mapFor bmFunBind >=> mMatch env mg
-      go (VarBind _ e _) = mapFor bmVarBind >=> mMatch env e
-      go (PatBind lhs rhs _ _ _)
-#else
-      go (FunBind _ _ mg _ _)  = mapFor bmFunBind >=> mMatch env mg
+#if __GLASGOW_HASKELL__ < 900
+      go (FunBind _ _ mg _ _) = mapFor bmFunBind >=> mMatch env mg
       go (VarBind _ _ e _) = mapFor bmVarBind >=> mMatch env e
-      go (PatBind _ lhs rhs _)
+#else
+      go (FunBind _ _ mg _) = mapFor bmFunBind >=> mMatch env mg
+      go (VarBind _ _ e) = mapFor bmVarBind >=> mMatch env e
 #endif
+      go (PatBind _ lhs rhs _)
         = mapFor bmPatBind >=> mMatch env lhs >=> mMatch env rhs
       go _ = const [] -- TODO
 
@@ -1150,15 +1052,13 @@
   mAlter env vs s f SMEmpty = mAlter env vs s f emptySMapWrapper
   mAlter env vs s f m@(SM {}) = go (unLoc s)
     where
-#if __GLASGOW_HASKELL__ < 806
-      go (BodyStmt e _ _ _) = m { smBodyStmt = mAlter env vs e f (smBodyStmt m) }
-      go (LastStmt e _ _)   = m { smLastStmt = mAlter env vs e f (smLastStmt m) }
-      go (BindStmt p e _ _ _) =
-#else
       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 p
             env' = foldr extendAlphaEnvInternal env bs
@@ -1175,14 +1075,12 @@
   mMatch _   _   (_,SMEmpty) = []
   mMatch env s   (hs,m) = go (unLoc s) (hs,m)
     where
-#if __GLASGOW_HASKELL__ < 806
-      go (BodyStmt e _ _ _) = mapFor smBodyStmt >=> mMatch env e
-      go (LastStmt e _ _) = mapFor smLastStmt >=> mMatch env e
-      go (BindStmt p e _ _ _) =
-#else
       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 p
             env' = extendMatchEnv env bs
@@ -1196,9 +1094,6 @@
   | TM { tyHole    :: Map RdrName a -- See Note [Holes]
        , tyHsTyVar :: VMap a
        , tyHsAppTy :: TyMap (TyMap a)
-#if __GLASGOW_HASKELL__ < 806
-       , tyHsAppsTy :: ListMap AppTyMap a
-#endif
 #if __GLASGOW_HASKELL__ < 810
        , tyHsForAllTy :: ForAllTyMap a -- See Note [Telescope]
 #else
@@ -1217,9 +1112,6 @@
 emptyTyMapWrapper :: TyMap a
 emptyTyMapWrapper = TM
   mEmpty mEmpty mEmpty
-#if __GLASGOW_HASKELL__ < 806
-  mEmpty
-#endif
   mEmpty mEmpty mEmpty mEmpty mEmpty mEmpty mEmpty
 
 instance PatternMap TyMap where
@@ -1235,9 +1127,6 @@
     { tyHole = unionOn tyHole m1 m2
     , tyHsTyVar = unionOn tyHsTyVar m1 m2
     , tyHsAppTy = unionOn tyHsAppTy m1 m2
-#if __GLASGOW_HASKELL__ < 806
-    , tyHsAppsTy = unionOn tyHsAppsTy m1 m2
-#endif
     , tyHsForAllTy = unionOn tyHsForAllTy m1 m2
     , tyHsFunTy = unionOn tyHsFunTy m1 m2
     , tyHsListTy = unionOn tyHsListTy m1 m2
@@ -1249,18 +1138,10 @@
 
   mAlter :: AlphaEnv -> Quantifiers -> Key TyMap -> A a -> TyMap a -> TyMap a
   mAlter env vs ty f TyEmpty = mAlter env vs ty f emptyTyMapWrapper
-#if __GLASGOW_HASKELL__ < 806
-  mAlter env vs (tyLookThrough -> ty) f m@(TM {}) =
-#else
   mAlter env vs ty f m@(TM {}) =
-#endif
     go (unLoc ty) -- See Note [TyVar Quantifiers]
     where
-#if __GLASGOW_HASKELL__ < 806
-      go (HsTyVar _ (L _ v))
-#else
       go (HsTyVar _ _ (L _ v))
-#endif
         | 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"
@@ -1270,30 +1151,21 @@
       go HsDocTy{} = missingSyntax "HsDocTy"
       go HsBangTy{} = missingSyntax "HsBangTy"
       go HsRecTy{} = missingSyntax "HsRecTy"
-#if __GLASGOW_HASKELL__ < 806
-      go (HsAppsTy atys) = m { tyHsAppsTy = mAlter env vs atys f (tyHsAppsTy m) }
-      go (HsAppTy ty1 ty2) = m { tyHsAppTy = mAlter env vs ty1 (toA (mAlter env vs ty2 f)) (tyHsAppTy m) }
-      go (HsCoreTy _) = missingSyntax "HsCoreTy"
-      go (HsEqTy _ _) = missingSyntax "HsEqTy"
-      go (HsForAllTy bndrs ty') = m { tyHsForAllTy = mAlter env vs (bndrs, ty') f (tyHsForAllTy m) }
-      go (HsFunTy ty1 ty2) = m { tyHsFunTy = mAlter env vs ty1 (toA (mAlter env vs ty2 f)) (tyHsFunTy m) }
-      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 (HsPArrTy _) = missingSyntax "HsPArrTy"
-      go (HsQualTy (L _ cons) ty') =
-        m { tyHsQualTy = mAlter env vs ty' (toA (mAlter env vs cons f)) (tyHsQualTy m) }
-      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) }
-#else
       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 (bndrs, ty') f (tyHsForAllTy m) }
-#else
+      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 (toA (mAlter env vs (bndrs, ty') f)) (tyHsForAllTy m) }
+        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 _ (L _ cons) ty') =
@@ -1303,110 +1175,60 @@
       go (HsTupleTy _ ts tys) =
         m { tyHsTupleTy = mAlter env vs ts (toA (mAlter env vs tys f)) (tyHsTupleTy m) }
       go XHsType{} = missingSyntax "XHsType"
-#endif
       go HsExplicitListTy{} = missingSyntax "HsExplicitListTy"
       go HsExplicitTupleTy{} = missingSyntax "HsExplicitTupleTy"
       go HsTyLit{} = missingSyntax "HsTyLit"
       go HsWildCardTy{} = missingSyntax "HsWildCardTy"
-#if __GLASGOW_HASKELL__ < 808
-#else
       go HsAppKindTy{} = missingSyntax "HsAppKindTy"
-#endif
 
   mMatch :: MatchEnv -> Key TyMap -> (Substitution, TyMap a) -> [(Substitution, a)]
   mMatch _   _  (_,TyEmpty) = []
-#if __GLASGOW_HASKELL__ < 806
-  mMatch env (tyLookThrough -> ty) (hs,m@TM{}) =
-#else
   mMatch env ty (hs,m@TM{}) =
-#endif
     hss ++ go (unLoc ty) (hs,m) -- See Note [TyVar Quantifiers]
     where
       hss = extendResult (tyHole m) (HoleType $ mePruneA env ty) hs
 
-#if __GLASGOW_HASKELL__ < 806
-      go (HsAppTy ty1 ty2) = mapFor tyHsAppTy >=> mMatch env ty1 >=> mMatch env ty2
-      go (HsAppsTy atys) = mapFor tyHsAppsTy >=> mMatch env atys
-      go (HsForAllTy bndrs ty') = mapFor tyHsForAllTy >=> mMatch env (bndrs, ty')
-      go (HsFunTy ty1 ty2) = mapFor tyHsFunTy >=> mMatch env ty1 >=> mMatch env ty2
-      go (HsListTy ty') = mapFor tyHsListTy >=> mMatch env ty'
-      go (HsParTy ty') = mapFor tyHsParTy >=> mMatch env ty'
-      go (HsQualTy (L _ cons) ty') = mapFor tyHsQualTy >=> mMatch env ty' >=> mMatch env cons
-      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)
-#else
       go (HsAppTy _ ty1 ty2) = mapFor tyHsAppTy >=> mMatch env ty1 >=> mMatch env ty2
 #if __GLASGOW_HASKELL__ < 810
-      go (HsForAllTy _ bndrs ty') = mapFor tyHsForAllTy >=> mMatch env (bndrs, ty')
-#else
+      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 >=> mMatch env (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'
       go (HsQualTy _ (L _ cons) ty') = mapFor tyHsQualTy >=> mMatch env ty' >=> mMatch env cons
       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)
-#endif
       go _                  = const [] -- TODO
 
-#if __GLASGOW_HASKELL__ < 806
--- Note [TyVar Quantifiers]
---
--- GHC parses a tycon app as a list of types (Maybe Int becomes [Maybe, Int]).
--- A nullary tycon app becomes a singleton list, and a tyvar is treated as a
--- a nullary tycon. Quantifiers are tyvars, so they'll be rigidly buried in
--- singleton lists, meaning 'a' cannot match with 'Maybe Int' because [a]
--- will not unify with [Maybe, Int]. Singleton tycons suffer the same problem.
--- [Foo] will not match with [Maybe, Foo] when unfolding Foo. To solve this,
--- we 'look through' such singleton lists.
-
-tyLookThrough :: Key TyMap -> Key TyMap
-tyLookThrough (L _ (HsAppsTy [L _ (HsAppPrefix ty)])) = ty
-tyLookThrough ty = ty
-
-------------------------------------------------------------------------
-
-data AppTyMap a
-  = AppTyEmpty
-  | ATM { atmAppInfix :: VMap a
-        , atmAppPrefix :: TyMap a
-        }
-  deriving (Functor)
-
-emptyAppTyMapWrapper :: AppTyMap a
-emptyAppTyMapWrapper = ATM mEmpty mEmpty
-
-instance PatternMap AppTyMap where
-  type Key AppTyMap = LHsAppType GhcPs
-
-  mEmpty :: AppTyMap a
-  mEmpty = AppTyEmpty
-
-  mUnion :: AppTyMap a -> AppTyMap a -> AppTyMap a
-  mUnion AppTyEmpty m = m
-  mUnion m AppTyEmpty = m
-  mUnion m1 m2 = ATM
-    { atmAppInfix = unionOn atmAppInfix m1 m2
-    , atmAppPrefix = unionOn atmAppPrefix m1 m2
-    }
-
-  mAlter :: AlphaEnv -> Quantifiers -> Key AppTyMap -> A a -> AppTyMap a -> AppTyMap a
-  mAlter env vs aty f AppTyEmpty = mAlter env vs aty f emptyAppTyMapWrapper
-  mAlter env vs aty f m@(ATM {}) = go (unLoc aty)
-    where
-      go (HsAppInfix r) = m { atmAppInfix = mAlter env vs (unLoc r) f (atmAppInfix m) }
-      go (HsAppPrefix ty) = m { atmAppPrefix = mAlter env vs ty f (atmAppPrefix m) }
+#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)
 
-  mMatch :: MatchEnv -> Key AppTyMap -> (Substitution, AppTyMap a) -> [(Substitution, a)]
-  mMatch _   _  (_,AppTyEmpty) = []
-  mMatch env aty (hs,m@ATM{})  = go (unLoc aty) (hs,m)
-    where
-      go (HsAppInfix r)   = mapFor atmAppInfix >=> mMatch env (unLoc r)
-      go (HsAppPrefix ty) = mapFor atmAppPrefix >=> mMatch env ty
+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
 
 ------------------------------------------------------------------------
@@ -1441,11 +1263,7 @@
 class RecordFieldToRdrName f where
   recordFieldToRdrName :: f -> RdrName
 
-#if __GLASGOW_HASKELL__ < 806
-instance RecordFieldToRdrName (AmbiguousFieldOcc p) where
-#else
 instance RecordFieldToRdrName (AmbiguousFieldOcc GhcPs) where
-#endif
   recordFieldToRdrName = rdrNameAmbiguousFieldOcc
 
 instance RecordFieldToRdrName (FieldOcc p) where
@@ -1517,7 +1335,7 @@
   deriving (Functor)
 
 instance PatternMap ForAllTyMap where
-  type Key ForAllTyMap = ([LHsTyVarBndr GhcPs], LHsType GhcPs)
+  type Key ForAllTyMap = ([(RdrName, Maybe (LHsKind GhcPs))], LHsType GhcPs)
 
   mEmpty :: ForAllTyMap a
   mEmpty = ForAllTyMap mEmpty mEmpty mEmpty
@@ -1531,71 +1349,38 @@
 
   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) }
-#if __GLASGOW_HASKELL__ < 806
-  mAlter env vs (L _ (UserTyVar (L _ v)):rest, ty) f m =
-#else
-  mAlter env vs (L _ (UserTyVar _ (L _ v)):rest, ty) f m =
-#endif
-    let
-      env' = extendAlphaEnvInternal v env
-      vs' = vs `exceptQ` [v]
-    in m { fatUser = mAlter env' vs' (rest, ty) f (fatUser m) }
-#if __GLASGOW_HASKELL__ < 806
-  mAlter env vs (L _ (KindedTyVar (L _ v) k):rest, ty) f m =
-#else
-  mAlter _ _ (L _ (XTyVarBndr _):_,_) _ _ = missingSyntax "XTyVarBndr"
-  mAlter env vs (L _ (KindedTyVar _ (L _ v) k):rest, ty) f m =
-#endif
-    let
+  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]
-    in m { fatKinded  = mAlter env vs k (toA (mAlter env' vs' (rest, ty) f)) (fatKinded m) }
 
   mMatch :: MatchEnv -> Key ForAllTyMap -> (Substitution, ForAllTyMap a) -> [(Substitution, a)]
   mMatch env ([],ty) = mapFor fatNil >=> mMatch env ty
-#if __GLASGOW_HASKELL__ < 806
-  mMatch env (L _ (UserTyVar (L _ v)):rest, ty) =
-#else
-  mMatch env (L _ (UserTyVar _ (L _ v)):rest, ty) =
-#endif
-    let env' = extendMatchEnv env [v]
-    in mapFor fatUser >=> mMatch env' (rest, ty)
-#if __GLASGOW_HASKELL__ < 806
-  mMatch env (L _ (KindedTyVar (L _ v) k):rest, ty) =
-#else
-  mMatch _ (L _ (XTyVarBndr _):_,_) = const []
-  mMatch env (L _ (KindedTyVar _ (L _ v) k):rest, ty) =
-#endif
-    let env' = extendMatchEnv env [v]
-    in mapFor fatKinded >=> mMatch env k >=> mMatch env' (rest, 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
-data ForallVisMap a = ForallVisMap
-  { favVis :: MaybeMap a
-  , favInvis :: MaybeMap a
-  }
+newtype ForallVisMap a = ForallVisMap { favBoolMap :: BoolMap a }
   deriving (Functor)
 
 instance PatternMap ForallVisMap where
-  type Key ForallVisMap = ForallVisFlag
+  type Key ForallVisMap = Bool
 
   mEmpty :: ForallVisMap a
-  mEmpty = ForallVisMap mEmpty mEmpty
+  mEmpty = ForallVisMap mEmpty
 
   mUnion :: ForallVisMap a -> ForallVisMap a -> ForallVisMap a
-  mUnion m1 m2 = ForallVisMap
-    { favVis = unionOn favVis m1 m2
-    , favInvis = unionOn favInvis m1 m2
-    }
+  mUnion m1 m2 = ForallVisMap (unionOn favBoolMap m1 m2)
 
   mAlter :: AlphaEnv -> Quantifiers -> Key ForallVisMap -> A a -> ForallVisMap a -> ForallVisMap a
-  mAlter env vs ForallVis f m =
-    m { favVis = mAlter env vs () f (favVis m) }
-  mAlter env vs ForallInvis f m =
-    m { favInvis = mAlter env vs () f (favInvis m) }
+  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 ForallVis = mapFor favVis >=> mMatch env ()
-  mMatch env ForallInvis = mapFor favInvis >=> mMatch env ()
+  mMatch env b = mapFor favBoolMap >=> mMatch env b
 #endif
diff --git a/Retrie/Pretty.hs b/Retrie/Pretty.hs
--- a/Retrie/Pretty.hs
+++ b/Retrie/Pretty.hs
@@ -3,6 +3,7 @@
 -- This source code is licensed under the MIT license found in the
 -- LICENSE file in the root directory of this source tree.
 --
+{-# LANGUAGE CPP #-}
 module Retrie.Pretty
   ( noColor
   , addColor
@@ -37,7 +38,11 @@
 ppSrcSpan :: ColoriseFun -> SrcSpan -> String
 ppSrcSpan colorise spn = case srcSpanStart spn of
   UnhelpfulLoc x -> unpackFS x
+#if __GLASGOW_HASKELL__ < 900
   RealSrcLoc loc -> intercalate (colorise Dull Cyan ":")
+#else
+  RealSrcLoc loc _ -> intercalate (colorise Dull Cyan ":")
+#endif
     [ colorise Dull Magenta $ unpackFS $ srcLocFile loc
     , colorise Dull Green $ show $ srcLocLine loc
     , colorise Dull Green $ show $ srcLocCol loc
@@ -62,10 +67,6 @@
 -- | Return HashMap from line number to line of a file.
 linesMap :: String -> IO (HashMap.HashMap Int String)
 linesMap fp = HashMap.fromList . zip [1..] . lines <$> readFile fp
-
-getRealLoc :: SrcLoc -> Maybe RealSrcLoc
-getRealLoc (RealSrcLoc x) = Just x
-getRealLoc _ = Nothing
 
 strip :: String -> String
 strip = dropWhileEnd isSpace . dropWhile isSpace
diff --git a/Retrie/Replace.hs b/Retrie/Replace.hs
--- a/Retrie/Replace.hs
+++ b/Retrie/Replace.hs
@@ -3,7 +3,6 @@
 -- 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 FlexibleContexts #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
@@ -36,7 +35,15 @@
   mkM (replaceImpl @(HsExpr GhcPs) c)
     `extM` (replaceImpl @(Stmt GhcPs (LHsExpr GhcPs)) c)
     `extM` (replaceImpl @(HsType GhcPs) c)
+    `extM` replacePat c
 
+replacePat :: MonadIO m => Context -> LPat GhcPs -> TransformT (WriterT Change m) (LPat GhcPs)
+-- We need to ensure we have a location available at the top level so we can
+-- transfer annotations. This ensures we don't try to rewrite a naked Pat.
+replacePat c p
+  | Just lp <- dLPat p = cLPat <$> replaceImpl c lp
+  | otherwise = return p
+
 -- | Generic replacement function. This is the thing that actually runs the
 -- 'Rewriter' carried by the context, instantiates templates, handles parens
 -- and other whitespace bookkeeping, and emits resulting 'Replacement's.
@@ -70,7 +77,7 @@
       -- copy appropriate annotations from old expression to template
       addAllAnnsT e r
       -- add parens to template if needed
-      res <- (mkM (parenify c) `extM` parenifyT c) r
+      res <- (mkM (parenify c) `extM` parenifyT c `extM` parenifyP c) r
       -- prune the resulting expression and log it with location
       orig <- printNoLeadingSpaces <$> pruneA e
       repl <- printNoLeadingSpaces <$> pruneA res
@@ -108,23 +115,7 @@
 -- of the parens, not the inner expression, so we have to
 -- keep both expressions around.
 getUnparened :: Data k => k -> k
-getUnparened = mkT e `extT` t
-  where
-    e :: LHsExpr GhcPs -> LHsExpr GhcPs
-#if __GLASGOW_HASKELL__ < 806
-    e (L _ (HsPar expr)) = expr
-#else
-    e (L _ (HsPar _ expr)) = expr
-#endif
-    e other = other
-
-    t :: LHsType GhcPs -> LHsType GhcPs
-#if __GLASGOW_HASKELL__ < 806
-    t (L _ (HsParTy ty)) = ty
-#else
-    t (L _ (HsParTy _ ty)) = ty
-#endif
-    t other = other
+getUnparened = mkT unparen `extT` unparenT `extT` unparenP
 
 -- The location of 'e' accurately points to the first non-space character
 -- of 'e', but when we exactprint 'e', we might get some leading spaces (if
diff --git a/Retrie/Rewrites.hs b/Retrie/Rewrites.hs
--- a/Retrie/Rewrites.hs
+++ b/Retrie/Rewrites.hs
@@ -1,8 +1,10 @@
+{-# LANGUAGE RecordWildCards #-}
 -- 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 OverloadedStrings #-}
 module Retrie.Rewrites
   ( RewriteSpec(..)
@@ -13,8 +15,8 @@
   ) where
 
 import Control.Exception
-import Data.Either (partitionEithers)
 import qualified Data.Map as Map
+import Data.Maybe
 import qualified Data.Text as Text
 import Data.Traversable
 import System.FilePath
@@ -24,6 +26,7 @@
 import Retrie.Fixity
 import Retrie.GHC
 import Retrie.Rewrites.Function
+import Retrie.Rewrites.Patterns
 import Retrie.Rewrites.Rules
 import Retrie.Rewrites.Types
 import Retrie.Types
@@ -37,6 +40,10 @@
   = Adhoc String
     -- ^ Equation in RULES-format. (e.g. @"forall x. succ (pred x) = x"@)
     -- Will be applied left-to-right.
+  | AdhocPattern String
+    -- ^ Equation in pattern-synonym format, _without_ the keyword 'pattern'.
+  | AdhocType String
+    -- ^ Equation in type-synonym format, _without_ the keyword 'type'.
   | Fold QualifiedName
     -- ^ Fold a function definition. The inverse of unfolding/inlining.
     -- Replaces instances of the function body with calls to the function.
@@ -50,34 +57,63 @@
     -- ^ Apply a type synonym left-to-right.
   | Unfold QualifiedName
     -- ^ Unfold, or inline, a function definition.
+  | PatternForward QualifiedName
+    -- ^ Unfold a pattern synonym
+  | PatternBackward QualifiedName
+    -- ^ Fold a pattern synonym, replacing instances of the rhs with the synonym
 
+
+data ClassifiedRewrites = ClassifiedRewrites
+  { adhocRules :: [String]
+  , adhocPatterns :: [String]
+  , adhocTypes :: [String]
+  , fileBased :: [(FilePath, [(FileBasedTy,[(FastString, Direction)])])]
+  }
+
+instance Monoid ClassifiedRewrites where
+  mempty = ClassifiedRewrites [] [] [] []
+
+instance Semigroup ClassifiedRewrites where
+  ClassifiedRewrites a b c d <> ClassifiedRewrites a' b' c' d' =
+    ClassifiedRewrites (a <> a') (b <> b') (c <> c') (d <> d')
+
 parseRewriteSpecs
   :: (FilePath -> IO (CPP AnnotatedModule))
   -> FixityEnv
   -> [RewriteSpec]
   -> IO [Rewrite Universe]
 parseRewriteSpecs parser fixityEnv specs = do
-  (adhocs, fileBased) <- partitionEithers <$> sequence
+  ClassifiedRewrites{..} <- mconcat <$> sequence
     [ case spec of
-        Adhoc rule -> return $ Left rule
+        Adhoc rule -> return mempty{adhocRules = [rule]}
+        AdhocPattern pSyn -> return mempty{adhocPatterns = [pSyn]}
+        AdhocType tySyn -> return mempty{adhocTypes = [tySyn]}
         Fold name -> mkFileBased FoldUnfold RightToLeft name
         RuleBackward name -> mkFileBased Rule RightToLeft name
         RuleForward name -> mkFileBased Rule LeftToRight name
         TypeBackward name -> mkFileBased Type RightToLeft name
         TypeForward name -> mkFileBased Type LeftToRight name
+        PatternBackward name -> mkFileBased Pattern RightToLeft name
+        PatternForward name -> mkFileBased Pattern LeftToRight name
         Unfold name -> mkFileBased FoldUnfold LeftToRight name
     | spec <- specs
     ]
   fbRewrites <- parseFileBased parser fileBased
-  adhocRewrites <- parseAdhocs fixityEnv adhocs
-  return $ fbRewrites ++ adhocRewrites
+  adhocExpressionRewrites <- parseAdhocs fixityEnv adhocRules
+  adhocTypeRewrites <- parseAdhocTypes fixityEnv adhocTypes
+  adhocPatternRewrites <- parseAdhocPatterns fixityEnv adhocPatterns
+  return $
+    fbRewrites ++
+    adhocExpressionRewrites ++
+    adhocTypeRewrites ++
+    adhocPatternRewrites
   where
     mkFileBased ty dir name =
       case parseQualified name of
         Left err -> throwIO $ ErrorCall $ "parseRewriteSpecs: " ++ err
-        Right (fp, fs) -> return $ Right (fp, [(ty, [(fs, dir)])])
+        Right (fp, fs) -> return mempty{fileBased = [(fp, [(ty, [(fs, dir)])])]}
 
-data FileBasedTy = FoldUnfold | Rule | Type
+data FileBasedTy = FoldUnfold | Rule | Type | Pattern
   deriving (Eq, Ord)
 
 parseFileBased
@@ -118,6 +154,35 @@
       , let nm = "adhoc" ++ show (i::Int)
       ]
 
+parseAdhocTypes :: FixityEnv -> [String] -> IO [Rewrite Universe]
+parseAdhocTypes _ [] = return []
+parseAdhocTypes fixities tySyns = do
+  print adhocTySyns
+  cpp <-
+    parseCPP (parseContent fixities "parseAdhocTypes") (Text.unlines adhocTySyns)
+  constructRewrites cpp Type adhocSpecs
+  where
+    (adhocSpecs, adhocTySyns) = unzip
+      [ ( (mkFastString nm, LeftToRight), "type " <> Text.pack s)
+      | s <- tySyns
+      , Just nm <- [listToMaybe $ words s]
+      ]
+
+parseAdhocPatterns :: FixityEnv -> [String] -> IO [Rewrite Universe]
+parseAdhocPatterns _ [] = return []
+parseAdhocPatterns fixities patSyns = do
+  cpp <-
+    parseCPP (parseContent fixities "parseAdhocPatterns")
+             (Text.unlines $ pragma : adhocPatSyns)
+  constructRewrites cpp Pattern adhocSpecs
+  where
+    pragma = "{-# LANGUAGE PatternSynonyms #-}"
+    (adhocSpecs, adhocPatSyns) = unzip
+      [ ( (mkFastString nm, LeftToRight), "pattern " <> Text.pack s)
+      | s <- patSyns
+      , Just nm <- [listToMaybe $ words s]
+      ]
+
 constructRewrites
   :: CPP AnnotatedModule
   -> FileBasedTy
@@ -131,6 +196,7 @@
     nameOf FoldUnfold = "definition"
     nameOf Rule = "rule"
     nameOf Type = "type synonym"
+    nameOf Pattern = "pattern synonym"
 
     m = foldr (plusUFM_C (++)) emptyUFM cppM
 
@@ -144,12 +210,21 @@
   :: FileBasedTy
   -> [(FastString, Direction)]
   -> AnnotatedModule
+#if __GLASGOW_HASKELL__ < 900
   -> IO (UniqFM [Rewrite Universe])
+#else
+  -> IO (UniqFM FastString [Rewrite Universe])
+#endif
 tyBuilder FoldUnfold specs am = promote <$> dfnsToRewrites specs am
 tyBuilder Rule specs am = promote <$> rulesToRewrites specs am
 tyBuilder Type specs am = promote <$> typeSynonymsToRewrites specs am
+tyBuilder Pattern specs am = patternSynonymsToRewrites specs am
 
+#if __GLASGOW_HASKELL__ < 900
 promote :: Matchable a => UniqFM [Rewrite a] -> UniqFM [Rewrite Universe]
+#else
+promote :: Matchable a => UniqFM k [Rewrite a] -> UniqFM k [Rewrite Universe]
+#endif
 promote = fmap (map toURewrite)
 
 parseQualified :: String -> Either String (FilePath, FastString)
diff --git a/Retrie/Rewrites/Function.hs b/Retrie/Rewrites/Function.hs
--- a/Retrie/Rewrites/Function.hs
+++ b/Retrie/Rewrites/Function.hs
@@ -5,7 +5,11 @@
 --
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE TupleSections #-}
-module Retrie.Rewrites.Function (dfnsToRewrites) where
+module Retrie.Rewrites.Function
+  ( dfnsToRewrites
+  , getImports
+  , matchToRewrites
+  ) where
 
 import Control.Monad
 import Control.Monad.State.Lazy
@@ -22,7 +26,11 @@
 dfnsToRewrites
   :: [(FastString, Direction)]
   -> AnnotatedModule
+#if __GLASGOW_HASKELL__ < 900
   -> IO (UniqFM [Rewrite (LHsExpr GhcPs)])
+#else
+  -> IO (UniqFM FastString [Rewrite (LHsExpr GhcPs)])
+#endif
 dfnsToRewrites specs am = fmap astA $ transformA am $ \ (L _ m) -> do
   let
     fsMap = uniqBag specs
@@ -33,11 +41,7 @@
         imps <- getImports dir (hsmodName m)
         (fName,) . concat <$>
           forM (unLoc $ mg_alts $ fun_matches f) (matchToRewrites fe imps dir)
-#if __GLASGOW_HASKELL__ < 806
-    | L _ (ValD f@FunBind{}) <- hsmodDecls m
-#else
     | L _ (ValD _ f@FunBind{}) <- hsmodDecls m
-#endif
     , let fRdrName = fun_id f
     , let fName = occNameFS (occName (unLoc fRdrName))
     , dir <- fromMaybe [] (lookupUFM fsMap fName)
@@ -76,17 +80,10 @@
   where
     go WildPat{} = True
     go VarPat{} = True
-#if __GLASGOW_HASKELL__ < 806
-    go (LazyPat p) = irrefutablePat p
-    go (AsPat _ p) = irrefutablePat p
-    go (ParPat p) = irrefutablePat p
-    go (BangPat p) = irrefutablePat p
-#else
     go (LazyPat _ p) = irrefutablePat p
     go (AsPat _ _ p) = irrefutablePat p
     go (ParPat _ p) = irrefutablePat p
     go (BangPat _ p) = irrefutablePat p
-#endif
     go _ = False
 
 makeFunctionQuery
@@ -101,11 +98,7 @@
   | any (not . irrefutablePat) bndpats = return []
   | otherwise = do
     let
-#if __GLASGOW_HASKELL__ < 806
-      GRHSs rhss lbs = grhss
-#else
       GRHSs _ rhss lbs = grhss
-#endif
       bs = collectPatsBinders argpats
     -- See Note [Wildcards]
     (es,(_,bs')) <- runStateT (mapM patToExpr argpats) (wildSupply bs, bs)
@@ -132,16 +125,6 @@
 backtickRules e imps dir@LeftToRight grhss ps@[p1, p2] = do
   let
     both, left, right :: AppBuilder
-#if __GLASGOW_HASKELL__ < 806
-    both op [l, r] = mkLoc (OpApp l op PlaceHolder r)
-    both _ _ = fail "backtickRules - both: impossible!"
-
-    left op [l] = mkLoc (SectionL l op)
-    left _ _ = fail "backtickRules - left: impossible!"
-
-    right op [r] = mkLoc (SectionR op r)
-    right _ _ = fail "backtickRules - right: impossible!"
-#else
     both op [l, r] = mkLoc (OpApp noExtField l op r)
     both _ _ = fail "backtickRules - both: impossible!"
 
@@ -150,7 +133,6 @@
 
     right op [r] = mkLoc (SectionR noExtField op r)
     right _ _ = fail "backtickRules - right: impossible!"
-#endif
   qs <- makeFunctionQuery e imps dir grhss both (ps, [])
   qsl <- makeFunctionQuery e imps dir grhss left ([p1], [p2])
   qsr <- makeFunctionQuery e imps dir grhss right ([p2], [p1])
diff --git a/Retrie/Rewrites/Patterns.hs b/Retrie/Rewrites/Patterns.hs
new file mode 100644
--- /dev/null
+++ b/Retrie/Rewrites/Patterns.hs
@@ -0,0 +1,134 @@
+-- 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 GADTs #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE RecordWildCards #-}
+module Retrie.Rewrites.Patterns (patternSynonymsToRewrites) where
+
+import Control.Monad.State (StateT(runStateT))
+import Control.Monad
+import Data.Maybe
+
+import Retrie.ExactPrint
+import Retrie.Expr
+import Retrie.GHC
+import Retrie.Quantifiers
+import Retrie.Rewrites.Function
+import Retrie.Types
+import Retrie.Universe
+import Retrie.Util
+
+patternSynonymsToRewrites
+  :: [(FastString, Direction)]
+  -> AnnotatedModule
+#if __GLASGOW_HASKELL__ < 900
+  -> IO (UniqFM [Rewrite Universe])
+#else
+  -> IO (UniqFM FastString [Rewrite Universe])
+#endif
+patternSynonymsToRewrites specs am = fmap astA $ transformA am $ \(L _ m) -> do
+  let
+    fsMap = uniqBag specs
+  imports <- getImports RightToLeft (hsmodName m)
+  rrs <- sequence
+      [ do
+          patRewrite <- mkPatRewrite dir imports nm params lrhs
+          expRewrites <- mkExpRewrite dir imports nm params rhs patdir
+          return (rdr, toURewrite patRewrite : map toURewrite expRewrites)
+      | L _ (ValD _ (PatSynBind _ (PSB _ nm params rhs patdir))) <- hsmodDecls m
+      , let rdr = rdrFS (unLoc nm)
+      , dir <- fromMaybe [] (lookupUFM fsMap rdr)
+      , Just lrhs <- [dLPat rhs]
+      ]
+
+  return $ listToUFM_C (++) rrs
+
+mkPatRewrite
+  :: Direction
+  -> AnnotatedImports
+  -> LRdrName
+  -> HsConDetails LRdrName [RecordPatSynField LRdrName]
+  -> Located (Pat GhcPs)
+  -> TransformT IO (Rewrite (Located (Pat GhcPs)))
+mkPatRewrite dir imports patName params rhs = do
+  lhs <- asPat patName params
+
+  (pat, temp) <- case dir of
+    LeftToRight -> return (lhs, rhs)
+    RightToLeft -> do
+      setEntryDPT lhs (DP (0,0))
+      -- Patterns from lhs have wonky annotations,
+      -- the space will be attached to the name, not to the ConPatIn ast node
+      setEntryDPTunderConPatIn lhs (DP (0,0))
+      return (rhs, lhs)
+
+  p <- pruneA pat
+  t <- pruneA temp
+  let bs = collectPatBinders (cLPat temp)
+  return $ addRewriteImports imports $ mkRewrite (mkQs bs) p t
+
+  where
+    setEntryDPTunderConPatIn
+      :: Monad m => Located (Pat GhcPs) -> DeltaPos -> TransformT m ()
+#if __GLASGOW_HASKELL__ < 900
+    setEntryDPTunderConPatIn (L _ (ConPatIn nm _)) = setEntryDPT nm
+#else
+    setEntryDPTunderConPatIn (L _ (ConPat _ nm _)) = setEntryDPT nm
+#endif
+    setEntryDPTunderConPatIn _ = const $ return ()
+
+asPat
+  :: Monad m
+  => LRdrName
+  -> HsConDetails LRdrName [RecordPatSynField LRdrName]
+  -> TransformT m (Located (Pat GhcPs))
+asPat patName params = do
+  params' <- bitraverseHsConDetails mkVarPat convertFields params
+  mkConPatIn patName params'
+  where
+
+    convertFields fields =
+      HsRecFields <$> traverse convertField fields <*> pure Nothing
+
+    convertField RecordPatSynField{..} = do
+      hsRecFieldLbl <- mkLoc $ mkFieldOcc recordPatSynSelectorId
+      hsRecFieldArg <- mkVarPat recordPatSynPatVar
+      let hsRecPun = False
+      mkLoc HsRecField{..}
+
+
+mkExpRewrite
+  :: Direction
+  -> AnnotatedImports
+  -> LRdrName
+  -> HsConDetails LRdrName [RecordPatSynField LRdrName]
+  -> LPat GhcPs
+  -> HsPatSynDir GhcPs
+  -> TransformT IO [Rewrite (LHsExpr GhcPs)]
+mkExpRewrite dir imports patName params rhs patDir = do
+  fe <- mkLocatedHsVar patName
+  let altsFromParams = case params of
+        PrefixCon names -> buildMatch names rhs
+        InfixCon a1 a2 -> buildMatch [a1, a2] rhs
+        RecCon{} -> missingSyntax "RecCon"
+  alts <- case patDir of
+    ExplicitBidirectional MG{mg_alts} -> pure $ unLoc mg_alts
+    ImplicitBidirectional -> altsFromParams
+    _ -> pure []
+  fmap concat $ forM alts $ matchToRewrites fe imports dir
+
+buildMatch
+  :: Monad m
+  => [Located (IdP GhcPs)]
+  -> LPat GhcPs
+  -> TransformT m [LMatch GhcPs (LHsExpr GhcPs)]
+buildMatch names rhs = do
+  pats <- traverse mkVarPat names
+  let bs = collectPatBinders rhs
+  (rhsExpr,(_,_bs')) <- runStateT (patToExpr rhs) (wildSupply bs, bs)
+  let alt = mkMatch PatSyn pats rhsExpr (noLoc emptyLocalBinds)
+  return [alt]
diff --git a/Retrie/Rewrites/Rules.hs b/Retrie/Rewrites/Rules.hs
--- a/Retrie/Rewrites/Rules.hs
+++ b/Retrie/Rewrites/Rules.hs
@@ -3,6 +3,7 @@
 -- 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 RecordWildCards #-}
 module Retrie.Rewrites.Rules (rulesToRewrites) where
 
@@ -17,7 +18,11 @@
 rulesToRewrites
   :: [(FastString, Direction)]
   -> AnnotatedModule
+#if __GLASGOW_HASKELL__ < 900
   -> IO (UniqFM [Rewrite (LHsExpr GhcPs)])
+#else
+  -> IO (UniqFM RuleName [Rewrite (LHsExpr GhcPs)])
+#endif
 rulesToRewrites specs am = fmap astA $ transformA am $ \ m -> do
   let
     fsMap = uniqBag specs
diff --git a/Retrie/Rewrites/Types.hs b/Retrie/Rewrites/Types.hs
--- a/Retrie/Rewrites/Types.hs
+++ b/Retrie/Rewrites/Types.hs
@@ -21,18 +21,18 @@
 typeSynonymsToRewrites
   :: [(FastString, Direction)]
   -> AnnotatedModule
+#if __GLASGOW_HASKELL__ < 900
   -> IO (UniqFM [Rewrite (LHsType GhcPs)])
+#else
+  -> IO (UniqFM FastString [Rewrite (LHsType GhcPs)])
+#endif
 typeSynonymsToRewrites specs am = fmap astA $ transformA am $ \ m -> do
   let
     fsMap = uniqBag specs
     tySyns =
       [ (rdr, (dir, (nm, hsq_explicit vars, rhs)))
         -- only hsq_explicit is available pre-renaming
-#if __GLASGOW_HASKELL__ < 806
-      | L _ (TyClD (SynDecl nm vars _ rhs _)) <- hsmodDecls $ unLoc m
-#else
       | L _ (TyClD _ (SynDecl _ nm vars _ rhs)) <- hsmodDecls $ unLoc m
-#endif
       , let rdr = rdrFS (unLoc nm)
       , dir <- fromMaybe [] (lookupUFM fsMap rdr)
       ]
@@ -44,7 +44,11 @@
 -- | Compile a list of RULES into a list of rewrites.
 mkTypeRewrite
   :: Direction
+#if __GLASGOW_HASKELL__ < 900
   -> (Located RdrName, [LHsTyVarBndr GhcPs], LHsType GhcPs)
+#else
+  -> (Located RdrName, [LHsTyVarBndr () GhcPs], LHsType GhcPs)
+#endif
   -> TransformT IO (Rewrite (LHsType GhcPs))
 mkTypeRewrite d (lhsName, vars, rhs) = do
   setEntryDPT lhsName $ DP (0,0)
diff --git a/Retrie/Subst.hs b/Retrie/Subst.hs
--- a/Retrie/Subst.hs
+++ b/Retrie/Subst.hs
@@ -49,11 +49,7 @@
   => Context
   -> LHsExpr GhcPs
   -> TransformT m (LHsExpr GhcPs)
-#if __GLASGOW_HASKELL__ < 806
-substExpr ctxt e@(L l1 (HsVar (L l2 v))) =
-#else
 substExpr ctxt e@(L l1 (HsVar x (L l2 v))) =
-#endif
   case lookupHoleVar v ctxt of
     Just (HoleExpr eA) -> do
       e' <- graftA (unparen <$> eA)
@@ -62,11 +58,7 @@
       transferAnnsT isComma e e'
       parenify ctxt e'
     Just (HoleRdr rdr) ->
-#if __GLASGOW_HASKELL__ < 806
-      return $ L l1 $ HsVar $ L l2 rdr
-#else
       return $ L l1 $ HsVar x $ L l2 rdr
-#endif
     _ -> return e
 substExpr _ e = return e
 
@@ -75,25 +67,19 @@
   => Context
   -> LPat GhcPs
   -> TransformT m (LPat GhcPs)
-#if __GLASGOW_HASKELL__ < 806
-substPat ctxt p@(L l1 (VarPat (L l2 v))) =
-#elif __GLASGOW_HASKELL__ < 808
-substPat ctxt p@(L l1 (VarPat x (L l2 v))) =
-#else
-substPat ctxt (dL -> p@(L l1 (VarPat x (dL -> L l2 v)))) =
-  fmap composeSrcSpan $
-#endif
+substPat ctxt (dLPat -> Just p@(L l1 (VarPat x vl@(L l2 v)))) = fmap cLPat $
   case lookupHoleVar v ctxt of
     Just (HolePat pA) -> do
-      p' <- graftA pA
+      p' <- graftA (unparenP <$> pA)
       transferEntryAnnsT isComma p p'
-      return p'
+      -- the relevant entry delta is sometimes attached to
+      -- the OccName and not to the VarPat.
+      -- This seems to be the case only when the pattern comes from a lhs,
+      -- whereas it has no annotations in patterns found in rhs's.
+      tryTransferEntryDPT vl p'
+      parenifyP ctxt p'
     Just (HoleRdr rdr) ->
-#if __GLASGOW_HASKELL__ < 806
-      return $ L l1 $ VarPat $ L l2 rdr
-#else
       return $ L l1 $ VarPat x $ L l2 rdr
-#endif
     _ -> return p
 substPat _ p = return p
 
@@ -116,8 +102,13 @@
 substHsMatchContext
   :: Monad m
   => Context
+#if __GLASGOW_HASKELL__ < 900
   -> HsMatchContext RdrName
   -> TransformT m (HsMatchContext RdrName)
+#else
+  -> HsMatchContext GhcPs
+  -> TransformT m (HsMatchContext GhcPs)
+#endif
 substHsMatchContext ctxt (FunRhs (L l v) f s)
   | Just (HoleRdr rdr) <- lookupHoleVar v ctxt =
     return $ FunRhs (L l rdr) f s
diff --git a/Retrie/Substitution.hs b/Retrie/Substitution.hs
--- a/Retrie/Substitution.hs
+++ b/Retrie/Substitution.hs
@@ -3,6 +3,7 @@
 -- This source code is licensed under the MIT license found in the
 -- LICENSE file in the root directory of this source tree.
 --
+{-# LANGUAGE CPP #-}
 module Retrie.Substitution
   ( Substitution
   , HoleVal(..)
@@ -17,7 +18,11 @@
 import Retrie.GHC
 
 -- | A 'Substitution' is essentially a map from variable name to 'HoleVal'.
+#if __GLASGOW_HASKELL__ < 900
 newtype Substitution = Substitution (UniqFM (FastString, HoleVal))
+#else
+newtype Substitution = Substitution (UniqFM FastString (FastString, HoleVal))
+#endif
 -- See Note [Why not RdrNames?] for explanation of use of FastString
 
 instance Show Substitution where
diff --git a/Retrie/Types.hs b/Retrie/Types.hs
--- a/Retrie/Types.hs
+++ b/Retrie/Types.hs
@@ -86,6 +86,7 @@
 -- | Precedence of parent node in the AST.
 data ParentPrec
   = HasPrec Fixity -- ^ Parent has precedence info.
+  | IsLhs      -- ^ We are a pattern in a left-hand-side
   | IsHsAppsTy -- ^ Parent is HsAppsTy
   | NeverParen -- ^ Based on parent, we should never add parentheses.
 
diff --git a/Retrie/Universe.hs b/Retrie/Universe.hs
--- a/Retrie/Universe.hs
+++ b/Retrie/Universe.hs
@@ -32,6 +32,7 @@
   = ULHsExpr (LHsExpr GhcPs)
   | ULStmt (LStmt GhcPs (LHsExpr GhcPs))
   | ULType (LHsType GhcPs)
+  | ULPat (Located (Pat GhcPs))
   deriving (Data)
 
 -- | Exactprint an annotated 'Universe'.
@@ -43,6 +44,7 @@
 exactPrintU (ULHsExpr e) anns = exactPrint e anns
 exactPrintU (ULStmt s) anns = exactPrint s anns
 exactPrintU (ULType t) anns = exactPrint t anns
+exactPrintU (ULPat p) anns = exactPrint p anns
 
 -------------------------------------------------------------------------------
 
@@ -64,6 +66,7 @@
   getOrigin (ULHsExpr e) = getOrigin e
   getOrigin (ULStmt s) = getOrigin s
   getOrigin (ULType t) = getOrigin t
+  getOrigin (ULPat p) = getOrigin p
 
 instance Matchable (LHsExpr GhcPs) where
   inject = ULHsExpr
@@ -83,6 +86,12 @@
   project _ = error "project ULType"
   getOrigin e = getLoc e
 
+instance Matchable (Located (Pat GhcPs)) where
+  inject = ULPat
+  project (ULPat p) = p
+  project _ = error "project ULPat"
+  getOrigin = getLoc
+
 -------------------------------------------------------------------------------
 
 -- | The pattern map for 'Universe'.
@@ -90,6 +99,7 @@
   { umExpr :: EMap a
   , umStmt :: SMap a
   , umType :: TyMap a
+  , umPat  :: PatMap a
   }
   deriving (Functor)
 
@@ -97,25 +107,27 @@
   type Key UMap = Universe
 
   mEmpty :: UMap a
-  mEmpty = UMap mEmpty mEmpty mEmpty
+  mEmpty = UMap mEmpty mEmpty mEmpty mEmpty
 
   mUnion :: UMap a -> UMap a -> UMap a
   mUnion m1 m2 = UMap
     (unionOn umExpr m1 m2)
     (unionOn umStmt m1 m2)
     (unionOn umType m1 m2)
+    (unionOn umPat m1 m2)
 
   mAlter :: AlphaEnv -> Quantifiers -> Universe -> A a -> UMap a -> UMap a
   mAlter env vs u f m = go u
     where
       go (ULHsExpr e) = m { umExpr = mAlter env vs e f (umExpr m) }
-      go (ULStmt s)   = m { umStmt = mAlter env vs s f (umStmt m) }
-      go (ULType t)   = m { umType = mAlter env vs t f (umType m) }
+      go (ULStmt s) = m { umStmt = mAlter env vs s f (umStmt m) }
+      go (ULType t) = m { umType = mAlter env vs t f (umType m) }
+      go (ULPat p) = m { umPat  = mAlter env vs (cLPat p) f (umPat m) }
 
   mMatch :: MatchEnv -> Universe -> (Substitution, UMap a) -> [(Substitution, a)]
   mMatch env = go
     where
       go (ULHsExpr e) = mapFor umExpr >=> mMatch env e
-      go (ULStmt s)   = mapFor umStmt >=> mMatch env s
-      go (ULType t)   = mapFor umType >=> mMatch env t
-
+      go (ULStmt s) = mapFor umStmt >=> mMatch env s
+      go (ULType t) = mapFor umType >=> mMatch env t
+      go (ULPat p) = mapFor umPat >=> mMatch env (cLPat p)
diff --git a/Retrie/Util.hs b/Retrie/Util.hs
--- a/Retrie/Util.hs
+++ b/Retrie/Util.hs
@@ -6,14 +6,17 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 module Retrie.Util where
 
+import Control.Arrow (first)
 import Control.Applicative
 import Control.Concurrent.Async
 import Control.Exception
 import Control.Monad
 import Data.List
+import qualified Data.Set as Set
 import System.Exit
 import System.FilePath
 import System.Process
+import System.IO (hPutStrLn, stderr)
 
 data Verbosity = Silent | Normal | Loud
   deriving (Eq, Ord, Show)
@@ -75,23 +78,34 @@
   case ec of
     ExitSuccess -> do
       let
-        (ifiles, dirs) = partition hasExtension
+        (ifiles, dirs) = first Set.fromList $ partition hasExtension
           [ normalise $ targetDir </> dropTrailingPathSeparator f
           | f <- lines fps ]
         idirs = extraDirs dirs
-      return $ Just $ \fp -> fp `elem` ifiles || any (`isPrefixOf` fp) idirs
+      return $ Just
+        $ \fp -> fp `Set.member` ifiles || any (`isPrefixOf` fp) idirs
     ExitFailure _ -> do
-      when (verbosity > Normal) $ putStrLn $ prefix ++ err
+      when (verbosity > Normal) $ putErrStrLn $ prefix ++ err
       return Nothing
 
 handler :: String -> Verbosity -> IOError -> IO (Maybe a)
 handler prefix verbosity err = do
-  when (verbosity > Normal) $ putStrLn $ prefix ++ show err
+  when (verbosity > Normal) $ putErrStrLn $ prefix ++ show err
   return Nothing
 
+putErrStrLn :: String -> IO ()
+putErrStrLn = hPutStrLn stderr
+
 -- | Like 'try', but rethrows async exceptions.
 trySync :: IO a -> IO (Either SomeException a)
 trySync io = catch (Right <$> io) $ \e ->
   case fromException e of
     Just (_ :: SomeAsyncException) -> throwIO e
     Nothing -> return (Left e)
+
+missingSyntax :: String -> a
+missingSyntax constructor = error $ unlines
+  [ "Missing syntax support: " ++ constructor
+  , "Please file an issue at https://github.com/facebookincubator/retrie/issues"
+  , "with an example of the rewrite you are attempting and we'll add it."
+  ]
diff --git a/demo/Main.hs b/demo/Main.hs
--- a/demo/Main.hs
+++ b/demo/Main.hs
@@ -3,7 +3,6 @@
 -- 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 OverloadedStrings #-}
 module Main where
 
@@ -40,11 +39,7 @@
 stringToFooArg _ctxt match
   | MatchResult substitution template <- match
   , Just (HoleExpr expr) <- lookupSubst "arg" substitution
-#if __GLASGOW_HASKELL__ < 806
-  , L _ (HsLit (HsString _ str)) <- astA expr = do
-#else
   , L _ (HsLit _ (HsString _ str)) <- astA expr = do
-#endif
     newExpr <- case lookup str argMapping of
       Nothing ->
         parseExpr $ "error \"invalid argument: " ++ unpackFS str ++ "\""
diff --git a/retrie.cabal b/retrie.cabal
--- a/retrie.cabal
+++ b/retrie.cabal
@@ -4,7 +4,7 @@
 -- LICENSE file in the root directory of this source tree.
 --
 name: retrie
-version: 0.1.1.1
+version: 1.0.0.0
 synopsis: A powerful, easy-to-use codemodding tool for Haskell.
 homepage: https://github.com/facebookincubator/retrie
 bug-reports: https://github.com/facebookincubator/retrie/issues
@@ -23,7 +23,7 @@
   README.md
   tests/inputs/*.custom
   tests/inputs/*.test
-tested-with: GHC ==8.10.1 || ==8.8.2 || ==8.6.5 || ==8.4.4
+tested-with: GHC ==9.0.1 || ==8.10.4 || ==8.8.4
 
 description:
   Retrie is a tool for codemodding Haskell. Key goals include:
@@ -62,6 +62,7 @@
     Retrie.Replace,
     Retrie.Rewrites,
     Retrie.Rewrites.Function,
+    Retrie.Rewrites.Patterns,
     Retrie.Rewrites.Rules,
     Retrie.Rewrites.Types,
     Retrie.Run,
@@ -73,18 +74,18 @@
     Retrie.Util
   GHC-Options: -Wall
   build-depends:
-    ansi-terminal >= 0.10.3 && < 0.11,
+    ansi-terminal >= 0.10.3 && < 0.12,
     async >= 2.2.2 && < 2.3,
-    base >= 4.11 && < 4.15,
+    base >= 4.11 && < 4.16,
     bytestring >= 0.10.8 && < 0.11,
     containers >= 0.5.11 && < 0.7,
     data-default >= 0.7.1 && < 0.8,
     directory >= 1.3.1 && < 1.4,
     filepath >= 1.4.2 && < 1.5,
-    ghc >= 8.4 && < 8.12,
+    ghc >= 8.8 && < 9.2,
     ghc-exactprint >= 0.6.2 && < 0.7,
     mtl >= 2.2.2 && < 2.3,
-    optparse-applicative >= 0.15.1 && < 0.16,
+    optparse-applicative >= 0.15.1 && < 0.17,
     process >= 1.6.3 && < 1.7,
     random-shuffle >= 0.0.4 && < 0.1,
     syb >= 0.7.1 && < 0.8,
@@ -109,7 +110,7 @@
   GHC-Options: -Wall
   build-depends:
     retrie,
-    base >= 4.11 && < 4.15,
+    base >= 4.11 && < 4.16,
     haskell-src-exts >= 1.23.0 && < 1.24
   default-language: Haskell2010
 
@@ -125,7 +126,7 @@
   GHC-Options: -Wall
   build-depends:
     retrie,
-    base >= 4.11 && < 4.15,
+    base >= 4.11 && < 4.16,
     haskell-src-exts >= 1.23.0 && < 1.24
   default-language: Haskell2010
 
@@ -152,13 +153,13 @@
   build-depends:
     retrie,
     HUnit,
-    base >= 4.11 && < 4.15,
+    base >= 4.11 && < 4.16,
     containers,
     data-default,
     deepseq,
     directory,
     filepath,
-    ghc >= 8.4 && < 8.12,
+    ghc >= 8.8 && < 9.2,
     ghc-paths,
     haskell-src-exts >= 1.23.0 && < 1.24,
     mtl,
diff --git a/tests/Annotated.hs b/tests/Annotated.hs
--- a/tests/Annotated.hs
+++ b/tests/Annotated.hs
@@ -3,6 +3,7 @@
 -- 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 RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 module Annotated (annotatedTest) where
@@ -195,19 +196,27 @@
 -- expected form.
 assertExactPrintAnns :: Anns -> Anns -> IO ()
 assertExactPrintAnns annsPreGraft annsPostGraft =
-  mapM_ (\(AnnKey ss _) -> assertGoodSrcSpan ss) newKeys
+  forM_ newKeys $ \(AnnKey ss _) ->
+#if __GLASGOW_HASKELL__ < 900
+    assertGoodSrcSpan ss
+#else
+    assertGoodRealSrcSpan ss
+#endif
   where
     newKeys :: S.Set AnnKey
     newKeys = M.keysSet annsPostGraft `S.difference` M.keysSet annsPreGraft
 
 assertGoodSrcSpan :: SrcSpan -> IO ()
 assertGoodSrcSpan srcSpan =
-  case srcSpan of
-    RealSrcSpan rss -> do
-      assertGoodSrcLoc (realSrcSpanStart rss)
-      assertGoodSrcLoc (realSrcSpanEnd rss)
-    UnhelpfulSpan _ ->
+  case getRealSpan srcSpan of
+    Just rss -> assertGoodRealSrcSpan rss
+    Nothing ->
       assertFailure "only real src spans should be generated"
+
+assertGoodRealSrcSpan :: RealSrcSpan -> IO ()
+assertGoodRealSrcSpan rss = do
+  assertGoodSrcLoc (realSrcSpanStart rss)
+  assertGoodSrcLoc (realSrcSpanEnd rss)
 
 assertGoodSrcLoc :: RealSrcLoc -> IO ()
 assertGoodSrcLoc srcLoc = do
diff --git a/tests/Demo.hs b/tests/Demo.hs
--- a/tests/Demo.hs
+++ b/tests/Demo.hs
@@ -3,7 +3,6 @@
 -- 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 OverloadedStrings #-}
 module Demo (stringToFooArg) where
 
@@ -16,11 +15,7 @@
 stringToFooArg _ctxt match
   | MatchResult substitution template <- match
   , Just (HoleExpr expr) <- lookupSubst "arg" substitution
-#if __GLASGOW_HASKELL__ < 806
-  , L _ (HsLit (HsString _ str)) <- astA expr = do
-#else
   , L _ (HsLit _ (HsString _ str)) <- astA expr = do
-#endif
     newExpr <- case lookup str argMapping of
       Nothing ->
         parseExpr $ "error \"invalid argument: " ++ unpackFS str ++ "\""
diff --git a/tests/inputs/Adhoc.test b/tests/inputs/Adhoc.test
--- a/tests/inputs/Adhoc.test
+++ b/tests/inputs/Adhoc.test
@@ -6,6 +6,9 @@
 --adhoc "forall f g xs. map f (map g xs) = map (f . g) xs"
 --adhoc "forall p xs. length (filter p xs) = count p xs"
 -u Adhoc.foo
+--adhoc-type "MyMaybe a = Maybe a"
+--adhoc "MyNothing = Nothing"
+--adhoc "forall x. MyJust x = Just x"
 ===
  module Adhoc where
  
@@ -22,3 +25,12 @@
    where
 -    zs = map (+1) (map (*3) ys)
 +    zs = map ((+1) . (*3)) ys
+
+ data MyMaybe a = MyNothing | MyJust a
+
+-baz :: Maybe a -> MyMaybe a 
++baz :: Maybe a -> Maybe a
+-baz Nothing = MyNothing
++baz Nothing = Nothing
+-baz (Just y) = MyJust y
++baz (Just y) = Just y
diff --git a/tests/inputs/PatternSyn1.test b/tests/inputs/PatternSyn1.test
new file mode 100644
--- /dev/null
+++ b/tests/inputs/PatternSyn1.test
@@ -0,0 +1,55 @@
+# 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.
+#
+--pattern-forward PatternSyn1.JustUnit
+--pattern-forward PatternSyn1.Some
+--pattern-forward PatternSyn1.SomeUni
+--pattern-forward PatternSyn1.LeftSomething
+--pattern-forward PatternSyn1.JustNot
+--adhoc-pattern "SomeAdhoc x = Just x"
+--adhoc-pattern "SomeAdhoc2 x <- Just x"
+===
+ {-# LANGUAGE PatternSynonyms #-}
+ {-# LANGUAGE ViewPatterns    #-}
+ module PatternSyn1 where
+
+ pattern JustUnit = Just ()
+ pattern Some x <- Just x where Some x = Just x
+ pattern SomeUni x <- Just x
+ pattern JustNot x <- Just (not -> x) where JustNot x = Just (not x)
+ pattern LeftSomething <- Left _
+ pattern SomeAdhoc x = Just x
+ pattern SomeAdhoc2 x = Just x
+
+ foo :: Maybe () -> Maybe ()
+
+-foo JustUnit = JustUnit
++foo (Just ()) = Just ()
+
+-foo (id -> JustUnit) = JustUnit
++foo (id -> Just ()) = Just ()
+
+-foo (Some ()) = Some ()
++foo (Just ()) = Just ()
+
+-foo (SomeUni ()) = Just ()
++foo (Just ()) = Just ()
+
+-foo (Some x) = let x = Some () in x
++foo (Just x) = let x = Just () in x
+
+-foo (SomeAdhoc ()) = SomeAdhoc ()
++foo (Just ()) = Just ()
+
+-foo (SomeAdhoc2 ()) = SomeAdhoc2 ()
++foo (Just ()) = SomeAdhoc2 ()
+
+ fooBool :: Maybe Bool -> MaybeBool
+-fooBool (JustNot x) = JustNot x
++fooBool (Just (not -> x)) = Just (not x)
+
+ bar :: Either () () -> Either () ()
+-bar LeftSomething = Left ()
++bar (Left _) = Left ()
diff --git a/tests/inputs/PatternSyn2.test b/tests/inputs/PatternSyn2.test
new file mode 100644
--- /dev/null
+++ b/tests/inputs/PatternSyn2.test
@@ -0,0 +1,30 @@
+# 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.
+#
+--pattern-backward PatternSyn2.Some
+--pattern-backward PatternSyn2.JustUnit
+--pattern-backward PatternSyn2.SomeUnit
+===
+ {-# LANGUAGE PatternSynonyms #-}
+ {-# LANGUAGE ViewPatterns    #-}
+ module PatternSyn2 where
+
+ pattern Some x <- Just x where Some x = Just x
+ pattern JustUnit = Some ()
+ pattern SomeUnit <- JustUnit
+
+ foo :: Maybe () -> Maybe ()
+
+-foo (Just ()) = Just ()
++foo (Some ()) = Some ()
+
+-foo (id -> Just ()) = Just ()
++foo (id -> Some ()) = Some ()
+
+-foo (Some ()) = Some ()
++foo JustUnit = JustUnit
+
+-foo JustUnit = JustUnit
++foo SomeUnit = JustUnit