retrie 1.0.0.0 → 1.1.0.0

raw patch · 9 files changed

+240/−71 lines, 9 filesdep +list-tdep ~bytestringdep ~optparse-applicativedep ~textnew-component:exe:demo-retrienew-uploaderPVP ok

version bump matches the API change (PVP)

Dependencies added: list-t

Dependency ranges changed: bytestring, optparse-applicative, text

API changes (from Hackage documentation)

Files

• CHANGELOG.md +5/−0
• Retrie/Elaborate.hs +115/−0
• Retrie/Expr.hs +4/−0
• Retrie/Options.hs +88/−31
• Retrie/PatternMap/Instances.hs +2/−20
• Retrie/Replace.hs +5/−8
• retrie.cabal +4/−2
• tests/GroundTerms.hs +16/−9
• tests/Targets.hs +1/−1

@@ -1,3 +1,8 @@++1.1.0.0 (November 13, 2021)+* Remove dependency on xargs (#31)+* Allow rewrite elaboration+ 1.0.0.0 (April 9, 2021)  * Added --adhoc-type flag (#13)

@@ -0,0 +1,115 @@+-- 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 FlexibleContexts #-}+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeApplications #-}+module Retrie.Elaborate+  ( defaultElaborations+  , elaborateRewritesInternal+  ) where++import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Trans.Class+import "list-t" ListT+import Data.Maybe++import Retrie.Context+import Retrie.ExactPrint+import Retrie.Expr+import Retrie.Fixity+import Retrie.GHC+import Retrie.Quantifiers+import Retrie.Rewrites+import Retrie.Subst+import Retrie.Substitution+import Retrie.SYB+import Retrie.Types+import Retrie.Universe++defaultElaborations :: [RewriteSpec]+defaultElaborations =+  [ Adhoc "forall f x. f $ x = f (x)"+  ]++elaborateRewritesInternal+  :: FixityEnv+  -> [Rewrite Universe]+  -> [Rewrite Universe]+  -> IO [Rewrite Universe]+elaborateRewritesInternal _ [] rewrites = return rewrites+elaborateRewritesInternal fixityEnv elaborations rewrites =+  concat <$> mapM (elaborateOne fixityEnv elaborator) rewrites+  where+    elaborator = foldMap mkRewriter elaborations++elaborateOne :: FixityEnv -> Rewriter -> Rewrite Universe -> IO [Rewrite Universe]+elaborateOne fixityEnv elaborator rr = do+  patterns <-+    transformA (qPattern rr) $ toList .+      everywhereMWithContextBut topDown+        (const False) (\c i x -> lift $ updateContext c i x) elaborate ctxt+  return [ rr { qPattern = pattern } | pattern <- sequenceA patterns ]+  where+    ctxt = emptyContext fixityEnv elaborator mempty++elaborate+  :: (Data a, MonadIO m) => Context -> a -> ListT (TransformT m) a+elaborate c =+  mkM (elaborateImpl @(HsExpr GhcPs) c)+    `extM` (elaborateImpl @(Stmt GhcPs (LHsExpr GhcPs)) c)+    `extM` (elaborateImpl @(HsType GhcPs) c)+    `extM` (elaboratePat c)++elaboratePat :: MonadIO m => Context -> LPat GhcPs -> ListT (TransformT 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.+elaboratePat c p+  | Just lp <- dLPat p = cLPat <$> elaborateImpl c lp+  | otherwise = return p++elaborateImpl+  :: forall ast m. (Annotate ast, Matchable (Located ast), MonadIO m)+  => Context -> Located ast -> ListT (TransformT m) (Located ast)+elaborateImpl ctxt e = do+  elaborations <- lift $ do+    matches <- runMatcher ctxt (ctxtRewriter ctxt) (getUnparened e)+    validMatches <- allMatches ctxt matches+    forM [ (sub, tmpl) | MatchResult sub tmpl <- validMatches ] $ \(sub, Template{..}) -> do+      -- graft template into target+      t' <- graftA tTemplate+      -- substitute for quantifiers in grafted template+      r <- subst sub ctxt t'+      -- copy appropriate annotations from old expression to template+      addAllAnnsT e r+      -- add parens to template if needed+      (mkM (parenify ctxt) `extM` parenifyT ctxt `extM` parenifyP ctxt) r++  fromFoldable (e : elaborations)++-- | Find the first 'valid' match.+-- Runs the user's 'MatchResultTransformer' and sanity checks the result.+allMatches+  :: (Matchable ast, MonadIO m)+  => Context+  -> [(Substitution, RewriterResult Universe)]+  -> TransformT m [MatchResult ast]+allMatches _ [] = return []+allMatches ctxt matchResults = do+  results <-+    forM matchResults $ \(sub, RewriterResult{..}) -> do+      result <- lift $ liftIO $ rrTransformer ctxt $ MatchResult sub rrTemplate+      return (rrQuantifiers, result)+  return+    [ project <$> result+    | (quantifiers, result@(MatchResult sub' _)) <- results+      -- Check that all quantifiers from the original rewrite have mappings+      -- in the resulting substitution. This is mostly to prevent a bad+      -- user-defined MatchResultTransformer from causing havok.+    , isJust $ sequence [ lookupSubst q sub' | q <- qList quantifiers ]+    ]

@@ -10,6 +10,7 @@ {-# LANGUAGE ViewPatterns #-} module Retrie.Expr   ( bitraverseHsConDetails+  , getUnparened   , grhsToExpr   , mkApps   , mkConPatIn@@ -263,6 +264,9 @@     needed NeverParen _ = False     needed _ Nothing = True     needed _ _ = False++getUnparened :: Data k => k -> k+getUnparened = mkT unparen `extT` unparenT `extT` unparenP  unparen :: LHsExpr GhcPs -> LHsExpr GhcPs unparen (L _ (HsPar _ e)) = e

@@ -23,10 +23,11 @@   , parseVerbosity   , ProtoOptions   , resolveOptions+  , GrepCommands(..)   ) where  import Control.Concurrent.Async (mapConcurrently)-import Control.Monad (when)+import Control.Monad (when, foldM) import Data.Bool import Data.Char (isAlphaNum, isSpace) import Data.Default as D@@ -44,6 +45,7 @@  import Retrie.CPP import Retrie.Debug+import Retrie.Elaborate import Retrie.ExactPrint import Retrie.Fixity import Retrie.GroundTerms@@ -87,6 +89,8 @@     -- ^ Imports specified by the command-line flag '--import'.   , colorise :: ColoriseFun     -- ^ Function used to colorize results of certain execution modes.+  , elaborations :: rewrites+    -- ^ Rewrites which are applied to the left-hand side of the actual rewrites.   , executionMode :: ExecutionMode     -- ^ Controls behavior of 'apply'. See 'ExecutionMode'.   , extraIgnores :: [FilePath]@@ -99,6 +103,8 @@     -- ^ Iterate the given rewrites or 'Retrie' computation up to this many     -- times. Iteration may stop before the limit if no changes are made during     -- a given iteration.+  , noDefaultElaborations :: Bool+    -- ^ Do not apply any of the built in elaborations in 'defaultElaborations'.   , randomOrder :: Bool     -- ^ Whether to randomize the order of target modules before rewriting them.   , rewrites :: rewrites@@ -125,10 +131,12 @@ defaultOptions fp = Options   { additionalImports = D.def   , colorise = noColor+  , elaborations = D.def   , executionMode = ExecRewrite   , extraIgnores = []   , fixityEnv = mempty   , iterateN = 1+  , noDefaultElaborations = False   , randomOrder = False   , rewrites = D.def   , roundtrips = []@@ -184,6 +192,11 @@     [ long "color"     , help "Highlight matches with color."     ]+  noDefaultElaborations <- switch $ mconcat+    [ long "no-default-elaborations"+    , showDefault+    , help "Don't apply any of the default elaborations to rewrites."+    ]   randomOrder <- switch $ mconcat     [ long "random-order"     , help "Randomize the order of targeted modules."@@ -198,9 +211,29 @@    executionMode <- parseMode   rewrites <- parseRewriteSpecOptions+  elaborations <- parseElaborations   roundtrips <- parseRoundtrips   return Options{ fixityEnv = fixityEnv dOpts, ..} +parseElaborations :: Parser [RewriteSpec]+parseElaborations = concat <$> traverse many+  [ fmap Adhoc $ option str $ mconcat+    [ long "elaborate"+    , metavar "EQUATION"+    , help "Elaborate the left-hand side of rewrites using the given equation."+    ]+  , fmap AdhocType $ option str $ mconcat+    [ long "elaborate-type"+    , metavar "EQUATION"+    , help "Elaborate the left-hand side of rewrites using the given equation."+    ]+  , fmap AdhocPattern $ option str $ mconcat+    [ long "elaborate-pattern"+    , metavar "EQUATION"+    , help "Elaborate the left-hand side of rewrites using the given equation."+    ]+  ]+ parseRewriteSpecOptions :: Parser [RewriteSpec] parseRewriteSpecOptions = concat <$> traverse many   [ fmap Unfold $ option str $ mconcat@@ -328,9 +361,14 @@       anns <- getAnnsT       return $ map (`exactPrint` anns) imps   rrs <- parseRewritesInternal opts rewrites+  es <- parseRewritesInternal opts $+    (if noDefaultElaborations then [] else defaultElaborations) +++    elaborations+  elaborated <- elaborateRewritesInternal fixityEnv es rrs   return Options     { additionalImports = parsedImports-    , rewrites = rrs+    , elaborations = es+    , rewrites = elaborated     , singleThreaded = singleThreaded || verbosity == Loud     , ..     }@@ -373,10 +411,7 @@   let ignore fp = ignorePred fp || extraIgnorePred fp   fpSets <- forM (dedup gtss) $ \ gts -> do     -- See Note [Ground Terms]-    fps <--      case buildGrepChain targetDir gts targetFiles of-        Left fs -> return fs-        Right (stdin, cmd) -> doCmd targetDir verbosity stdin (unwords cmd)+    fps <- runGrepChain targetDir verbosity (buildGrepChain targetDir gts targetFiles)      let       r = filter (not . ignore)@@ -395,19 +430,34 @@         putStrLn "Reading VCS ignore failed! Continuing without ignoring."       return $ const False --- | Either returns an exact list of target paths, or a command for finding--- them.+-- | Return a chain of grep commands to find files with relevant groundTerms+-- If filesGiven is empty, use all *.hs files under targetDir buildGrepChain   :: FilePath   -> HashSet String   -> [FilePath]-  -> Either [FilePath] (String, [String])-buildGrepChain targetDir gts =-  -- Limit the size of the shell command we build by only selecting-  -- up to 10 ground terms. The goal is to filter file list down to-  -- a manageable size. It doesn't have to be exact.-  filterFiles (take 10 $ filter p $ HashSet.toList gts)+  -> GrepCommands+buildGrepChain targetDir gts filesGiven = GrepCommands {initialFileSet=filesGiven, commandChain=commands}   where+    commands = if null filesGiven+               then commandsWithoutFiles+               else commandsWithFiles++    commandsWithFiles = case terms of+        [] -> [] -- no processing+        gs -> map normalGrep gs+    commandsWithoutFiles = case terms of+        [] -> [findCmd] -- all .hs files+        g:gs -> recursiveGrep g : map normalGrep gs -- start with recursive grep++    findCmd = unwords ["find", quotePath (addTrailingPathSeparator targetDir), "-iname", hsExtension]+    recursiveGrep g = unwords ["grep", "-R", "--include=" ++ hsExtension, "-l", esc g, quotePath targetDir]+    normalGrep gt = unwords ["grep", "-l", esc gt]++   -- Limit the number of the shell command we build by only selecting+   -- up to 10 ground terms. The goal is to filter file list down to+   -- a manageable size. It doesn't have to be exact.+    terms = take 10 $ filter p $ HashSet.toList gts     p [] = False     p (c:cs)       | isSpace c = p cs@@ -415,28 +465,35 @@      hsExtension = "\"*.hs\"" -    filterFiles [] [] = Right ("", findCmd) -- all .hs files-    filterFiles [] fs = Left fs -- targetFiles-    -- start with all .hs files and filter-    filterFiles (g:gs) [] =-      Right ("", intercalate ["|"] $ firstCmd g : filterChain gs)-    -- start with targetFiles and filter-    filterFiles gs fs =-      Right (unlines fs, intercalate ["|"] $ filterChain gs)+    esc s = "'" ++ intercalate "[[:space:]]\\+" (words $ escChars s) ++ "'"+    escChars = concatMap escChar+    escChar c+      | c `elem` magicChars = "\\" <> [c]+      | otherwise  = [c]+    magicChars :: [Char]+    magicChars = "*?[#˜=%\\" -    findCmd = ["find", addTrailingPathSeparator targetDir, "-iname", hsExtension] -    firstCmd g =-      ["grep", "-R", "--include=" ++ hsExtension, "-l", esc g, targetDir]+type CommandLine = String+data GrepCommands = GrepCommands { initialFileSet :: [FilePath], commandChain :: [CommandLine] }+  deriving (Eq, Show) -    filterChain gs = [ ["xargs", "grep", "-l", esc gt] | gt <- gs ]+runGrepChain :: FilePath -> Verbosity -> GrepCommands -> IO [FilePath]+runGrepChain targetDir verbosity GrepCommands{..} = foldM (commandStep targetDir verbosity)  initialFileSet commandChain -    esc s = "'" ++ intercalate "[[:space:]]\\+" (words s) ++ "'"+-- | run a command with a list of files as quoted arguments+commandStep :: FilePath -> Verbosity -> [FilePath]-> CommandLine -> IO [FilePath]+commandStep targetDir verbosity files cmd = doCmd targetDir verbosity (cmd <> formatPaths files)+ where+    formatPaths [] = ""+    formatPaths xs = " " <> unwords (map quotePath xs)+quotePath :: FilePath -> FilePath+quotePath x = "'" <> x <> "'" -doCmd :: FilePath -> Verbosity -> String -> String -> IO [FilePath]-doCmd targetDir verbosity inp shellCmd = do-  debugPrint verbosity "stdin:" [inp]++doCmd :: FilePath -> Verbosity -> String -> IO [FilePath]+doCmd targetDir verbosity shellCmd = do   debugPrint verbosity "shellCmd:" [shellCmd]   let cmd = (shell shellCmd) { cwd = Just targetDir }-  (_ec, fps, _) <- readCreateProcessWithExitCode cmd inp+  (_ec, fps, _) <- readCreateProcessWithExitCode cmd ""   return $ lines fps

@@ -265,17 +265,6 @@ -- Statement lists bind to the right, so we need to extend the environment -- as we move down it. Thus we cannot simply store them as ListMap SMap a. --- Note [Dollar Fork]--- When 'f $ x' appears in the pattern, we insert two things in the EMap--- instead of just one:------ * The original infix application of ($).--- * The expression transformed into a normal application with parens around---   the right argument to ($). i.e. f (x)------ This allows us to put ($) in the LHS of rewrites and match both literal ($)--- applications and the parenthesized equivalent.- data EMap a   = EMEmpty   | EM { emHole  :: Map RdrName a -- See Note [Holes]@@ -347,13 +336,6 @@   mAlter env vs e f EMEmpty = mAlter env vs e f emptyEMapWrapper   mAlter env vs e f m@EM{} = go (unLoc e)     where-      -- See Note [Dollar Fork]-      dollarFork v@HsVar{} l r-        | Just (L _ rdr) <- varRdrName v-        , occNameString (occName rdr) == "$" =-          go (HsApp noExtField l (noLoc (HsPar noExtField r)))-      dollarFork _ _ _ = m-       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) }@@ -379,8 +361,8 @@       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 (OpApp _ l o r) =+        m { 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) =

@@ -65,6 +65,11 @@       , any (`elemFVs` fvs) (ctxtBinders c) = NoMatch       | otherwise = match +  -- We want to match through HsPar so we can make a decision+  -- about whether to keep the parens or not based on the+  -- resulting expression, but we need to know the entry location+  -- of the parens, not the inner expression, so we have to+  -- keep both expressions around.   match <- runRewriter f c (ctxtRewriter c) (getUnparened e)    case match of@@ -108,14 +113,6 @@   mappend other        NoChange     = other   mappend (Change rs1 is1) (Change rs2 is2) =     Change (rs1 <> rs2) (is1 <> is2)---- We want to match through HsPar so we can make a decision--- about whether to keep the parens or not based on the--- resulting expression, but we need to know the entry location--- of the parens, not the inner expression, so we have to--- keep both expressions around.-getUnparened :: Data k => k -> k-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

@@ -4,7 +4,7 @@ -- LICENSE file in the root directory of this source tree. -- name: retrie-version: 1.0.0.0+version: 1.1.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@@ -44,6 +44,7 @@     Retrie.CPP,     Retrie.Context,     Retrie.Debug,+    Retrie.Elaborate,     Retrie.ExactPrint,     Retrie.ExactPrint.Annotated,     Retrie.Expr,@@ -84,6 +85,7 @@     filepath >= 1.4.2 && < 1.5,     ghc >= 8.8 && < 9.2,     ghc-exactprint >= 0.6.2 && < 0.7,+    list-t >= 1.0.4 && < 1.1,     mtl >= 2.2.2 && < 2.3,     optparse-applicative >= 0.15.1 && < 0.17,     process >= 1.6.3 && < 1.7,@@ -114,7 +116,7 @@     haskell-src-exts >= 1.23.0 && < 1.24   default-language: Haskell2010 -executable demo+executable demo-retrie   if flag(BuildExecutable)     Buildable: True   else

@@ -28,29 +28,39 @@ groundTermsTest = TestLabel "ground terms" $ TestList   [ gtTest "map"       ""+      []       [Adhoc "forall f g xs. map f (map g xs) = map (f . g) xs"]       [["map"]]-      [("", "grep -R --include=\"*.hs\" -l 'map' ~/si_sigma")]+      [GrepCommands [] ["grep -R --include=\"*.hs\" -l 'map' '~/si_sigma'"]]   , gtTest "isSpace"       ""+      []       [Adhoc "forall xs. or (map isSpace xs) = any isSpace xs"]       [["or", "map isSpace"]]-      [("", "grep -R --include=\"*.hs\" -l 'or' ~/si_sigma | xargs grep -l 'map[[:space:]]\\+isSpace'")]+      [GrepCommands [] ["grep -R --include=\"*.hs\" -l 'or' '~/si_sigma'", "grep -l 'map[[:space:]]\\+isSpace'"]]   , gtTest "MyType"       "type MyType a = MyOtherType a"+      []       [TypeForward "Test.MyType"]       [["MyType"]]-      [("", "grep -R --include=\"*.hs\" -l 'MyType' ~/si_sigma")]+      [GrepCommands [] ["grep -R --include=\"*.hs\" -l 'MyType' '~/si_sigma'"]]+  , gtTest "isSpace with file"+      ""+      ["Test.hs", "Test2.hs"]+      [Adhoc "forall xs. or (map isSpace xs) = any isSpace xs"]+      [["or", "map isSpace"]]+      [GrepCommands ["Test.hs", "Test2.hs"] ["grep -l 'or'", "grep -l 'map[[:space:]]\\+isSpace'"]]   ]  gtTest   :: String   -> Text+  -> [FilePath]   -> [RewriteSpec]   -> [[String]]-  -> [(String, String)]+  -> [GrepCommands]   -> Test-gtTest lbl contents specs expected expectedCmds =+gtTest lbl contents targFiles specs expected expectedCmds =   TestLabel ("groundTerms: " ++ lbl) $ TestCase $ do     -- since we 'zip' below     assertEqual "length of specs and expected ground terms"@@ -72,12 +82,9 @@       (HashSet.fromList gtss) -- compare hashsets to avoid ordering issues      forM_ (zip gtss expectedCmds) $ \(gts, expectedCmd) ->-      case buildGrepChain "~/si_sigma" gts [] of-        Left _ -> assertFailure "gtTest: Left"-        Right (i, c) ->           assertEqual "buildGrepChain did not give expected command"             expectedCmd-            (i, unwords c)+            (buildGrepChain "~/si_sigma" gts targFiles)  getFocusTests :: IO [Test] getFocusTests = do

@@ -28,7 +28,7 @@       gts = [HashSet.fromList ["Groundterm"]]       targetFps = retrieTargetFiles       -- 'withFakeHgRepo' creates every file with its own name as the contents-      expectedFps = ["targeted/Groundterm.hs"]+      expectedFps = ["targeted" </> "Groundterm.hs"]  assertFileListEqual   :: [FilePath]