retrie 0.1.1.1 → 1.0.0.0

raw patch · 30 files changed

+858/−742 lines, 30 filesdep ~ansi-terminaldep ~basedep ~ghcPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: ansi-terminal, base, ghc, optparse-applicative

API changes (from Hackage documentation)

Files

• CHANGELOG.md +9/−1
• Retrie/CPP.hs +3/−3
• Retrie/Context.hs +11/−35
• Retrie/ExactPrint.hs +39/−44
• Retrie/ExactPrint/Annotated.hs +1/−1
• Retrie/Expr.hs +89/−135
• Retrie/GHC.hs +112/−45
• Retrie/Options.hs +20/−0
• Retrie/PatternMap/Bag.hs +5/−0
• Retrie/PatternMap/Class.hs +2/−8
• Retrie/PatternMap/Instances.hs +136/−351
• Retrie/Pretty.hs +5/−4
• Retrie/Replace.hs +10/−19
• Retrie/Rewrites.hs +82/−7
• Retrie/Rewrites/Function.hs +9/−27
• Retrie/Rewrites/Patterns.hs +134/−0
• Retrie/Rewrites/Rules.hs +5/−0
• Retrie/Rewrites/Types.hs +8/−4
• Retrie/Subst.hs +13/−22
• Retrie/Substitution.hs +5/−0
• Retrie/Types.hs +1/−0
• Retrie/Universe.hs +18/−6
• Retrie/Util.hs +18/−4
• demo/Main.hs +0/−5
• retrie.cabal +11/−10
• tests/Annotated.hs +15/−6
• tests/Demo.hs +0/−5
• tests/inputs/Adhoc.test +12/−0
• tests/inputs/PatternSyn1.test +55/−0
• tests/inputs/PatternSyn2.test +30/−0

@@ -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)

@@ -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

@@ -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

@@ -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

@@ -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)) 

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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)

@@ -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])

@@ -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]

@@ -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

@@ -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)

@@ -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

@@ -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

@@ -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. 

@@ -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)

@@ -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."+  ]

@@ -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 ++ "\""

@@ -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,

@@ -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

@@ -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 ++ "\""

@@ -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

@@ -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 ()

@@ -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