diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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) diff --git a/Retrie/Elaborate.hs b/Retrie/Elaborate.hs new file mode 100644 --- /dev/null +++ b/Retrie/Elaborate.hs @@ -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 ] + ] diff --git a/Retrie/Expr.hs b/Retrie/Expr.hs --- a/Retrie/Expr.hs +++ b/Retrie/Expr.hs @@ -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 diff --git a/Retrie/Options.hs b/Retrie/Options.hs --- a/Retrie/Options.hs +++ b/Retrie/Options.hs @@ -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 diff --git a/Retrie/PatternMap/Instances.hs b/Retrie/PatternMap/Instances.hs --- a/Retrie/PatternMap/Instances.hs +++ b/Retrie/PatternMap/Instances.hs @@ -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) = diff --git a/Retrie/Replace.hs b/Retrie/Replace.hs --- a/Retrie/Replace.hs +++ b/Retrie/Replace.hs @@ -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 diff --git a/retrie.cabal b/retrie.cabal --- a/retrie.cabal +++ b/retrie.cabal @@ -4,7 +4,7 @@ -- LICENSE file in the root directory of this source tree. -- name: retrie -version: 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 diff --git a/tests/GroundTerms.hs b/tests/GroundTerms.hs --- a/tests/GroundTerms.hs +++ b/tests/GroundTerms.hs @@ -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 diff --git a/tests/Targets.hs b/tests/Targets.hs --- a/tests/Targets.hs +++ b/tests/Targets.hs @@ -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]