diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,3 @@ +1.0.0 (March 16, 2020) + +Initial release diff --git a/CODE_OF_CONDUCT.md b/CODE_OF_CONDUCT.md new file mode 100644 --- /dev/null +++ b/CODE_OF_CONDUCT.md @@ -0,0 +1,76 @@ +# Code of Conduct + +## Our Pledge + +In the interest of fostering an open and welcoming environment, we as +contributors and maintainers pledge to make participation in our project and +our community a harassment-free experience for everyone, regardless of age, body +size, disability, ethnicity, sex characteristics, gender identity and expression, +level of experience, education, socio-economic status, nationality, personal +appearance, race, religion, or sexual identity and orientation. + +## Our Standards + +Examples of behavior that contributes to creating a positive environment +include: + +* Using welcoming and inclusive language +* Being respectful of differing viewpoints and experiences +* Gracefully accepting constructive criticism +* Focusing on what is best for the community +* Showing empathy towards other community members + +Examples of unacceptable behavior by participants include: + +* The use of sexualized language or imagery and unwelcome sexual attention or + advances +* Trolling, insulting/derogatory comments, and personal or political attacks +* Public or private harassment +* Publishing others' private information, such as a physical or electronic + address, without explicit permission +* Other conduct which could reasonably be considered inappropriate in a + professional setting + +## Our Responsibilities + +Project maintainers are responsible for clarifying the standards of acceptable +behavior and are expected to take appropriate and fair corrective action in +response to any instances of unacceptable behavior. + +Project maintainers have the right and responsibility to remove, edit, or +reject comments, commits, code, wiki edits, issues, and other contributions +that are not aligned to this Code of Conduct, or to ban temporarily or +permanently any contributor for other behaviors that they deem inappropriate, +threatening, offensive, or harmful. + +## Scope + +This Code of Conduct applies within all project spaces, and it also applies when +an individual is representing the project or its community in public spaces. +Examples of representing a project or community include using an official +project e-mail address, posting via an official social media account, or acting +as an appointed representative at an online or offline event. Representation of +a project may be further defined and clarified by project maintainers. + +## Enforcement + +Instances of abusive, harassing, or otherwise unacceptable behavior may be +reported by contacting the project team at . All +complaints will be reviewed and investigated and will result in a response that +is deemed necessary and appropriate to the circumstances. The project team is +obligated to maintain confidentiality with regard to the reporter of an incident. +Further details of specific enforcement policies may be posted separately. + +Project maintainers who do not follow or enforce the Code of Conduct in good +faith may face temporary or permanent repercussions as determined by other +members of the project's leadership. + +## Attribution + +This Code of Conduct is adapted from the [Contributor Covenant][homepage], version 1.4, +available at https://www.contributor-covenant.org/version/1/4/code-of-conduct.html + +[homepage]: https://www.contributor-covenant.org + +For answers to common questions about this code of conduct, see +https://www.contributor-covenant.org/faq diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md new file mode 100644 --- /dev/null +++ b/CONTRIBUTING.md @@ -0,0 +1,40 @@ +# Contributing to retrie +We want to make contributing to this project as easy and transparent as +possible. + +## Our Development Process +retrie is developed internally at Facebook and then exported to GitHub by an +automated tool. Pull requests will first be imported to our internal +repository, then synced back to GitHub. + +## Pull Requests +We actively welcome your pull requests. + +1. Fork the repo and create your branch from `master`. +2. If you've added code that should be tested, add tests. +3. If you've changed APIs, update the documentation. +4. Ensure the test suite passes. +5. If you haven't already, complete the Contributor License Agreement ("CLA"). + +## Contributor License Agreement ("CLA") +In order to accept your pull request, we need you to submit a CLA. You only need +to do this once to work on any of Facebook's open source projects. + +Complete your CLA here: + +## Issues +We use GitHub issues to track public bugs. Please ensure your description is +clear and has sufficient instructions to be able to reproduce the issue. + +Facebook has a [bounty program](https://www.facebook.com/whitehat/) for the safe +disclosure of security bugs. In those cases, please go through the process +outlined on that page and do not file a public issue. + +## Coding Style +* 2 spaces for indentation rather than tabs +* 80 character line length +* Avoid using whitespace to vertically align things unnecessarily. + +## License +By contributing to retrie, you agree that your contributions will be licensed +under the LICENSE file in the root directory of this source tree. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) Facebook, Inc. and its affiliates. + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,303 @@ +Retrie is a powerful, easy-to-use codemodding tool for Haskell. + +# Install + +``` +cabal update +cabal install retrie +``` + +# Example + +Assume you have some code, including functions like `foo`: + +```haskell +module MyModule where + +foo :: [Int] -> [Int] +foo ints = map bar (map baz ints) +``` + +Someone points out that traversing the list `ints` twice is slower than doing it once. You could fix the code by hand, or you could rewrite it with retrie: + +```bash +retrie --adhoc "forall f g xs. map f (map g xs) = map (f . g) xs" +``` + +Retrie applies the equation as a rewrite to all the Haskell modules it finds in the current directory: + +```diff + module MyModule where + + foo :: [Int] -> [Int] +-foo ints = map bar (map baz ints) ++foo ints = map (bar . baz) ints +``` + +Of course, now you might find this code more difficult to understand. You also learn that GHC will do this sort of optimization automatically, so you decide to undo your rewrite: + +```bash +retrie --adhoc "forall f g xs. map (f . g) xs = map f (map g xs)" +``` + +Now you have your original code back. + +# Other Sources Of Equations + +* The `--adhoc` flag, above, admits anything you can specify in a `RULES` pragma. +* You can apply actual `RULES` pragmas, in either direction, with `--rule-forward` and `--rule-backward`. +* Since definitions in Haskell are themselves equations, you can unfold (or inline) function definitions with `--unfold`. You can also fold a function definition with `--fold`, replacing an instance of the function's body with a call to that function. +* Type synonyms are also equations. You can apply type synonyms in either direction using `--type-forward` and `--type-backward`. + +To try some examples, put the following into `MyModule2.hs`: + +```haskell +module MyModule2 where + +maybe :: b -> (a -> b) -> Maybe a -> b +maybe d f mb = case mb of + Nothing -> d + Just x -> f x + +type MyMaybe = Maybe Int + +{-# RULES "myRule" forall x. maybe Nothing Just x = x #-} + +foo :: Maybe Int +foo = maybe Nothing Just (Just 5) +``` + +Then try the following rewrites and check the contents of the module after each step: + +```bash +retrie --type-backward MyModule2.MyMaybe +``` + +```diff + module MyModule2 where + + maybe :: b -> (a -> b) -> Maybe a -> b + maybe d f mb = case mb of + Nothing -> d + Just x -> f x + + type MyMaybe = Maybe Int + + {-# RULES "myRule" forall x. maybe Nothing Just x = x #-} + +-foo :: Maybe Int ++foo :: MyMaybe + foo = maybe Nothing Just (Just 5) +``` + +```bash +retrie --unfold MyModule2.maybe +``` + +```diff + module MyModule2 where + + maybe :: b -> (a -> b) -> Maybe a -> b + maybe d f mb = case mb of + Nothing -> d + Just x -> f x + + type MyMaybe = Maybe Int + +-{-# RULES "myRule" forall x. maybe Nothing Just x = x #-} ++{-# RULES "myRule" forall x. case x of ++ Nothing -> Nothing ++ Just x1 -> Just x1 = x #-} + + foo :: MyMaybe +-foo = maybe Nothing Just (Just 5) ++foo = case Just 5 of ++ Nothing -> Nothing ++ Just x -> Just x +``` + +```bash +retrie --fold MyModule2.maybe +``` + +```diff + module MyModule2 where + + maybe :: b -> (a -> b) -> Maybe a -> b + maybe d f mb = case mb of + Nothing -> d + Just x -> f x + + type MyMaybe = Maybe Int + +-{-# RULES "myRule" forall x. case x of +- Nothing -> Nothing +- Just x1 -> Just x1 = x #-} ++{-# RULES "myRule" forall x. maybe Nothing Just x = x #-} + + foo :: MyMaybe +-foo = case Just 5 of +- Nothing -> Nothing +- Just x -> Just x ++foo = maybe Nothing Just (Just 5) +``` + +```bash +retrie --rule-forward MyModule2.myRule +``` + +```diff + module MyModule2 where + + maybe :: b -> (a -> b) -> Maybe a -> b + maybe d f mb = case mb of + Nothing -> d + Just x -> f x + + type MyMaybe = Maybe Int + + {-# RULES "myRule" forall x. maybe Nothing Just x = x #-} + + foo :: MyMaybe +-foo = maybe Nothing Just (Just 5) ++foo = Just 5 +``` + +```bash +retrie --type-forward MyModule2.MyMaybe +``` + +```diff + module MyModule2 where + + maybe :: b -> (a -> b) -> Maybe a -> b + maybe d f mb = case mb of + Nothing -> d + Just x -> f x + + type MyMaybe = Maybe Int + + {-# RULES "myRule" forall x. maybe Nothing Just x = x #-} + +-foo :: MyMaybe ++foo :: Maybe Int + foo = Just 5 +``` + +# Motivation + +Refactoring tools fall on a spectrum. At one end is simple string replacement (`grep` and `sed`). At the other is parsing an abstract-syntax tree (AST) and directly manipulating it. Broadly, the tradeoffs are: + +* String manipulation + * Hard to write: Essentially need to hand-roll a parser using a regular expression. + * Limited power: Find and replace. + * Fast. + +* AST manipulation + * Hard to write: Requires extensive domain knowledge about language/parser. + * Very powerful. + * Slow: Parsing and traversing large codebases is expensive. + +Retrie finds a middle ground: + +* Easy to write: Equations are defined using syntax of target language. +* Powerful: + * Equations are more powerful than regular expressions. + * Rewrites can be scripted and enforce side-conditions (see below). +* Fast: Search space is narrowed using `grep` before parsing. Time is (morally) proportional to the number of matches, not the number of target files. + +# Features + +* Power + * Can rewrite expressions, types, and patterns. + * Matching is up to alpha-equivalence. + * Rewrites are equational: a quantifier that appears twice in the left-hand side must match the same expression (up to alpha-equivalence). + * Inserts imports. (As specified by the user, and automatically in some cases.) + * Rewrites can be scripted and have side conditions. + * Uses GHC's parser, so supports all of the *de facto* Haskell language. +* Correctness + * Local scoping is respected. (Will not introduce shadowing/capture bugs.) + * Impossible to match/rewrite an incomplete expression fragment. + * Parentheses are automatically removed/inserted as needed. +* Whitespace + * Whitespace is ignored when matching. No fiddling with `\s`. + * Whitespace is preserved in resulting expression. +* Will not rewrite in comments. Existing comments are preserved. +* Respects git/hg ignore files. + +See `retrie --help` for a complete list of options. + +# Scripting and Side Conditions + +Retrie can be used as a library to tackle more complex rewrites. + +Consider the task of changing the argument type of a function from `String` to an enumeration: + +```haskell +fooOld :: String -> IO () + +data FooArg = Foo | Bar + +fooNew :: FooArg -> IO () +``` + +Retrie provides a small monadic DSL for scripting the application of rewrites. It also allows you to intercept and manipulate the result of matching the left-hand side of an equation. Putting those two together, you could implement the following refactoring: + +```haskell +{-# LANGUAGE OverloadedStrings #-} +module Main where + +import Retrie + +main :: IO () +main = runScript $ \opts -> + [rewrite] <- parseRewrites opts [Adhoc "forall arg. fooOld arg = fooNew arg"] + return $ apply [setRewriteTransformer stringToFooArg rewrite] + +argMapping :: [(FastString, String)] +argMapping = [("foo", "Foo"), ("bar", "Bar")] + +stringToFooArg :: MatchResultTransformer +stringToFooArg _ctxt match + | MatchResult substitution template <- match + , Just (HoleExpr expr) <- lookupSubst "arg" substitution + , L _ (HsLit _ (HsString _ str)) <- astA expr = do + newExpr <- case lookup str argMapping of + Nothing -> + parseExpr $ "error \"invalid argument: " ++ unpackFS str ++ "\"" + Just constructor -> parseExpr constructor + return $ + MatchResult (extendSubst substitution "arg" (HoleExpr newExpr)) template + | otherwise = return NoMatch +``` + +Running this program would create the following diff: + +```diff + module MyModule3 where + + baz, bar, quux :: IO () +-baz = fooOld "foo" ++baz = fooNew Foo + +-bar = fooOld "bar" ++bar = fooNew Bar + +-quux = fooOld "quux" ++quux = fooNew (error "invalid argument: quux") +``` + +Defining the `stringToFooArg` function requires knowledge of both the Retrie library and GHC's internal AST types. You'll find haddock/hoogle invaluable for both. + +# Reporting Bugs/Submitting Patches + +To report a bug in the result of a rewrite, please create a test case ([example](tests/inputs/Adhoc.test)) and submit it as an issue or merge request. + +To report other bugs, please create a GitHub issue. + +[![Build Status](https://travis-ci.org/facebookincubator/retrie.svg?branch=master)](https://travis-ci.org/facebookincubator/retrie) + +# License + +Retrie is MIT licensed, as found in the [LICENSE](LICENSE) file. + diff --git a/Retrie.hs b/Retrie.hs new file mode 100644 --- /dev/null +++ b/Retrie.hs @@ -0,0 +1,162 @@ +-- 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. +-- + +-- | This module provides the external interface for using Retrie as a library. +-- All other modules should be considered internal, with APIs that are subject +-- to change without notice. +{-# LANGUAGE RecordWildCards #-} +module Retrie + ( -- * Scripting + runScript + , runScriptWithModifiedOptions + -- ** Parsing Rewrites + -- *** Imports + , parseImports + -- *** Queries + , parseQueries + , QuerySpec(..) + -- *** Rewrites + , parseRewrites + , RewriteSpec(..) + , QualifiedName + -- ** Retrie Computations + , Retrie + + -- *** Applying Rewrites + , apply + , applyWithStrategy + , applyWithUpdate + , applyWithUpdateAndStrategy + , addImports + -- *** Control Flow + , ifChanged + , iterateR + -- *** Focusing + , focus + -- *** Querying the AST + , query + , queryWithUpdate + -- *** Traversal Strategies + , bottomUp + , topDown + , topDownPrune + -- * Advanced Scripting + -- $advanced + -- ** Side Conditions + , MatchResultTransformer + , defaultTransformer + , MatchResult(..) + -- * Annotated ASTs + , Annotated + , astA + -- ** Type Synonyms + , AnnotatedHsDecl + , AnnotatedHsExpr + , AnnotatedHsType + , AnnotatedImports + , AnnotatedModule + , AnnotatedPat + , AnnotatedStmt + -- ** Parsing + -- | Note: These parsers do not re-associate infix operators. + -- To do so, use 'Retrie.ExactPrint.fix'. For example: + -- + -- > do + -- > expr <- parseExpr "f <$> x <*> y" + -- > e <- transformA expr (fix (fixityEnv opts)) + -- + , parseDecl + , parseExpr + , parsePattern + , parseStmt + , parseType + -- ** Operations + , transformA + , graftA + , pruneA + , trimA + , printA + -- ** Util + -- | Collection of miscellaneous helpers for manipulating the GHC AST. + , module Retrie.Expr + -- * Types + -- ** Context + , Context(..) + , ContextUpdater + , updateContext + -- ** Options + , Options + , Options_(..) + , Verbosity(..) + -- ** Quantifiers + , module Retrie.Quantifiers + -- ** Queries + , Query(..) + -- ** Rewrites + , Rewrite + , Template(..) + , mkRewrite + , ppRewrite + , addRewriteImports + , setRewriteTransformer + -- ** Substitution + , subst + -- | See "Retrie.Substitution" for the 'Substitution' type. + , module Retrie.Substitution + -- ** Universe + , Universe + , Matchable(..) + , toURewrite + , fromURewrite + -- * GHC API + -- | "Retrie.GHC" re-exports the GHC API, with some helpers for consistency + -- across versions. + , module Retrie.GHC + ) where + +import Retrie.Context +import Retrie.ExactPrint.Annotated hiding (unsafeMkA) +import Retrie.ExactPrint +import Retrie.Expr +import Retrie.Fixity +import Retrie.GHC +import Retrie.Monad +import Retrie.Options +import Retrie.Quantifiers +import Retrie.Query + ( QuerySpec(..) + , parseQuerySpecs + ) +import Retrie.Rewrites +import Retrie.Run +import Retrie.Subst +import Retrie.Substitution +import Retrie.SYB +import Retrie.Types +import Retrie.Universe +import Retrie.Util + +-- | Create 'Rewrite's from string specifications of rewrites. +parseRewrites :: Options -> [RewriteSpec] -> IO [Rewrite Universe] +parseRewrites = parseRewritesInternal + +-- | Create 'Query's from string specifications of expressions/types/statements. +parseQueries + :: Options -> [(Quantifiers, QuerySpec, v)] -> IO [Query Universe v] +parseQueries Options{..} = parseQuerySpecs fixityEnv + +-- $advanced +-- For advanced rewriting, Retrie provides the notion of a +-- 'MatchResultTransformer'. This is a callback function that is provided the +-- result of matching the left-hand side of an equation. Whatever the callback +-- returns is used to perform the actual rewrite. +-- +-- The callback has access to the 'Context' of the match, the generated +-- 'Substitution', and 'IO'. Helper libraries such as 'Annotated' and 'subst' +-- make it possible to define complex transformers without too much tedium. +-- +-- Transformers can check side conditions by examining the 'MatchResult' and +-- returning 'NoMatch' when conditions do not hold. diff --git a/Retrie/AlphaEnv.hs b/Retrie/AlphaEnv.hs new file mode 100644 --- /dev/null +++ b/Retrie/AlphaEnv.hs @@ -0,0 +1,75 @@ +-- 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. +-- +module Retrie.AlphaEnv + ( AlphaEnv + , alphaEnvOffset + , emptyAlphaEnv + , extendAlphaEnv + , lookupAlphaEnv + , pruneAlphaEnv + -- ** For Internal Use Only + , extendAlphaEnvInternal + ) where + +import Retrie.GHC + +-- | Environment used to implement alpha-equivalence checking. As we pass a +-- binder we map it to a de-bruijn index. When we later encounter a variable +-- occurrence, we look it up in the map, and if present, use the index for +-- matching, rather than the name. +data AlphaEnv = AE + { _aeNext :: !Int -- ^ Name supply for de-bruijn indices + , aeEnv :: OccEnv Int -- ^ Map from OccName of binder to de-bruijn index + , aeOffset :: !Int -- ^ Initial index offset, see Note [AlphaEnv Offset] + } + +-- Note [AlphaEnv Offset] +-- The offset is used to prevent matching under a local binding. This is best +-- explained by example. Consider this code: +-- +-- let map f xs = xs +-- in map (g . h) xs +-- +-- If we were to apply the map fusion rule [map (f . g) xs = map f (map g xs)] +-- to this module, we would not want to match in the body of the 'let', because +-- 'map' no longer means what it meant where the rewrite was specified. +-- +-- Without the offset, de-bruijn indexing would start at the redex that matches +-- the rewrite [map (g . h) xs] and would be blind to the fact that 'map' was +-- locally redefined. +-- +-- To solve this, we carry an AlphaEnv in the Context from the very top of the +-- traversal, and bump this offset each time we extend the environment. Then, +-- during matching, when we encounter 'map', it will have an index (a negative +-- one, see 'lookupAlphaEnv'), so we know it has been locally redefined and the +-- negative index will prevent it from matching any other index (because all +-- indices in the constructed PatternMap are positive). + +alphaEnvOffset :: AlphaEnv -> Int +alphaEnvOffset = aeOffset + +emptyAlphaEnv :: AlphaEnv +emptyAlphaEnv = AE 0 emptyOccEnv 0 + +-- | For internal use of PatternMap methods. +extendAlphaEnvInternal :: RdrName -> AlphaEnv -> AlphaEnv +extendAlphaEnvInternal nm (AE i env off) = + AE (i+1) (extendOccEnv env (occName nm) i) off + +-- | For external use to build an initial AlphaEnv for mMatch. +-- We add local bindings to the AlphaEnv and track an offset which +-- we subtract in lookupAlphaEnv. This prevents locally-bound variable +-- occurrences from unifying with free variables in the pattern. +extendAlphaEnv :: RdrName -> AlphaEnv -> AlphaEnv +extendAlphaEnv nm e = e' { aeOffset = aeOffset e' + 1 } + where e' = extendAlphaEnvInternal nm e + +pruneAlphaEnv :: Int -> AlphaEnv -> AlphaEnv +pruneAlphaEnv i ae = ae { aeEnv = filterOccEnv (>= i) (aeEnv ae) } + +lookupAlphaEnv :: RdrName -> AlphaEnv -> Maybe Int +lookupAlphaEnv nm (AE _ env off) = + (-) <$> lookupOccEnv env (occName nm) <*> pure off diff --git a/Retrie/CPP.hs b/Retrie/CPP.hs new file mode 100644 --- /dev/null +++ b/Retrie/CPP.hs @@ -0,0 +1,348 @@ +-- 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 OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +module Retrie.CPP + ( CPP(..) + , addImportsCPP + , parseCPPFile + , parseCPP + , printCPP + -- ** Internal interface exported for tests + , cppFork + ) where + +import Data.Char (isSpace) +import Data.Function (on) +import Data.Functor.Identity +import Data.List (nubBy, sortOn) +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.IO as Text +import Debug.Trace +import Retrie.ExactPrint +import Retrie.GHC +import Retrie.Replace + +-- Note [CPP] +-- We can't just run the pre-processor on files and then rewrite them, because +-- the rewrites will apply to a module that never exists as code! Exactprint +-- has no support for roundtripping CPP, because the GHC parser doesn't +-- actually parse it (it looks for the pragma and then delegates to the +-- pre-processor). +-- +-- To solve this, we instead generate all possible versions of the module +-- (exponential in the number of #if directives :-P). We then apply rewrites +-- to all versions, and collect all the 'Replacement's that they generate. +-- We can then use these to splice results back into the original file. +-- +-- Suprisingly, this works. It depends on a few observations: +-- +-- * We don't need to actually evaluate any CPP directives. This is because +-- we want all versions of the file. +-- +-- * Since we don't need to evaluate, we can simply replace all CPP directives +-- with blank lines and the locations of all AST elements in each version of +-- the module will be exactly the same as in the original module. This is the +-- key to splicing properly. +-- +-- * Replacements can be spliced in directly with no smarts about binders, etc, +-- because retrie did the instantiation during matching. +-- + +-- The CPP Type ---------------------------------------------------------------- + +data CPP a + = NoCPP a + | CPP Text [AnnotatedImports] [a] + +instance Functor CPP where + fmap f (NoCPP x) = NoCPP (f x) + fmap f (CPP orig is xs) = CPP orig is (map f xs) + +instance Foldable CPP where + foldMap f (NoCPP x) = f x + foldMap f (CPP _ _ xs) = foldMap f xs + +instance Traversable CPP where + traverse f (NoCPP x) = NoCPP <$> f x + traverse f (CPP orig is xs) = CPP orig is <$> traverse f xs + +addImportsCPP + :: [AnnotatedImports] + -> CPP AnnotatedModule + -> CPP AnnotatedModule +addImportsCPP is (NoCPP m) = + NoCPP $ runIdentity $ transformA m $ insertImports is +addImportsCPP is (CPP orig is' ms) = CPP orig (is++is') ms + +-- Parsing a CPP Module -------------------------------------------------------- + +parseCPPFile + :: (FilePath -> String -> IO AnnotatedModule) + -> FilePath + -> IO (CPP AnnotatedModule) +parseCPPFile p fp = + -- read file strictly + Text.readFile fp >>= parseCPP (p fp) + +parseCPP + :: Monad m + => (String -> m AnnotatedModule) + -> Text -> m (CPP AnnotatedModule) +parseCPP p orig + | any isCPP (Text.lines orig) = + CPP orig [] <$> mapM (p . Text.unpack) (cppFork orig) + | otherwise = NoCPP <$> p (Text.unpack orig) + +-- Printing a CPP Module ------------------------------------------------------- + +printCPP :: [Replacement] -> CPP AnnotatedModule -> String +printCPP _ (NoCPP m) = printA m +printCPP repls (CPP orig is ms) = Text.unpack $ Text.unlines $ + case is of + [] -> splice "" 1 1 sorted origLines + _ -> + splice + (Text.unlines newHeader) + (length revHeader + 1) + 1 + sorted + (reverse revDecls) + where + sorted = sortOn fst + [ (r, replReplacement) + | Replacement{..} <- repls + , RealSrcSpan r <- [replLocation] + ] + + origLines = Text.lines orig + mbName = unLoc <$> hsmodName (unLoc $ astA $ head ms) + importLines = runIdentity $ fmap astA $ transformA (filterAndFlatten mbName is) $ + mapM $ fmap (Text.pack . dropWhile isSpace . printA) . pruneA + + p t = isImport t || isModule t || isPragma t + (revDecls, revHeader) = break p (reverse origLines) + newHeader = reverse revHeader ++ importLines + +splice :: Text -> Int -> Int -> [(RealSrcSpan, String)] -> [Text] -> [Text] +splice _ _ _ _ [] = [] +splice prefix _ _ [] (t:ts) = prefix <> t : ts +splice prefix l c rs@((r, repl):rs') ts@(t:ts') + | srcSpanStartLine r > l = + -- Next rewrite is not on this line. Output line. + prefix <> t : splice "" (l+1) 1 rs ts' + | srcSpanStartLine r < l || srcSpanStartCol r < c = + -- Next rewrite starts before current position. This happens when + -- the same rewrite is made in multiple versions of the CPP'd module. + -- Drop the duplicate rewrite and keep going. + splice prefix l c rs' ts + | (old, ln:lns) <- splitAt (srcSpanEndLine r - l) ts = + -- The next rewrite starts on this line. + let + start = srcSpanStartCol r + end = srcSpanEndCol r + + prefix' = prefix <> Text.take (start - c) t <> Text.pack repl + ln' = Text.drop (end - c) ln + + -- For an example of how this can happen, see the CPPConflict test. + errMsg = unlines + [ "Refusing to rewrite across CPP directives." + , "" + , "Location: " ++ locStr + , "" + , "Original:" + , "" + , Text.unpack orig + , "" + , "Replacement:" + , "" + , repl + ] + orig = + Text.unlines $ (prefix <> t : drop 1 old) ++ [Text.take (end - c) ln] + locStr = unpackFS (srcSpanFile r) ++ ":" ++ show l ++ ":" ++ show start + in + if any isCPP old + then trace errMsg $ splice prefix l c rs' ts + else splice prefix' (srcSpanEndLine r) end rs' (ln':lns) + | otherwise = error "printCPP: impossible replacement past end of file" + +-- Forking the module ---------------------------------------------------------- + +cppFork :: Text -> [Text] +cppFork = cppTreeToList . mkCPPTree + +-- | Tree representing the module. Each #endif becomes a Node. +data CPPTree + = Node [Text] CPPTree CPPTree + | Leaf [Text] + +-- | Stack type used to keep track of how many #ifs we are nested into. +-- Controls whether we emit lines into each version of the module. +data CPPBranch + = CPPTrue -- print until an 'else' + | CPPFalse -- print blanks until an 'else' or 'endif' + | CPPOmit -- print blanks until an 'endif' + +-- | Build CPPTree from lines of the module. +mkCPPTree :: Text -> CPPTree +mkCPPTree = go False [] [] . reverse . Text.lines + -- We reverse the lines once up front, then process the module from bottom + -- to top, branching at #endifs. If we were to process from top to bottom, + -- we'd have to reverse each version later, rather than reversing the original + -- once. This also makes it easy to spot import statements and stop branching + -- since we don't care about differences in imports. + where + go :: Bool -> [CPPBranch] -> [Text] -> [Text] -> CPPTree + go _ _ suffix [] = Leaf suffix + go True [] suffix ls = + Leaf (blankifyAndReverse suffix ls) -- See Note [Imports] + go seenImport st suffix (l:ls) = + case extractCPPCond l of + Just If -> -- pops from stack + case st of + (_:st') -> emptyLine st' + [] -> error "mkCPPTree: if with empty stack" + Just ElIf -> -- stack same size + case st of + (CPPOmit:_) -> emptyLine st + (CPPFalse:st') -> emptyLine (CPPOmit:st') + (CPPTrue:st') -> -- See Note [ElIf] + let + omittedSuffix = replicate (length suffix) "" + in + Node + [] + (emptyLine (CPPOmit:st')) + (go seenImport (CPPTrue:st') ("":omittedSuffix) ls) + [] -> error "mkCPPTree: else with empty stack" + Just Else -> -- stack same size + case st of + (CPPOmit:_) -> emptyLine st + (CPPTrue:st') -> emptyLine (CPPFalse:st') + (CPPFalse:st') -> emptyLine (CPPTrue:st') + [] -> error "mkCPPTree: else with empty stack" + Just EndIf -> -- push to stack + case st of + (CPPOmit:_) -> emptyLine (CPPOmit:st) + (CPPFalse:_) -> emptyLine (CPPOmit:st) + _ -> + Node + suffix + (go seenImport (CPPTrue:st) [""] ls) + (go seenImport (CPPFalse:st) [""] ls) + Nothing -> -- stack same size + case st of + (CPPOmit:_) -> go seenImport' st ("":suffix) ls + (CPPFalse:_) -> go seenImport' st ("":suffix) ls + _ -> go seenImport' st (blankCPP l:suffix) ls + where + emptyLine st' = go seenImport st' ("":suffix) ls + seenImport' = seenImport || isImport l + + blankifyAndReverse :: [Text] -> [Text] -> [Text] + blankifyAndReverse suffix [] = suffix + blankifyAndReverse suffix (l:ls) = blankifyAndReverse (blankCPP l:suffix) ls + +-- Note [Imports] +-- If we have seen an import statement, and have an empty stack, that means all +-- conditionals above this point only control imports/exports, etc. Retrie +-- doesn't match in those places anyway, and the imports don't matter because +-- we only parse, no renaming. As a micro-optimization, we can stop branching. +-- This saves forking the module in the common case that CPP is used to choose +-- imports. We have to wait for stack to be empty because we might have seen an +-- import in one branch, but there is a decl in the other branch. + +-- Note [ElIf] +-- The way we handle #elif is pretty subtle. Some observations: +-- If we're on the CPPOmit branch, keep omitting up to the next #if, like usual. +-- If we're on the CPPFalse branch, we didn't show the #elif, but either we +-- showed the #else, or this whole #if might not output anything. So either way, +-- we need to omit up to the next #if. +-- If we're on the CPPTrue branch, we definitely showed the #elif, so we need to +-- fork with a Node. One side of the branch omits up to the next #if. The other +-- side is as if we have omitted everything from the last #endif, and we +-- continue showing up from here. This will show whatever is above the #elif. +-- It is crucial we do this branching on the CPPTrue branch, so any #elif +-- above this point is also handled correctly. + +-- | Expand CPPTree into 2^h-1 versions of the module. +cppTreeToList :: CPPTree -> [Text] +cppTreeToList t = go [] t [] + where + go rest (Leaf suffix) = (Text.unlines (suffix ++ rest) :) + go rest (Node suffix l r) = + let rest' = suffix ++ rest -- right-nested + in go rest' l . go rest' r + +-- Spotting CPP directives ----------------------------------------------------- + +data CPPCond = If | ElIf | Else | EndIf + +extractCPPCond :: Text -> Maybe CPPCond +extractCPPCond t + | Just ('#',t') <- Text.uncons t = + case Text.words t' of + ("if":_) -> Just If + ("else":_) -> Just Else + ("elif":_) -> Just ElIf + ("endif":_) -> Just EndIf + _ -> Nothing + | otherwise = Nothing + +blankCPP :: Text -> Text +blankCPP t + | isCPP t = "" + | otherwise = t + +isCPP :: Text -> Bool +isCPP = Text.isPrefixOf "#" + +isImport :: Text -> Bool +isImport = Text.isPrefixOf "import" + +isModule :: Text -> Bool +isModule = Text.isPrefixOf "module" + +isPragma :: Text -> Bool +isPragma = Text.isPrefixOf "{-#" + +------------------------------------------------------------------------------- +-- This would make more sense in Retrie.Expr, but that creates an import cycle. +-- Ironic, I know. + +insertImports + :: Monad m + => [AnnotatedImports] -- ^ imports and their annotations + -> Located (HsModule GhcPs) -- ^ target module + -> TransformT m (Located (HsModule GhcPs)) +insertImports is (L l m) = do + imps <- graftA $ filterAndFlatten (unLoc <$> hsmodName m) is + let + deduped = nubBy (eqImportDecl `on` unLoc) $ hsmodImports m ++ imps + return $ L l m { hsmodImports = deduped } + +filterAndFlatten :: Maybe ModuleName -> [AnnotatedImports] -> AnnotatedImports +filterAndFlatten mbName is = + runIdentity $ transformA (mconcat is) $ return . externalImps mbName + where + externalImps :: Maybe ModuleName -> [LImportDecl GhcPs] -> [LImportDecl GhcPs] + externalImps (Just mn) = filter ((/= mn) . unLoc . ideclName . unLoc) + externalImps _ = id + +eqImportDecl :: ImportDecl GhcPs -> ImportDecl GhcPs -> Bool +eqImportDecl x y = + ((==) `on` unLoc . ideclName) x y + && ((==) `on` ideclQualified) x y + && ((==) `on` ideclAs) x y + && ((==) `on` ideclHiding) x y + && ((==) `on` ideclPkgQual) x y + && ((==) `on` ideclSource) x y + && ((==) `on` ideclSafe) x y + -- intentionally leave out ideclImplicit and ideclSourceSrc + -- former doesn't matter for this check, latter is prone to whitespace issues diff --git a/Retrie/Context.hs b/Retrie/Context.hs new file mode 100644 --- /dev/null +++ b/Retrie/Context.hs @@ -0,0 +1,258 @@ +-- 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 RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Retrie.Context + ( ContextUpdater + , updateContext + , emptyContext + ) where + +import Control.Monad.IO.Class +import Data.Char (isDigit) +import Data.Either (partitionEithers) +import Data.Generics hiding (Fixity) +import Data.List +import Data.Maybe + +import Retrie.AlphaEnv +import Retrie.ExactPrint +import Retrie.Fixity +import Retrie.FreeVars +import Retrie.GHC +import Retrie.Substitution +import Retrie.SYB +import Retrie.Types +import Retrie.Universe + +------------------------------------------------------------------------------- + +-- | Type of context update functions for 'apply'. +-- When defining your own 'ContextUpdater', you probably want to extend +-- 'updateContext' using SYB combinators such as 'mkQ' and 'extQ'. +type ContextUpdater = forall m. MonadIO m => GenericCU (TransformT m) Context + +-- | Default context update function. +updateContext :: forall m. MonadIO m => GenericCU (TransformT m) Context +updateContext c i = + 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` updStmtList + `extQ` (return . updHsBind) + `extQ` (return . updTyClDecl) + where + neverParen = c { ctxtParentPrec = NeverParen } + + updExp :: HsExpr GhcPs -> Context + updExp HsApp{} = + c { ctxtParentPrec = HasPrec $ Fixity (SourceText "HsApp") (10 + i - firstChild) InfixL } + -- 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 + + 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 + updGRHS XGRHS{} = neverParen + updGRHS (GRHS _ gs _) +#endif + -- binders are in scope over the body (right child) only + | i > firstChild = addInScope neverParen bs + | otherwise = fst $ updateSubstitution neverParen bs + where + bs = collectLStmtsBinders gs + + updStmt :: Stmt GhcPs (LHsExpr GhcPs) -> Context +#if __GLASGOW_HASKELL__ < 806 + updStmt (BindStmt p _body _ _ _) +#else + updStmt (BindStmt _ p _body _ _) +#endif + -- i > firstChild == 'for the body' + | i > firstChild = addBinders neverParen (collectPatBinders p) + updStmt _ = neverParen + + updStmtList :: [LStmt GhcPs (LHsExpr GhcPs)] -> TransformT m Context + updStmtList [] = return neverParen + updStmtList (ls:_) + -- 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 + bs = collectLStmtBinders ls + + updHsBind :: HsBind GhcPs -> Context + updHsBind FunBind{..} = + let rdr = unLoc fun_id + in addBinders (addInScope neverParen [rdr]) [rdr] + updHsBind _ = neverParen + + updTyClDecl :: TyClDecl GhcPs -> Context + updTyClDecl SynDecl{..} = addInScope neverParen [unLoc tcdLName] + updTyClDecl DataDecl{..} = addInScope neverParen [unLoc tcdLName] + updTyClDecl ClassDecl{..} = addInScope neverParen [unLoc tcdLName] + updTyClDecl _ = neverParen + +-- | Create an empty 'Context' with given 'FixityEnv', rewriter, and dependent +-- rewrite generator. +emptyContext :: FixityEnv -> Rewriter -> Rewriter -> Context +emptyContext ctxtFixityEnv ctxtRewriter ctxtDependents = Context{..} + where + ctxtBinders = [] + ctxtInScope = emptyAlphaEnv + ctxtParentPrec = NeverParen + ctxtSubst = Nothing + +-- 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 + :: (Matchable k, MonadIO m) => Context -> [RdrName] -> k -> TransformT m Context +insertDependentRewrites c bs x = do + r <- runRewriter id c (ctxtDependents c) x + let + c' = addInScope c bs + case r of + NoMatch -> return c' + MatchResult _ Template{..} -> do + let + rrs = fromMaybe [] tDependents + ds = rewritesWithDependents rrs + f = foldMap (mkLocalRewriter $ ctxtInScope c') + return c' + { ctxtRewriter = f rrs <> ctxtRewriter c' + , ctxtDependents = f ds <> ctxtDependents c' + } + +-- | Add set of binders to 'ctxtInScope'. +addInScope :: Context -> [RdrName] -> Context +addInScope c bs = + c' { ctxtInScope = foldr extendAlphaEnv (ctxtInScope c') bs' } + where + (c', bs') = updateSubstitution c bs + +-- | Add set of binders to 'ctxtBinders'. +addBinders :: Context -> [RdrName] -> Context +addBinders c bs = c { ctxtBinders = bs ++ ctxtBinders c } + +-- Capture-avoiding substitution +-------------------------------------------------------------------------------- + +-- | Update the Context's substitution appropriately for a set of binders. +-- Returns a new Context and a potentially alpha-renamed set of binders. +updateSubstitution :: Context -> [RdrName] -> (Context, [RdrName]) +updateSubstitution c rdrs = + case ctxtSubst c of + Nothing -> (c, rdrs) + Just sub -> + let + -- This prevents substituting for 'x' under a binding for 'x'. + sub' = deleteSubst sub $ map rdrFS rdrs + -- Compute free vars of substitution that could possibly be captured. + fvs = substFVs sub' + -- Partition binders into noncapturing and capturing. + (noncapturing, capturing) = + partitionEithers $ map (updateBinder fvs) rdrs + -- Extend substitution with alpha-renamings. + alphaSub = foldl' (uncurry . extendSubst) sub' + [ (rdrFS rdr, HoleRdr rdr') | (rdr, rdr') <- capturing ] + -- There are no telescopes in source Haskell, so order doesn't matter. + -- Capturing should be rare, so put it first to avoid quadratic append. + rdrs' = map snd capturing ++ noncapturing + in (c { ctxtSubst = Just alphaSub }, rdrs') + +-- | Check if RdrName is in FreeVars. +-- +-- If so, return a pair of it and its new name (Right). +-- If not, return it unchanged (Left). +updateBinder :: FreeVars -> RdrName -> Either RdrName (RdrName, RdrName) +updateBinder fvs rdr + | elemFVs rdr fvs = Right (rdr, renameBinder rdr fvs) + | otherwise = Left rdr + +-- | Given a RdrName, rename it to something not in given FreeVars. +-- +-- x => x1 +-- x1 => x2 +-- x9 => x10 +-- +-- etc. +-- +-- Only works on unqualified RdrNames. This is fine, as we only use this to +-- rename local binders. +renameBinder :: RdrName -> FreeVars -> RdrName +renameBinder rdr fvs = head + [ rdr' + | i <- [n..] + , let rdr' = mkVarUnqual $ mkFastString $ baseName ++ show i + , not $ rdr' `elemFVs` fvs + ] + where + (ds, rest) = span isDigit $ reverse $ occNameString $ occName rdr + + baseName = reverse rest + + n :: Int + n | null ds = 1 + | otherwise = read (reverse ds) + 1 diff --git a/Retrie/Debug.hs b/Retrie/Debug.hs new file mode 100644 --- /dev/null +++ b/Retrie/Debug.hs @@ -0,0 +1,39 @@ +-- 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 ApplicativeDo #-} +module Retrie.Debug + ( RoundTrip(..) + , parseRoundtrips + , doRoundtrips + ) where + +import Options.Applicative +import System.FilePath + +import Retrie.CPP +import Retrie.ExactPrint +import Retrie.Fixity + +data RoundTrip = RoundTrip Bool FilePath {- True = with fixities -} + +parseRoundtrips :: Parser [RoundTrip] +parseRoundtrips = concat <$> traverse many + [ RoundTrip True <$> option str + ( long "roundtrip" <> metavar "PATH" + <> help "Roundtrip file through ghc-exactprint and fixity adjustment.") + , RoundTrip False <$> option str + ( long "roundtrip-no-fixity" <> metavar "PATH" + <> help "Roundtrip file through ghc-exactprint only.") + ] + +doRoundtrips :: FixityEnv -> FilePath -> [RoundTrip] -> IO () +doRoundtrips fixities targetDir = mapM_ $ \ (RoundTrip doFix fp) -> do + let path = targetDir fp + cpp <- + if doFix + then parseCPPFile (parseContent fixities) path + else parseCPPFile parseContentNoFixity path + writeFile path $ printCPP [] cpp diff --git a/Retrie/ExactPrint.hs b/Retrie/ExactPrint.hs new file mode 100644 --- /dev/null +++ b/Retrie/ExactPrint.hs @@ -0,0 +1,410 @@ +-- 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 PatternSynonyms #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} +-- | Provides consistent interface with ghc-exactprint. +module Retrie.ExactPrint + ( -- * Fixity re-association + fix + -- * Parsers + , parseContent + , parseContentNoFixity + , parseDecl + , parseExpr + , parseImports + , parsePattern + , parseStmt + , parseType + -- * Primitive Transformations + , addAllAnnsT + , cloneT + , setEntryDPT + , swapEntryDPT + , transferAnnsT + , transferEntryAnnsT + , transferEntryDPT + -- * Utils + , debugDump + , debugParse + , hasComments + , isComma + -- * Annotated AST + , module Retrie.ExactPrint.Annotated + -- * ghc-exactprint re-exports + , module Language.Haskell.GHC.ExactPrint + , module Language.Haskell.GHC.ExactPrint.Annotate + , module Language.Haskell.GHC.ExactPrint.Types + , module Language.Haskell.GHC.ExactPrint.Utils + ) where + +import Control.Exception +import Control.Monad.State.Lazy hiding (fix) +import Data.Default as D +import Data.Function (on) +import Data.List (transpose) +import Data.Maybe +import qualified Data.Map as M +import Text.Printf + +import Language.Haskell.GHC.ExactPrint hiding + ( cloneT + , setEntryDP + , setEntryDPT + , transferEntryDPT + , transferEntryDP + ) +import Language.Haskell.GHC.ExactPrint.Annotate (Annotate) +import qualified Language.Haskell.GHC.ExactPrint.Parsers as Parsers +import Language.Haskell.GHC.ExactPrint.Types + ( AnnConName(..) + , DeltaPos(..) + , KeywordId(..) + , annGetConstr + , annNone + , emptyAnns + , mkAnnKey + ) +import Language.Haskell.GHC.ExactPrint.Utils (annLeadingCommentEntryDelta, showGhc) + +import Retrie.ExactPrint.Annotated +import Retrie.Fixity +import Retrie.GHC +import Retrie.SYB + +-- Fixity traversal ----------------------------------------------------------- + +-- | Re-associate AST using given 'FixityEnv'. (The GHC parser has no knowledge +-- of operator fixity, because that requires running the renamer, so it parses +-- all operators as left-associated.) +fix :: (Data ast, Monad m) => FixityEnv -> ast -> TransformT m ast +fix env = fixAssociativity >=> fixEntryDP + where + fixAssociativity = everywhereM (mkM (fixOneExpr env) `extM` fixOnePat env) + fixEntryDP = everywhereM (mkM fixOneEntryExpr `extM` fixOneEntryPat) + +-- Should (x op1 y) op2 z be reassociated as x op1 (y op2 z)? +associatesRight :: Fixity -> Fixity -> Bool +associatesRight (Fixity _ p1 a1) (Fixity _ p2 _a2) = + p2 > p1 || p1 == p2 && a1 == InfixR + +-- We know GHC produces left-associated chains, so 'z' is never an +-- operator application. We also know that this will be applied bottom-up +-- by 'everywhere', so we can assume the children are already fixed. +fixOneExpr + :: Monad m + => 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 + swapEntryDPT ap1 ap2' + 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 (L l2 (ConPatIn op2 (InfixCon 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 ap2' + return $ L l1 (ConPatIn op1 (InfixCon x rhs)) +#else +fixOnePat env (dL -> L l2 (ConPatIn op2 (InfixCon (dL -> 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)) +#endif +fixOnePat _ e = return e + +-- Move leading whitespace from the left child of an operator application +-- to the application itself. We need this so we have correct offsets when +-- substituting into patterns and don't end up with extra leading spaces. +-- We can assume it is run bottom-up, and that precedence is already fixed. +fixOneEntry + :: (Monad m, Data a) + => Located a -- ^ Overall application + -> Located a -- ^ Left child + -> TransformT m (Located a) +fixOneEntry e x = do + anns <- getAnnsT + let + zeros = DP (0,0) + (DP (xr,xc), DP (actualRow,_)) = + case M.lookup (mkAnnKey x) anns of + Nothing -> (zeros, zeros) + Just ann -> (annLeadingCommentEntryDelta ann, annEntryDelta ann) + DP (er,ec) = + maybe zeros annLeadingCommentEntryDelta $ M.lookup (mkAnnKey e) anns + when (actualRow == 0) $ do + setEntryDPT e $ DP (er, xc + ec) + setEntryDPT x $ DP (xr, 0) + 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@(L _ (ConPatIn _ (InfixCon x _))) = fixOneEntry p x +#else +fixOneEntryPat p@(ConPatIn _ (InfixCon x _)) = + composeSrcSpan <$> fixOneEntry (dL p) (dL x) +#endif +fixOneEntryPat p = return p + +------------------------------------------------------------------------------- + +swapEntryDPT + :: (Data a, Data b, Monad m) + => Located a -> Located b -> TransformT m () +swapEntryDPT a b = modifyAnnsT $ \ anns -> + let akey = mkAnnKey a + bkey = mkAnnKey b + aann = fromMaybe annNone $ M.lookup akey anns + bann = fromMaybe annNone $ M.lookup bkey anns + in M.insert akey + aann { annEntryDelta = annEntryDelta bann + , annPriorComments = annPriorComments bann } $ + M.insert bkey + bann { annEntryDelta = annEntryDelta aann + , annPriorComments = annPriorComments aann } anns + +------------------------------------------------------------------------------- + +-- Compatibility module with ghc-exactprint + +parseContentNoFixity :: FilePath -> String -> IO AnnotatedModule +parseContentNoFixity fp str = do + r <- Parsers.parseModuleFromString fp str + case r of + Left msg -> fail $ show msg + Right (anns, m) -> return $ unsafeMkA m anns 0 + +parseContent :: FixityEnv -> FilePath -> String -> IO AnnotatedModule +parseContent fixities fp = + parseContentNoFixity fp >=> (`transformA` fix fixities) + +-- | Parse import statements. Each string must be a full import statement, +-- including the keyword 'import'. Supports full import syntax. +parseImports :: [String] -> IO AnnotatedImports +parseImports [] = return mempty +parseImports imports = do + -- imports start on second line, so delta offsets are correct + am <- parseContentNoFixity "parseImports" $ "\n" ++ unlines imports + ais <- transformA am $ pure . hsmodImports . unLoc + return $ trimA ais + +-- | Parse a top-level 'HsDecl'. +parseDecl :: String -> IO AnnotatedHsDecl +parseDecl = parseHelper "parseDecl" Parsers.parseDecl + +-- | Parse a 'HsExpr'. +parseExpr :: String -> IO AnnotatedHsExpr +parseExpr = parseHelper "parseExpr" Parsers.parseExpr + +-- | Parse a 'Pat'. +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 + +-- | Parse a 'Stmt'. +parseStmt :: String -> IO AnnotatedStmt +parseStmt = parseHelper "parseStmt" Parsers.parseStmt + +-- | Parse a 'HsType'. +parseType :: String -> IO AnnotatedHsType +parseType = parseHelper "parseType" Parsers.parseType + +parseHelper :: FilePath -> Parsers.Parser a -> String -> IO (Annotated a) +parseHelper fp parser str = do + r <- Parsers.withDynFlags p + case r of + Left (_, msg) -> throwIO $ ErrorCall msg + Right (anns, x) -> return $ unsafeMkA x anns 0 + where + p dflags = parser dflags fp str + +------------------------------------------------------------------------------- + +debugDump :: Annotate a => Annotated (Located a) -> IO () +debugDump ax = do + let + str = printA ax + maxCol = maximum $ map length $ lines str + (tens, ones) = + case transpose [printf "%2d" i | i <- [1 .. maxCol]] of + [ts, os] -> (ts, os) + _ -> ("", "") + putStrLn $ unlines + [ show k ++ "\n " ++ show v | (k,v) <- M.toList (annsA ax) ] + putStrLn tens + putStrLn ones + putStrLn str + +cloneT :: (Data a, Typeable a, Monad m) => a -> TransformT m a +cloneT e = getAnnsT >>= flip graftT e + +-- 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) + => (KeywordId -> Bool) -- transfer Anns matching predicate + -> Located a -- from + -> Located b -- to + -> TransformT m () +transferEntryAnnsT p a b = do + transferEntryDPT a b + transferAnnsT p a b + +-- | 'Transform' monad version of 'transferEntryDP' +transferEntryDPT + :: (Data a, Data b, Monad m) + => Located a -> Located b -> TransformT m () +transferEntryDPT a b = + modifyAnnsT (transferEntryDP a b) + +-- 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 a b anns = setEntryDP b dp anns' + where + maybeAnns = do -- Maybe monad + anA <- M.lookup (mkAnnKey a) anns + let anB = M.findWithDefault annNone (mkAnnKey b) anns + anB' = anB { annEntryDelta = DP (0,0) } + return (M.insert (mkAnnKey b) anB' anns, annLeadingCommentEntryDelta anA) + (anns',dp) = fromMaybe + (error $ "transferEntryDP: lookup failed: " ++ show (mkAnnKey a)) + maybeAnns + +addAllAnnsT + :: (Data a, Data b, Monad m) + => Located a -> Located b -> TransformT m () +addAllAnnsT a b = + modifyAnnsT (addAllAnns a b) + +addAllAnns :: (Data a, Data b) => Located a -> Located b -> Anns -> Anns +addAllAnns a b anns = + fromMaybe + (error $ "addAllAnns: lookup failed: " ++ show (mkAnnKey a) + ++ " or " ++ show (mkAnnKey b)) + $ do ann <- M.lookup (mkAnnKey a) anns + case M.lookup (mkAnnKey b) anns of + Just ann' -> return $ M.insert (mkAnnKey b) (ann `annAdd` ann') anns + Nothing -> return $ M.insert (mkAnnKey b) ann anns + where annAdd ann ann' = ann' + { annEntryDelta = annEntryDelta ann + , annPriorComments = ((++) `on` annPriorComments) ann ann' + , annFollowingComments = ((++) `on` annFollowingComments) ann ann' + , annsDP = ((++) `on` annsDP) ann ann' + } + +isComma :: KeywordId -> Bool +isComma (G AnnComma) = True +isComma _ = False + +isCommentKeyword :: KeywordId -> Bool +isCommentKeyword (AnnComment _) = True +isCommentKeyword _ = False + +isCommentAnnotation :: Annotation -> Bool +isCommentAnnotation Ann{..} = + (not . null $ annPriorComments) + || (not . null $ annFollowingComments) + || any (isCommentKeyword . fst) annsDP + +hasComments :: (Data a, Monad m) => Located a -> TransformT m Bool +hasComments e = do + anns <- getAnnsT + let b = isCommentAnnotation <$> M.lookup (mkAnnKey e) anns + return $ fromMaybe False b + +transferAnnsT + :: (Data a, Data b, Monad m) + => (KeywordId -> Bool) -- transfer Anns matching predicate + -> Located a -- from + -> Located b -- to + -> TransformT m () +transferAnnsT p a b = modifyAnnsT f + where + bKey = mkAnnKey b + f anns = fromMaybe anns $ do + anA <- M.lookup (mkAnnKey a) anns + anB <- M.lookup bKey anns + let anB' = anB { annsDP = annsDP anB ++ filter (p . fst) (annsDP anA) } + return $ M.insert bKey anB' anns + +-- | 'Transform' monad version of 'getEntryDP' +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. +setEntryDP :: Data a => Located a -> DeltaPos -> Anns -> Anns +setEntryDP x dp anns = M.alter (Just . f . fromMaybe annNone) k anns + where + k = mkAnnKey x + f ann = case annPriorComments ann of + [] -> ann { annEntryDelta = dp } + (c,_):cs -> ann { annPriorComments = (c,dp):cs } + +-- Useful for figuring out what annotations should be on something. +debugParse :: String -> IO () +debugParse s = do + writeFile "debug.txt" s + r <- parseModule "debug.txt" + case r of + Left _ -> putStrLn "parse failed" + Right (anns, modl) -> do + let m = unsafeMkA modl anns 0 + putStrLn "parseModule" + debugDump m + void $ transformDebug m + where + transformDebug = + run "fixOneExpr D.def" (fixOneExpr D.def) + >=> run "fixOnePat D.def" (fixOnePat D.def) + >=> run "fixOneEntryExpr" fixOneEntryExpr + >=> run "fixOneEntryPat" fixOneEntryPat + + run wat f m = do + putStrLn wat + m' <- transformA m (everywhereM (mkM f)) + debugDump m' + return m' diff --git a/Retrie/ExactPrint/Annotated.hs b/Retrie/ExactPrint/Annotated.hs new file mode 100644 --- /dev/null +++ b/Retrie/ExactPrint/Annotated.hs @@ -0,0 +1,150 @@ +-- 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 DeriveFunctor #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Retrie.ExactPrint.Annotated + ( -- * Annotated + Annotated + , astA + , annsA + , seedA + -- ** Synonyms + , AnnotatedHsDecl + , AnnotatedHsExpr + , AnnotatedHsType + , AnnotatedImport + , AnnotatedImports + , AnnotatedModule + , AnnotatedPat + , AnnotatedStmt + -- ** Operations + , pruneA + , graftA + , transformA + , trimA + , printA + -- * Internal + , unsafeMkA + ) where + +import Control.Monad.State.Lazy hiding (fix) +import Data.Default as D +import Data.Functor.Identity + +import Language.Haskell.GHC.ExactPrint hiding + ( cloneT + , setEntryDP + , setEntryDPT + , transferEntryDPT + , transferEntryDP + ) +import Language.Haskell.GHC.ExactPrint.Annotate (Annotate) +import Language.Haskell.GHC.ExactPrint.Types (emptyAnns) + +import Retrie.GHC +import Retrie.SYB + +-- Annotated ----------------------------------------------------------------- + +type AnnotatedHsDecl = Annotated (LHsDecl GhcPs) +type AnnotatedHsExpr = Annotated (LHsExpr GhcPs) +type AnnotatedHsType = Annotated (LHsType GhcPs) +type AnnotatedImport = Annotated (LImportDecl GhcPs) +type AnnotatedImports = Annotated [LImportDecl GhcPs] +type AnnotatedModule = Annotated (Located (HsModule GhcPs)) +type AnnotatedPat = Annotated (Located (Pat GhcPs)) +type AnnotatedStmt = Annotated (LStmt GhcPs (LHsExpr GhcPs)) + +-- | 'Annotated' packages an AST fragment with the annotations necessary to +-- 'exactPrint' or 'transform' that AST. +data Annotated ast = Annotated + { astA :: ast + -- ^ Examine the actual AST. + , annsA :: Anns + -- ^ Annotations generated/consumed by ghc-exactprint + , seedA :: Int + -- ^ Name supply used by ghc-exactprint to generate unique locations. + } + +instance Functor Annotated where + fmap f Annotated{..} = Annotated{astA = f astA, ..} + +instance Foldable Annotated where + foldMap f = f . astA + +instance Traversable Annotated where + traverse f Annotated{..} = + (\ast -> Annotated{astA = ast, ..}) <$> f astA + +instance Default ast => Default (Annotated ast) where + def = Annotated D.def emptyAnns 0 + +instance (Data ast, Monoid ast) => Semigroup (Annotated ast) where + (<>) = mappend + +instance (Data ast, Monoid ast) => Monoid (Annotated ast) where + mempty = Annotated mempty emptyAnns 0 + mappend a1 (Annotated ast2 anns _) = + runIdentity $ transformA a1 $ \ ast1 -> + mappend ast1 <$> graftT anns ast2 + +-- | Construct an 'Annotated'. +-- This should really only be used in the parsing functions, hence the scary name. +-- Don't use this unless you know what you are doing. +unsafeMkA :: ast -> Anns -> Int -> Annotated ast +unsafeMkA = Annotated + +-- | Transform an 'Annotated' thing. +transformA + :: Monad m => Annotated ast1 -> (ast1 -> TransformT m ast2) -> m (Annotated ast2) +transformA (Annotated ast anns seed) f = do + (ast',(anns',seed'),_) <- runTransformFromT seed anns (f ast) + return $ Annotated ast' anns' seed' + +-- | Graft an 'Annotated' thing into the current transformation. +-- The resulting AST will have proper annotations within the 'TransformT' +-- computation. For example: +-- +-- > mkDeclList :: IO (Annotated [LHsDecl GhcPs]) +-- > mkDeclList = do +-- > ad1 <- parseDecl "myId :: a -> a" +-- > ad2 <- parseDecl "myId x = x" +-- > transformA ad1 $ \ d1 -> do +-- > d2 <- graftA ad2 +-- > return [d1, d2] +-- +graftA :: (Data ast, Monad m) => Annotated ast -> TransformT m ast +graftA (Annotated x anns _) = graftT anns x + +-- | Encapsulate something in the current transformation into an 'Annotated' +-- thing. This is the inverse of 'graftT'. For example: +-- +-- > splitHead :: Monad m => Annotated [a] -> m (Annotated a, Annotated [a]) +-- > splitHead l = fmap astA $ transformA l $ \(x:xs) -> do +-- > y <- pruneA x +-- > ys <- pruneA xs +-- > return (y, ys) +-- +pruneA :: (Data ast, Monad m) => ast -> TransformT m (Annotated ast) +pruneA ast = Annotated ast <$> getAnnsT <*> gets snd + +-- | Trim the annotation data to only include annotations for 'ast'. +-- (Usually, the annotation data is a superset of what is necessary.) +-- Also freshens all source locations, so filename information +-- in annotation keys is discarded. +-- +-- Note: not commonly needed, but useful if you want to inspect the annotation +-- data directly and don't want to wade through a mountain of output. +trimA :: Data ast => Annotated ast -> Annotated ast +trimA = runIdentity . transformA nil . const . graftA + where + nil :: Annotated () + nil = mempty + +-- | Exactprint an 'Annotated' thing. +printA :: Annotate ast => Annotated (Located ast) -> String +printA (Annotated ast anns _) = exactPrint ast anns diff --git a/Retrie/Expr.hs b/Retrie/Expr.hs new file mode 100644 --- /dev/null +++ b/Retrie/Expr.hs @@ -0,0 +1,365 @@ +-- 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 RecordWildCards #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} +module Retrie.Expr + ( grhsToExpr + , mkApps + , mkHsAppsTy + , mkLams + , mkLet + , mkLoc + , mkLocatedHsVar + , mkTyVar + , parenify + , parenifyT + , patToExpr + , patToExprA + , unparen + , unparenT + , wildSupply + ) where + +import Control.Monad.State.Lazy +import Data.Functor.Identity +import qualified Data.Map as M +import Data.Maybe + +import Retrie.AlphaEnv +import Retrie.ExactPrint +import Retrie.Fixity +import Retrie.GHC +import Retrie.SYB +import Retrie.Types + +------------------------------------------------------------------------------- + +mkLocatedHsVar :: Monad m => Located RdrName -> TransformT m (LHsExpr GhcPs) +mkLocatedHsVar v = do + -- This special casing for [] is gross, but this is apparently how the + -- annotations work. + let anns = + case occNameString (occName (unLoc v)) of + "[]" -> [(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 noExt r)) +#endif + case v' of +#if __GLASGOW_HASKELL__ < 806 + HsVar x -> +#else + HsVar _ x -> +#endif + swapEntryDPT x lv + _ -> return () + return lv + +------------------------------------------------------------------------------- + +setAnnsFor :: (Data e, Monad m) + => Located e -> [(KeywordId, DeltaPos)] -> TransformT m (Located e) +setAnnsFor e anns = modifyAnnsT (M.alter f (mkAnnKey e)) >> return e + where f Nothing = Just annNone { annsDP = anns } + f (Just a) = Just a { annsDP = M.toList + $ M.union (M.fromList anns) + (M.fromList (annsDP a)) } + +mkLoc :: (Data e, Monad m) => e -> TransformT m (Located e) +mkLoc e = do + le <- L <$> uniqueSrcSpanT <*> pure e + setAnnsFor le [] + +------------------------------------------------------------------------------- + +mkLams + :: [LPat GhcPs] + -> LHsExpr GhcPs + -> TransformT IO (LHsExpr GhcPs) +mkLams [] e = return e +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 noExt))] +#endif + 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 noExt 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 noExt 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 noExt 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 noExt 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 noExt NotPromoted nm) +#endif + _ <- setAnnsFor nm [(G AnnVal, DP (0,0))] + swapEntryDPT tv nm + return tv + +------------------------------------------------------------------------------- + +-- Note [Wildcards] +-- We need to invent unique binders for wildcard patterns and feed +-- them in as quantified variables for the matcher (they will match +-- some expression and be discarded). We do this hackily here, by +-- generating a supply of w1, w2, etc variables, and filter out any +-- other binders we know about. However, we should also filter out +-- the free variables of the expression, to avoid capture. Haven't found +-- a free variable computation on HsExpr though. :-( + +type PatQ m = StateT ([RdrName], [RdrName]) (TransformT m) + +newWildVar :: Monad m => PatQ m RdrName +newWildVar = do + (s, u) <- get + case s of + (r:s') -> do + put (s', r:u) + return r + [] -> error "impossible: empty wild supply" + +wildSupply :: [RdrName] -> [RdrName] +wildSupply used = wildSupplyP (`notElem` used) + +wildSupplyAlphaEnv :: AlphaEnv -> [RdrName] +wildSupplyAlphaEnv env = wildSupplyP (\ nm -> isNothing (lookupAlphaEnv nm env)) + +wildSupplyP :: (RdrName -> Bool) -> [RdrName] +wildSupplyP p = + [ r | i <- [0..] + , let r = mkVarUnqual (mkFastString ('w' : show (i :: Int))) + , p r ] + +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, []) + +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 + where + go WildPat{} = newWildVar >>= lift . mkLocatedHsVar . noLoc + go LazyPat{} = error "patToExpr LazyPat" + go AsPat{} = error "patToExpr AsPat" + go BangPat{} = error "patToExpr BangPat" + go TuplePat{} = error "patToExpr TuplePat" + go (ConPatIn con ds) = conPatHelper con ds + go ConPatOut{} = error "patToExpr ConPatOut" + go ViewPat{} = error "patToExpr ViewPat" + go SplicePat{} = error "patToExpr SplicePat" + go LitPat{} = error "patToExpr LitPat" + go NPat{} = error "patToExpr NPat" + go NPlusKPat{} = error "patToExpr NPlusKPat" +#if __GLASGOW_HASKELL__ < 806 + 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 PArrPat{} = error "patToExpr PArrPat" + go (ParPat p') = lift . mkParen HsPar =<< patToExpr p' + go SigPatIn{} = error "patToExpr SigPatIn" + go SigPatOut{} = error "patToExpr SigPatOut" + go (VarPat i) = lift $ mkLocatedHsVar i +#else + go (ListPat _ ps) = do + ps' <- mapM patToExpr ps + lift $ do + el <- mkLoc $ ExplicitList noExt Nothing ps' + setAnnsFor el [(G AnnOpenS, DP (0,0)), (G AnnCloseS, DP (0,0))] + go (ParPat _ p') = lift . mkParen (HsPar noExt) =<< patToExpr p' + go (VarPat _ i) = lift $ mkLocatedHsVar i + go SigPat{} = error "patToExpr SigPat" + go XPat{} = error "patToExpr XPat" +#endif + go CoPat{} = error "patToExpr CoPat" + go SumPat{} = error "patToExpr SumPat" + +conPatHelper :: Monad m + => Located RdrName + -> 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 noExt + <*> patToExpr x + <*> lift (mkLocatedHsVar con) + <*> patToExpr y +#endif +conPatHelper con (PrefixCon xs) = do + f <- lift $ mkLocatedHsVar con + as <- mapM patToExpr xs + lift $ mkApps f as +conPatHelper _ _ = error "conPatHelper RecCon" + +------------------------------------------------------------------------------- + +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 noExt) le +#endif + | otherwise = return le + where + {- parent -} {- child -} + needed (HasPrec (Fixity _ p1 d1)) (Just (Fixity _ p2 d2)) = + p1 > p2 || (p1 == p2 && (d1 /= d2 || d2 == InfixN)) + needed NeverParen _ = False + needed _ Nothing = True + 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 + pe <- mkLoc (k e) + _ <- setAnnsFor pe [(G AnnOpenP, DP (0,0)), (G AnnCloseP, DP (0,0))] + swapEntryDPT e pe + return pe + +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 noExt) 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 diff --git a/Retrie/Fixity.hs b/Retrie/Fixity.hs new file mode 100644 --- /dev/null +++ b/Retrie/Fixity.hs @@ -0,0 +1,97 @@ +-- 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 RankNTypes #-} +module Retrie.Fixity + ( FixityEnv + , mkFixityEnv + , lookupOp + , lookupOpRdrName + , Fixity(..) + , FixityDirection(..) + , defaultFixityEnv + , extendFixityEnv + , ppFixityEnv + ) where + +-- Note [HSE] +-- GHC's parser parses all operator applications left-associatived, +-- then fixes up the associativity in the renamer, since fixity info isn't +-- known until after name resolution. +-- +-- Ideally, we'd run the module through the renamer and let it do its thing, +-- but ghc-exactprint cannot roundtrip renamed modules. +-- +-- The next best thing we can do is reassociate the operators ourselves, but +-- we need fixity info. Ideally (#2) we'd rename the module and then extract +-- the info from the FixityEnv. That is a TODO. For now, lets just reuse the +-- list of base package fixities in HSE. +import qualified Language.Haskell.Exts as HSE + +import Data.Default + +import Retrie.GHC + +newtype FixityEnv = FixityEnv + { unFixityEnv :: FastStringEnv (FastString, Fixity) } + +instance Default FixityEnv where + def = defaultFixityEnv + +defaultFixityEnv :: FixityEnv +defaultFixityEnv = mkFixityEnv HSE.baseFixities + +instance Semigroup FixityEnv where + -- | 'mappend' for 'FixityEnv' is right-biased + (<>) = mappend + +instance Monoid FixityEnv where + mempty = mkFixityEnv [] + -- | 'mappend' for 'FixityEnv' is right-biased + mappend (FixityEnv e1) (FixityEnv e2) = FixityEnv (plusFsEnv e1 e2) + +lookupOp :: LHsExpr GhcPs -> FixityEnv -> Fixity +lookupOp (L _ e) | Just n <- varRdrName e = lookupOpRdrName n +lookupOp _ = error "lookupOp: called with non-variable!" + +lookupOpRdrName :: Located RdrName -> FixityEnv -> Fixity +lookupOpRdrName (L _ n) (FixityEnv env) = + maybe defaultFixity snd $ lookupFsEnv env (occNameFS $ occName n) + +mkFixityEnv :: [HSE.Fixity] -> FixityEnv +mkFixityEnv = FixityEnv . mkFsEnv . map hseToGHC + +extendFixityEnv :: [(FastString, Fixity)] -> FixityEnv -> FixityEnv +extendFixityEnv l (FixityEnv env) = + FixityEnv $ extendFsEnvList env [ (fs, p) | p@(fs,_) <- l ] + +ppFixityEnv :: FixityEnv -> String +ppFixityEnv = unlines . map ppFixity . eltsUFM . unFixityEnv + where + ppFixity (fs, Fixity _ p d) = unwords + [ case d of + InfixN -> "infix" + InfixL -> "infixl" + InfixR -> "infixr" + , show p + , unpackFS fs + ] + +hseToGHC :: HSE.Fixity -> (FastString, (FastString, Fixity)) +hseToGHC (HSE.Fixity assoc p nm) = (fs, (fs, Fixity (SourceText nm') p (dir assoc))) + where + dir (HSE.AssocNone _) = InfixN + dir (HSE.AssocLeft _) = InfixL + dir (HSE.AssocRight _) = InfixR + + nm' = case nm of + HSE.Qual _ _ n -> nameStr n + HSE.UnQual _ n -> nameStr n + _ -> "SpecialCon" + + fs = mkFastString nm' + + nameStr (HSE.Ident _ s) = s + nameStr (HSE.Symbol _ s) = s diff --git a/Retrie/FreeVars.hs b/Retrie/FreeVars.hs new file mode 100644 --- /dev/null +++ b/Retrie/FreeVars.hs @@ -0,0 +1,69 @@ +-- 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. +-- +module Retrie.FreeVars + ( FreeVars + , substFVs + , elemFVs + , capturesFVs + ) where + +import Data.Generics hiding (Fixity) + +import Retrie.ExactPrint.Annotated +import Retrie.GHC +import Retrie.Quantifiers +import Retrie.Substitution + +-------------------------------------------------------------------------------- + +newtype FreeVars = FreeVars (OccEnv FastString) + +emptyFVs :: FreeVars +emptyFVs = FreeVars emptyOccEnv + +instance Semigroup FreeVars where + (<>) = mappend + +instance Monoid FreeVars where + mempty = emptyFVs + mappend (FreeVars m1) (FreeVars m2) = FreeVars $ plusOccEnv m2 m1 + +instance Show FreeVars where + show (FreeVars m) = show (occEnvElts m) + +substFVs :: Substitution -> FreeVars +substFVs = foldSubst (f . snd) emptyFVs + where + f (HoleExpr e) fvs = freeVars emptyQs (astA e) <> fvs + f (HoleRdr rdr) fvs = rdrFV rdr <> fvs + f _ fvs = fvs -- TODO(anfarmer) types? + +capturesFVs :: (Data a, Typeable a) => Quantifiers -> [RdrName] -> a -> Bool +capturesFVs qs binders thing = any (`elemOccEnv` fvEnv) $ map occName binders + where + FreeVars fvEnv = freeVars qs thing + +-- | This is an over-approximation, but that is fine for our purposes. +freeVars :: (Data a, Typeable a) => Quantifiers -> a -> FreeVars +freeVars qs = everything (<>) (mkQ emptyFVs fvsExpr `extQ` fvsType) + where + fvsExpr :: HsExpr GhcPs -> FreeVars + fvsExpr e + | Just (L _ rdr) <- varRdrName e + , not $ isQ rdr qs = rdrFV rdr + fvsExpr _ = emptyFVs + + fvsType :: HsType GhcPs -> FreeVars + fvsType ty + | Just (L _ rdr) <- tyvarRdrName ty + , not $ isQ rdr qs = rdrFV rdr + fvsType _ = emptyFVs + +elemFVs :: RdrName -> FreeVars -> Bool +elemFVs rdr (FreeVars m) = elemOccEnv (occName rdr) m + +rdrFV :: RdrName -> FreeVars +rdrFV rdr = FreeVars $ unitOccEnv (occName rdr) (rdrFS rdr) diff --git a/Retrie/GHC.hs b/Retrie/GHC.hs new file mode 100644 --- /dev/null +++ b/Retrie/GHC.hs @@ -0,0 +1,132 @@ +-- 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 RecordWildCards #-} +module Retrie.GHC + ( module Retrie.GHC + , module ApiAnnotation + , module Bag + , module BasicTypes + , module FastString + , module FastStringEnv + , module HsExpr + , module HsSyn + , module Module + , module Name + , module OccName + , module RdrName + , module SrcLoc + , module Unique + , module UniqFM + , module UniqSet + ) where + +import ApiAnnotation +import Bag +import BasicTypes +import FastString +import FastStringEnv +import HsExpr +#if __GLASGOW_HASKELL__ < 806 +import HsSyn hiding (HasDefault(..)) +#else +import HsSyn +#endif +import Module +import Name +import OccName +import RdrName +import SrcLoc +import Unique +import UniqFM +import UniqSet + +import Data.Maybe + +rdrFS :: RdrName -> FastString +rdrFS = occNameFS . occName + +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 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{..} ] +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 + XRuleBndr{} -> Nothing +#endif + | L _ b <- bs + ] + +tyBindersToLocatedRdrNames :: [LHsTyVarBndr GhcPs] -> [Located RdrName] +tyBindersToLocatedRdrNames vars = catMaybes + [ case var of +#if __GLASGOW_HASKELL__ < 806 + UserTyVar v -> Just v + KindedTyVar v _ -> Just v +#else + UserTyVar _ v -> Just v + KindedTyVar _ v _ -> Just v + XTyVarBndr{} -> Nothing +#endif + | L _ var <- vars ] + +data RuleInfo = RuleInfo + { riName :: RuleName + , riQuantifiers :: [RdrName] + , riLHS :: LHsExpr GhcPs + , riRHS :: LHsExpr GhcPs + } diff --git a/Retrie/GroundTerms.hs b/Retrie/GroundTerms.hs new file mode 100644 --- /dev/null +++ b/Retrie/GroundTerms.hs @@ -0,0 +1,81 @@ +-- 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 RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +module Retrie.GroundTerms + ( GroundTerms + , groundTerms + ) where + +import Data.HashSet (HashSet) +import qualified Data.HashSet as HashSet + +import Retrie.ExactPrint +import Retrie.GHC +import Retrie.Quantifiers +import Retrie.SYB +import Retrie.Types + +------------------------------------------------------------------------ + +-- | 'Ground Terms' are variables in the pattern that are not quantifiers. +-- We use a set of ground terms to save time during matching by filtering out +-- files which do not contain all the terms. We store one set of terms per +-- pattern because when filtering we must take care to only filter files which +-- do not match any of the patterns. +-- +-- Example: +-- +-- Patterns of 'forall x. foo (bar x) = ...' and 'forall y. baz (quux y) = ...' +-- +-- groundTerms = [{'foo', 'bar'}, {'baz', 'quux'}] +-- +-- Files will be found by unioning results of these commands: +-- +-- grep -R --include "*.hs" -l foo dir | xargs grep -l bar +-- grep -R --include "*.hs" -l baz dir | xargs grep -l quux +-- +-- If there are no ground terms (e.g. 'forall f x y. f x y = f y x') +-- we fall back to 'find dir -iname "*.hs"'. This case seems pathological. +type GroundTerms = HashSet String + +groundTerms :: Data k => Query k v -> GroundTerms +groundTerms Query{..} = HashSet.fromList $ go $ astA qPattern + where + go :: GenericQ [String] + go x + -- 'x' contains a quantifier, so split it into subtrees + | everything (||) isQuantifier x = concat $ gmapQ go x + -- 'x' doesn't contain a quantifier, and can be exactprinted, so return + -- the result of exactprinting + | strs@(_:_) <- printer x = strs + -- 'x' cannot be exactprinted, so recurse to find a printable child + | otherwise = concat $ gmapQ go x + + isQuantifier :: GenericQ Bool + isQuantifier = mkQ False exprIsQ `extQ` tyIsQ + + -- returns 'True' if expression is a var that is a quantifier + exprIsQ :: HsExpr GhcPs -> Bool + exprIsQ e | Just (L _ v) <- varRdrName e = isQ v qQuantifiers + exprIsQ _ = False + + -- returns 'True' if type is a tyvar that is a quantifier + tyIsQ :: HsType GhcPs -> Bool + tyIsQ ty | Just (L _ v) <- tyvarRdrName ty = isQ v qQuantifiers + tyIsQ _ = False + + -- exactprinter that only works for expressions and types + printer :: GenericQ [String] + printer = mkQ [] printExpr `extQ` printTy + + anns = annsA qPattern + + printExpr :: LHsExpr GhcPs -> [String] + printExpr e = [exactPrint e anns] + + printTy :: LHsType GhcPs -> [String] + printTy t = [exactPrint t anns] diff --git a/Retrie/Monad.hs b/Retrie/Monad.hs new file mode 100644 --- /dev/null +++ b/Retrie/Monad.hs @@ -0,0 +1,292 @@ +-- 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 DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +module Retrie.Monad + ( -- * Retrie Computations + Retrie + , addImports + , apply + , applyWithStrategy + , applyWithUpdate + , applyWithUpdateAndStrategy + , focus + , ifChanged + , iterateR + , query + , queryWithUpdate + , topDownPrune + -- * Internal + , getGroundTerms + , liftRWST + , runRetrie + ) where + +import Control.Monad.IO.Class +import Control.Monad.State.Strict +import Control.Monad.RWS +import Control.Monad.Writer.Strict +import Data.Foldable + +import Retrie.Context +import Retrie.CPP +import Retrie.ExactPrint +import Retrie.Fixity +import Retrie.GroundTerms +import Retrie.Query +import Retrie.Replace +import Retrie.Substitution +import Retrie.SYB +import Retrie.Types +import Retrie.Universe + +------------------------------------------------------------------------------- + +-- | The 'Retrie' monad is essentially 'IO', plus state containing the module +-- that is being transformed. __It is run once per target file.__ +-- +-- It is special because it also allows Retrie to extract a set of 'GroundTerms' +-- from the 'Retrie' computation /without evaluating it/. +-- +-- Retrie uses the ground terms to select which files to target. This is the +-- key optimization that allows Retrie to handle large codebases. +-- +-- Note: Due to technical limitations, we cannot extract ground terms if you +-- use 'liftIO' before calling one of 'apply', 'focus', or 'query' at least +-- once. This will cause Retrie to attempt to parse every module in the target +-- directory. In this case, please add a call to 'focus' before the call to +-- 'liftIO'. +data Retrie a where + Bind :: Retrie b -> (b -> Retrie a) -> Retrie a + Inst :: RetrieInstruction a -> Retrie a + Pure :: a -> Retrie a + +data RetrieInstruction a where + Focus :: [GroundTerms] -> RetrieInstruction () + Tell :: Change -> RetrieInstruction () + IfChanged :: Retrie () -> Retrie () -> RetrieInstruction () + Compute :: RetrieComp a -> RetrieInstruction a + +type RetrieComp = RWST FixityEnv Change (CPP AnnotatedModule) IO + +singleton :: RetrieInstruction a -> Retrie a +singleton = Inst + +liftRWST :: RetrieComp a -> Retrie a +liftRWST = singleton . Compute + +-- Note [Retrie Monad] +-- We want to extract a set of ground terms (See Note [Ground Terms]) +-- from a 'Retrie' computation corresponding to the ground terms of +-- the _first_ rewrite application. To do so, we keep the chain of +-- binds associated to the right (normal form) so an application is +-- always at the head of the chain. This allows us to look at the +-- ground terms without evaluating the computation. +-- +-- We _must_ be able to get ground terms without evaluating, because +-- we use them to filter the set of files on which we run the +-- computation itself. This is why we can't simply use a writer. + +-- | We want a right-associated chain of binds, because then we can inspect +-- the instructions in a list-like fashion. We could re-associate in the Monad +-- instance, but that leads to a quadratic bind operation. Instead, we use the +-- view technique. +-- +-- Right-associativity is guaranteed because the left side of ':>>=' +-- can never be another 'Retrie' computation. It is a primitive +-- 'RetrieInstruction'. +data RetrieView a where + Return :: a -> RetrieView a + (:>>=) :: RetrieInstruction b -> (b -> Retrie a) -> RetrieView a + +view :: Retrie a -> RetrieView a +view (Pure x) = Return x +view (Inst inst) = inst :>>= return +view (Bind (Pure x) k) = view (k x) +view (Bind (Inst inst) k) = inst :>>= k +view (Bind (Bind m k1) k2) = view (Bind m (k1 >=> k2)) + +------------------------------------------------------------------------------- +-- Instances + +instance Functor Retrie where + fmap = liftM + +instance Applicative Retrie where + pure = Pure + (<*>) = ap + +instance Monad Retrie where + return = Pure + (>>=) = Bind + +instance MonadIO Retrie where + liftIO = singleton . Compute . liftIO + +------------------------------------------------------------------------------- +-- Running + +-- | Run the 'Retrie' monad. +runRetrie + :: FixityEnv + -> Retrie a + -> CPP AnnotatedModule + -> IO (a, CPP AnnotatedModule, Change) +runRetrie fixities retrie = runRWST (getComp retrie) fixities + +-- | Helper to extract the ground terms from a 'Retrie' computation. +getGroundTerms :: Retrie a -> [GroundTerms] +getGroundTerms = eval . view + where + eval :: RetrieView a -> [GroundTerms] + eval Return{} = [] -- The computation is empty! + eval (inst :>>= k) = + case inst of + Focus gts -> gts + Tell _ -> getGroundTerms $ k () + IfChanged retrie1 retrie2 + | gts@(_:_) <- getGroundTerms retrie1 -> gts + | gts@(_:_) <- getGroundTerms retrie2 -> gts + | otherwise -> getGroundTerms $ k () + -- If we reach actual computation, we have to give up. The only + -- way this can currently happen is if 'liftIO' is called before + -- any focusing is done. + Compute _ -> [] + +-- | Reflect the reified monadic computation. +getComp :: Retrie a -> RetrieComp a +getComp = eval . view + where + eval (Return x) = return x + eval (inst :>>= k) = evalInst inst >>= getComp . k + + evalInst (Focus _) = return () + evalInst (Tell c) = tell c + evalInst (IfChanged r1 r2) = ifChangedComp (getComp r1) (getComp r2) + evalInst (Compute m) = m + +------------------------------------------------------------------------------- +-- Public API + +-- | Use the given queries/rewrites to select files for rewriting. +-- Does not actually perform matching. This is useful if the queries/rewrites +-- which best determine which files to target are not the first ones you run, +-- and when you need to 'liftIO' before running any queries/rewrites. +focus :: Data k => [Query k v] -> Retrie () +focus [] = return () +focus qs = singleton $ Focus $ map groundTerms qs + +-- | Apply a set of rewrites. By default, rewrites are applied top-down, +-- pruning the traversal at successfully changed AST nodes. See 'topDownPrune'. +apply :: [Rewrite Universe] -> Retrie () +apply = applyWithUpdateAndStrategy updateContext topDownPrune + +-- | Apply a set of rewrites with a custom context-update function. +applyWithUpdate + :: ContextUpdater -> [Rewrite Universe] -> Retrie () +applyWithUpdate updCtxt = applyWithUpdateAndStrategy updCtxt topDownPrune + +-- | Apply a set of rewrites with a custom traversal strategy. +applyWithStrategy + :: Strategy (TransformT (WriterT Change IO)) + -> [Rewrite Universe] + -> Retrie () +applyWithStrategy = applyWithUpdateAndStrategy updateContext + +-- | Apply a set of rewrites with custom context-update and traversal strategy. +applyWithUpdateAndStrategy + :: ContextUpdater + -> Strategy (TransformT (WriterT Change IO)) + -> [Rewrite Universe] + -> Retrie () +applyWithUpdateAndStrategy _ _ [] = return () +applyWithUpdateAndStrategy updCtxt strategy rrs = do + focus rrs + singleton $ Compute $ rs $ \ fixityEnv -> + traverse $ flip transformA $ + everywhereMWithContextBut strategy + (const False) updCtxt replace (emptyContext fixityEnv m d) + where + m = foldMap mkRewriter rrs + d = foldMap mkRewriter $ rewritesWithDependents rrs + +-- | Query the AST. Each match returns the context of the match, a substitution +-- mapping quantifiers to matched subtrees, and the query's value. +query :: [Query Universe v] -> Retrie [(Context, Substitution, v)] +query = queryWithUpdate updateContext + +-- | Query the AST with a custom context update function. +queryWithUpdate + :: ContextUpdater + -> [Query Universe v] + -> Retrie [(Context, Substitution, v)] +queryWithUpdate _ [] = return [] +queryWithUpdate updCtxt qs = do + focus qs + singleton $ Compute $ do + fixityEnv <- ask + cpp <- get + results <- lift $ forM (toList cpp) $ \modl -> do + annotatedResults <- transformA modl $ + everythingMWithContextBut + (const False) + updCtxt + (genericQ matcher) + (emptyContext fixityEnv mempty mempty) + return (astA annotatedResults) + return $ concat results + where + matcher = foldMap mkMatcher qs + +-- | If the first 'Retrie' computation makes a change to the module, +-- run the second 'Retrie' computation. +ifChanged :: Retrie () -> Retrie () -> Retrie () +ifChanged r1 r2 = singleton $ IfChanged r1 r2 + +ifChangedComp :: RetrieComp () -> RetrieComp () -> RetrieComp () +ifChangedComp r1 r2 = do + (_, c) <- listen r1 + case c of + Change{} -> r2 + NoChange -> return () + +-- | Iterate given 'Retrie' computation until it no longer makes changes, +-- or N times, whichever happens first. +iterateR :: Int -> Retrie () -> Retrie () +iterateR n r = when (n > 0) $ ifChanged r $ iterateR (n-1) r +-- By implementing in terms of 'ifChanged', we expose the ground terms for 'r' + +-- | Add imports to the module. +addImports :: AnnotatedImports -> Retrie () +addImports imports = singleton $ Tell $ Change [] [imports] + +-- | Top-down traversal that does not descend into changed AST nodes. +-- Default strategy used by 'apply'. +topDownPrune :: Monad m => Strategy (TransformT (WriterT Change m)) +topDownPrune p cs x = do + (p', c) <- listenTransformT (p x) + case c of + Change{} -> return p' + NoChange -> cs x + +-- | Monad transformer shuffling. +listenTransformT + :: (Monad m, Monoid w) + => TransformT (WriterT w m) a -> TransformT (WriterT w m) (a, w) +listenTransformT (TransformT rwst) = + TransformT $ RWST $ \ r s -> do + ((x,y,z),w) <- listen $ runRWST rwst r s + return ((x,w),y,z) -- naming is hard + +-- | Like 'rws', but builds 'RWST' instead of 'RWS', +-- takes argument in WriterT layer, and specialized to (). +rs :: Monad m => (r -> s -> WriterT w m s) -> RWST r w s m () +rs f = RWST $ \ r s -> do + (s', w) <- runWriterT (f r s) + return ((), s', w) diff --git a/Retrie/Options.hs b/Retrie/Options.hs new file mode 100644 --- /dev/null +++ b/Retrie/Options.hs @@ -0,0 +1,420 @@ +-- 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 ApplicativeDo #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} +module Retrie.Options + ( -- * Options + Options + , Options_(..) + , ExecutionMode(..) + , defaultOptions + , parseOptions + -- * Internal + , buildGrepChain + , forFn + , getOptionsParser + , getTargetFiles + , parseRewritesInternal + , parseVerbosity + , ProtoOptions + , resolveOptions + ) where + +import Control.Concurrent.Async (mapConcurrently) +import Control.Monad (when) +import Data.Bool +import Data.Char (isAlphaNum, isSpace) +import Data.Default as D +import Data.Foldable (toList) +import Data.Functor.Identity +import Data.List +import Data.HashSet (HashSet) +import qualified Data.HashSet as HashSet +import Data.Traversable +import Options.Applicative +import System.Directory +import System.FilePath +import System.Process +import System.Random.Shuffle + +import Retrie.CPP +import Retrie.Debug +import Retrie.ExactPrint +import Retrie.Fixity +import Retrie.GroundTerms +import Retrie.GHC +import Retrie.Pretty +import Retrie.Rewrites +import Retrie.Types +import Retrie.Universe +import Retrie.Util + +-- | Command-line options. +type Options = Options_ [Rewrite Universe] AnnotatedImports + +-- | Parse options using the given 'FixityEnv'. +parseOptions :: FixityEnv -> IO Options +parseOptions fixityEnv = do + p <- getOptionsParser fixityEnv + opts <- execParser (info (p <**> helper) fullDesc) + resolveOptions opts + +-- | Create 'Rewrite's from string specifications of rewrites. +-- We expose this from "Retrie" with a nicer type signature as +-- 'Retrie.Options.parseRewrites'. We have it here so we can use it with +-- 'ProtoOptions'. +parseRewritesInternal :: Options_ a b -> [RewriteSpec] -> IO [Rewrite Universe] +parseRewritesInternal Options{..} = parseRewriteSpecs parser fixityEnv + where + parser fp = parseCPPFile (parseContent fixityEnv) (targetDir fp) + +-- | Controls the ultimate action taken by 'apply'. The default action is +-- 'ExecRewrite'. +data ExecutionMode + = ExecDryRun -- ^ Pretend to do rewrites, show diff. + | ExecRewrite -- ^ Perform rewrites. + | ExecExtract -- ^ Print the resulting expression for each match. + | ExecSearch -- ^ Print the matched expressions. + deriving (Show) + +data Options_ rewrites imports = Options + { additionalImports :: imports + -- ^ Imports specified by the command-line flag '--import'. + , colorise :: ColoriseFun + -- ^ Function used to colorize results of certain execution modes. + , executionMode :: ExecutionMode + -- ^ Controls behavior of 'apply'. See 'ExecutionMode'. + , extraIgnores :: [FilePath] + -- ^ Specific files that should be ignored. Paths should be relative to + -- 'targetDir'. + , fixityEnv :: FixityEnv + -- ^ Fixity information for operators used during parsing (of rewrites and + -- target modules). Defaults to base fixities. + , iterateN :: Int + -- ^ 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. + , randomOrder :: Bool + -- ^ Whether to randomize the order of target modules before rewriting them. + , rewrites :: rewrites + -- ^ Rewrites specified by command-line flags such as '--adhoc'. + , roundtrips :: [RoundTrip] + -- ^ Paths that should be roundtripped through ghc-exactprint to debug. + -- Specified by the '--roundtrip' command-line flag. + , singleThreaded :: Bool + -- ^ Whether to concurrently rewrite target modules. + -- Mostly useful for viewing debugging output without interleaving it. + , targetDir :: FilePath + -- ^ Directory that contains the code being targeted for rewriting. + , targetFiles :: [FilePath] + -- ^ Instead of targeting all Haskell files in 'targetDir', only target + -- specific files. Paths should be relative to 'targetDir'. + , verbosity :: Verbosity + -- ^ How much should be output on 'stdout'. + } + +-- | Construct default options for the given target directory. +defaultOptions + :: (Default rewrites, Default imports) + => FilePath -> Options_ rewrites imports +defaultOptions fp = Options + { additionalImports = D.def + , colorise = noColor + , executionMode = ExecRewrite + , extraIgnores = [] + , fixityEnv = D.def + , iterateN = 1 + , randomOrder = False + , rewrites = D.def + , roundtrips = [] + , singleThreaded = False + , targetDir = fp + , targetFiles = [] + , verbosity = Normal + } + +-- | Get the options parser. The returned 'ProtoOptions' should be passed +-- to 'resolveOptions' to get final 'Options'. +getOptionsParser :: FixityEnv -> IO (Parser ProtoOptions) +getOptionsParser fEnv = do + dOpts <- defaultOptions <$> getCurrentDirectory + return $ buildParser dOpts { fixityEnv = fEnv } + +buildParser :: ProtoOptions -> Parser ProtoOptions +buildParser dOpts = do + singleThreaded <- switch $ mconcat + [ long "single-threaded" + , showDefault + , help "Don't try to parallelize things (for debugging)." + ] + targetDir <- option str $ mconcat + [ long "target" + , short 't' + , metavar "PATH" + , action "directory" -- complete with directory + , value (targetDir dOpts) + , showDefault + , help "Path to target with rewrites." + ] + targetFiles <- many $ option str $ mconcat + [ long "target-file" + , metavar "PATH" + , action "file" -- complete with filenames + , help "Target specific file for rewriting." + ] + verbosity <- parseVerbosity (verbosity dOpts) + additionalImports <- many $ option str $ mconcat + [ long "import" + , metavar "IMPORT" + , help + "Add given import statement to modules that are modified by a rewrite." + ] + extraIgnores <- many $ option str $ mconcat + [ long "ignore" + , metavar "PATH" + , action "file" -- complete with filenames + , help "Ignore specific file while rewriting." + ] + colorise <- fmap (bool noColor addColor) $ switch $ mconcat + [ long "color" + , help "Highlight matches with color." + ] + randomOrder <- switch $ mconcat + [ long "random-order" + , help "Randomize the order of targeted modules." + ] + iterateN <- option auto $ mconcat + [ long "iterate" + , short 'i' + , metavar "N" + , value 1 + , help "Iterate rewrites up to N times." + ] + + executionMode <- parseMode + rewrites <- parseRewriteSpecOptions + roundtrips <- parseRoundtrips + return Options{ fixityEnv = fixityEnv dOpts, ..} + +parseRewriteSpecOptions :: Parser [RewriteSpec] +parseRewriteSpecOptions = concat <$> traverse many + [ fmap Unfold $ option str $ mconcat + [ long "unfold" + , short 'u' + , metavar "NAME" + , help "Unfold given fully-qualified name." + ] + , fmap Fold $ option str $ mconcat + [ long "fold" + , short 'f' + , metavar "NAME" + , help "Fold given fully-qualified name." + ] + , fmap RuleForward $ option str $ mconcat + [ long "rule-forward" + , short 'l' + , metavar "NAME" + , help "Apply fully-qualified RULE name left-to-right." + ] + , fmap RuleBackward $ option str $ mconcat + [ long "rule-backward" + , short 'r' + , metavar "NAME" + , help "Apply fully-qualified RULE name right-to-left." + ] + , fmap TypeForward $ option str $ mconcat + [ long "type-forward" + , metavar "NAME" + , help "Apply fully-qualified type synonym name left-to-right." + ] + , fmap TypeBackward $ option str $ mconcat + [ long "type-backward" + , metavar "NAME" + , help "Apply fully-qualified type synonym name right-to-left." + ] + , fmap Adhoc $ option str $ mconcat + [ long "adhoc" + , metavar "EQUATION" + , help "Apply an adhoc equation of the form: forall vs. lhs = rhs" + ] + ] + +parseMode :: Parser ExecutionMode +parseMode = + parseDryRun <|> + parseExtract <|> + parseSearch <|> + pure ExecRewrite + +parseDryRun :: Parser ExecutionMode +parseDryRun = flag' ExecDryRun $ mconcat + [ long "dry-run" + , help "Don't overwrite files. Print rewrite results." + ] + +parseExtract :: Parser ExecutionMode +parseExtract = flag' ExecExtract $ mconcat + [ long "extract" + , help "Find the left-hand side, display the instantiated right-hand side." + ] + +parseSearch :: Parser ExecutionMode +parseSearch = flag' ExecSearch $ mconcat + [ long "search" + , help "Search for left-hand side of the rewrite and show matches." + ] + +-- | Parser for 'Verbosity'. +parseVerbosity :: Verbosity -> Parser Verbosity +parseVerbosity defaultV = option (eitherReader verbosityReader) $ mconcat + [ long "verbosity" + , short 'v' + , value defaultV + , showDefault + , help verbosityHelp + ] + +verbosityReader :: String -> Either String Verbosity +verbosityReader "0" = Right Silent +verbosityReader "1" = Right Normal +verbosityReader "2" = Right Loud +verbosityReader _ = + Left $ "invalid verbosity. Valid values: " ++ verbosityHelp + +verbosityHelp :: String +verbosityHelp = "0: silent, 1: normal, 2: loud (implies --single-threaded)" + +------------------------------------------------------------------------------- + +-- | Options that have been parsed, but not fully resolved. +type ProtoOptions = Options_ [RewriteSpec] [String] + +-- | Resolve 'ProtoOptions' into 'Options'. Parses rewrites into 'Rewrite's, +-- parses imports, validates options, and extends 'fixityEnv' with any +-- declared fixities in the target directory. +resolveOptions :: ProtoOptions -> IO Options +resolveOptions protoOpts = do + opts@Options{..} <- addLocalFixities protoOpts + parsedImports <- parseImports additionalImports + debugPrint verbosity "Imports:" $ + runIdentity $ fmap astA $ transformA parsedImports $ \ imps -> do + anns <- getAnnsT + return $ map (`exactPrint` anns) imps + rrs <- parseRewritesInternal opts rewrites + return Options + { rewrites = rrs + , additionalImports = parsedImports + , singleThreaded = singleThreaded || verbosity == Loud + , .. + } + +-- | Find all fixity declarations in targetDir and add them to fixity env. +addLocalFixities :: Options_ a b -> IO (Options_ a b) +addLocalFixities opts = do + -- do not limit search for infix decls to only targetFiles + let opts' = opts { targetFiles = [] } + -- "infix" will find infixl and infixr as well + files <- getTargetFiles opts' [HashSet.singleton "infix"] + + fixFns <- forFn opts files $ \ fp -> do + ms <- toList <$> parseCPPFile parseContentNoFixity fp + return $ extendFixityEnv + [ (rdrFS nm, fixity) + | m <- ms + , (L _ nm, fixity) <- fixityDecls (unLoc (astA m)) + ] + + return opts { fixityEnv = foldr ($) (fixityEnv opts) fixFns } + +-- | 'forM', but concurrency and input order controled by 'Options'. +forFn :: Options_ x y -> [a] -> (a -> IO b) -> IO [b] +forFn Options{..} c f + | randomOrder = fn f =<< shuffleM c + | otherwise = fn f c + where + fn + | singleThreaded = mapM + | otherwise = mapConcurrently + +-- | Find all files to target for rewriting. +getTargetFiles :: Options_ a b -> [GroundTerms] -> IO [FilePath] +-- Always include at least one set of ground terms +-- This selects all files if the list of rewrites is empty +getTargetFiles opts [] = getTargetFiles opts [mempty] +getTargetFiles Options{..} gtss = do + ignorePred <- maybe onIgnoreErr return =<< vcsIgnorePred targetDir + 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) + + let + r = filter (not . ignore) + $ map (normalise . (targetDir )) fps + debugPrint verbosity "Files:" r + return $ HashSet.fromList r + + return $ HashSet.toList $ mconcat fpSets + where + dedup = HashSet.toList . HashSet.fromList + extraIgnorePred = + let fps = [ normalise (targetDir f) | f <- extraIgnores ] + in \fp -> any (`isPrefixOf` fp) fps + onIgnoreErr = do + when (verbosity > Silent) $ + 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. +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) + where + p [] = False + p (c:cs) + | isSpace c = p cs + | otherwise = isAlphaNum c + + 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) + + findCmd = ["find", addTrailingPathSeparator targetDir, "-iname", hsExtension] + + firstCmd g = + ["grep", "-R", "--include=" ++ hsExtension, "-l", esc g, targetDir] + + filterChain gs = [ ["xargs", "grep", "-l", esc gt] | gt <- gs ] + + esc s = "'" ++ intercalate "[[:space:]]\\+" (words s) ++ "'" + +doCmd :: FilePath -> Verbosity -> String -> String -> IO [FilePath] +doCmd targetDir verbosity inp shellCmd = do + debugPrint verbosity "stdin:" [inp] + debugPrint verbosity "shellCmd:" [shellCmd] + let cmd = (shell shellCmd) { cwd = Just targetDir } + (_ec, fps, _) <- readCreateProcessWithExitCode cmd inp + return $ lines fps diff --git a/Retrie/PatternMap/Bag.hs b/Retrie/PatternMap/Bag.hs new file mode 100644 --- /dev/null +++ b/Retrie/PatternMap/Bag.hs @@ -0,0 +1,162 @@ +-- 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 InstanceSigs #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveFunctor #-} +module Retrie.PatternMap.Bag where + +import qualified Data.Map as M +import qualified Data.IntMap as I + +import Retrie.AlphaEnv +import qualified Retrie.GHC as GHC +import Retrie.PatternMap.Class +import Retrie.Quantifiers +import Retrie.Substitution + +data BoolMap a + = EmptyBoolMap + | BoolMap + { bmTrue :: MaybeMap a + , bmFalse :: MaybeMap a + } + deriving (Functor) + +instance PatternMap BoolMap where + type Key BoolMap = Bool + + mEmpty :: BoolMap a + mEmpty = EmptyBoolMap + + mUnion :: BoolMap a -> BoolMap a -> BoolMap a + mUnion EmptyBoolMap m = m + mUnion m EmptyBoolMap = m + mUnion (BoolMap tm1 fm1) (BoolMap tm2 fm2) = + BoolMap (mUnion tm1 tm2) (mUnion fm1 fm2) + + mAlter + :: AlphaEnv -> Quantifiers -> Key BoolMap -> A a -> BoolMap a -> BoolMap a + mAlter env qs b f EmptyBoolMap = mAlter env qs b f (BoolMap mEmpty mEmpty) + mAlter env qs b f m@BoolMap{} + | b = m { bmTrue = mAlter env qs () f (bmTrue m) } + | otherwise = m { bmFalse = mAlter env qs () f (bmFalse m) } + + mMatch + :: MatchEnv + -> Key BoolMap + -> (Substitution, BoolMap a) + -> [(Substitution, a)] + mMatch _ _ (_, EmptyBoolMap) = [] + mMatch env b hs@(_, BoolMap{}) + | b = mapFor bmTrue hs >>= mMatch env () + | otherwise = mapFor bmFalse hs >>= mMatch env () + +------------------------------------------------------------------------ + +newtype IntMap a = IntMap { unIntMap :: I.IntMap [a] } + deriving (Functor) + +instance PatternMap IntMap where + type Key IntMap = I.Key + + mEmpty :: IntMap a + mEmpty = IntMap I.empty + + mUnion :: IntMap a -> IntMap a -> IntMap a + mUnion (IntMap m1) (IntMap m2) = IntMap $ I.unionWith (++) m1 m2 + + mAlter :: AlphaEnv -> Quantifiers -> Key IntMap -> A a -> IntMap a -> IntMap a + mAlter _ _ i f (IntMap m) = IntMap $ I.alter (toAList f) i m + + mMatch + :: MatchEnv + -> Key IntMap + -> (Substitution, IntMap a) + -> [(Substitution, a)] + mMatch _ i = maybeListMap (I.lookup i . unIntMap) + +------------------------------------------------------------------------ + +newtype Map k a = Map { unMap :: M.Map k [a] } + deriving (Functor) + +mapAssocs :: Map k v -> [(k,v)] +mapAssocs (Map m) = [ (k,v) | (k,vs) <- M.assocs m, v <- vs ] + +instance Ord k => PatternMap (Map k) where + type Key (Map k) = k + + mEmpty :: Map k a + mEmpty = Map M.empty + + mUnion :: Map k a -> Map k a -> Map k a + mUnion (Map m1) (Map m2) = Map $ M.unionWith (++) m1 m2 + + mAlter :: AlphaEnv -> Quantifiers -> Key (Map k) -> A a -> Map k a -> Map k a + mAlter _ _ k f (Map m) = Map $ M.alter (toAList f) k m + + mMatch + :: MatchEnv + -> Key (Map k) + -> (Substitution, Map k a) + -> [(Substitution, a)] + mMatch _ k = maybeListMap (M.lookup k . unMap) + +------------------------------------------------------------------------ + +-- Note [OccEnv] +-- +-- We avoid using OccEnv because the Uniquable instance for OccName +-- takes the NameSpace of the OccName into account, which we rarely actually +-- want. (Doing so requires creating new RdrNames with the proper namespace, +-- which is a bunch of fiddling for no obvious gain for our uses.) Instead +-- we just use a map based on the FastString name. + +newtype FSEnv a = + FSEnv { _unFSEnv :: UniqFM a } -- this is the UniqFM below, NOT GHC's UniqFM + deriving (Functor) + +instance PatternMap FSEnv where + type Key FSEnv = GHC.FastString + + mEmpty :: FSEnv a + mEmpty = FSEnv mEmpty + + mUnion :: FSEnv a -> FSEnv a -> FSEnv a + mUnion (FSEnv m1) (FSEnv m2) = FSEnv (mUnion m1 m2) + + mAlter :: AlphaEnv -> Quantifiers -> Key FSEnv -> A a -> FSEnv a -> FSEnv a + mAlter env qs fs f (FSEnv m) = FSEnv (mAlter env qs (GHC.getUnique fs) f m) + + mMatch :: MatchEnv -> Key FSEnv -> (Substitution, FSEnv a) -> [(Substitution, a)] + mMatch env fs (hs, FSEnv m) = mMatch env (GHC.getUnique fs) (hs, m) + +------------------------------------------------------------------------ + +newtype UniqFM a = UniqFM { unUniqFM :: GHC.UniqFM [a] } + deriving (Functor) + +instance PatternMap UniqFM where + type Key UniqFM = GHC.Unique + + mEmpty :: UniqFM a + mEmpty = UniqFM GHC.emptyUFM + + mUnion :: UniqFM a -> UniqFM a -> UniqFM a + mUnion (UniqFM m1) (UniqFM m2) = UniqFM $ GHC.plusUFM_C (++) m1 m2 + + mAlter :: AlphaEnv -> Quantifiers -> Key UniqFM -> A a -> UniqFM a -> UniqFM a + mAlter _ _ k f (UniqFM m) = UniqFM $ GHC.alterUFM (toAList f) m k + + mMatch + :: MatchEnv + -> Key UniqFM + -> (Substitution, UniqFM a) + -> [(Substitution, a)] + mMatch _ k = maybeListMap (flip GHC.lookupUFM_Directly k . unUniqFM) + +------------------------------------------------------------------------ diff --git a/Retrie/PatternMap/Class.hs b/Retrie/PatternMap/Class.hs new file mode 100644 --- /dev/null +++ b/Retrie/PatternMap/Class.hs @@ -0,0 +1,125 @@ +-- 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 DeriveFunctor #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +module Retrie.PatternMap.Class where + +import Control.Monad +import Data.Maybe + +import Retrie.AlphaEnv +import Retrie.ExactPrint +import Retrie.GHC +import Retrie.Quantifiers +import Retrie.Substitution + +------------------------------------------------------------------------ + +data MatchEnv = ME + { meAlphaEnv :: AlphaEnv + , mePruneA :: forall a. a -> Annotated a + } + +extendMatchEnv :: MatchEnv -> [RdrName] -> MatchEnv +extendMatchEnv me bs = + me { meAlphaEnv = foldr extendAlphaEnvInternal (meAlphaEnv me) bs } + +pruneMatchEnv :: Int -> MatchEnv -> MatchEnv +pruneMatchEnv i me = me { meAlphaEnv = pruneAlphaEnv i (meAlphaEnv me) } + +------------------------------------------------------------------------ + +-- TODO: Maybe a -> a ??? -- we never need to delete +type A a = Maybe a -> Maybe a + +toA :: PatternMap m => (m a -> m a) -> A (m a) +toA f = Just . f . fromMaybe mEmpty + +toAList :: A a -> A [a] +toAList f Nothing = (:[]) <$> f Nothing +toAList f (Just xs) = Just $ mapMaybe (f . Just) xs + +------------------------------------------------------------------------ + +class PatternMap m where + type Key m :: * + + mEmpty :: m a + mUnion :: m a -> m a -> m a + + mAlter :: AlphaEnv -> Quantifiers -> Key m -> A a -> m a -> m a + mMatch :: MatchEnv -> Key m -> (Substitution, m a) -> [(Substitution, a)] + +-- Useful to get the chain started in mMatch +mapFor :: (b -> c) -> (a, b) -> [(a, c)] +mapFor f (hs,m) = [(hs, f m)] + +-- Useful for using existing lookup functions in mMatch +maybeMap :: (b -> Maybe c) -> (a, b) -> [(a, c)] +maybeMap f (hs,m) = maybeToList $ (hs,) <$> f m + +maybeListMap :: (b -> Maybe [c]) -> (a, b) -> [(a, c)] +maybeListMap f (hs, m) = [ (a, c) | (a, cs) <- maybeMap f (hs, m), c <- cs ] + +------------------------------------------------------------------------ + +newtype MaybeMap a = MaybeMap [a] + deriving (Functor) + +instance PatternMap MaybeMap where + type Key MaybeMap = () + + mEmpty :: MaybeMap a + mEmpty = MaybeMap [] + + mUnion :: MaybeMap a -> MaybeMap a -> MaybeMap a + mUnion (MaybeMap m1) (MaybeMap m2) = MaybeMap $ m1 ++ m2 + + mAlter :: AlphaEnv -> Quantifiers -> Key MaybeMap -> A a -> MaybeMap a -> MaybeMap a + mAlter _ _ () f (MaybeMap []) = MaybeMap $ maybeToList $ f Nothing + mAlter _ _ () f (MaybeMap xs) = MaybeMap $ mapMaybe (f . Just) xs + + mMatch + :: MatchEnv + -> Key MaybeMap + -> (Substitution, MaybeMap a) + -> [(Substitution, a)] + mMatch _ () (hs, MaybeMap xs) = map (hs,) xs + +------------------------------------------------------------------------ + +data ListMap m a + = ListMap { lmNil :: MaybeMap a + , lmCons :: m (ListMap m a) } + deriving (Functor) + +instance PatternMap m => PatternMap (ListMap m) where + type Key (ListMap m) = [Key m] + + mEmpty :: ListMap m a + mEmpty = ListMap mEmpty mEmpty + + mUnion :: ListMap m a -> ListMap m a -> ListMap m a + mUnion (ListMap n1 c1) (ListMap n2 c2) = ListMap (mUnion n1 n2) (mUnion c1 c2) + + mAlter :: AlphaEnv -> Quantifiers -> Key (ListMap m) -> A a -> ListMap m a -> ListMap m a + mAlter env vs [] f m = m { lmNil = mAlter env vs () f (lmNil m) } + mAlter env vs (x:xs) f m = m { lmCons = mAlter env vs x (toA (mAlter env vs xs f)) (lmCons m) } + + mMatch :: MatchEnv -> Key (ListMap m) -> (Substitution, ListMap m a) -> [(Substitution, a)] + mMatch env [] = mapFor lmNil >=> mMatch env () + mMatch env (x:xs) = mapFor lmCons >=> mMatch env x >=> mMatch env xs + +------------------------------------------------------------------------ + +findMatch :: PatternMap m => MatchEnv -> Key m -> m a -> [(Substitution, a)] +findMatch env k m = mMatch env k (emptySubst, m) + +insertMatch :: PatternMap m => AlphaEnv -> Quantifiers -> Key m -> a -> m a -> m a +insertMatch env vs k x = mAlter env vs k (const (Just x)) diff --git a/Retrie/PatternMap/Instances.hs b/Retrie/PatternMap/Instances.hs new file mode 100644 --- /dev/null +++ b/Retrie/PatternMap/Instances.hs @@ -0,0 +1,1373 @@ +-- Copyright (c) Facebook, Inc. and its affiliates. +-- +-- This source code is licensed under the MIT license found in the +-- LICENSE file in the root directory of this source tree. +-- +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} +module Retrie.PatternMap.Instances where + +import Control.Monad +import Data.ByteString (ByteString) +import Data.Maybe + +import Retrie.AlphaEnv +import Retrie.ExactPrint +import Retrie.GHC +import Retrie.PatternMap.Bag +import Retrie.PatternMap.Class +import Retrie.Quantifiers +import Retrie.Substitution + +------------------------------------------------------------------------ + +data TupArgMap a + = TupArgMap { tamPresent :: EMap a, tamMissing :: MaybeMap a } + deriving (Functor) + +instance PatternMap TupArgMap where + type Key TupArgMap = LHsTupArg GhcPs + + mEmpty :: TupArgMap a + mEmpty = TupArgMap mEmpty mEmpty + + mUnion :: TupArgMap a -> TupArgMap a -> TupArgMap a + mUnion (TupArgMap p1 m1) (TupArgMap p2 m2) = TupArgMap (mUnion p1 p2) (mUnion m1 m2) + + 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) } + go XTupArg{} = error "XTupArg" +#endif + go (Missing _) = m { tamMissing = mAlter env vs () f (tamMissing m) } + + 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 + go XTupArg{} = const [] +#endif + go (Missing _) = mapFor tamMissing >=> mMatch env () + +------------------------------------------------------------------------ + +data BoxityMap a + = BoxityMap { boxBoxed :: MaybeMap a, boxUnboxed :: MaybeMap a } + deriving (Functor) + +instance PatternMap BoxityMap where + type Key BoxityMap = Boxity + + mEmpty :: BoxityMap a + mEmpty = BoxityMap mEmpty mEmpty + + mUnion :: BoxityMap a -> BoxityMap a -> BoxityMap a + mUnion (BoxityMap b1 u1) (BoxityMap b2 u2) = BoxityMap (mUnion b1 b2) (mUnion u1 u2) + + mAlter :: AlphaEnv -> Quantifiers -> Key BoxityMap -> A a -> BoxityMap a -> BoxityMap a + mAlter env vs Boxed f m = m { boxBoxed = mAlter env vs () f (boxBoxed m) } + mAlter env vs Unboxed f m = m { boxUnboxed = mAlter env vs () f (boxUnboxed m) } + + mMatch :: MatchEnv -> Key BoxityMap -> (Substitution, BoxityMap a) -> [(Substitution, a)] + mMatch env Boxed = mapFor boxBoxed >=> mMatch env () + mMatch env Unboxed = mapFor boxUnboxed >=> mMatch env () + +------------------------------------------------------------------------ + +data VMap a = VM { bvmap :: IntMap a, fvmap :: FSEnv a } + | VMEmpty + deriving (Functor) + +instance PatternMap VMap where + type Key VMap = RdrName + + mEmpty :: VMap a + mEmpty = VMEmpty + + mUnion :: VMap a -> VMap a -> VMap a + mUnion VMEmpty m = m + mUnion m VMEmpty = m + mUnion (VM b1 f1) (VM b2 f2) = VM (mUnion b1 b2) (mUnion f1 f2) + + mAlter :: AlphaEnv -> Quantifiers -> Key VMap -> A a -> VMap a -> VMap a + mAlter env vs v f VMEmpty = mAlter env vs v f (VM mEmpty mEmpty) + mAlter env vs v f m@VM{} + | Just bv <- lookupAlphaEnv v env = m { bvmap = mAlter env vs bv f (bvmap m) } + | otherwise = m { fvmap = mAlter env vs (rdrFS v) f (fvmap m) } + + mMatch :: MatchEnv -> Key VMap -> (Substitution, VMap a) -> [(Substitution, a)] + mMatch _ _ (_,VMEmpty) = [] + mMatch env v (hs,m@VM{}) + | Just bv <- lookupAlphaEnv v (meAlphaEnv env) = mMatch env bv (hs, bvmap m) + | otherwise = mMatch env (rdrFS v) (hs, fvmap m) + +------------------------------------------------------------------------ + +data LMap a + = LMEmpty + | LM { lmChar :: Map Char a + , lmCharPrim :: Map Char a + , lmString :: FSEnv a + , lmStringPrim :: Map ByteString a + , lmInt :: BoolMap (Map Integer a) + , lmIntPrim :: Map Integer a + , lmWordPrim :: Map Integer a + , lmInt64Prim :: Map Integer a + , lmWord64Prim :: Map Integer a + } + deriving (Functor) + +emptyLMapWrapper :: LMap a +emptyLMapWrapper + = LM mEmpty mEmpty mEmpty mEmpty mEmpty + mEmpty mEmpty mEmpty mEmpty + +instance PatternMap LMap where + type Key LMap = HsLit GhcPs + + mEmpty :: LMap a + mEmpty = LMEmpty + + mUnion :: LMap a -> LMap a -> LMap a + mUnion LMEmpty m = m + mUnion m LMEmpty = m + mUnion (LM a1 b1 c1 d1 e1 f1 g1 h1 i1) + (LM a2 b2 c2 d2 e2 f2 g2 h2 i2) = + LM (mUnion a1 a2) + (mUnion b1 b2) + (mUnion c1 c2) + (mUnion d1 d2) + (mUnion e1 e2) + (mUnion f1 f2) + (mUnion g1 g2) + (mUnion h1 h2) + (mUnion i1 i2) + + mAlter :: AlphaEnv -> Quantifiers -> Key LMap -> A a -> LMap a -> LMap a + mAlter env vs lit f LMEmpty = mAlter env vs lit f emptyLMapWrapper + mAlter env vs lit f m@LM{} = go lit + where + go (HsChar _ c) = m { lmChar = mAlter env vs c f (lmChar m) } + go (HsCharPrim _ c) = m { lmCharPrim = mAlter env vs c f (lmCharPrim m) } + go (HsString _ fs) = m { lmString = mAlter env vs fs f (lmString m) } + go (HsStringPrim _ bs) = m { lmStringPrim = mAlter env vs bs f (lmStringPrim m) } + go (HsInt _ (IL _ b i)) = + m { lmInt = mAlter env vs b (toA (mAlter env vs i f)) (lmInt m) } + go (HsIntPrim _ i) = m { lmIntPrim = mAlter env vs i f (lmIntPrim m) } + go (HsWordPrim _ i) = m { lmWordPrim = mAlter env vs i f (lmWordPrim m) } + go (HsInt64Prim _ i) = m { lmInt64Prim = mAlter env vs i f (lmInt64Prim m) } + go (HsWord64Prim _ i) = m { lmWord64Prim = mAlter env vs i f (lmWord64Prim m) } + go (HsInteger _ _ _) = error "HsInteger" + go HsRat{} = error "HsRat" + go HsFloatPrim{} = error "HsFloatPrim" + go HsDoublePrim{} = error "HsDoublePrim" +#if __GLASGOW_HASKELL__ < 806 +#else + go XLit{} = error "XLit" +#endif + + mMatch :: MatchEnv -> Key LMap -> (Substitution, LMap a) -> [(Substitution, a)] + mMatch _ _ (_,LMEmpty) = [] + mMatch env lit (hs,m@LM{}) = go lit (hs,m) + where + go (HsChar _ c) = mapFor lmChar >=> mMatch env c + go (HsCharPrim _ c) = mapFor lmCharPrim >=> mMatch env c + go (HsString _ fs) = mapFor lmString >=> mMatch env fs + go (HsStringPrim _ bs) = mapFor lmStringPrim >=> mMatch env bs + go (HsInt _ (IL _ b i)) = mapFor lmInt >=> mMatch env b >=> mMatch env i + go (HsIntPrim _ i) = mapFor lmIntPrim >=> mMatch env i + go (HsWordPrim _ i) = mapFor lmWordPrim >=> mMatch env i + go (HsInt64Prim _ i) = mapFor lmInt64Prim >=> mMatch env i + go (HsWord64Prim _ i) = mapFor lmWord64Prim >=> mMatch env i + go _ = const [] -- TODO + +------------------------------------------------------------------------ + +data OLMap a + = OLMEmpty + | OLM + { olmIntegral :: BoolMap (Map Integer a) + , olmFractional :: Map Rational a + , olmIsString :: FSEnv a + } + deriving (Functor) + +emptyOLMapWrapper :: OLMap a +emptyOLMapWrapper = OLM mEmpty mEmpty mEmpty + +instance PatternMap OLMap where + type Key OLMap = OverLitVal + + mEmpty :: OLMap a + mEmpty = OLMEmpty + + mUnion :: OLMap a -> OLMap a -> OLMap a + mUnion OLMEmpty m = m + mUnion m OLMEmpty = m + mUnion (OLM a1 b1 c1) (OLM a2 b2 c2) = + OLM (mUnion a1 a2) (mUnion b1 b2) (mUnion c1 c2) + + mAlter :: AlphaEnv -> Quantifiers -> Key OLMap -> A a -> OLMap a -> OLMap a + mAlter env vs lv f OLMEmpty = mAlter env vs lv f emptyOLMapWrapper + mAlter env vs lv f m@OLM{} = go lv + where + go (HsIntegral (IL _ b i)) = + m { olmIntegral = mAlter env vs b (toA (mAlter env vs i f)) (olmIntegral m) } + go (HsFractional fl) = m { olmFractional = mAlter env vs (fl_value fl) f (olmFractional m) } + go (HsIsString _ fs) = m { olmIsString = mAlter env vs fs f (olmIsString m) } + + mMatch :: MatchEnv -> Key OLMap -> (Substitution, OLMap a) -> [(Substitution, a)] + mMatch _ _ (_,OLMEmpty) = [] + mMatch env lv (hs,m@OLM{}) = go lv (hs,m) + where + go (HsIntegral (IL _ b i)) = + mapFor olmIntegral >=> mMatch env b >=> mMatch env i + go (HsFractional fl) = mapFor olmFractional >=> mMatch env (fl_value fl) + go (HsIsString _ fs) = mapFor olmIsString >=> mMatch env fs + +------------------------------------------------------------------------ + +-- Note [Holes] +-- Holes are distinguished variables which can match any expression. (The +-- universally quantified variables in an Equality.) Ideally, they would be +-- stored as a TyMap, so the type of the expression can be checked against the +-- type of the hole. Fixing this is a TODO. This wraps a map from RdrName to +-- result. We use a regular map instead of a OccEnv so we can get the RdrName +-- back, which allows us to assign it to the expression when building the +-- result. + +-- Note [Lambdas] +-- This currently stores both HsLam and HsLamCase + +-- Note [Stmt Lists] +-- Statement lists bind to the right, so we need to extend the environment +-- as we move down it. Thus we cannot simply store them as ListMap SMap a. + +-- 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] + , emVar :: VMap a + , emIPVar :: FSEnv a + , emOverLit :: OLMap a + , emLit :: LMap a + , emLam :: MGMap a -- See Note [Lambdas] + , emApp :: EMap (EMap a) + , emOpApp :: EMap (EMap (EMap a)) -- op, lhs, rhs + , emNegApp :: EMap a + , emPar :: EMap a + , emExplicitTuple :: BoxityMap (ListMap TupArgMap a) + , emCase :: EMap (MGMap a) + , emSecL :: EMap (EMap a) -- operator, operand (flipped) + , emSecR :: EMap (EMap a) -- operator, operand + , emIf :: EMap (EMap (EMap a)) -- cond, true, false + , emLet :: LBMap (EMap a) + , emDo :: SCMap (SLMap a) -- See Note [Stmt Lists] + , emExplicitList :: ListMap EMap a + , emRecordCon :: VMap (ListMap RFMap a) + , emRecordUpd :: EMap (ListMap RFMap a) + , emExprWithTySig :: EMap (TyMap a) + } + deriving (Functor) + +emptyEMapWrapper :: EMap a +emptyEMapWrapper = + EM mEmpty mEmpty mEmpty mEmpty mEmpty + mEmpty mEmpty mEmpty mEmpty mEmpty + mEmpty mEmpty mEmpty mEmpty mEmpty + mEmpty mEmpty mEmpty mEmpty mEmpty + mEmpty + +instance PatternMap EMap where + type Key EMap = LHsExpr GhcPs + + mEmpty :: EMap a + mEmpty = EMEmpty + + mUnion :: EMap a -> EMap a -> EMap a + mUnion EMEmpty m = m + mUnion m EMEmpty = m + mUnion (EM a1 b1 c1 d1 e1 f1 g1 h1 i1 j1 k1 l1 m1 n1 o1 p1 q1 r1 s1 t1 u1) + (EM a2 b2 c2 d2 e2 f2 g2 h2 i2 j2 k2 l2 m2 n2 o2 p2 q2 r2 s2 t2 u2) = + EM (mUnion a1 a2) + (mUnion b1 b2) + (mUnion c1 c2) + (mUnion d1 d2) + (mUnion e1 e2) + (mUnion f1 f2) + (mUnion g1 g2) + (mUnion h1 h2) + (mUnion i1 i2) + (mUnion j1 j2) + (mUnion k1 k2) + (mUnion l1 l2) + (mUnion m1 m2) + (mUnion n1 n2) + (mUnion o1 o2) + (mUnion p1 p2) + (mUnion q1 q2) + (mUnion r1 r2) + (mUnion s1 s2) + (mUnion t1 t2) + (mUnion u1 u2) + + mAlter :: AlphaEnv -> Quantifiers -> Key EMap -> A a -> EMap a -> EMap a + mAlter env vs e f EMEmpty = mAlter env vs e f emptyEMapWrapper + mAlter env vs e f m@EM{} = go (unLoc e) + where + -- See Note [Dollar Fork] + 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 noExt l (noLoc (HsPar noExt 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) } + 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 XExpr{} = error "XExpr" + go (HsLet _ lbs e') = +#endif + let + bs = collectLocalBinders $ unLoc lbs + env' = foldr extendAlphaEnvInternal env bs + vs' = vs `exceptQ` bs + in m { emLet = mAlter env vs (unLoc lbs) (toA (mAlter env' vs' e' f)) (emLet m) } + go HsLamCase{} = error "HsLamCase" + go HsMultiIf{} = error "HsMultiIf" + go (ExplicitList _ _ es) = m { emExplicitList = mAlter env vs es f (emExplicitList m) } + go ArithSeq{} = error "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) } + go ExprWithTySig{} = error "ExprWithTySig" +#endif + go HsSCC{} = error "HsSCC" + go HsCoreAnn{} = error "HsCoreAnn" + go HsBracket{} = error "HsBracket" + go HsRnBracketOut{} = error "HsRnBracketOut" + go HsTcBracketOut{} = error "HsTcBracketOut" + go HsSpliceE{} = error "HsSpliceE" + go HsProc{} = error "HsProc" + go HsStatic{} = error "HsStatic" + go HsArrApp{} = error "HsArrApp" + go HsArrForm{} = error "HsArrForm" + go HsTick{} = error "HsTick" + go HsBinTick{} = error "HsBinTick" + go HsTickPragma{} = error "HsTickPragma" + go EWildPat{} = error "EWildPat" + go EAsPat{} = error "EAsPat" + go EViewPat{} = error "EViewPat" + go ELazyPat{} = error "ELazyPat" + go HsWrap{} = error "HsWrap" + go HsUnboundVar{} = error "HsUnboundVar" + go HsRecFld{} = error "HsRecFld" + go HsOverLabel{} = error "HsOverLabel" + go HsAppType{} = error "HsAppType" + go HsConLikeOut{} = error "HsConLikeOut" + go ExplicitSum{} = error "ExplicitSum" +#if __GLASGOW_HASKELL__ < 806 + go ExplicitPArr{} = error "ExplicitPArr" + go ExprWithTySigOut{} = error "ExprWithTySigOut" + go HsAppTypeOut{} = error "HsAppTypeOut" + go PArrSeq{} = error "PArrSeq" +#endif + + mMatch :: MatchEnv -> Key EMap -> (Substitution, EMap a) -> [(Substitution, a)] + mMatch _ _ (_,EMEmpty) = [] + mMatch env e (hs,m@EM{}) = hss ++ go (unLoc e) (hs,m) + where + hss = extendResult (emHole m) (HoleExpr $ mePruneA env e) hs + +#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) + 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 (OpApp _ l o r) = + mapFor emOpApp >=> mMatch env o >=> mMatch env l >=> mMatch env r + go (NegApp _ e' _) = mapFor emNegApp >=> mMatch env e' + 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') = +#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 + +-- Add the matched expression to the holes map, fails if expression differs from one already in hole. +extendResult :: Map RdrName a -> HoleVal -> Substitution -> [(Substitution, a)] +extendResult hm v sub = catMaybes + [ case lookupSubst n sub of + Nothing -> return (extendSubst sub n v, x) + Just v' -> sameHoleValue v v' >> return (sub, x) + | (nm,x) <- mapAssocs hm, let n = rdrFS nm ] + +singleton :: [a] -> Maybe a +singleton [x] = Just x +singleton _ = Nothing + +-- | Determine if two expressions are alpha-equivalent. +sameHoleValue :: HoleVal -> HoleVal -> Maybe () +sameHoleValue (HoleExpr e1) (HoleExpr e2) = + alphaEquivalent (astA e1) (astA e2) EMEmpty +sameHoleValue (HolePat p1) (HolePat p2) = + alphaEquivalent +#if __GLASGOW_HASKELL__ < 808 + (astA p1) + (astA p2) +#else + (composeSrcSpan $ astA p1) + (composeSrcSpan $ astA p2) +#endif + PatEmpty +sameHoleValue (HoleType ty1) (HoleType ty2) = + alphaEquivalent (astA ty1) (astA ty2) TyEmpty +sameHoleValue _ _ = Nothing + +alphaEquivalent :: PatternMap m => Key m -> Key m -> m () -> Maybe () +alphaEquivalent v1 v2 e = snd <$> singleton (findMatch env v2 m) + where + m = insertMatch emptyAlphaEnv emptyQs v1 () e + env = ME emptyAlphaEnv err + err _ = error "hole prune during alpha-equivalence check is impossible!" + +------------------------------------------------------------------------ + +data SCMap a + = SCEmpty + | SCM { scmListComp :: MaybeMap a + , scmMonadComp :: MaybeMap a + , scmDoExpr :: MaybeMap a + -- TODO: the rest + } + deriving (Functor) + +emptySCMapWrapper :: SCMap a +emptySCMapWrapper = SCM mEmpty mEmpty mEmpty + +instance PatternMap SCMap where + type Key SCMap = HsStmtContext Name -- see comment on HsDo in GHC + + mEmpty :: SCMap a + mEmpty = SCEmpty + + mUnion :: SCMap a -> SCMap a -> SCMap a + mUnion SCEmpty m = m + mUnion m SCEmpty = m + mUnion (SCM a1 b1 c1) (SCM a2 b2 c2) = + SCM (mUnion a1 a2) (mUnion b1 b2) (mUnion c1 c2) + + mAlter :: AlphaEnv -> Quantifiers -> Key SCMap -> A a -> SCMap a -> SCMap a + mAlter env vs sc f SCEmpty = mAlter env vs sc f emptySCMapWrapper + mAlter env vs sc f m@SCM{} = go sc + where + go ListComp = m { scmListComp = mAlter env vs () f (scmListComp m) } + go MonadComp = m { scmMonadComp = mAlter env vs () f (scmMonadComp m) } +#if __GLASGOW_HASKELL__ < 806 + go PArrComp = error "PArrComp" +#endif + go DoExpr = m { scmDoExpr = mAlter env vs () f (scmDoExpr m) } + go MDoExpr = error "MDoExpr" + go ArrowExpr = error "ArrowExpr" + go GhciStmtCtxt = error "GhciStmtCtxt" + go (PatGuard _) = error "PatGuard" + go (ParStmtCtxt _) = error "ParStmtCtxt" + go (TransStmtCtxt _) = error "TransStmtCtxt" + + mMatch :: MatchEnv -> Key SCMap -> (Substitution, SCMap a) -> [(Substitution, a)] + mMatch _ _ (_,SCEmpty) = [] + mMatch env sc (hs,m@SCM{}) = go sc (hs,m) + where + go ListComp = mapFor scmListComp >=> mMatch env () + go MonadComp = mapFor scmMonadComp >=> mMatch env () + go DoExpr = mapFor scmDoExpr >=> mMatch env () + go _ = const [] -- TODO + +------------------------------------------------------------------------ + +-- Note [MatchGroup] +-- A MatchGroup contains a list of argument types and a result type, but +-- these aren't available until after typechecking, so they are all placeholders +-- at this point. Also, don't care about the origin. +newtype MGMap a = MGMap { unMGMap :: ListMap MMap a } + deriving (Functor) + +instance PatternMap MGMap where + type Key MGMap = MatchGroup GhcPs (LHsExpr GhcPs) + + mEmpty :: MGMap a + mEmpty = MGMap mEmpty + + mUnion :: MGMap a -> MGMap a -> MGMap a + mUnion (MGMap m1) (MGMap m2) = MGMap (mUnion m1 m2) + + mAlter :: AlphaEnv -> Quantifiers -> Key MGMap -> A a -> MGMap a -> MGMap a + mAlter env vs mg f (MGMap m) = MGMap (mAlter env vs alts f m) + where alts = map unLoc (unLoc $ mg_alts mg) + + mMatch :: MatchEnv -> Key MGMap -> (Substitution, MGMap a) -> [(Substitution, a)] + mMatch env mg = mapFor unMGMap >=> mMatch env alts + where alts = map unLoc (unLoc $ mg_alts mg) + +------------------------------------------------------------------------ + +newtype MMap a = MMap { unMMap :: ListMap PatMap (GRHSSMap a) } + deriving (Functor) + +instance PatternMap MMap where + type Key MMap = Match GhcPs (LHsExpr GhcPs) + + mEmpty :: MMap a + mEmpty = MMap mEmpty + + mUnion :: MMap a -> MMap a -> MMap a + mUnion (MMap m1) (MMap m2) = MMap (mUnion m1 m2) + + mAlter :: AlphaEnv -> Quantifiers -> Key MMap -> A a -> MMap a -> MMap a + mAlter env vs match f (MMap m) = + let lpats = m_pats match + pbs = collectPatsBinders lpats + env' = foldr extendAlphaEnvInternal env pbs + vs' = vs `exceptQ` pbs + in MMap (mAlter env vs lpats + (toA (mAlter env' vs' (m_grhss match) f)) m) + + mMatch :: MatchEnv -> Key MMap -> (Substitution, MMap a) -> [(Substitution, a)] + mMatch env match = mapFor unMMap >=> mMatch env lpats >=> mMatch env' (m_grhss match) + where + lpats = m_pats match + pbs = collectPatsBinders lpats + env' = extendMatchEnv env pbs + +------------------------------------------------------------------------ + +data CDMap a + = CDEmpty + | CDMap { cdPrefixCon :: ListMap PatMap a + -- TODO , cdRecCon :: MaybeMap a + , cdInfixCon :: PatMap (PatMap a) + } + deriving (Functor) + +emptyCDMapWrapper :: CDMap a +emptyCDMapWrapper = CDMap mEmpty mEmpty + +instance PatternMap CDMap where + type Key CDMap = HsConDetails (LPat GhcPs) (HsRecFields GhcPs (LPat GhcPs)) + + mEmpty :: CDMap a + mEmpty = CDEmpty + + mUnion :: CDMap a -> CDMap a -> CDMap a + mUnion CDEmpty m = m + mUnion m CDEmpty = m + mUnion (CDMap a1 b1) (CDMap a2 b2) = CDMap (mUnion a1 a2) (mUnion b1 b2) + + mAlter :: AlphaEnv -> Quantifiers -> Key CDMap -> A a -> CDMap a -> CDMap a + mAlter env vs d f CDEmpty = mAlter env vs d f emptyCDMapWrapper + mAlter env vs d f m@CDMap{} = go d + where + go (PrefixCon ps) = m { cdPrefixCon = mAlter env vs ps f (cdPrefixCon m) } + go (RecCon _) = error "RecCon" + go (InfixCon p1 p2) = m { cdInfixCon = mAlter env vs p1 + (toA (mAlter env vs p2 f)) + (cdInfixCon m) } + + mMatch :: MatchEnv -> Key CDMap -> (Substitution, CDMap a) -> [(Substitution, a)] + mMatch _ _ (_ ,CDEmpty) = [] + mMatch env d (hs,m@CDMap{}) = go d (hs,m) + where + go (PrefixCon ps) = mapFor cdPrefixCon >=> mMatch env ps + go (InfixCon p1 p2) = mapFor cdInfixCon >=> mMatch env p1 >=> mMatch env p2 + go _ = const [] -- TODO + +------------------------------------------------------------------------ + +-- Note [Variable Binders] +-- We don't actually care about the variable name, since we are checking for +-- alpha-equivalence. + +data PatMap a + = PatEmpty + | PatMap { pmHole :: Map RdrName a -- See Note [Holes] + , pmWild :: MaybeMap a + , pmVar :: MaybeMap a -- See Note [Variable Binders] + , pmParPat :: PatMap a + , pmTuplePat :: BoxityMap (ListMap PatMap a) + , pmConPatIn :: FSEnv (CDMap a) + -- TODO: the rest + } + deriving (Functor) + +emptyPatMapWrapper :: PatMap a +emptyPatMapWrapper = PatMap mEmpty mEmpty mEmpty mEmpty mEmpty mEmpty + +instance PatternMap PatMap where + type Key PatMap = LPat GhcPs + + mEmpty :: PatMap a + mEmpty = PatEmpty + + mUnion :: PatMap a -> PatMap a -> PatMap a + mUnion PatEmpty m = m + mUnion m PatEmpty = m + mUnion (PatMap a1 b1 c1 d1 e1 f1) + (PatMap a2 b2 c2 d2 e2 f2) = + PatMap (mUnion a1 a2) + (mUnion b1 b2) + (mUnion c1 c2) + (mUnion d1 d2) + (mUnion e1 e2) + (mUnion f1 f2) + + mAlter :: AlphaEnv -> Quantifiers -> Key PatMap -> A a -> PatMap a -> PatMap a + mAlter env vs pat f PatEmpty = mAlter env vs pat f emptyPatMapWrapper + mAlter env vs pat f m@PatMap{} = go (unLoc pat) + where + go (WildPat _) = m { pmWild = mAlter env vs () f (pmWild m) } +#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{} = error "LazyPat" + go AsPat{} = error "AsPat" + go BangPat{} = error "BangPat" + go ListPat{} = error "ListPat" + go (ConPatIn c d) = m { pmConPatIn = mAlter env vs (rdrFS (unLoc c)) (toA (mAlter env vs d f)) (pmConPatIn m) } + go ConPatOut{} = error "ConPatOut" + go ViewPat{} = error "ViewPat" + go SplicePat{} = error "SplicePat" + go LitPat{} = error "LitPat" + go NPat{} = error "NPat" + go NPlusKPat{} = error "NPlusKPat" +#if __GLASGOW_HASKELL__ < 806 + go (PArrPat _ _) = error "PArrPat" + go (ParPat p) = m { pmParPat = mAlter env vs p f (pmParPat m) } + go (SigPatIn _ _) = error "SigPatIn" + go (SigPatOut _ _) = error "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{} = error "SigPat" + go XPat{} = error "XPat" +#endif + go CoPat{} = error "CoPat" + go SumPat{} = error "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) + where + hss = extendResult (pmHole m) (HolePat $ mePruneA env pat) 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 () +#endif + go (ConPatIn c d) = mapFor pmConPatIn >=> mMatch env (rdrFS (unLoc c)) >=> mMatch env d + go _ = const [] -- TODO + +------------------------------------------------------------------------ + +newtype GRHSSMap a = GRHSSMap { unGRHSSMap :: LBMap (ListMap GRHSMap a) } + deriving (Functor) + +instance PatternMap GRHSSMap where + type Key GRHSSMap = GRHSs GhcPs (LHsExpr GhcPs) + + mEmpty :: GRHSSMap a + mEmpty = GRHSSMap mEmpty + + mUnion :: GRHSSMap a -> GRHSSMap a -> GRHSSMap a + mUnion (GRHSSMap m1) (GRHSSMap m2) = GRHSSMap (mUnion m1 m2) + + mAlter :: AlphaEnv -> Quantifiers -> Key GRHSSMap -> A a -> GRHSSMap a -> GRHSSMap a + mAlter env vs grhss f (GRHSSMap m) = + let lbs = unLoc $ grhssLocalBinds grhss + bs = collectLocalBinders lbs + env' = foldr extendAlphaEnvInternal env bs + vs' = vs `exceptQ` bs + in GRHSSMap (mAlter env vs lbs + (toA (mAlter env' vs' (map unLoc $ grhssGRHSs grhss) f)) m) + + mMatch :: MatchEnv -> Key GRHSSMap -> (Substitution, GRHSSMap a) -> [(Substitution, a)] + mMatch env grhss = mapFor unGRHSSMap >=> mMatch env lbs + >=> mMatch env' (map unLoc $ grhssGRHSs grhss) + where + lbs = unLoc $ grhssLocalBinds grhss + bs = collectLocalBinders lbs + env' = extendMatchEnv env bs + +------------------------------------------------------------------------ + +newtype GRHSMap a = GRHSMap { unGRHSMap :: SLMap (EMap a) } + deriving (Functor) + +instance PatternMap GRHSMap where + type Key GRHSMap = GRHS GhcPs (LHsExpr GhcPs) + + mEmpty :: GRHSMap a + mEmpty = GRHSMap mEmpty + + mUnion :: GRHSMap a -> GRHSMap a -> GRHSMap a + mUnion (GRHSMap m1) (GRHSMap m2) = GRHSMap (mUnion m1 m2) + + mAlter :: AlphaEnv -> Quantifiers -> Key GRHSMap -> A a -> GRHSMap a -> GRHSMap a +#if __GLASGOW_HASKELL__ < 806 + mAlter env vs (GRHS gs b) f (GRHSMap m) = +#else + mAlter _ _ XGRHS{} _ _ = error "XGRHS" + mAlter env vs (GRHS _ gs b) f (GRHSMap m) = +#endif + 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 + mMatch _ XGRHS{} = const [] + mMatch env (GRHS _ gs b) = +#endif + mapFor unGRHSMap >=> mMatch env gs >=> mMatch env' b + where + bs = collectLStmtsBinders gs + env' = extendMatchEnv env bs + +------------------------------------------------------------------------ + +data SLMap a + = SLEmpty + | SLM { slmNil :: MaybeMap a + , slmCons :: SMap (SLMap a) + } + deriving (Functor) + +emptySLMapWrapper :: SLMap a +emptySLMapWrapper = SLM mEmpty mEmpty + +instance PatternMap SLMap where + type Key SLMap = [LStmt GhcPs (LHsExpr GhcPs)] + + mEmpty :: SLMap a + mEmpty = SLEmpty + + mUnion :: SLMap a -> SLMap a -> SLMap a + mUnion SLEmpty m = m + mUnion m SLEmpty = m + mUnion (SLM a1 b1) (SLM a2 b2) = SLM (mUnion a1 a2) (mUnion b1 b2) + + mAlter :: AlphaEnv -> Quantifiers -> Key SLMap -> A a -> SLMap a -> SLMap a + mAlter env vs ss f SLEmpty = mAlter env vs ss f emptySLMapWrapper + mAlter env vs ss f m@SLM{} = go ss + where + go [] = m { slmNil = mAlter env vs () f (slmNil m) } + go (s:ss') = + let + bs = collectLStmtBinders s + env' = foldr extendAlphaEnvInternal env bs + vs' = vs `exceptQ` bs + in m { slmCons = mAlter env vs s (toA (mAlter env' vs' ss' f)) (slmCons m) } + + mMatch :: MatchEnv -> Key SLMap -> (Substitution, SLMap a) -> [(Substitution, a)] + mMatch _ _ (_,SLEmpty) = [] + mMatch env ss (hs,m@SLM{}) = go ss (hs,m) + where + go [] = mapFor slmNil >=> mMatch env () + go (s:ss') = + let + bs = collectLStmtBinders s + env' = extendMatchEnv env bs + in mapFor slmCons >=> mMatch env s >=> mMatch env' ss' + +------------------------------------------------------------------------ + +-- Note [Local Binds] +-- We simplify this a bit here, assuming always ValBindsIn (because ValBindsOut +-- only shows up after renaming. Also we ignore the [LSig] for now. + +data LBMap a + = LBEmpty + | LB { lbValBinds :: ListMap BMap a -- see Note [Local Binds] + -- TODO: , lbIPBinds :: + , lbEmpty :: MaybeMap a + } + deriving (Functor) + +emptyLBMapWrapper :: LBMap a +emptyLBMapWrapper = LB mEmpty mEmpty + +instance PatternMap LBMap where + type Key LBMap = HsLocalBinds GhcPs + + mEmpty :: LBMap a + mEmpty = LBEmpty + + mUnion :: LBMap a -> LBMap a -> LBMap a + mUnion LBEmpty m = m + mUnion m LBEmpty = m + mUnion (LB a1 b1) (LB a2 b2) = + LB (mUnion a1 a2) (mUnion b1 b2) + + mAlter :: AlphaEnv -> Quantifiers -> Key LBMap -> A a -> LBMap a -> LBMap a + mAlter env vs lbs f LBEmpty = mAlter env vs lbs f emptyLBMapWrapper + mAlter env vs lbs f m@LB{} = go lbs + where +#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) } + go XHsLocalBindsLR{} = error "XHsLocalBindsLR" + go (HsValBinds _ vbs) = +#endif + let + bs = collectHsValBinders vbs + env' = foldr extendAlphaEnvInternal env bs + vs' = vs `exceptQ` bs + in m { lbValBinds = mAlter env' vs' (deValBinds vbs) f (lbValBinds m) } + go HsIPBinds{} = error "HsIPBinds" + + mMatch :: MatchEnv -> Key LBMap -> (Substitution, LBMap a) -> [(Substitution, a)] + 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 + in mapFor lbValBinds >=> mMatch env' (deValBinds vbs) + 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" + +------------------------------------------------------------------------ + +-- Note [Bind env] +-- We don't extend the env because it was already done at the LBMap level +-- (because all bindings are available to the recursive group). + +data BMap a + = BMEmpty + | BM { bmFunBind :: MGMap a + , bmVarBind :: EMap a + , bmPatBind :: PatMap (GRHSSMap a) + -- TODO: rest + } + deriving (Functor) + +emptyBMapWrapper :: BMap a +emptyBMapWrapper = BM mEmpty mEmpty mEmpty + +instance PatternMap BMap where + type Key BMap = HsBind GhcPs + + mEmpty :: BMap a + mEmpty = BMEmpty + + mUnion :: BMap a -> BMap a -> BMap a + mUnion BMEmpty m = m + mUnion m BMEmpty = m + mUnion (BM a1 b1 c1) (BM a2 b2 c2) + = BM (mUnion a1 a2) (mUnion b1 b2) (mUnion c1 c2) + + mAlter :: AlphaEnv -> Quantifiers -> Key BMap -> A a -> BMap a -> BMap a + mAlter env vs b f BMEmpty = mAlter env vs b f emptyBMapWrapper + mAlter env vs b f m@BM{} = go b + where -- see Note [Bind env] +#if __GLASGOW_HASKELL__ < 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 + 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{} = error "XHsBindsLR" + go (PatBind _ lhs rhs _) = +#endif + m { bmPatBind = mAlter env vs lhs + (toA $ mAlter env vs rhs f) (bmPatBind m) } + go AbsBinds{} = error "AbsBinds" + go PatSynBind{} = error "PatSynBind" + + mMatch :: MatchEnv -> Key BMap -> (Substitution, BMap a) -> [(Substitution, a)] + mMatch _ _ (_,BMEmpty) = [] + mMatch env b (hs,m@BM{}) = go b (hs,m) + where +#if __GLASGOW_HASKELL__ < 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 + go (VarBind _ _ e _) = mapFor bmVarBind >=> mMatch env e + go (PatBind _ lhs rhs _) +#endif + = mapFor bmPatBind >=> mMatch env lhs >=> mMatch env rhs + go _ = const [] -- TODO + +------------------------------------------------------------------------ + +data SMap a + = SMEmpty + | SM { smLastStmt :: EMap a + , smBindStmt :: PatMap (EMap a) + , smBodyStmt :: EMap a + -- TODO: the rest + } + deriving (Functor) + +emptySMapWrapper :: SMap a +emptySMapWrapper = SM mEmpty mEmpty mEmpty + +instance PatternMap SMap where + type Key SMap = LStmt GhcPs (LHsExpr GhcPs) + + mEmpty :: SMap a + mEmpty = SMEmpty + + mUnion :: SMap a -> SMap a -> SMap a + mUnion SMEmpty m = m + mUnion m SMEmpty = m + mUnion (SM a1 b1 c1) (SM a2 b2 c2) = + SM (mUnion a1 a2) (mUnion b1 b2) (mUnion c1 c2) + + mAlter :: AlphaEnv -> Quantifiers -> Key SMap -> A a -> SMap a -> SMap a + mAlter env vs s f SMEmpty = mAlter env vs s f emptySMapWrapper + mAlter env vs s f m@(SM {}) = go (unLoc s) + where +#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) } + go XStmtLR{} = error "XStmtLR" + go (BindStmt _ p e _ _) = +#endif + let bs = collectPatBinders p + env' = foldr extendAlphaEnvInternal env bs + vs' = vs `exceptQ` bs + in m { smBindStmt = mAlter env vs p + (toA (mAlter env' vs' e f)) (smBindStmt m) } + go LetStmt{} = error "LetStmt" + go ParStmt{} = error "ParStmt" + go TransStmt{} = error "TransStmt" + go RecStmt{} = error "RecStmt" + go ApplicativeStmt{} = error "ApplicativeStmt" + + mMatch :: MatchEnv -> Key SMap -> (Substitution, SMap a) -> [(Substitution, a)] + 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 + go (BindStmt _ p e _ _) = +#endif + let bs = collectPatBinders p + env' = extendMatchEnv env bs + in mapFor smBindStmt >=> mMatch env p >=> mMatch env' e + go _ = const [] -- TODO + +------------------------------------------------------------------------ + +data TyMap a + = TyEmpty + | TM { tyHole :: Map RdrName a -- See Note [Holes] + , tyHsTyVar :: VMap a + , tyHsFunTy :: TyMap (TyMap a) + , tyHsAppTy :: TyMap (TyMap a) +#if __GLASGOW_HASKELL__ < 806 + , tyHsAppsTy :: ListMap AppTyMap a +#endif + , tyHsParTy :: TyMap a + -- TODO: the rest + } + deriving (Functor) + +emptyTyMapWrapper :: TyMap a +emptyTyMapWrapper = + TM mEmpty mEmpty mEmpty mEmpty mEmpty +#if __GLASGOW_HASKELL__ < 806 + mEmpty +#endif + +instance PatternMap TyMap where + type Key TyMap = LHsType GhcPs + + mEmpty :: TyMap a + mEmpty = TyEmpty + + mUnion :: TyMap a -> TyMap a -> TyMap a + mUnion TyEmpty m = m + mUnion m TyEmpty = m +#if __GLASGOW_HASKELL__ < 806 + mUnion (TM a1 b1 c1 d1 e1 f1) (TM a2 b2 c2 d2 e2 f2) = + TM (mUnion a1 a2) (mUnion b1 b2) (mUnion c1 c2) (mUnion d1 d2) + (mUnion e1 e2) (mUnion f1 f2) +#else + mUnion (TM a1 b1 c1 d1 e1) (TM a2 b2 c2 d2 e2) = + TM (mUnion a1 a2) (mUnion b1 b2) (mUnion c1 c2) (mUnion d1 d2) + (mUnion e1 e2) +#endif + + 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 HsForAllTy{} = error "HsForAllTy" + go HsQualTy{} = error "HsQualTy" + go HsListTy{} = error "HsListTy" + go HsTupleTy{} = error "HsTupleTy" + go HsOpTy{} = error "HsOpTy" + go HsIParamTy{} = error "HsIParamTy" + go HsKindSig{} = error "HsKindSig" + go HsSpliceTy{} = error "HsSpliceTy" + go HsDocTy{} = error "HsDocTy" + go HsBangTy{} = error "HsBangTy" + go HsRecTy{} = error "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 (HsFunTy ty1 ty2) = m { tyHsFunTy = mAlter env vs ty1 (toA (mAlter env vs ty2 f)) (tyHsFunTy m) } + go (HsCoreTy _) = error "HsCoreTy" + go (HsEqTy _ _) = error "HsEqTy" + go (HsParTy ty') = m { tyHsParTy = mAlter env vs ty' f (tyHsParTy m) } + go (HsPArrTy _) = error "HsPArrTy" +#else + go (HsAppTy _ ty1 ty2) = m { tyHsAppTy = mAlter env vs ty1 (toA (mAlter env vs ty2 f)) (tyHsAppTy m) } + go (HsFunTy _ ty1 ty2) = m { tyHsFunTy = mAlter env vs ty1 (toA (mAlter env vs ty2 f)) (tyHsFunTy m) } + go (HsParTy _ ty') = m { tyHsParTy = mAlter env vs ty' f (tyHsParTy m) } + go HsStarTy{} = error "HsStarTy" + go XHsType{} = error "XHsType" +#endif + go HsExplicitListTy{} = error "HsExplicitListTy" + go HsExplicitTupleTy{} = error "HsExplicitTupleTy" + go HsTyLit{} = error "HsTyLit" + go HsWildCardTy{} = error "HsWildCardTy" + go HsSumTy{} = error "HsSumTy" +#if __GLASGOW_HASKELL__ < 808 +#else + go HsAppKindTy{} = error "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 (HsFunTy ty1 ty2) = mapFor tyHsFunTy >=> mMatch env ty1 >=> mMatch env ty2 + go (HsParTy ty') = mapFor tyHsParTy >=> mMatch env ty' + go (HsTyVar _ v) = mapFor tyHsTyVar >=> mMatch env (unLoc v) +#else + go (HsAppTy _ ty1 ty2) = mapFor tyHsAppTy >=> mMatch env ty1 >=> mMatch env ty2 + go (HsFunTy _ ty1 ty2) = mapFor tyHsFunTy >=> mMatch env ty1 >=> mMatch env ty2 + go (HsParTy _ ty') = mapFor tyHsParTy >=> mMatch env ty' + 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 (ATM a1 b1) (ATM a2 b2) = + ATM (mUnion a1 a2) (mUnion b1 b2) + + 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) } + + 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 +#endif + +------------------------------------------------------------------------ + +newtype RFMap a = RFM { rfmField :: VMap (EMap a) } + deriving (Functor) + +instance PatternMap RFMap where + type Key RFMap = LHsRecField' RdrName (LHsExpr GhcPs) + + mEmpty :: RFMap a + mEmpty = RFM mEmpty + + mUnion :: RFMap a -> RFMap a -> RFMap a + mUnion (RFM m1) (RFM m2) = RFM (mUnion m1 m2) + + mAlter :: AlphaEnv -> Quantifiers -> Key RFMap -> A a -> RFMap a -> RFMap a + mAlter env vs lf f m = go (unLoc lf) + where + go (HsRecField lbl arg _pun) = + m { rfmField = mAlter env vs (unLoc lbl) (toA (mAlter env vs arg f)) (rfmField m) } + + mMatch :: MatchEnv -> Key RFMap -> (Substitution, RFMap a) -> [(Substitution, a)] + mMatch env lf (hs,m) = go (unLoc lf) (hs,m) + where + go (HsRecField lbl arg _pun) = + mapFor rfmField >=> mMatch env (unLoc lbl) >=> mMatch env arg + +-- Helper class to collapse the complex encoding of record fields into RdrNames. +-- (The complexity is to support punning/duplicate/overlapping fields, which +-- all happens well after parsing, so is not needed here.) +class RecordFieldToRdrName f where + recordFieldToRdrName :: f -> RdrName + +#if __GLASGOW_HASKELL__ < 806 +instance RecordFieldToRdrName (AmbiguousFieldOcc p) where +#else +instance RecordFieldToRdrName (AmbiguousFieldOcc GhcPs) where +#endif + recordFieldToRdrName = rdrNameAmbiguousFieldOcc + +instance RecordFieldToRdrName (FieldOcc p) where + recordFieldToRdrName = unLoc . rdrNameFieldOcc + +fieldsToRdrNames + :: RecordFieldToRdrName f + => [LHsRecField' f arg] + -> [LHsRecField' RdrName arg] +fieldsToRdrNames = map go + where + go (L l (HsRecField (L l2 f) arg pun)) = + L l (HsRecField (L l2 (recordFieldToRdrName f)) arg pun) diff --git a/Retrie/Pretty.hs b/Retrie/Pretty.hs new file mode 100644 --- /dev/null +++ b/Retrie/Pretty.hs @@ -0,0 +1,71 @@ +-- 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. +-- +module Retrie.Pretty + ( noColor + , addColor + , ppSrcSpan + , ColoriseFun + , strip + , ppRepl + , linesMap + ) where + +import Data.Char +import Data.List +import Data.Maybe +import qualified Data.HashMap.Strict as HashMap +import System.Console.ANSI + +import Retrie.GHC + +type ColoriseFun = ColorIntensity -> Color -> String -> String + +noColor :: ColoriseFun +noColor _ _ = id + +addColor :: ColoriseFun +addColor intensity color x = mconcat + [ setSGRCode [SetColor Foreground intensity color] + , x + , setSGRCode [Reset] + ] + +-- | Pretty print location of the file. +ppSrcSpan :: ColoriseFun -> SrcSpan -> String +ppSrcSpan colorise spn = case srcSpanStart spn of + UnhelpfulLoc x -> unpackFS x + RealSrcLoc loc -> intercalate (colorise Dull Cyan ":") + [ colorise Dull Magenta $ unpackFS $ srcLocFile loc + , colorise Dull Green $ show $ srcLocLine loc + , colorise Dull Green $ show $ srcLocCol loc + , "" + ] + +-- | Get lines covering span and replace span with replacement string. +ppRepl :: HashMap.HashMap Int String -> SrcSpan -> String -> [String] +ppRepl lMap spn replacement = fromMaybe [replacement] $ do + startPos <- getRealLoc $ srcSpanStart spn + endPos <- getRealLoc $ srcSpanEnd spn + startLine <- getLine' startPos + endLine <- getLine' endPos + return $ lines $ mconcat + [ take (srcLocCol startPos - 1) startLine + , dropWhile isSpace replacement + , drop (srcLocCol endPos - 1) endLine + ] + where + getLine' pos = HashMap.lookup (srcLocLine pos) lMap + +-- | Return HashMap from line number to line of a file. +linesMap :: String -> IO (HashMap.HashMap Int String) +linesMap fp = HashMap.fromList . zip [1..] . lines <$> readFile fp + +getRealLoc :: SrcLoc -> Maybe RealSrcLoc +getRealLoc (RealSrcLoc x) = Just x +getRealLoc _ = Nothing + +strip :: String -> String +strip = dropWhileEnd isSpace . dropWhile isSpace diff --git a/Retrie/Quantifiers.hs b/Retrie/Quantifiers.hs new file mode 100644 --- /dev/null +++ b/Retrie/Quantifiers.hs @@ -0,0 +1,74 @@ +-- 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 TypeFamilies #-} +module Retrie.Quantifiers + ( Quantifiers + , emptyQs + , exceptQ + , isQ + , mkQs + , mkFSQs + , qList + , qSet + , unionQ + ) where + +import GHC.Exts (IsList(..)) +import Retrie.GHC + +------------------------------------------------------------------------ + +-- Note [Why not RdrNames?] +-- RdrNames carry their namespace in their OccName. The unification of holes +-- already handles the namespace more finely, so the extra distinction inside the +-- RdrName is just a pain when manipulating the substitution, checking for +-- equality, etc. + +-- Thus, Quantifiers are keyed on FastString (an OccName is a namespace plus +-- FastString, so this is just the OccName without its namespace). + +instance IsList Quantifiers where + type Item Quantifiers = String + + fromList = mkFSQs . map mkFastString + toList = map unpackFS . qList + +-- | 'Quantifiers' is a set of variable names. If you enable the +-- "OverloadedLists" language extension, you can construct using a literal +-- list of strings. +newtype Quantifiers = Quantifiers + { qSet :: UniqSet FastString + -- ^ Convert to a 'UniqSet'. + } + +-- | Construct from GHC's 'RdrName's. +mkQs :: [RdrName] -> Quantifiers +mkQs = mkFSQs . map rdrFS + +-- | Construct from 'FastString's. +mkFSQs :: [FastString] -> Quantifiers +mkFSQs = Quantifiers . mkUniqSet + +-- | The empty set. +emptyQs :: Quantifiers +emptyQs = Quantifiers emptyUniqSet + +-- | Existence check. +isQ :: RdrName -> Quantifiers -> Bool +isQ r (Quantifiers s) = elementOfUniqSet (rdrFS r) s + +-- | Set union. +unionQ :: Quantifiers -> Quantifiers -> Quantifiers +unionQ (Quantifiers s) (Quantifiers t) = Quantifiers $ unionUniqSets s t + +-- | Remove a set of 'RdrName's from the set. +exceptQ :: Quantifiers -> [RdrName] -> Quantifiers +exceptQ (Quantifiers s) rs = + Quantifiers $ delListFromUniqSet s (map rdrFS rs) + +-- | Convert to a list. +qList :: Quantifiers -> [FastString] +qList (Quantifiers s) = nonDetEltsUniqSet s diff --git a/Retrie/Query.hs b/Retrie/Query.hs new file mode 100644 --- /dev/null +++ b/Retrie/Query.hs @@ -0,0 +1,66 @@ +-- 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 RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +module Retrie.Query + ( QuerySpec(..) + , parseQuerySpecs + , genericQ + ) where + +import Retrie.ExactPrint +import Retrie.Fixity +import Retrie.GHC +import Retrie.Quantifiers +import Retrie.Substitution +import Retrie.SYB +import Retrie.Types +import Retrie.Universe + +-- | Specifies which parser to use in 'Retrie.parseQueries'. +data QuerySpec + = QExpr String + | QType String + | QStmt String + +parseQuerySpecs + :: FixityEnv + -> [(Quantifiers, QuerySpec, v)] + -> IO [Query Universe v] +parseQuerySpecs fixityEnv = + mapM $ \(qQuantifiers, querySpec, qResult) -> do + qPattern <- parse querySpec + return Query{..} + where + parse (QExpr s) = do + e <- parseExpr s + fmap inject <$> transformA e (fix fixityEnv) + parse (QType s) = fmap inject <$> parseType s + parse (QStmt s) = do + stmt <- parseStmt s + fmap inject <$> transformA stmt (fix fixityEnv) + +genericQ + :: Typeable a + => Matcher v + -> Context + -> a + -> TransformT IO [(Context, Substitution, v)] +genericQ m ctxt = + mkQ (return []) (genericQImpl @(LHsExpr GhcPs) m ctxt) + `extQ` (genericQImpl @(LStmt GhcPs (LHsExpr GhcPs)) m ctxt) + `extQ` (genericQImpl @(LHsType GhcPs) m ctxt) + +genericQImpl + :: forall ast v. Matchable ast + => Matcher v + -> Context + -> ast + -> TransformT IO [(Context, Substitution, v)] +genericQImpl m ctxt ast = do + pairs <- runMatcher ctxt m ast + return [ (ctxt, sub, v) | (sub, v) <- pairs ] diff --git a/Retrie/Replace.hs b/Retrie/Replace.hs new file mode 100644 --- /dev/null +++ b/Retrie/Replace.hs @@ -0,0 +1,137 @@ +-- 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 FlexibleContexts #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +module Retrie.Replace + ( replace + , Replacement(..) + , Change(..) + ) where + +import Control.Monad.Trans.Class +import Control.Monad.Writer.Strict +import Data.Char (isSpace) +import Data.Generics + +import Retrie.ExactPrint +import Retrie.Expr +import Retrie.FreeVars +import Retrie.GHC +import Retrie.Subst +import Retrie.Types +import Retrie.Universe +import Retrie.Util + +------------------------------------------------------------------------ + +-- | Specializes 'replaceImpl' to each of the AST types that retrie supports. +replace + :: (Data a, MonadIO m) => Context -> a -> TransformT (WriterT Change m) a +replace c = + mkM (replaceImpl @(HsExpr GhcPs) c) + `extM` (replaceImpl @(Stmt GhcPs (LHsExpr GhcPs)) c) + `extM` (replaceImpl @(HsType GhcPs) c) + +-- | 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. +replaceImpl + :: forall ast m. (Annotate ast, Matchable (Located ast), MonadIO m) + => Context -> Located ast -> TransformT (WriterT Change m) (Located ast) +replaceImpl c e = do + let + -- Prevent rewriting source of the rewrite itself by refusing to + -- match under a binding of something that appears in the template. + f result@RewriterResult{..} = result + { rrTransformer = + fmap (fmap (check rrOrigin rrQuantifiers)) <$> rrTransformer + } + check origin quantifiers match + | getLoc e `overlaps` origin = NoMatch + | MatchResult _ Template{..} <- match + , capturesFVs quantifiers (ctxtBinders c) (astA tTemplate) = NoMatch + | otherwise = match + + match <- runRewriter f c (ctxtRewriter c) (getUnparened e) + + case match of + NoMatch -> return e + MatchResult sub Template{..} -> do + -- graft template into target module + t' <- graftA tTemplate + -- substitute for quantifiers in grafted template + r <- subst sub c t' + -- 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 + -- prune the resulting expression and log it with location + orig <- printNoLeadingSpaces <$> pruneA e + repl <- printNoLeadingSpaces <$> pruneA res + let replacement = Replacement (getLoc e) orig repl + TransformT $ lift $ tell $ Change [replacement] [tImports] + -- make the actual replacement + return res + +-- | Records a replacement made. In cases where we cannot use ghc-exactprint +-- to print the resulting AST (e.g. CPP modules), we fall back on splicing +-- strings. Can also be used by external tools (search, linters, etc). +data Replacement = Replacement + { replLocation :: SrcSpan + , replOriginal :: String + , replReplacement :: String + } + +-- | Used as the writer type during matching to indicate whether any change +-- to the module should be made. +data Change = NoChange | Change [Replacement] [AnnotatedImports] + +instance Semigroup Change where + (<>) = mappend + +instance Monoid Change where + mempty = NoChange + mappend NoChange other = other + 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 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 + +-- 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 +-- annEntryDelta of the first token is non-zero). This means we can't just +-- splice in the printed expression at the desired location and call it a day. +-- Unfortunately, its hard to find the right annEntryDelta (it may not be the +-- top of the redex) and zero it out. As janky as it seems, its easier to just +-- drop leading spaces like this. +printNoLeadingSpaces :: Annotate k => Annotated (Located k) -> String +printNoLeadingSpaces = dropWhile isSpace . printA diff --git a/Retrie/Rewrites.hs b/Retrie/Rewrites.hs new file mode 100644 --- /dev/null +++ b/Retrie/Rewrites.hs @@ -0,0 +1,182 @@ +-- 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 OverloadedStrings #-} +module Retrie.Rewrites + ( RewriteSpec(..) + , QualifiedName + , parseRewriteSpecs + , parseQualified + , parseAdhocs + ) where + +import Control.Exception +import Data.Either (partitionEithers) +import qualified Data.Map as Map +import qualified Data.Text as Text +import Data.Traversable +import System.FilePath + +import Retrie.CPP +import Retrie.ExactPrint +import Retrie.Fixity +import Retrie.GHC +import Retrie.Rewrites.Function +import Retrie.Rewrites.Rules +import Retrie.Rewrites.Types +import Retrie.Types +import Retrie.Universe + +-- | A qualified name. (e.g. @"Module.Name.functionName"@) +type QualifiedName = String + +-- | Possible ways to specify rewrites to 'parseRewrites'. +data RewriteSpec + = Adhoc String + -- ^ Equation in RULES-format. (e.g. @"forall x. succ (pred x) = x"@) + -- Will be applied left-to-right. + | Fold QualifiedName + -- ^ Fold a function definition. The inverse of unfolding/inlining. + -- Replaces instances of the function body with calls to the function. + | RuleBackward QualifiedName + -- ^ Apply a GHC RULE right-to-left. + | RuleForward QualifiedName + -- ^ Apply a GHC RULE left-to-right. + | TypeBackward QualifiedName + -- ^ Apply a type synonym right-to-left. + | TypeForward QualifiedName + -- ^ Apply a type synonym left-to-right. + | Unfold QualifiedName + -- ^ Unfold, or inline, a function definition. + +parseRewriteSpecs + :: (FilePath -> IO (CPP AnnotatedModule)) + -> FixityEnv + -> [RewriteSpec] + -> IO [Rewrite Universe] +parseRewriteSpecs parser fixityEnv specs = do + (adhocs, fileBased) <- partitionEithers <$> sequence + [ case spec of + Adhoc rule -> return $ Left rule + 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 + Unfold name -> mkFileBased FoldUnfold LeftToRight name + | spec <- specs + ] + fbRewrites <- parseFileBased parser fileBased + adhocRewrites <- parseAdhocs fixityEnv adhocs + return $ fbRewrites ++ adhocRewrites + where + mkFileBased ty dir name = + case parseQualified name of + Left err -> throwIO $ ErrorCall $ "parseRewriteSpecs: " ++ err + Right (fp, fs) -> return $ Right (fp, [(ty, [(fs, dir)])]) + +data FileBasedTy = FoldUnfold | Rule | Type + deriving (Eq, Ord) + +parseFileBased + :: (FilePath -> IO (CPP AnnotatedModule)) + -> [(FilePath, [(FileBasedTy, [(FastString, Direction)])])] + -> IO [Rewrite Universe] +parseFileBased _ [] = return [] +parseFileBased parser specs = concat <$> mapM (uncurry goFile) (gather specs) + where + gather :: Ord a => [(a,[b])] -> [(a,[b])] + gather = Map.toList . Map.fromListWith (++) + + goFile + :: FilePath + -> [(FileBasedTy, [(FastString, Direction)])] + -> IO [Rewrite Universe] + goFile fp rules = do + cpp <- parser fp + concat <$> mapM (uncurry $ constructRewrites cpp) (gather rules) + +parseAdhocs :: FixityEnv -> [String] -> IO [Rewrite Universe] +parseAdhocs _ [] = return [] +parseAdhocs fixities adhocs = do + cpp <- + parseCPP (parseContent fixities "parseAdhocs") (Text.unlines adhocRules) + constructRewrites cpp Rule adhocSpecs + where + -- In search mode, there is no need to specify a right-hand side, but we + -- need one to parse as a RULE, so add it if necessary. + addRHS s + | '=' `elem` s = s + | otherwise = s ++ " = undefined" + (adhocSpecs, adhocRules) = unzip + [ ( (mkFastString nm, LeftToRight) + , "{-# RULES \"" <> Text.pack nm <> "\" " <> Text.pack s <> " #-}" + ) + | (i,s) <- zip [1..] $ map addRHS adhocs + , let nm = "adhoc" ++ show (i::Int) + ] + +constructRewrites + :: CPP AnnotatedModule + -> FileBasedTy + -> [(FastString, Direction)] + -> IO [Rewrite Universe] +constructRewrites cpp ty specs = do + cppM <- traverse (tyBuilder ty specs) cpp + let + names = nonDetEltsUniqSet $ mkUniqSet $ map fst specs + + nameOf FoldUnfold = "definition" + nameOf Rule = "rule" + nameOf Type = "type synonym" + + m = foldr (plusUFM_C (++)) emptyUFM cppM + + fmap concat $ forM names $ \fs -> + case lookupUFM m fs of + Nothing -> + fail $ "could not find " ++ nameOf ty ++ " named " ++ unpackFS fs + Just rrs -> return rrs + +tyBuilder + :: FileBasedTy + -> [(FastString, Direction)] + -> AnnotatedModule + -> IO (UniqFM [Rewrite Universe]) +tyBuilder FoldUnfold specs am = promote <$> dfnsToRewrites specs am +tyBuilder Rule specs am = promote <$> rulesToRewrites specs am +tyBuilder Type specs am = promote <$> typeSynonymsToRewrites specs am + +promote :: Matchable a => UniqFM [Rewrite a] -> UniqFM [Rewrite Universe] +promote = fmap (map toURewrite) + +parseQualified :: String -> Either String (FilePath, FastString) +parseQualified [] = Left "qualified name is empty" +parseQualified fqName = + case span isHsSymbol reversed of + (_,[]) -> mkError "unqualified operator name" + ([],_) -> + case span (/='.') reversed of + (_,[]) -> mkError "unqualified function name" + (rname,_:rmod) -> mkResult (reverse rmod) (reverse rname) + (rop,rmod) -> + case reverse rop of + '.':op -> mkResult (reverse rmod) op + _ -> mkError "malformed qualified operator" + where + reversed = reverse fqName + mkError str = Left $ str ++ ": " ++ fqName + mkResult moduleNameStr occNameStr = Right + -- 'moduleNameSlashes' gives us system-dependent path separator + ( moduleNameSlashes (mkModuleName moduleNameStr) <.> "hs" + , mkFastString occNameStr + ) + +isHsSymbol :: Char -> Bool +isHsSymbol = (`elem` symbols) + -- see https://www.haskell.org/onlinereport/lexemes.html + where + symbols :: String + symbols = "!#$%&*+./<=>?@\\^|-~" diff --git a/Retrie/Rewrites/Function.hs b/Retrie/Rewrites/Function.hs new file mode 100644 --- /dev/null +++ b/Retrie/Rewrites/Function.hs @@ -0,0 +1,145 @@ +-- 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 TupleSections #-} +module Retrie.Rewrites.Function (dfnsToRewrites) where + +import Control.Monad +import Control.Monad.State.Lazy +import Data.List +import Data.Maybe +import Data.Traversable + +import Retrie.ExactPrint +import Retrie.Expr +import Retrie.GHC +import Retrie.Quantifiers +import Retrie.Types +import Retrie.Util + +dfnsToRewrites + :: [(FastString, Direction)] + -> AnnotatedModule + -> IO (UniqFM [Rewrite (LHsExpr GhcPs)]) +dfnsToRewrites specs am = fmap astA $ transformA am $ \ (L _ m) -> do + let + fsMap = uniqBag specs + + rrs <- sequence + [ do + fe <- mkLocatedHsVar fRdrName + 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) + ] + + return $ listToUFM_C (++) rrs + +------------------------------------------------------------------------ + +getImports + :: Direction -> Maybe (Located ModuleName) -> TransformT IO AnnotatedImports +getImports RightToLeft (Just (L _ mn)) = -- See Note [fold only] + lift $ liftIO $ parseImports ["import " ++ moduleNameString mn] +getImports _ _ = return mempty + +matchToRewrites + :: LHsExpr GhcPs + -> AnnotatedImports + -> Direction + -> LMatch GhcPs (LHsExpr GhcPs) + -> TransformT IO [Rewrite (LHsExpr GhcPs)] +matchToRewrites e imps dir (L _ alt) = do + let + pats = m_pats alt + grhss = m_grhss alt + qss <- for (zip (inits pats) (tails pats)) $ + makeFunctionQuery e imps dir grhss mkApps + qs <- backtickRules e imps dir grhss pats + return $ qs ++ concat qss + +type AppBuilder = + LHsExpr GhcPs -> [LHsExpr GhcPs] -> TransformT IO (LHsExpr GhcPs) + +makeFunctionQuery + :: LHsExpr GhcPs + -> AnnotatedImports + -> Direction + -> GRHSs GhcPs (LHsExpr GhcPs) + -> AppBuilder + -> ([LPat GhcPs], [LPat GhcPs]) + -> TransformT IO [Rewrite (LHsExpr GhcPs)] +makeFunctionQuery e imps dir grhss mkAppFn (argpats, bndpats) = 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) + lhs <- mkAppFn e es + for rhss $ \ grhs -> do + le <- mkLet (unLoc lbs) (grhsToExpr grhs) + rhs <- mkLams bndpats le + let + (pat, temp) = + case dir of + LeftToRight -> (lhs,rhs) + RightToLeft -> (rhs,lhs) + p <- pruneA pat + t <- pruneA temp + return $ addRewriteImports imps $ mkRewrite (mkQs bs') p t + +backtickRules + :: LHsExpr GhcPs + -> AnnotatedImports + -> Direction + -> GRHSs GhcPs (LHsExpr GhcPs) + -> [LPat GhcPs] + -> TransformT IO [Rewrite (LHsExpr GhcPs)] +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 noExt l op r) + both _ _ = fail "backtickRules - both: impossible!" + + left op [l] = mkLoc (SectionL noExt l op) + left _ _ = fail "backtickRules - left: impossible!" + + right op [r] = mkLoc (SectionR noExt 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]) + return $ qs ++ qsl ++ qsr +backtickRules _ _ _ _ _ = return [] + +-- Note [fold only] +-- Currently we only generate imports for folds, because it is easy. +-- (We only need to add an import for the module defining the folded +-- function.) Generating the imports for unfolds will require some +-- sort of analysis with haskell-names and is a TODO. diff --git a/Retrie/Rewrites/Rules.hs b/Retrie/Rewrites/Rules.hs new file mode 100644 --- /dev/null +++ b/Retrie/Rewrites/Rules.hs @@ -0,0 +1,43 @@ +-- 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 RecordWildCards #-} +module Retrie.Rewrites.Rules (rulesToRewrites) where + +import Data.Generics +import Data.Maybe + +import Retrie.ExactPrint +import Retrie.GHC +import Retrie.Quantifiers +import Retrie.Types +import Retrie.Util + +rulesToRewrites + :: [(FastString, Direction)] + -> AnnotatedModule + -> IO (UniqFM [Rewrite (LHsExpr GhcPs)]) +rulesToRewrites specs am = fmap astA $ transformA am $ \ m -> do + let + fsMap = uniqBag specs + + uniqBag <$> sequence + [ mkRuleRewrite dir info + | info@RuleInfo{..} <- everything (++) (mkQ [] ruleInfo) m + , dir <- fromMaybe [] (lookupUFM fsMap riName) + ] + +------------------------------------------------------------------------ + +mkRuleRewrite + :: Direction + -> RuleInfo + -> TransformT IO (RuleName, Rewrite (LHsExpr GhcPs)) +mkRuleRewrite RightToLeft (RuleInfo name qs lhs rhs) = + mkRuleRewrite LeftToRight (RuleInfo name qs rhs lhs) +mkRuleRewrite _ RuleInfo{..} = do + p <- pruneA riLHS + t <- pruneA riRHS + return (riName, mkRewrite (mkQs riQuantifiers) p t) diff --git a/Retrie/Rewrites/Types.hs b/Retrie/Rewrites/Types.hs new file mode 100644 --- /dev/null +++ b/Retrie/Rewrites/Types.hs @@ -0,0 +1,66 @@ +-- 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 RankNTypes #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +module Retrie.Rewrites.Types where + +import Control.Monad +import Data.Maybe + +import Retrie.ExactPrint +import Retrie.Expr +import Retrie.GHC +import Retrie.Quantifiers +import Retrie.Types +import Retrie.Util + +typeSynonymsToRewrites + :: [(FastString, Direction)] + -> AnnotatedModule + -> IO (UniqFM [Rewrite (LHsType GhcPs)]) +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) + ] + fmap uniqBag $ + forM tySyns $ \(rdr, args) -> (rdr,) <$> uncurry mkTypeRewrite args + +------------------------------------------------------------------------ + +-- | Compile a list of RULES into a list of rewrites. +mkTypeRewrite + :: Direction + -> (Located RdrName, [LHsTyVarBndr GhcPs], LHsType GhcPs) + -> TransformT IO (Rewrite (LHsType GhcPs)) +mkTypeRewrite d (lhsName, vars, rhs) = do + setEntryDPT lhsName $ DP (0,0) + tc <- mkTyVar lhsName + let + lvs = tyBindersToLocatedRdrNames vars + args <- forM lvs $ \ lv -> do + tv <- mkTyVar lv + setEntryDPT tv (DP (0,1)) + return tv + lhsApps <- mkHsAppsTy (tc:args) + let + (pat, tmp) = case d of + LeftToRight -> (lhsApps, rhs) + RightToLeft -> (rhs, lhsApps) + p <- pruneA pat + t <- pruneA tmp + return $ mkRewrite (mkQs $ map unLoc lvs) p t diff --git a/Retrie/Run.hs b/Retrie/Run.hs new file mode 100644 --- /dev/null +++ b/Retrie/Run.hs @@ -0,0 +1,163 @@ +-- 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 RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +module Retrie.Run + ( runScript + , runScriptWithModifiedOptions + , execute + , run + , WriteFn + , writeCountLines + , writeDiff + , writeSearch + , writeExtract + ) where + +import Control.Monad.State.Strict +import Data.Char +import Data.Default +import Data.List +import Data.Monoid +import System.Console.ANSI + +import Retrie.CPP +import Retrie.ExactPrint +import Retrie.Monad +import Retrie.Options +import Retrie.Pretty +import Retrie.Replace +import Retrie.Util + +-- | Define a custom refactoring script. +-- A script is an 'IO' action that defines a 'Retrie' computation. The 'IO' +-- action is run once, and the resulting 'Retrie' computation is run once +-- for each target file. Typically, rewrite parsing/construction is done in +-- the 'IO' action, so it is performed only once. Example: +-- +-- > module Main where +-- > +-- > main :: IO () +-- > main = runScript $ \opts -> do +-- > rr <- parseRewrites opts ["forall f g xs. map f (map g xs) = map (f . g) xs"] +-- > return $ apply rr +-- +-- To run the script, compile the program and execute it. +runScript :: (Options -> IO (Retrie ())) -> IO () +runScript f = runScriptWithModifiedOptions (\opts -> (opts,) <$> f opts) + +-- | Define a custom refactoring script and run it with modified options. +-- This is the same as 'runScript', but the returned 'Options' will be used +-- during rewriting. +runScriptWithModifiedOptions :: (Options -> IO (Options, Retrie ())) -> IO () +runScriptWithModifiedOptions f = do + opts <- parseOptions def + (opts', retrie) <- f opts + execute opts' retrie + +-- | Implements retrie's iteration and execution modes. +execute :: Options -> Retrie () -> IO () +execute opts@Options{..} retrie0 = do + let retrie = iterateR iterateN retrie0 + case executionMode of + ExecDryRun -> void $ run (writeDiff opts) id opts retrie + ExecExtract -> void $ run (writeExtract opts) id opts retrie + ExecRewrite -> do + s <- mconcat <$> run writeCountLines id opts retrie + when (verbosity > Silent) $ + putStrLn $ "Done! " ++ show (getSum s) ++ " lines changed." + ExecSearch -> void $ run (writeSearch opts) id opts retrie + +-- | Callback function to actually write the resulting file back out. +-- Is given list of changed spans, module contents, and user-defined data. +type WriteFn a b = [Replacement] -> String -> a -> IO b + +-- | Primitive means of running a 'Retrie' computation. +run + :: Monoid b + => (FilePath -> WriteFn a b) + -- ^ write action when a file changes, unchanged files result in 'mempty' + -> (IO b -> IO c) -- ^ wrap per-file rewrite action + -> Options -> Retrie a -> IO [c] +run writeFn wrapper opts@Options{..} r = do + fps <- getTargetFiles opts (getGroundTerms r) + forFn opts fps $ \ fp -> wrapper $ do + debugPrint verbosity "Processing:" [fp] + p <- trySync $ parseCPPFile (parseContent fixityEnv) fp + case p of + Left ex -> do + when (verbosity > Silent) $ print ex + return mempty + Right cpp -> runOneModule (writeFn fp) opts r cpp + +-- | Run a 'Retrie' computation on the given parsed module, writing +-- changes with the given write action. +runOneModule + :: Monoid b + => WriteFn a b + -- ^ write action if the module changes, unchanged module returns 'mempty' + -> Options + -> Retrie a + -> CPP AnnotatedModule + -> IO b +runOneModule writeFn Options{..} r cpp = do + (x, cpp', changed) <- runRetrie fixityEnv r cpp + case changed of + NoChange -> return mempty + Change repls imports -> do + let cpp'' = addImportsCPP (additionalImports:imports) cpp' + writeFn repls (printCPP repls cpp'') x + +-- | Write action which counts changed lines using 'diff' +writeCountLines :: FilePath -> WriteFn a (Sum Int) +writeCountLines fp reps str _ = do + let lc = lineCount $ map replLocation reps + putStrLn $ "Writing: " ++ fp ++ " (" ++ show lc ++ " lines changed)" + writeFile fp str + return $ Sum lc + +-- | Print the lines before replacement and after replacement. +writeDiff :: Options -> FilePath -> WriteFn a (Sum Int) +writeDiff Options{..} fp repls _ _ = do + fl <- linesMap fp + forM_ repls $ \Replacement{..} -> do + let ppLines lineStart color = unlines + . map (lineStart ++) + . ppRepl fl replLocation + . colorise Vivid color + putStrLn $ mconcat + [ ppSrcSpan colorise replLocation + , "\n" + , ppLines "- " Red replOriginal + , ppLines "+ " Green replReplacement + ] + return $ Sum $ lineCount $ map replLocation repls + +-- | Print lines that match the query and highligh the matched string. +writeSearch :: Options -> FilePath -> WriteFn a () +writeSearch Options{..} fp repls _ _ = do + fl <- linesMap fp + forM_ repls $ \Replacement{..} -> + putStrLn $ mconcat + [ ppSrcSpan colorise replLocation + , ppLine + $ ppRepl fl replLocation + $ colorise Vivid Red replOriginal + ] + where + ppLine [] = "" + ppLine [x] = strip x + ppLine xs = '\n': dropWhileEnd isSpace (unlines xs) + +-- | Print only replacement. +writeExtract :: Options -> FilePath -> WriteFn a () +writeExtract Options{..} _ repls _ _ = do + forM_ repls $ \Replacement{..} -> do + putStrLn $ mconcat + [ ppSrcSpan colorise replLocation + , strip replReplacement + ] diff --git a/Retrie/SYB.hs b/Retrie/SYB.hs new file mode 100644 --- /dev/null +++ b/Retrie/SYB.hs @@ -0,0 +1,96 @@ +-- 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 BangPatterns #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Retrie.SYB + ( everywhereMWithContextBut + , GenericCU + , GenericMC + , Strategy + , topDown + , bottomUp + , everythingMWithContextBut + , GenericMCQ + , module Data.Generics + ) where + +import Control.Monad +import Data.Generics hiding (Fixity(..)) + +-- | Monadic rewrite with context +type GenericMC m c = forall a. Data a => c -> a -> m a + +-- | Context update: +-- Given current context, child number, and parent, create new context +type GenericCU m c = forall a. Data a => c -> Int -> a -> m c + +-- | Monadic traversal with pruning and context propagation. +everywhereMWithContextBut + :: forall m c. Monad m + => Strategy m -- ^ Traversal order (see 'topDown' and 'bottomUp') + -> GenericQ Bool -- ^ Short-circuiting stop condition + -> GenericCU m c -- ^ Context update function + -> GenericMC m c -- ^ Context-aware rewrite + -> GenericMC m c +everywhereMWithContextBut strategy stop upd f = go + where + go :: GenericMC m c + go ctxt x + | stop x = return x + | otherwise = strategy (f ctxt) (h ctxt) x + + h ctxt parent = gforMIndexed parent $ \i child -> do + ctxt' <- upd ctxt i parent + go ctxt' child + +type GenericMCQ m c r = forall a. Data a => c -> a -> m r + +-- | Monadic query with pruning and context propagation. +everythingMWithContextBut + :: forall m c r. (Monad m, Monoid r) + => GenericQ Bool -- ^ Short-circuiting stop condition + -> GenericCU m c -- ^ Context update function + -> GenericMCQ m c r -- ^ Context-aware query + -> GenericMCQ m c r +everythingMWithContextBut stop upd q = go + where + go :: GenericMCQ m c r + go ctxt x + | stop x = return mempty + | otherwise = do + r <- q ctxt x + rs <- gforQIndexed x $ \i child -> do + ctxt' <- upd ctxt i x + go ctxt' child + return $ mconcat (r:rs) + +-- | Traversal strategy. +-- Given a rewrite on the node and a rewrite on the node's children, define +-- a composite rewrite. +type Strategy m = forall a. Monad m => (a -> m a) -> (a -> m a) -> a -> m a + +-- | Perform a top-down traversal. +topDown :: Strategy m +topDown p cs = p >=> cs + +-- | Perform a bottom-up traversal. +bottomUp :: Strategy m +bottomUp p cs = cs >=> p + +-- | 'gmapM' with arguments flipped and providing zero-based index of child +-- to mapped function. +gforMIndexed + :: (Monad m, Data a) => a -> (forall d. Data d => Int -> d -> m d) -> m a +gforMIndexed x f = snd (gmapAccumM (accumIndex f) (-1) x) +-- -1 is constructor, 0 is first child + +accumIndex :: (Int -> a -> b) -> Int -> a -> (Int, b) +accumIndex f i y = let !i' = i+1 in (i', f i' y) + +gforQIndexed + :: (Monad m, Data a) => a -> (forall d. Data d => Int -> d -> m r) -> m [r] +gforQIndexed x f = sequence $ snd $ gmapAccumQ (accumIndex f) (-1) x diff --git a/Retrie/Subst.hs b/Retrie/Subst.hs new file mode 100644 --- /dev/null +++ b/Retrie/Subst.hs @@ -0,0 +1,135 @@ +-- 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 ViewPatterns #-} +module Retrie.Subst (subst) where + +import Control.Monad.Writer.Strict +import Data.Generics + +import Retrie.Context +import Retrie.ExactPrint +import Retrie.Expr +import Retrie.GHC +import Retrie.Substitution +import Retrie.SYB +import Retrie.Types + +------------------------------------------------------------------------ + +-- | Perform the given 'Substitution' on an AST, avoiding variable capture +-- by alpha-renaming binders as needed. +subst + :: (MonadIO m, Data ast) + => Substitution + -> Context + -> ast + -> TransformT m ast +subst sub ctxt = + everywhereMWithContextBut bottomUp (const False) updateContext f ctxt' + where + ctxt' = ctxt { ctxtSubst = Just sub } + f c = + mkM (substExpr c) + `extM` substPat c + `extM` substType c + `extM` substHsMatchContext c + `extM` substBind c + +lookupHoleVar :: RdrName -> Context -> Maybe HoleVal +lookupHoleVar rdr ctxt = do + sub <- ctxtSubst ctxt + lookupSubst (rdrFS rdr) sub + +substExpr + :: Monad m + => 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) + comments <- hasComments e' + unless comments $ transferEntryDPT e e' + 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 + +substPat + :: Monad m + => 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 + case lookupHoleVar v ctxt of + Just (HolePat pA) -> do + p' <- graftA pA + transferEntryAnnsT isComma p p' + return 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 + +substType + :: Monad m + => Context + -> LHsType GhcPs + -> TransformT m (LHsType GhcPs) +substType ctxt ty + | Just (L _ v) <- tyvarRdrName (unLoc ty) + , Just (HoleType tyA) <- lookupHoleVar v ctxt = do + ty' <- graftA (unparenT <$> tyA) + transferEntryAnnsT isComma ty ty' + parenifyT ctxt ty' +substType _ ty = return ty + +-- You might reasonably think that we would replace the RdrName in FunBind... +-- but no, exactprint only cares about the RdrName in the MatchGroup matches, +-- which are here. In case that changes in the future, we define substBind too. +substHsMatchContext + :: Monad m + => Context + -> HsMatchContext RdrName + -> TransformT m (HsMatchContext RdrName) +substHsMatchContext ctxt (FunRhs (L l v) f s) + | Just (HoleRdr rdr) <- lookupHoleVar v ctxt = + return $ FunRhs (L l rdr) f s +substHsMatchContext _ other = return other + +substBind + :: Monad m + => Context + -> HsBind GhcPs + -> TransformT m (HsBind GhcPs) +substBind ctxt fb@FunBind{} + | L l v <- fun_id fb + , Just (HoleRdr rdr) <- lookupHoleVar v ctxt = + return fb { fun_id = L l rdr } +substBind _ other = return other diff --git a/Retrie/Substitution.hs b/Retrie/Substitution.hs new file mode 100644 --- /dev/null +++ b/Retrie/Substitution.hs @@ -0,0 +1,57 @@ +-- 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. +-- +module Retrie.Substitution + ( Substitution + , HoleVal(..) + , emptySubst + , extendSubst + , lookupSubst + , deleteSubst + , foldSubst + ) where + +import Retrie.ExactPrint +import Retrie.GHC + +-- | A 'Substitution' is essentially a map from variable name to 'HoleVal'. +newtype Substitution = Substitution (UniqFM (FastString, HoleVal)) +-- See Note [Why not RdrNames?] for explanation of use of FastString + +instance Show Substitution where + show (Substitution m) = show (eltsUFM m) + +-- | Sum type of possible substitution values. +data HoleVal + = HoleExpr AnnotatedHsExpr -- ^ 'HsExpr' + | HolePat AnnotatedPat -- ^ 'Pat' + | HoleType AnnotatedHsType -- ^ 'HsType' + | HoleRdr RdrName -- ^ Alpha-renamed binder. + +instance Show HoleVal where + show (HoleExpr e) = "HoleExpr " ++ printA e + show (HolePat p) = "HolePat " ++ printA p + show (HoleType t) = "HoleType " ++ printA t + show (HoleRdr r) = "HoleRdr " ++ unpackFS (rdrFS r) + +-- | The empty substitution. +emptySubst :: Substitution +emptySubst = Substitution emptyUFM + +-- | Lookup a value in the substitution. +lookupSubst :: FastString -> Substitution -> Maybe HoleVal +lookupSubst k (Substitution m) = snd <$> lookupUFM m k + +-- | Extend the substitution. If the key already exists, its value is replaced. +extendSubst :: Substitution -> FastString -> HoleVal -> Substitution +extendSubst (Substitution m) k v = Substitution (addToUFM m k (k,v)) + +-- | Delete from the substitution. +deleteSubst :: Substitution -> [FastString] -> Substitution +deleteSubst (Substitution m) ks = Substitution (delListFromUFM m ks) + +-- | Fold over the substitution. +foldSubst :: ((FastString, HoleVal) -> a -> a) -> a -> Substitution -> a +foldSubst f x (Substitution m) = foldUFM f x m diff --git a/Retrie/Types.hs b/Retrie/Types.hs new file mode 100644 --- /dev/null +++ b/Retrie/Types.hs @@ -0,0 +1,352 @@ +-- 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 DeriveFunctor #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} +module Retrie.Types + ( Direction(..) + -- * Queries and Matchers + , Query(..) + , Matcher(..) + , mkMatcher + , mkLocalMatcher + , runMatcher + -- * Rewrites and Rewriters + , Rewrite + , mkRewrite + , Rewriter + , mkRewriter + , mkLocalRewriter + , runRewriter + , MatchResult(..) + , Template(..) + , MatchResultTransformer + , defaultTransformer + -- ** Functions on Rewrites + , addRewriteImports + , setRewriteTransformer + , toURewrite + , fromURewrite + , ppRewrite + , rewritesWithDependents + -- * Internal + , RewriterResult(..) + , ParentPrec(..) + , Context(..) + ) where + +import Control.Monad.IO.Class +import Control.Monad.State +import Data.Bifunctor +import qualified Data.IntMap.Strict as I +import Data.Maybe + +import Retrie.AlphaEnv +import Retrie.ExactPrint +import Retrie.Fixity +import Retrie.GHC +import Retrie.PatternMap.Class +import Retrie.Quantifiers +import Retrie.Substitution +import Retrie.Universe + +-- | 'Context' maintained by AST traversals. +data Context = Context + { ctxtBinders :: [RdrName] + -- ^ Stack of bindings of which we are currently in the right-hand side. + -- Used to avoid introducing self-recursion. + , ctxtDependents :: Rewriter + -- ^ The rewriter we apply to determine whether to add context-dependent + -- rewrites to 'ctxtRewriter'. We keep this separate because most of the time + -- it is empty, and we don't want to match every rewrite twice. + , ctxtFixityEnv :: FixityEnv + -- ^ Current FixityEnv. + , ctxtInScope :: AlphaEnv + -- ^ In-scope local bindings. Used to detect shadowing. + , ctxtParentPrec :: ParentPrec + -- ^ Precedence of parent + -- (app = HasPrec 10, infix op = HasPrec $ op precedence) + , ctxtRewriter :: Rewriter + -- ^ The rewriter we should use to mutate the code. + , ctxtSubst :: Maybe Substitution + -- ^ If present, update substitution with binder renamings. + -- Used to implement capture-avoiding substitution. + } + +-- | Precedence of parent node in the AST. +data ParentPrec + = HasPrec Fixity -- ^ Parent has precedence info. + | IsHsAppsTy -- ^ Parent is HsAppsTy + | NeverParen -- ^ Based on parent, we should never add parentheses. + +------------------------------------------------------------------------ + +data Direction = LeftToRight | RightToLeft + deriving (Eq) + +------------------------------------------------------------------------ + +-- | 'Query' is the primitive way to specify a matchable pattern (quantifiers +-- and expression). Whenever the pattern is matched, the associated result +-- will be returned. +data Query ast v = Query + { qQuantifiers :: Quantifiers + , qPattern :: Annotated ast + , qResult :: v + } + +instance Functor (Query ast) where + fmap f (Query qs ast v) = Query qs ast (f v) + +instance Bifunctor Query where + bimap f g (Query qs ast v) = Query qs (fmap f ast) (g v) + +------------------------------------------------------------------------ + +-- | 'Matcher' is a compiled 'Query'. Several queries can be compiled and then +-- merged into a single compiled 'Matcher' via 'Semigroup'/'Monoid'. +newtype Matcher a = Matcher (I.IntMap (UMap a)) + deriving (Functor) +-- The 'IntMap' tracks the binding level at which the 'Matcher' was built. +-- See Note [AlphaEnv Offset] for details. + +instance Semigroup (Matcher a) where + (<>) = mappend + +instance Monoid (Matcher a) where + mempty = Matcher I.empty + mappend (Matcher m1) (Matcher m2) = Matcher (I.unionWith mUnion m1 m2) + +-- | Compile a 'Query' into a 'Matcher'. +mkMatcher :: Matchable ast => Query ast v -> Matcher v +mkMatcher = mkLocalMatcher emptyAlphaEnv + +-- | Compile a 'Query' into a 'Matcher' within a given local scope. Useful for +-- introducing local matchers which only match within a given local scope. +mkLocalMatcher :: Matchable ast => AlphaEnv -> Query ast v -> Matcher v +mkLocalMatcher env Query{..} = Matcher $ + I.singleton (alphaEnvOffset env) $ + insertMatch + emptyAlphaEnv + qQuantifiers + (inject $ astA qPattern) + qResult + mEmpty + +------------------------------------------------------------------------ + +-- | Run a 'Matcher' on an expression in the given 'AlphaEnv' and return the +-- results from any matches. Results are accompanied by a 'Substitution', which +-- maps 'Quantifiers' from the original 'Query' to the expressions they unified +-- with. +runMatcher + :: (Matchable ast, MonadIO m) + => Context + -> Matcher v + -> ast + -> TransformT m [(Substitution, v)] +runMatcher Context{..} (Matcher m) ast = do + (anns, seed) <- get + let + matchEnv = ME ctxtInScope (\x -> unsafeMkA x anns seed) + uast = inject ast + + return + [ match + | (lvl, umap) <- I.toAscList m + , match <- findMatch (pruneMatchEnv lvl matchEnv) uast umap + ] + +------------------------------------------------------------------------ + +-- | A 'Rewrite' is a 'Query' specialized to 'Template' results, which have +-- all the information necessary to replace one expression with another. +type Rewrite ast = Query ast (Template ast, MatchResultTransformer) + +-- | Make a 'Rewrite' from given quantifiers and left- and right-hand sides. +mkRewrite :: Quantifiers -> Annotated ast -> Annotated ast -> Rewrite ast +mkRewrite qQuantifiers qPattern tTemplate = Query{..} + where + tImports = mempty + tDependents = Nothing + qResult = (Template{..}, defaultTransformer) + +-- | Add imports to a 'Rewrite'. Whenever the 'Rewrite' successfully rewrites +-- an expression, the imports are inserted into the enclosing module. +addRewriteImports :: AnnotatedImports -> Rewrite ast -> Rewrite ast +addRewriteImports imports q = q { qResult = (newTemplate, transformer) } + where + (template, transformer) = qResult q + newTemplate = template { tImports = imports <> tImports template } + +-- | Set the 'MatchResultTransformer' for a 'Rewrite'. +setRewriteTransformer :: MatchResultTransformer -> Rewrite ast -> Rewrite ast +setRewriteTransformer transformer q = + q { qResult = second (const transformer) (qResult q) } + +-- | A 'Rewriter' is a complied 'Rewrite', much like a 'Matcher' is a compiled +-- 'Query'. +type Rewriter = Matcher (RewriterResult Universe) + +-- | Compile a 'Rewrite' into a 'Rewriter'. +mkRewriter :: Matchable ast => Rewrite ast -> Rewriter +mkRewriter = mkLocalRewriter emptyAlphaEnv + +-- | Compile a 'Rewrite' into a 'Rewriter' with a given local scope. Useful for +-- introducing local matchers which only match within a given local scope. +mkLocalRewriter :: Matchable ast => AlphaEnv -> Rewrite ast -> Rewriter +mkLocalRewriter env q@Query{..} = + mkLocalMatcher env q { qResult = RewriterResult{..} } + where + rrOrigin = getOrigin $ astA qPattern + rrQuantifiers = qQuantifiers + (rrTemplate, rrTransformer) = first (fmap inject) qResult + +-- | Wrapper that allows us to attach extra derived information to the +-- 'Template' supplied by the 'Rewrite'. Saves the user from specifying it. +data RewriterResult ast = RewriterResult + { rrOrigin :: SrcSpan + , rrQuantifiers :: Quantifiers + , rrTransformer :: MatchResultTransformer + , rrTemplate :: Template ast + } + deriving (Functor) + +-- | A 'MatchResultTransformer' allows the user to specify custom logic to +-- modify the result of matching the left-hand side of a rewrite +-- (the 'MatchResult'). The 'MatchResult' generated by this function is used +-- to effect the resulting AST rewrite. +-- +-- For example, this transformer looks at the matched expression to build +-- the resulting expression: +-- +-- > fancyMigration :: MatchResultTransformer +-- > fancyMigration ctxt matchResult +-- > | MatchResult sub t <- matchResult +-- > , HoleExpr e <- lookupSubst sub "x" = do +-- > e' <- ... some fancy IO computation using 'e' ... +-- > return $ MatchResult (extendSubst sub "x" (HoleExpr e')) t +-- > | otherwise = NoMatch +-- > +-- > main :: IO () +-- > main = runScript $ \opts -> do +-- > rrs <- parseRewrites opts [Adhoc "forall x. ... = ..."] +-- > return $ apply +-- > [ setRewriteTransformer fancyMigration rr | rr <- rrs ] +-- +-- Since the 'MatchResultTransformer' can also modify the 'Template', you +-- can construct an entirely novel right-hand side, add additional imports, +-- or inject new dependent rewrites. +type MatchResultTransformer = + Context -> MatchResult Universe -> IO (MatchResult Universe) + +-- | The default transformer. Returns the 'MatchResult' unchanged. +defaultTransformer :: MatchResultTransformer +defaultTransformer = const return + +-- | The right-hand side of a 'Rewrite'. +data Template ast = Template + { tTemplate :: Annotated ast -- ^ The expression for the right-hand side. + , tImports :: AnnotatedImports + -- ^ Imports to add whenever a rewrite is successful. + , tDependents :: Maybe [Rewrite Universe] + -- ^ Dependent rewrites to introduce whenever a rewrite is successful. + -- See Note [tDependents] + } + +instance Functor Template where + fmap f Template{..} = Template { tTemplate = fmap f tTemplate, ..} + +-- Note [tDependents] +-- Why Maybe [] instead of just []? We want to support two things: +-- +-- 1. Ability to avoid putting most rewrites into ctxtDependents if possible, +-- so context updating doesn't require double-matching every rewrite. Dependent +-- rewrites are not the norm. +-- +-- 2. Ability of tTransform to introduce new dependent rewrites. To support +-- this in conjunction with #1, we need some way to say "this should be in +-- ctxtDependents, even if the list is empty". +-- +-- So: +-- +-- * Nothing = don't include in ctxtDependents +-- * Just [] = include in ctxtDependents, but presumably tTransform will +-- introduce the actual dependent rewrites +-- * Just xs = include in ctxtDependents + +-- | The result of matching the left-hand side of a 'Rewrite'. +data MatchResult ast + = MatchResult Substitution (Template ast) + | NoMatch + +instance Functor MatchResult where + fmap f (MatchResult s t) = MatchResult s (f <$> t) + fmap _ NoMatch = NoMatch + +------------------------------------------------------------------------ + +-- | Run a 'Rewriter' on an expression in the given 'AlphaEnv' and return the +-- 'MatchResult's from any matches. Takes an extra function for rewriting the +-- 'RewriterResult', which is run *before* the 'MatchResultTransformer' is run. +runRewriter + :: forall ast m. (Matchable ast, MonadIO m) + => (RewriterResult Universe -> RewriterResult Universe) + -> Context + -> Rewriter + -> ast + -> TransformT m (MatchResult ast) +runRewriter f ctxt rewriter = + runMatcher ctxt rewriter >=> firstMatch ctxt . map (second f) + +-- | Find the first 'valid' match. +-- Runs the user's 'MatchResultTransformer' and sanity checks the result. +firstMatch + :: (Matchable ast, MonadIO m) + => Context + -> [(Substitution, RewriterResult Universe)] + -> TransformT m (MatchResult ast) +firstMatch _ [] = return NoMatch +firstMatch ctxt ((sub, RewriterResult{..}):matchResults) = do + -- 'firstMatch' is lazy in 'rrTransformer', only running it enough + -- times to get the first valid MatchResult. + matchResult <- lift $ liftIO $ rrTransformer ctxt (MatchResult sub rrTemplate) + case matchResult of + MatchResult sub' _ + -- 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 rrQuantifiers ] -> + return $ project <$> matchResult + _ -> firstMatch ctxt matchResults + +------------------------------------------------------------------------ + +-- | Pretty-print a 'Rewrite' for debugging. +ppRewrite :: Rewrite Universe -> String +ppRewrite Query{..} = + show (qList qQuantifiers) ++ + "\n" ++ printU qPattern ++ + "\n==>\n" ++ printU (tTemplate $ fst qResult) + +-- | Inject a type-specific rewrite into the universal type. +toURewrite :: Matchable ast => Rewrite ast -> Rewrite Universe +toURewrite = bimap inject (first (fmap inject)) + +-- | Project a type-specific rewrite from the universal type. +fromURewrite :: Matchable ast => Rewrite Universe -> Rewrite ast +fromURewrite = bimap project (first (fmap project)) + +-- | Filter a list of rewrites for those that introduce dependent rewrites. +rewritesWithDependents :: [Rewrite ast] -> [Rewrite ast] +rewritesWithDependents = filter (isJust . tDependents . fst . qResult) diff --git a/Retrie/Universe.hs b/Retrie/Universe.hs new file mode 100644 --- /dev/null +++ b/Retrie/Universe.hs @@ -0,0 +1,119 @@ +-- 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 DeriveDataTypeable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} +module Retrie.Universe + ( Universe + , printU + , Matchable(..) + , UMap(..) + ) where + +import Control.Monad +import Data.Data + +import Retrie.AlphaEnv +import Retrie.ExactPrint +import Retrie.GHC +import Retrie.PatternMap.Class +import Retrie.PatternMap.Instances +import Retrie.Quantifiers +import Retrie.Substitution + +-- | A sum type to collect all possible top-level rewritable types. +data Universe + = ULHsExpr (LHsExpr GhcPs) + | ULStmt (LStmt GhcPs (LHsExpr GhcPs)) + | ULType (LHsType GhcPs) + deriving (Data) + +-- | Exactprint an annotated 'Universe'. +printU :: Annotated Universe -> String +printU u = exactPrintU (astA u) (annsA u) + +-- | Primitive exactprint for 'Universe'. +exactPrintU :: Universe -> Anns -> String +exactPrintU (ULHsExpr e) anns = exactPrint e anns +exactPrintU (ULStmt s) anns = exactPrint s anns +exactPrintU (ULType t) anns = exactPrint t anns + +------------------------------------------------------------------------------- + +-- | Class of types which can be injected into the 'Universe' type. +class Matchable ast where + -- | Inject an AST into 'Universe' + inject :: ast -> Universe + + -- | Project an AST from a 'Universe'. + -- Can fail if universe contains the wrong type. + project :: Universe -> ast + + -- | Get the original location of the AST. + getOrigin :: ast -> SrcSpan + +instance Matchable Universe where + inject = id + project = id + getOrigin (ULHsExpr e) = getOrigin e + getOrigin (ULStmt s) = getOrigin s + getOrigin (ULType t) = getOrigin t + +instance Matchable (LHsExpr GhcPs) where + inject = ULHsExpr + project (ULHsExpr x) = x + project _ = error "project LHsExpr" + getOrigin e = getLoc e + +instance Matchable (LStmt GhcPs (LHsExpr GhcPs)) where + inject = ULStmt + project (ULStmt x) = x + project _ = error "project LStmt" + getOrigin e = getLoc e + +instance Matchable (LHsType GhcPs) where + inject = ULType + project (ULType t) = t + project _ = error "project ULType" + getOrigin e = getLoc e + +------------------------------------------------------------------------------- + +-- | The pattern map for 'Universe'. +data UMap a = UMap + { umExpr :: EMap a + , umStmt :: SMap a + , umType :: TyMap a + } + deriving (Functor) + +instance PatternMap UMap where + type Key UMap = Universe + + mEmpty :: UMap a + mEmpty = UMap mEmpty mEmpty mEmpty + + mUnion :: UMap a -> UMap a -> UMap a + mUnion (UMap x1 x2 x3) (UMap y1 y2 y3) = + UMap (mUnion x1 y1) (mUnion x2 y2) (mUnion x3 y3) + + 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) } + + 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 + diff --git a/Retrie/Util.hs b/Retrie/Util.hs new file mode 100644 --- /dev/null +++ b/Retrie/Util.hs @@ -0,0 +1,116 @@ +-- 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 ScopedTypeVariables #-} +module Retrie.Util where + +import Control.Applicative +import Control.Concurrent.Async +import Control.Exception +import Data.Bifunctor (second) +import Data.List +import System.Exit +import System.FilePath +import System.Process + +import Retrie.GHC + +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 _ _ = False + +within :: (Int, Int) -> RealSrcSpan -> Bool +within (l,p) s = + srcSpanStartLine s <= l && + srcSpanStartCol s <= p && + srcSpanEndLine s >= l && + srcSpanEndCol s >= p + +lineCount :: [SrcSpan] -> Int +lineCount ss = sum + [ srcSpanEndLine s - srcSpanStartLine s + 1 + | RealSrcSpan s <- ss + ] + +showRdrs :: [RdrName] -> String +showRdrs = show . map (occNameString . occName) + +data Verbosity = Silent | Normal | Loud + deriving (Eq, Ord, Show) + +debugPrint :: Verbosity -> String -> [String] -> IO () +debugPrint verbosity header ls + | verbosity < Loud = return () + | otherwise = mapM_ putStrLn (header:ls) + +-- | Returns predicate which says whether filepath is ignored by VCS. +vcsIgnorePred :: FilePath -> IO (Maybe (FilePath -> Bool)) +vcsIgnorePred fp = do + (gitPred, hgPred) <- concurrently (gitIgnorePred fp) (hgIgnorePred fp) + return $ gitPred <|> hgPred + +-- | Read .gitignore in dir and if successful, return predicate for whether +-- given repo path should be ignored. +gitIgnorePred :: FilePath -> IO (Maybe (FilePath -> Bool)) +gitIgnorePred targetDir = do + let + cmd = + (proc "git" + [ "ls-files" + , "--ignored" + , "--exclude-standard" + , "--others" + , "--directory" + , targetDir + ]) + { cwd = Just targetDir } + (ec, fps, _) <- readCreateProcessWithExitCode cmd "" + case ec of + ExitSuccess -> do + let + (ifiles, idirs) = partition hasExtension + [ normalise $ targetDir dropTrailingPathSeparator f + | f <- lines fps ] + return $ Just (\fp -> fp `elem` ifiles || any (`isPrefixOf` fp) idirs) + ExitFailure _ -> return Nothing + +-- | Read .hgignore in dir and if successful, return predicate for whether +-- given repo path should be ignored. +hgIgnorePred :: FilePath -> IO (Maybe (FilePath -> Bool)) +hgIgnorePred targetDir = do + let + cmd = + (proc "hg" + [ "status" + , "--ignored" + , "--no-status" + , "-I" + , "re:.*\\.hs$" + ]) + { cwd = Just targetDir } + (ec, fps, _) <- readCreateProcessWithExitCode cmd "" + case ec of + ExitSuccess -> do + let + (ifiles, dirs) = partition hasExtension + [ normalise $ targetDir dropTrailingPathSeparator f + | f <- lines fps ] + -- .hg looks like an extension, so have to add this after the partition + idirs = normalise (targetDir ".hg") : dirs + return $ Just $ \fp -> fp `elem` ifiles || any (`isPrefixOf` fp) idirs + ExitFailure _ -> return Nothing + +-- | 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) + +uniqBag :: Uniquable a => [(a,b)] -> UniqFM [b] +uniqBag = listToUFM_C (++) . map (second pure) diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,7 @@ +-- 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. +-- +import Distribution.Simple +main = defaultMain diff --git a/bin/Main.hs b/bin/Main.hs new file mode 100644 --- /dev/null +++ b/bin/Main.hs @@ -0,0 +1,24 @@ +-- 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 RecordWildCards #-} +module Main (main) where + +import Control.Monad +import Data.Default +import Retrie +import Retrie.Debug +import Retrie.Options +import Retrie.Run + +main :: IO () +main = do + opts@Options{..} <- parseOptions def + doRoundtrips fixityEnv targetDir roundtrips + unless (null rewrites) $ do + when (verbosity > Silent) $ do + putStrLn "Adding:" + mapM_ (putStrLn . ppRewrite) rewrites + execute opts $ apply rewrites diff --git a/demo/Main.hs b/demo/Main.hs new file mode 100644 --- /dev/null +++ b/demo/Main.hs @@ -0,0 +1,54 @@ +-- 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 Main where + +import Retrie + +-- | A script for rewriting calls to a function that takes a string to be +-- calls to a new function that takes an enumeration. See the README for +-- details. Running this would result in the following diff: +-- +-- module MyModule where +-- +-- baz, bar, quux :: IO () +-- -baz = fooOld "foo" +-- +baz = fooNew Foo +-- -bar = fooOld "bar" +-- +bar = fooNew Bar +-- -quux = fooOld "quux" +-- +quux = fooNew (error "invalid argument: quux") +-- +main :: IO () +main = runScript $ \opts -> do + [rewrite] <- parseRewrites opts [Adhoc "forall arg. fooOld arg = fooNew arg"] + return $ apply [setRewriteTransformer stringToFooArg rewrite] + +argMapping :: [(FastString, String)] +argMapping = [("foo", "Foo"), ("bar", "Bar")] + +-- | This 'transform' receives the result of matching the left-hand side of the +-- equation. The returned 'MatchResult' is used to instantiate the right-hand +-- side of the equation. In this example we are just modifying the +-- substitution, but you can also modify the template, which contains the +-- right-hand side itself. +stringToFooArg :: MatchResultTransformer +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 ++ "\"" + Just constructor -> parseExpr constructor + return $ + MatchResult (extendSubst substitution "arg" (HoleExpr newExpr)) template + | otherwise = return NoMatch diff --git a/retrie.cabal b/retrie.cabal new file mode 100644 --- /dev/null +++ b/retrie.cabal @@ -0,0 +1,156 @@ +-- 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. +-- +name: retrie +version: 0.1.0.0 +synopsis: A powerful, easy-to-use codemodding tool for Haskell. +license: MIT +license-file: LICENSE +author: Andrew Farmer +maintainer: Andrew Farmer +copyright: Copyright (c) Facebook, Inc. and its affiliates. +category: Development +build-type: Simple +cabal-version: >=1.10 +extra-source-files: + CHANGELOG.md + CODE_OF_CONDUCT.md + CONTRIBUTING.md + README.md + tests/inputs/*.custom + tests/inputs/*.test +tested-with: GHC ==8.8.2 || ==8.6.5 || ==8.4.4 + +description: + Retrie is a tool for codemodding Haskell. Key goals include: + . + * Speed: Efficiently rewrite in large (>1 million line) codebases. + * Safety: Avoids large classes of codemod-related errors. + * Ease-of-use: Haskell syntax instead of regular expressions. No hand-rolled AST traversals. + . + This package provides a command-line tool (@retrie@) and a library + ("Retrie") for making equational edits to Haskell code. + . + Please see the [README](#readme) for examples and usage. + +library + exposed-modules: + Retrie, + Retrie.AlphaEnv, + Retrie.CPP, + Retrie.Context, + Retrie.Debug, + Retrie.ExactPrint, + Retrie.ExactPrint.Annotated, + Retrie.Expr, + Retrie.Fixity, + Retrie.FreeVars, + Retrie.GHC, + Retrie.GroundTerms, + Retrie.Monad, + Retrie.Options, + Retrie.PatternMap.Bag, + Retrie.PatternMap.Class, + Retrie.PatternMap.Instances, + Retrie.Pretty, + Retrie.Quantifiers, + Retrie.Query, + Retrie.Replace, + Retrie.Rewrites, + Retrie.Rewrites.Function, + Retrie.Rewrites.Rules, + Retrie.Rewrites.Types, + Retrie.Run, + Retrie.Subst, + Retrie.Substitution, + Retrie.SYB, + Retrie.Types, + Retrie.Universe, + Retrie.Util + GHC-Options: -Wall + build-depends: + ansi-terminal >= 0.10.3 && < 0.11, + async >= 2.2.2 && < 2.3, + base >= 4.11 && < 4.14, + 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.10, + ghc-exactprint >= 0.6.2 && < 0.7, + haskell-src-exts >= 1.23.0 && < 1.24, + mtl >= 2.2.2 && < 2.3, + optparse-applicative >= 0.15.1 && < 0.16, + process >= 1.6.3 && < 1.7, + random-shuffle >= 0.0.4 && < 0.1, + syb >= 0.7.1 && < 0.8, + text >= 1.2.3 && < 1.3, + transformers >= 0.5.5 && < 0.6, + unordered-containers >= 0.2.10 && < 0.3 + default-language: Haskell2010 + +executable retrie + main-is: + Main.hs + hs-source-dirs: bin + other-modules: + GHC-Options: -Wall + build-depends: + retrie, + base >= 4.11 && < 4.14, + data-default + default-language: Haskell2010 + +executable demo + main-is: + Main.hs + hs-source-dirs: demo + other-modules: + GHC-Options: -Wall + build-depends: + retrie, + base >= 4.11 && < 4.14 + default-language: Haskell2010 + +test-suite test + type: exitcode-stdio-1.0 + main-is: Main.hs + other-modules: + AllTests, + Annotated, + CPP, + Demo, + Dependent, + Exclude, + Golden, + GroundTerms, + Ignore, + ParseQualified, + Targets, + Util + hs-source-dirs: tests + default-language: Haskell2010 + GHC-Options: -Wall + build-depends: + retrie, + HUnit, + base >= 4.11 && < 4.14, + containers, + data-default, + deepseq, + directory, + filepath, + ghc >= 8.4 && < 8.10, + ghc-paths, + mtl, + optparse-applicative, + process, + syb, + tasty, + tasty-hunit, + temporary, + text, + unordered-containers diff --git a/tests/AllTests.hs b/tests/AllTests.hs new file mode 100644 --- /dev/null +++ b/tests/AllTests.hs @@ -0,0 +1,92 @@ +-- 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 OverloadedLists #-} +{-# LANGUAGE RecordWildCards #-} +module AllTests (allTests) where + +import Data.Default +import Data.Maybe +import Retrie +import Retrie.Options +import System.Environment +import System.FilePath +import Test.HUnit + +import Annotated +import CPP +import qualified Demo +import Dependent +import Exclude +import Golden +import GroundTerms +import Ignore +import ParseQualified +import Targets + +allTests :: Verbosity -> IO Test +allTests rtVerbosity = do + p <- getOptionsParser def + rtDir <- + fromMaybe (dropFileName __FILE__ "inputs") + <$> lookupEnv "RETRIEINPUTSDIR" + testFiles <- listDir rtDir + focusTests <- getFocusTests + return $ TestList + [ annotatedTest + , cppTest + , dependentStmtTest rtDir p rtVerbosity + , excludeTest rtVerbosity + , TestLabel "golden" $ TestList + [ TestLabel rtName $ TestCase $ runTest p RetrieTest{..} + | testFile <- testFiles + , takeExtension testFile == ".test" + , let + rtName = dropExtension testFile + rtTest = testFile + rtRetrie = return . apply . rewrites + ] + , TestLabel "custom Retrie" $ TestCase $ + runTest p RetrieTest + { rtName = "custom Retrie" + , rtTest = "Adhoc2.custom" + , rtRetrie = \opts -> do + rrs' <- parseRewrites opts + [ 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" + ] + return $ apply $ rewrites opts <> rrs' + , .. + } + , TestLabel "README advanced rewrite demo" $ TestCase $ + runTest p RetrieTest + { rtName = "README advanced rewrite demo" + , rtTest = "Readme.custom" + , rtRetrie = \opts -> do + [rewrite] <- + parseRewrites opts [Adhoc "forall arg. fooOld arg = fooNew arg"] + return $ apply [setRewriteTransformer Demo.stringToFooArg rewrite] + , .. + } + , TestLabel "query test" $ TestCase $ do + is <- runQueryTest p RetrieTest + { rtName = "query test" + , rtTest = "Query.custom" + , rtRetrie = \opts -> do + qs <- parseQueries opts [(["x"], QExpr "succ x", 1::Int)] + return $ do + matches <- query qs + return [ v | (_,_,v) <- matches ] + , .. + } + assertEqual "found three succs" 3 (sum is) + , TestLabel "groundterms can be found" $ TestList focusTests + , groundTermsTest + , ignoreTest + , parseQualifiedTest + , basicTargetTest + , targetedWithGroundTerms + ] diff --git a/tests/Annotated.hs b/tests/Annotated.hs new file mode 100644 --- /dev/null +++ b/tests/Annotated.hs @@ -0,0 +1,218 @@ +-- 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 RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Annotated (annotatedTest) where + +import Control.Monad.State.Lazy +import Data.Data +import Data.Generics +import qualified Data.Map as M +import qualified Data.Set as S +import Data.Maybe +import Test.HUnit + +import Retrie.ExactPrint +import Retrie.GHC + +annotatedTest :: Test +annotatedTest = TestLabel "Annotated" $ TestList + [ increasingSeedTest + , elemsPostGraftTest + , inverseTest + , uniqueSrcSpanTest + , trimTest + ] + +exprs :: [String] +exprs = + [ "3 + x" + , "let _ = \\_ -> 4 in 7" + , "case x of { y -> y }" + , "let x = y in z" + , unlines + [ "case (3, 4) of" + , " (x, 5) -> (5, x)" + , " (_, y) -> (y, y)" + ] + , unlines + [ "let f :: Int -> Int" + , " f x = x + 3" + , " y = 4" + , "in f y + f y" + ] + ] + +types :: [String] +types = + [ "Int -> Int" + , "Data a => a -> Int" + , "(Eq a, Eq b) => (a -> b, b -> a)" + ] + +-- Run test on all ASTs parsed from the above lists +forAst :: (forall a. Data a => Annotated a -> IO ()) -> IO () +forAst f = do + mapM_ (parseExpr >=> f) exprs + mapM_ (parseType >=> f) types + +-- Repeat a single transformation multiple times on an ast. The ast returned +-- from the previous transformation is passed to the next transformation. +testChainedTransforms :: (forall a. Data a => a -> TransformT IO a) -> IO () +testChainedTransforms f = forAst $ \at -> do + _ <- fmap astA $ transformA at (f >=> f >=> f >=> f) + return () + +increasingSeedTest :: Test +increasingSeedTest = TestLabel "graft increases seed" $ TestCase $ + testChainedTransforms transform + where + transform :: Data a => a -> TransformT IO a + transform = transformWithSeedIncreaseCheck . (pruneA >=> graftA) + +-- Following a graft, the annotation map in the state has the expected elements +elemsPostGraftTest :: Test +elemsPostGraftTest = TestLabel "Expected elems in map" $ TestCase $ + testChainedTransforms transform + where + transform :: Data a => a -> TransformT IO a + transform t = do + annsPreGraft <- gets fst + at <- pruneA t + t' <- graftA at + annsPostGraft <- gets fst + lift $ liftIO $ do + assertCountMaintained annsPreGraft t annsPostGraft + assertNoOverwrite annsPreGraft annsPostGraft + assertExactPrintAnns annsPreGraft annsPostGraft + return t' + +inverseTest :: Test +inverseTest = TestLabel "graftA and pruneA are inverse" $ TestCase $ + testChainedTransforms transform + where + transform :: Data a => a -> TransformT IO a + transform t = do + anns <- gets fst + at <- pruneA t + t' <- graftA at + anns' <- gets fst + lift $ liftIO $ + assertAstsEqual "ast pre-graft is same as ast post-graft" + (anns, t) + (anns', t') + return t' + +uniqueSrcSpanTest :: Test +uniqueSrcSpanTest = TestLabel "unique src span" $ TestCase $ + fmap astA $ transformA (mempty :: Annotated ()) $ \() -> do + ss <- transformWithSeedIncreaseCheck uniqueSrcSpanT + lift $ liftIO $ assertGoodSrcSpan ss + +trimTest :: Test +trimTest = TestLabel "trimA" $ TestCase $ + forAst $ \at -> + let at' = trimA at in + assertLocsReplaced (astA at') + +transformWithSeedIncreaseCheck :: TransformT IO a -> TransformT IO a +transformWithSeedIncreaseCheck m = do + seed <- gets snd + x <- m + seed' <- gets snd + lift $ liftIO $ assertBool "transform increases seed" (seed' > seed) + return x + +-- Creates a query that returns the result of applying q to the argument (if the +-- argument is a GenLocated node containing a SrcSpan), otherwise returning +-- the provided default value. +locatedQ :: forall b. b -> (forall a. Data a => Located a -> b) -> GenericQ b +locatedQ defaultVal q = const defaultVal `ext2Q` query + where + query :: (Data loc, Data a) => GenLocated loc a -> b + query (L l t) = + case cast l :: Maybe SrcSpan of + Nothing -> defaultVal + Just ss -> q (L ss t) + +-- Structure of HsExpr AST, including constructor names and annotations +-- associated with SrcSpan locations. +data ConTree = ConNode AnnConName (Maybe Annotation) [ConTree] + deriving (Eq, Show) + +-- Assert ast equality (up to src span location labeling) +assertAstsEqual :: Data a => String -> (Anns, a) -> (Anns, a) -> IO () +assertAstsEqual msg (anns1, t1) (anns2, t2) = + assertEqual msg (conTree anns1 t1) (conTree anns2 t2) + where + conTree :: Data a => Anns -> a -> ConTree + conTree anns = loop + where + loop :: Data a => a -> ConTree + loop t = ConNode (annGetConstr t) (annQ t) (gmapQ loop t) + + annQ :: GenericQ (Maybe Annotation) + annQ = locatedQ Nothing $ \loc -> M.lookup (mkAnnKey loc) anns + +-- Assert that all locations in the updated ast are generated by uniqueSrcSpanT +assertLocsReplaced :: Data a => a -> IO () +assertLocsReplaced = everything (>>) assertReplaced + where + assertReplaced :: GenericQ (IO ()) + assertReplaced = locatedQ (return ()) $ \(L ss _) -> assertGoodSrcSpan ss + +-- Assert that every location in the ast has been added to the pre-graft +-- annotations to form the post-graft annotations. +assertCountMaintained :: Data a => Anns -> a -> Anns -> IO () +assertCountMaintained annsPreGraft t annsPostGraft = + let numAnnsAdded = everything (+) countIfInAnns t in + assertEqual + "sum of pre-graft size and # of SrcSpan sites in AST equals post-graft size" + (M.size annsPreGraft + numAnnsAdded) + (M.size annsPostGraft) + where + countIfInAnns :: GenericQ Int + countIfInAnns = locatedQ 0 $ \loc -> + if M.member (mkAnnKey loc) annsPreGraft then 1 else 0 + +-- Check that no data in pre-graft map was overwritten. +assertNoOverwrite :: Anns -> Anns -> IO () +assertNoOverwrite annsPreGraft annsPostGraft = + assertEqual "pre-graft keys correspond to same data as post-graft" + dataPreGraft + dataPostGraft + where + dataPreGraft = M.toList annsPreGraft + dataPostGraft = mapMaybe (\(k, _) -> do + v <- M.lookup k annsPostGraft + return (k, v)) + dataPreGraft + +-- Assert that the annotation keys corresponding to newly-added data are of the +-- expected form. +assertExactPrintAnns :: Anns -> Anns -> IO () +assertExactPrintAnns annsPreGraft annsPostGraft = + mapM_ (\(AnnKey ss _) -> assertGoodSrcSpan ss) newKeys + 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 _ -> + assertFailure "only real src spans should be generated" + +assertGoodSrcLoc :: RealSrcLoc -> IO () +assertGoodSrcLoc srcLoc = do + let + file = unpackFS $ srcLocFile srcLoc + line = srcLocLine srcLoc + assertEqual "srcLoc file is correctly named" "ghc-exactprint" file + assertEqual "srcLoc line is correctly placed" (-1) line diff --git a/tests/CPP.hs b/tests/CPP.hs new file mode 100644 --- /dev/null +++ b/tests/CPP.hs @@ -0,0 +1,261 @@ +-- 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 OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +module CPP (cppTest) where + +import Control.Monad +import Data.List (intersperse, sort) +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.IO as Text +import Retrie.CPP +import Retrie.ExactPrint +import Retrie.Util +import Test.HUnit + +data CPPTest = CPPTest + { name :: String + , code :: Text + , results :: [[Text]] + } + +cppTest :: Test +cppTest = TestLabel "cpp" $ TestList $ + map cppForkTest testList ++ + map roundTripTest testList + +testList :: [CPPTest] +testList = + [ CPPTest "no cpp" noCPPCode [Text.lines noCPPCode] + , CPPTest "define" defineCode + [ ["a","","b"] + ] + , CPPTest "one if" oneIfCode + [ ["a","","b","","c"] + , ["a","","","","c"] + ] + , CPPTest "if else" ifElseCode + [ ["a","b","","","","","e","f","","g","h"] + , ["a","b","","c","d","","","","","g","h"] + ] + , CPPTest "if elif else" elIfCode + [ ["a","b","","c","d","","","","","","","","i","j"] + , ["a","b","","","","","e","f","","","","","i","j"] + , ["a","b","","","","","","","","g","h","","i","j"] + ] + , CPPTest "if elif elif else" twoElIfCode + [ ["a","b","","c","d","","","","","","","","","","","k","l"] + , ["a","b","","","","","e","f","","","","","","","","k","l"] + , ["a","b","","","","","","","","g","h","","","","","k","l"] + , ["a","b","","","","","","","","","","","i","j","","k","l"] + ] + , CPPTest "if elif" elIfNoElseCode + [ ["a","b","","c","d","","","","","i","j"] + , ["a","b","","","","","e","f","","i","j"] + , ["a","b","","","","","","","","i","j"] + ] + , CPPTest "nested if" nestedIfCode + [ ["a","","b","","","","","e","","f","g","","h"] + , ["a","","b","","c","d","","","","f","g","","h"] + , ["a","","","","","","","","","","","","h"] + ] + , CPPTest "imports" importCode + [ importExpected1, importExpected2 ] + ] + +noCPPCode :: Text +noCPPCode = Text.unlines + [ "a" + , "b" + , "c" + ] + +defineCode :: Text +defineCode = Text.unlines + [ "a" + , "#define FOO 1" + , "b" + ] + +oneIfCode :: Text +oneIfCode = Text.unlines + [ "a" + , "#if FOO" + , "b" + , "#endif" + , "c" + ] + +ifElseCode :: Text +ifElseCode = Text.unlines + [ "a" + , "b" + , "#if FOO" + , "c" + , "d" + , "#else" + , "e" + , "f" + , "#endif" + , "g" + , "h" + ] + +elIfCode :: Text +elIfCode = Text.unlines + [ "a" + , "b" + , "#if FOO" + , "c" + , "d" + , "#elif BAR" + , "e" + , "f" + , "#else" + , "g" + , "h" + , "#endif" + , "i" + , "j" + ] + +twoElIfCode :: Text +twoElIfCode = Text.unlines + [ "a" + , "b" + , "#if FOO" + , "c" + , "d" + , "#elif BAR" + , "e" + , "f" + , "#elif BAZ" + , "g" + , "h" + , "#else" + , "i" + , "j" + , "#endif" + , "k" + , "l" + ] + +elIfNoElseCode :: Text +elIfNoElseCode = Text.unlines + [ "a" + , "b" + , "#if FOO" + , "c" + , "d" + , "#elif BAR" + , "e" + , "f" + , "#endif" + , "i" + , "j" + ] + +nestedIfCode :: Text +nestedIfCode = Text.unlines + [ "a" + , "#if FOO" + , "b" + , "#if BAR" + , "c" + , "d" + , "#else" + , "e" + , "#endif" + , "f" + , "g" + , "#endif" + , "h" + ] + +importCode :: Text +importCode = Text.unlines + [ "module Foo where" + , "" + , "import Bar" + , "#if BAZ" + , "import Baz" + , "#endif" + , "import Quux" + , "#if QUUX" + , "import Something" + , "" + , "myDecl :: Int" + , "myDecl = 54" + , "#else" + , "import Something.Else" + , "#endif" + , "" + , "thats all = folks" + ] + +importExpected2 :: [Text] +importExpected2 = + [ "module Foo where" + , "" + , "import Bar" + , "" + , "import Baz" + , "" + , "import Quux" + , "" + , "import Something" + , "" + , "myDecl :: Int" + , "myDecl = 54" + , "" + , "" + , "" + , "" + , "thats all = folks" + ] + +importExpected1 :: [Text] +importExpected1 = + [ "module Foo where" + , "" + , "import Bar" + , "" + , "import Baz" + , "" + , "import Quux" + , "" + , "" + , "" + , "" + , "" + , "" + , "import Something.Else" + , "" + , "" + , "thats all = folks" + ] + +cppForkTest :: CPPTest -> Test +cppForkTest CPPTest{..} = TestLabel ("cpp fork: " ++ name) $ TestCase $ do + let + sorted = sort $ map Text.unlines results + fork = sort $ cppFork code + unless (sorted == fork) $ do + putStrLn "Expected:" + mapM_ Text.putStrLn (intersperse "===" sorted) + putStrLn "But Got:" + mapM_ Text.putStrLn (intersperse "===" fork) + assertFailure "cppFork does not give expected result" + +roundTripTest :: CPPTest -> Test +roundTripTest CPPTest{..} = TestLabel ("roundtrip: " ++ name) $ TestCase $ do + r <- trySync $ parseCPP (parseContentNoFixity "roundTripTest") code + case r of + Left msg -> assertFailure (show msg) + Right cpp -> assertEqual "cpp did not roundtrip correctly" + (Text.unpack code) + (printCPP [] cpp) diff --git a/tests/Demo.hs b/tests/Demo.hs new file mode 100644 --- /dev/null +++ b/tests/Demo.hs @@ -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. +-- +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +module Demo (stringToFooArg) where + +import Retrie + +argMapping :: [(FastString, String)] +argMapping = [("foo", "Foo"), ("bar", "Bar")] + +stringToFooArg :: MatchResultTransformer +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 ++ "\"" + Just constructor -> parseExpr constructor + return $ + MatchResult (extendSubst substitution "arg" (HoleExpr newExpr)) template + | otherwise = return NoMatch diff --git a/tests/Dependent.hs b/tests/Dependent.hs new file mode 100644 --- /dev/null +++ b/tests/Dependent.hs @@ -0,0 +1,32 @@ +-- 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 RecordWildCards #-} +module Dependent where + +import Options.Applicative +import Test.HUnit + +import Golden +import Retrie +import Retrie.Options + +dependentStmtTest :: FilePath -> Parser ProtoOptions -> Verbosity -> Test +dependentStmtTest rtDir p rtVerbosity = + TestLabel "dependent stmt" $ TestCase $ + runTest p RetrieTest + { rtName = "dependent stmt" + , rtTest = "DependentStmt.custom" + , rtRetrie = \opts -> do + rrs <- parseRewrites opts [ Adhoc "forall x. foo x = baz x" ] + stmt <- parseStmt "y <- bar 54" + let + rr = toURewrite $ + Query emptyQs stmt + (Template stmt mempty (Just rrs), defaultTransformer) + + return $ apply [rr] + , .. + } diff --git a/tests/Exclude.hs b/tests/Exclude.hs new file mode 100644 --- /dev/null +++ b/tests/Exclude.hs @@ -0,0 +1,67 @@ +-- 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 LambdaCase #-} + +module Exclude (excludeTest) where + +import Data.List (isPrefixOf, stripPrefix) +import Retrie +import Retrie.Options +import System.FilePath +import Test.HUnit +import Util + +excludedPaths :: [FilePath] +excludedPaths = ["foo", "bar/ignore"] + +allFiles :: [FilePath] +allFiles = + [ "foo/Foo.hs" + , "foo/bar/Foobar.hs" + , "bar/Bar.hs" + , "bar/foo/Baz.hs" + , "bar/ignore/Ignore.hs" + ] + +excludeTest :: Verbosity -> Test +excludeTest v = TestLabel "exclude path prefixes" $ + TestCase $ do + withFakeHgRepo [] allFiles $ \dir -> do + let opts = optionsWithExtraIgnores dir v + filepaths <- getTargetFiles opts [] + assertBool (unlines ["Expected ", show excludedPaths, + "to be excluded, these were included : ", show filepaths]) + $ excludedPathsAreExcluded filepaths + + let relfilepaths = map (stripPrefix $ addTrailingPathSeparator dir) + filepaths + assertBool (unlines ["Expected ", show includedPaths, + " to be included, these were included: ", show relfilepaths]) + $ nonExcludedPathsAreIncluded relfilepaths + +optionsWithExtraIgnores :: FilePath -> Verbosity -> Options +optionsWithExtraIgnores target v = (defaultOptions target) + { extraIgnores = excludedPaths + , verbosity = v + } + +-- Check that filepaths with prefixes in the excluded list are excluded +excludedPathsAreExcluded :: [FilePath] -> Bool +excludedPathsAreExcluded = all notPrefixOfAllExcluded + +-- Check that filepaths without prefixes in the excluded list are not excluded +nonExcludedPathsAreIncluded :: [Maybe FilePath] -> Bool +nonExcludedPathsAreIncluded results = all (\case + Nothing -> False + Just relpath -> relpath `elem` includedPaths) results + && length results == length includedPaths + +includedPaths :: [FilePath] +includedPaths = filter notPrefixOfAllExcluded allFiles + +-- Returns True if a filepath starts with an excluded prefix +notPrefixOfAllExcluded :: FilePath -> Bool +notPrefixOfAllExcluded file = all (\p -> not $ isPrefixOf p file) excludedPaths diff --git a/tests/Golden.hs b/tests/Golden.hs new file mode 100644 --- /dev/null +++ b/tests/Golden.hs @@ -0,0 +1,176 @@ +-- 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 RecordWildCards #-} +module Golden + ( RetrieTest(..) + , runQueryTest + , runTest + , displayAndAssertEqual + , withTmpCopyOfInputs + , listDir + ) where + +import Control.DeepSeq (force) +import Control.Exception (evaluate) +import Control.Monad +import Data.Bifunctor (second) +import Data.Char (isSpace) +import Data.List (intersperse) +import Options.Applicative +import Retrie +import Retrie.Options hiding (parseOptions) +import Retrie.Run +import System.Directory +import System.FilePath +import System.IO.Temp +import System.Process +import Test.HUnit + +data RetrieTest a = RetrieTest + { rtDir :: FilePath + , rtName :: String + , rtTest :: FilePath + , rtVerbosity :: Verbosity + , rtRetrie :: Options -> IO (Retrie a) + } + +parseOptions + :: Parser ProtoOptions + -> FilePath + -> RetrieTest a + -> IO Options +parseOptions p dir RetrieTest{..} = do + flags <- takeFlags <$> readFileNoComments (rtDir rtTest) + case runParserOnString p flags of + Nothing -> + fail $ unwords [rtName, " options did not parse: ", flags] + Just opts -> do + resolveOptions opts { targetDir = dir, verbosity = rtVerbosity } + +runParserOnString :: Parser a -> String -> Maybe a +runParserOnString p args = getParseResult $ + execParserPure (prefs mempty) (info p fullDesc) (quotedWords args) + where + recurse (w,s) = w : quotedWords s + -- Mimic shell's ability to group tokens with double quotes. + quotedWords s = + case dropWhile isSpace s of + "" -> [] + ('"':cs) -> recurse . second tail $ break (=='"') cs + s' -> recurse $ break isSpace s' + +runTestWrapper + :: Parser ProtoOptions + -> RetrieTest a + -> (Options -> IO b) + -> IO b +runTestWrapper p t@RetrieTest{..} f = + withTmpCopyOfInputs rtDir $ \dir -> do + -- Make the Rewrites from the temp file, to get correct SrcSpan's + opts <- parseOptions p dir t + f opts { targetFiles = [dir replaceExtension rtTest ".hs"] } + +runQueryTest + :: Monoid a + => Parser ProtoOptions + -> RetrieTest a + -> IO a +runQueryTest p t@RetrieTest{..} = + runTestWrapper p t $ \opts -> do + let writeFn _fp _locs _res = return + retrie <- rtRetrie opts + -- A 'writeFn' is only executed if the module changes, so add empty imports + -- to trip the Changed flag. + fmap mconcat $ run writeFn id opts $ do + r <- retrie + addImports mempty + return r + +runTest :: Parser ProtoOptions -> RetrieTest () -> IO () +runTest p t@RetrieTest{..} = + runTestWrapper p t $ \opts@Options{..} -> do + let + writeFn fp _locs res _ = writeFile fp res + [tmpFile] = targetFiles + before <- evaluate . force =<< readFile tmpFile + retrie <- rtRetrie opts + void $ run writeFn id opts $ iterateR iterateN retrie + res <- readFile tmpFile + expected <- readFile $ targetDir replaceExtension rtTest ".expected" + displayAndAssertEqual before expected res + +displayAndAssertEqual :: String -> String -> String -> IO () +displayAndAssertEqual before expected res + | expected == res = return () + | otherwise = do + let bars = replicate 60 '=' + d <- diff expected res + putStrLn $ unlines $ intersperse bars + [ "" + , "Original:", before + , "Expected:", expected + , "Got:", res + , "Diff:", d + , "" + ] + assertFailure "file contents differ" + +diff :: String -> String -> IO String +diff s1 s2 = withSystemTempDirectory "diff" $ \dir -> do + let + aFile = dir "a.txt" + bFile = dir "b.txt" + writeFile aFile s1 + writeFile bFile s2 + (_ec, so, _) <- readProcessWithExitCode "diff" [aFile, bFile] "" + return so + +-- Copies input dir, mapping *.test to *.hs, +-- and provides a filepath to the root +-- of the copy. Deletes the copy when done. +withTmpCopyOfInputs :: FilePath -> (FilePath -> IO a) -> IO a +withTmpCopyOfInputs inputsDir comp = do + fs <- listDir inputsDir + withSystemTempDirectory "inputs" $ \dir -> do + forM_ fs $ \f -> do + if takeExtension f `elem` [".test", ".custom"] + then splitAndCopyTest inputsDir f dir + else copyFile (inputsDir f) (dir f) + comp dir + +splitAndCopyTest :: FilePath -> FilePath -> FilePath -> IO () +splitAndCopyTest inputsDir testFile dstDir = do + (hs, expected) <- splitTest <$> readFileNoComments (inputsDir testFile) + writeFile (dstDir replaceExtension testFile ".hs") hs + writeFile (dstDir replaceExtension testFile ".expected") expected + +splitTest :: String -> (String, String) +splitTest = go ([],[]) . takeWhile (/="===") . reverse . lines + where + go (hs,ex) [] = (unlines hs, unlines ex) + go (hs,ex) ([]:ls) = go ([]:hs,[]:ex) ls + go (hs,ex) ((' ':ln):ls) = go (ln:hs,ln:ex) ls + go (hs,ex) (('-':ln):ls) = go (ln:hs,ex) ls + go (hs,ex) (('+':ln):ls) = go (hs,ln:ex) ls + go _ (ln:_) = error $ + "Malformed test file. " ++ + "Each line must start with a space, +, -, #, or be empty.\n" ++ ln + +takeFlags :: String -> String +takeFlags = unwords . takeWhile (/="===") . lines + +readFileNoComments :: FilePath -> IO String +readFileNoComments path = + unlines . filter notComment . lines <$> readFile path + where + notComment ('#':_) = False + notComment _ = True + +-- This is 'listDirectory' in 'directory >= 1.2.5.0' +listDir :: FilePath -> IO [FilePath] +listDir path = + filter f <$> getDirectoryContents path + where f filename = filename /= "." && filename /= ".." diff --git a/tests/GroundTerms.hs b/tests/GroundTerms.hs new file mode 100644 --- /dev/null +++ b/tests/GroundTerms.hs @@ -0,0 +1,114 @@ +-- 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 OverloadedStrings #-} +module GroundTerms + ( getFocusTests + , groundTermsTest + ) where + +import Control.Monad +import Control.Monad.IO.Class +import Data.Default +import qualified Data.HashSet as HashSet +import Data.Text (Text) +import Retrie.CPP +import Retrie.ExactPrint +import Retrie.GroundTerms +import Retrie.Monad +import Retrie.Options +import Retrie.Rewrites +import Retrie.Types +import Retrie.Universe +import Test.HUnit + +groundTermsTest :: Test +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")] + , 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'")] + , gtTest "MyType" + "type MyType a = MyOtherType a" + [TypeForward "Test.MyType"] + [["MyType"]] + [("", "grep -R --include=\"*.hs\" -l 'MyType' ~/si_sigma")] + ] + +gtTest + :: String + -> Text + -> [RewriteSpec] + -> [[String]] + -> [(String, String)] + -> Test +gtTest lbl contents specs expected expectedCmds = + TestLabel ("groundTerms: " ++ lbl) $ TestCase $ do + -- since we 'zip' below + assertEqual "length of specs and expected ground terms" + (length specs) + (length expected) + assertEqual "length of expected ground terms and expected commands" + (length expected) + (length expectedCmds) + + rrs <- + parseRewriteSpecs + (\_ -> parseCPP (parseContent def "Test") contents) + def + specs + let gtss = map groundTerms rrs + + assertEqual "groundTerms does not give expected term set" + (HashSet.fromList $ map HashSet.fromList expected) + (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) + +getFocusTests :: IO [Test] +getFocusTests = do + rrs1 <- parseAdhocs def ["forall xs. or (map isSpace xs) = any isSpace xs"] + rrs2 <- parseAdhocs def ["forall f g xs. map f (map g xs) = map (f . g) xs"] + let + -- compare hashsets to avoid ordering issues + terms = HashSet.fromList $ map groundTerms rrs1 + + return + [ TestLabel caseName $ TestCase $ + assertEqual caseName expected $ + HashSet.fromList $ getGroundTerms retrie + | (caseName, retrie, expected) <- + [ ("apply", apply rrs1, terms) + , ("apply twice", apply rrs1 >> apply rrs2, terms) + , ("query", () <$ query rrs1, terms) + , ("focus", focus rrs1, terms) + , ("focus empty", focus ([] :: [Rewrite Universe]), HashSet.empty) + , ("focus empty next", focus ([] :: [Rewrite Universe]) >> apply rrs1, terms) + -- We should generate no ground terms if no iteration happens + , ("iterateR 0", iterateR 0 (apply rrs1), HashSet.empty) + , ("iterateR 0 then apply", iterateR 0 (apply rrs2) >> apply rrs1, terms) + , ("iterateR 5", iterateR 5 (apply rrs1), terms) + -- test that adding imports first (calling 'tell') doesn't block us + -- from finding ground terms + , ("addImports", addImports mempty >> apply rrs1, terms) + , ("ifChanged normal", ifChanged (apply rrs1) (apply rrs2), terms) + -- the pathological case: changed but no ground terms + , ("ifChanged weird", ifChanged (addImports mempty) (apply rrs1), terms) + , ("liftIO", liftIO (return ()) >> apply rrs1, HashSet.empty) + , ("liftIO after focus", focus rrs1 >> liftIO (return ()) >> apply rrs2, terms) + ] + ] diff --git a/tests/Ignore.hs b/tests/Ignore.hs new file mode 100644 --- /dev/null +++ b/tests/Ignore.hs @@ -0,0 +1,67 @@ +-- 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. +-- +module Ignore (ignoreTest) where + +import Retrie.Util +import System.FilePath +import Test.HUnit +import Util + +allFiles :: [FilePath] +allFiles = [ c:".hs" | c <- ['A'..'F'] ] ++ + [ "ignored-folder/A.thrift" + , "ignored-folder/subfolder/Ctest.hs" + , "ignored-folder/subfolder/subfolder2/Btest.hs" + ] + +ignoredFiles :: [FilePath] +ignoredFiles = ["B.hs", "C.hs", "ignored-folder/"] + +ignoreTest :: Test +ignoreTest = TestLabel "ignore" $ TestList + [ hgTest + , gitTest + , unifiedTest1 + , unifiedTest2 + ] + +assertStuff :: FilePath -> Maybe (FilePath -> Bool) -> IO () +assertStuff _ Nothing = assertFailure "pred was Nothing" +assertStuff repo (Just p) = do + assertBool "B.hs ignored" $ p $ repo "B.hs" + assertBool "C.hs ignored" $ p $ repo "C.hs" + assertBool "A.hs not ignored" $ not $ p $ repo "A.hs" + assertBool "Foo.hs not ignored" $ not $ p $ repo "Foo.hs" + assertBool "subfolder ignored" $ + p $ repo "ignored-folder/subfolder/Ctest.hs" + assertBool "deep subfolder ignored" $ + p $ repo "ignored-folder/subfolder/subfolder2/Btest.hs" + +hgTest :: Test +hgTest = TestLabel "hg ignore" $ TestCase $ + withFakeHgRepo ignoredFiles allFiles $ \repo -> do + maybePredicate <- hgIgnorePred repo + assertStuff repo maybePredicate + case maybePredicate of + Just p -> + assertBool "subfolder non-hs file not ignored" $ + not $ p $ repo "ignored-folder/A.thrift" + Nothing -> assertFailure "pred was Nothing" + +gitTest :: Test +gitTest = TestLabel "git ignore" $ TestCase $ + withFakeGitRepo ignoredFiles allFiles $ \repo -> + gitIgnorePred repo >>= assertStuff repo + +unifiedTest1 :: Test +unifiedTest1 = TestLabel "vcs ignore on git repo" $ TestCase $ + withFakeGitRepo ignoredFiles allFiles $ \repo -> + vcsIgnorePred repo >>= assertStuff repo + +unifiedTest2 :: Test +unifiedTest2 = TestLabel "vcs ignore on hg repo" $ TestCase $ + withFakeHgRepo ignoredFiles allFiles $ \repo -> + vcsIgnorePred repo >>= assertStuff repo diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,21 @@ +-- 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. +-- +module Main (main) where + +import Test.HUnit +import Test.Tasty +import Test.Tasty.HUnit + +import Retrie +import AllTests + +main :: IO () +main = allTests Silent >>= defaultMain . toTasty . TestLabel "retrie" + +toTasty :: Test -> TestTree +toTasty (TestLabel lbl (TestCase io)) = testCase lbl io +toTasty (TestLabel lbl (TestList ts)) = testGroup lbl (map toTasty ts) +toTasty t = error $ "toTasty: unlabeled test " ++ show t diff --git a/tests/ParseQualified.hs b/tests/ParseQualified.hs new file mode 100644 --- /dev/null +++ b/tests/ParseQualified.hs @@ -0,0 +1,38 @@ +-- 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. +-- +module ParseQualified (parseQualifiedTest) where + +import Retrie +import Retrie.Rewrites +import System.FilePath +import Test.HUnit + +parseQualifiedTest :: Test +parseQualifiedTest = TestLabel "parseQualified" $ TestCase $ do + assertEqual "parseQualified1" + (parseQualified "My.Thing.foo") + (mkRight "My.Thing" "foo") + assertEqual "parseQualified2" + (parseQualified "foo") + (Left "unqualified function name: foo") + assertEqual "parseQualified3" + (parseQualified "My.<>") + (mkRight "My" "<>") + assertEqual "parseQualified4" + (parseQualified "My.CategoryLibrary..") + (mkRight "My.CategoryLibrary" ".") + assertEqual "parseQualified5" + (parseQualified "My.Strange.Operators..<.>.") + (mkRight "My.Strange.Operators" ".<.>.") + assertEqual "parseQualified6" + (parseQualified "<|>") + (Left "unqualified operator name: <|>") + assertEqual "parseQualified7" + (parseQualified "Bad.ModName:<>") + (Left "malformed qualified operator: Bad.ModName:<>") + where + mkRight x y = Right + (moduleNameSlashes (mkModuleName x) <.> "hs", mkFastString y) diff --git a/tests/Targets.hs b/tests/Targets.hs new file mode 100644 --- /dev/null +++ b/tests/Targets.hs @@ -0,0 +1,66 @@ +-- 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. +-- +module Targets + ( basicTargetTest + , targetedWithGroundTerms + ) where + +import qualified Data.HashSet as HashSet +import Data.List +import Retrie.GroundTerms +import Retrie.Options +import System.FilePath +import Test.HUnit +import Util + +basicTargetTest :: Test +basicTargetTest = TestLabel "Target files without ground terms specified" $ + TestCase $ assertFileListEqual retrieTargetFiles [] retrieTargetFiles + +targetedWithGroundTerms :: Test +targetedWithGroundTerms = + TestLabel "Should filter to subset of target files with ground terms" $ + TestCase $ assertFileListEqual expectedFps gts targetFps + where + gts = [HashSet.fromList ["Groundterm"]] + targetFps = retrieTargetFiles + -- 'withFakeHgRepo' creates every file with its own name as the contents + expectedFps = ["targeted/Groundterm.hs"] + +assertFileListEqual + :: [FilePath] + -> [GroundTerms] + -> [FilePath] + -> Assertion +assertFileListEqual expected gts targetFps = + withFakeHgRepo [] allFiles $ \dir -> do + let opts = optionsWithTargetFiles dir targetFps + filepaths <- getTargetFiles opts gts + assertPermutationOf "Targeted files should be all of those specified" + (map (dir ) expected) filepaths + where + assertPermutationOf m as bs = assertEqual m (sort as) (sort bs) + +retrieTargetFiles :: [FilePath] +retrieTargetFiles = + [ "targeted/File.hs" + , "targeted/Nested/File.hs" + , "targeted/Groundterm.hs" + ] + +allFiles :: [FilePath] +allFiles = + [ "foo/Foo.hs" + , "foo/bar/Foobar.hs" + , "bar/Bar.hs" + , "bar/foo/Baz.hs" + , "bar/ignore/Ignore.hs" + , "targeted/File.c" + ] ++ retrieTargetFiles + +optionsWithTargetFiles :: FilePath -> [FilePath] -> Options +optionsWithTargetFiles dir targets = (defaultOptions dir) + { targetFiles = map (dir ) targets } diff --git a/tests/Util.hs b/tests/Util.hs new file mode 100644 --- /dev/null +++ b/tests/Util.hs @@ -0,0 +1,54 @@ +-- 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. +-- +module Util where + +import Control.Monad +import System.Directory (createDirectoryIfMissing) +import System.Exit +import System.FilePath +import System.IO.Temp +import System.Process +import Test.HUnit + +withFakeRepo :: (FilePath -> IO ()) -> (FilePath -> IO ()) -> IO () +withFakeRepo f initialise = + withSystemTempDirectory "retrieTmpRepo" $ \dir -> do + initialise dir + f dir + +withFakeRepoCmds + :: String + -> String + -> [FilePath] + -> [FilePath] + -> (FilePath -> IO ()) + -> IO () +withFakeRepoCmds initCmd ignoreFile ignoredFiles allFiles f = + withFakeRepo f $ \dir -> do + doOrDie dir initCmd + createAllFiles dir allFiles + writeFile (dir ignoreFile) $ unlines ignoredFiles + where + createAllFiles dir files = forM_ files $ \fp -> do + let filePath = dir fp + createDirectoryIfMissing True (takeDirectory filePath) + -- Every file has its own name as the contents. + writeFile filePath fp + +withFakeHgRepo :: [FilePath] -> [FilePath] -> (FilePath -> IO ()) -> IO () +withFakeHgRepo = withFakeRepoCmds "hg init" ".gitignore" + +withFakeGitRepo :: [FilePath] -> [FilePath] -> (FilePath -> IO ()) -> IO () +withFakeGitRepo = withFakeRepoCmds "git init" ".gitignore" + +doOrDie :: FilePath -> String -> IO () +doOrDie dir cmd = do + let shellCmd = (shell cmd) { cwd = Just dir } + (ec, _, _) <- readCreateProcessWithExitCode shellCmd "" + case ec of + ExitSuccess -> return () + ExitFailure err -> + assertFailure $ cmd ++ " failed with: " ++ show err diff --git a/tests/inputs/Adhoc.test b/tests/inputs/Adhoc.test new file mode 100644 --- /dev/null +++ b/tests/inputs/Adhoc.test @@ -0,0 +1,24 @@ +# 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. +# +--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 +=== + module Adhoc where + + main :: IO () +-main = print $ foo (bar [1..10]) ++main = print $ bar [1..10] - 2 + + foo :: Int -> Int + foo x = x - 2 + + bar :: [Int] -> Int +-bar ys = length (filter even zs) ++bar ys = count even zs + where +- zs = map (+1) (map (*3) ys) ++ zs = map ((+1) . (*3)) ys diff --git a/tests/inputs/Adhoc2.custom b/tests/inputs/Adhoc2.custom new file mode 100644 --- /dev/null +++ b/tests/inputs/Adhoc2.custom @@ -0,0 +1,22 @@ +# 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. +# +-u Adhoc2.foo +=== + module Adhoc2 where + + main :: IO () +-main = print $ foo (bar [1..10]) ++main = print $ bar [1..10] - 2 + + foo :: Int -> Int + foo x = x - 2 + + bar :: [Int] -> Int +-bar ys = length (filter even zs) ++bar ys = count even zs + where +- zs = map (+1) (map (*3) ys) ++ zs = map ((+1) . (*3)) ys diff --git a/tests/inputs/Backticks.test b/tests/inputs/Backticks.test new file mode 100644 --- /dev/null +++ b/tests/inputs/Backticks.test @@ -0,0 +1,24 @@ +# 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. +# +-u Backticks.foo +=== + module Backticks where + + main :: IO () +-main = print $ foo `bar` [1..10] ++main = print $ (baz `div` quux 10) `bar` [1..10] + + foo :: Int + foo = baz `div` quux 10 + + bar :: Int -> [Int] -> Int + bar x xs = x + sum xs + + baz :: Int + baz = 100 + + quux :: Int -> Int + quux x = x - 1 diff --git a/tests/inputs/Backticks2.test b/tests/inputs/Backticks2.test new file mode 100644 --- /dev/null +++ b/tests/inputs/Backticks2.test @@ -0,0 +1,29 @@ +# 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. +# +-u Backticks.bar +=== + module Backticks where + + main :: IO () + main = do +- print $ foo `bar` [1..10] ++ print $ foo + sum [1..10] +- print $ (foo `bar`) [1..10] ++ print $ (\ xs -> foo + sum xs) [1..10] +- print $ (`bar` [1..10]) foo ++ print $ (\ x -> x + sum [1..10]) foo + + foo :: Int + foo = baz `div` quux 10 + + bar :: Int -> [Int] -> Int + bar x xs = x + sum xs + + baz :: Int + baz = 100 + + quux :: Int -> Int + quux x = x - 1 diff --git a/tests/inputs/CPP.test b/tests/inputs/CPP.test new file mode 100644 --- /dev/null +++ b/tests/inputs/CPP.test @@ -0,0 +1,61 @@ +# 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. +# +--adhoc "forall f g xs. map f (map g xs) = map (f . g) xs" +-u CPP.otherthing +=== + {-# LANGUAGE CPP #-} + module CPP where + + #define TRUE 1 + + infixr 0 $ + + main :: IO () + main = print $ foo (bar [1..10]) + + foo :: Int -> Int + foo x = x - 2 + + #if TRUE + bar :: [Int] -> Int + bar ys = length (filter even zs) + where +- zs = map (+1) (map (*3) ys) ++ zs = map ((+1) . (*3)) ys + #endif + + #if TRUE + bar2 :: [Int] -> Int + bar2 ys = length (filter even zs) + where +- zs = map (+2) (map (*3) ys) ++ zs = map ((+2) . (*3)) ys + #else + bar2 :: [Int] -> Int + bar2 ys = length (filter even zs) + where +- zs = map (+2) (map (*4) ys) ++ zs = map ((+2) . (*4)) ys + + otherthing :: Maybe a -> Int + otherthing mb = case mb of + Just{} -> 1 + Nothing -> 0 + + useit :: Int +-useit = otherthing (Just 54) ++useit = case Just 54 of ++ Just{} -> 1 ++ Nothing -> 0 + + #if TRUE + useit2 :: Int +-useit2 = otherthing (Just 42) ++useit2 = case Just 42 of ++ Just{} -> 1 ++ Nothing -> 0 + #endif + #endif diff --git a/tests/inputs/CPPConflict.test b/tests/inputs/CPPConflict.test new file mode 100644 --- /dev/null +++ b/tests/inputs/CPPConflict.test @@ -0,0 +1,21 @@ +# 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. +# +--rule-forward CPPConflict.foobar +=== + {-# LANGUAGE CPP #-} + module CPPConflict where + + -- We should NOT match this rule, as it would overwrite the CPP directives. + {-# RULES "foobar" forall x y. foo bar x y = foo bar y x #-} + + baz x y = foo + #if __XXX__ + bar + #else + somethingElse + #endif + x + y diff --git a/tests/inputs/Capture.test b/tests/inputs/Capture.test new file mode 100644 --- /dev/null +++ b/tests/inputs/Capture.test @@ -0,0 +1,60 @@ +# 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. +# +-u Capture.foo +-u Capture.bar +-u Capture.baz +-u Capture.baz2 +-u Capture.quux +-u Capture.stmts +=== + module Capture where + + y = 5 + xy9 = 4 + + -- basic: y should get renamed so it doesn't capture substitution + foo :: Int -> Int -> Int + foo x y = x + y + +-test1 = print $ map (foo y) [4] ++test1 = print $ map (\ y1 -> y + y1) [4] + + -- reverse: ensure substition for 'x' doesn't happen under lambda + bar :: Int -> Int -> Int + bar x y = y + (\x -> y + x) x + +-test2 = print $ map (bar y) [4] ++test2 = print $ map (\ y1 -> y1 + (\x -> y1 + x) y) [4] + + -- double: renaming outer y to y1 forces inner y1 to become y2 + baz :: Int -> Int -> Int + baz x y = y + (\y1 -> y + y1) x + +-test3 = print $ map (baz y) [4] ++test3 = print $ map (\ y1 -> y1 + (\y2 -> y1 + y2) y) [4] + + -- double2: same as double, make sure var incrementing works + -- for longer vars and past 9 + baz2 :: Int -> Int -> Int + baz2 x xy9 = xy9 + (\xy10 -> xy9 + xy10) x + +-test4 = print $ map (baz2 xy9) [4] ++test4 = print $ map (\ xy10 -> xy10 + (\xy11 -> xy10 + xy11) xy9) [4] + + -- let: works for let expressions + quux :: Int -> Int + quux x = let y = 5 in x + y + + -- TODO: fix parens in result +-test5 = print $ quux y ++test5 = print $ (let y1 = 5 in y + y1) + + -- stmts + stmts :: Int -> IO Int + stmts x = do y <- return x; print (x + y) + +-test6 = stmts y ++test6 = do y1 <- return y; print (y + y1) diff --git a/tests/inputs/Combined.test b/tests/inputs/Combined.test new file mode 100644 --- /dev/null +++ b/tests/inputs/Combined.test @@ -0,0 +1,85 @@ +# 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. +# +-l Union.fo +-l Types.ascribe +-u Parens.foo -u Parens.bar +-l Union.fi +-u Parens.quux -u Parens.blarg +-r Types.ascribe +-f Operator.f +--import "import Combined" +=== + module Combined where ++import Operator + + main :: IO () + main = do + let t = "some text, with commas, and spaces" +- ts = split " " t +- tss = [ split "," t' | t' <- ts ] ++ ts = Text.splitOn " " t ++ tss = [ Text.splitOn "," t' | t' <- ts ] + print tss + + main :: IO (Pointless ()) + main = do +- print $ (foo :: Int -> String -> Bool) 54 "yolo" +- print $ (bar ("swaggins" :: Text) (True :: Bool) :: Maybe Int) ++ print $ (foo (54 :: Int) ("yolo" :: String) :: Bool) ++ print $ (bar :: Text -> Bool -> Maybe Int) "swaggins" True + + #define CPPVALUE 1 + + foo :: Int + foo = 3 + 4 + + bar :: Int +-bar = 5 * foo ++bar = 5 * (3 + 4) + + baz :: Int +-baz = quux bar ++baz = foo * bar + + baz2 :: Int +-baz2 = foo * bar ++baz2 = (3 + 4) * 5 * foo + + quux :: Int -> Int +-quux x = foo * x ++quux x = (3 + 4) * x + + splat :: Int +-splat = undefined foo ++splat = undefined (3 + 4) + + blarg :: Int -> Int + blarg = + case 54 of + 0 -> pred + _ -> succ + + blerg :: Int +-blerg = blarg 42 ++blerg = (case 54 of ++ 0 -> pred ++ _ -> succ) 42 + + jank :: IO (Int -> Int) +-jank = return blarg ++jank = return (case 54 of ++ 0 -> pred ++ _ -> succ) + + jenk :: IO Int +-jenk = return $ blarg 42 ++jenk = return $ (case 54 of ++ 0 -> pred ++ _ -> succ) 42 + + mneh :: Bool +-mneh = 3 == 2 ++mneh = f 3 diff --git a/tests/inputs/Commas.test b/tests/inputs/Commas.test new file mode 100644 --- /dev/null +++ b/tests/inputs/Commas.test @@ -0,0 +1,17 @@ +# 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. +# +-u Commas.foo +=== + module Commas where + + import Debug.Trace + + main :: IO () +-main = print [(foo), pred foo, foo] ++main = print [succ 4, pred (succ 4), succ 4] + + foo :: Int + foo = succ 4 diff --git a/tests/inputs/Comments.test b/tests/inputs/Comments.test new file mode 100644 --- /dev/null +++ b/tests/inputs/Comments.test @@ -0,0 +1,56 @@ +# 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. +# +-l Comments.old +-l Comments.swap +-l Comments.convt +-u Comments.oldFunc +=== + module Comments where + + {-# RULES "old" forall x. oldfunc x = newfunc x #-} + {-# RULES "swap" forall x y. swapFunc x y = newSwapFunc y x #-} + {-# RULES "convt" a = alpha #-} + + main1 :: IO () + main1 = +- oldfunc -- note: change this to newfunc ++ newfunc -- note: change this to newfunc + arg + + main2 :: IO () + main2 = +- swapFunc ++ newSwapFunc arg2 + -- note: swap args and update +- arg1 arg2 ++ arg1 + + main3 :: IO () + main3 = + [ + f -- first +- a +- , a -- ^ second ++ alpha ++ , alpha -- ^ second + -- third +- , a ++ , alpha + ] + + oldFunc x = + [ x + , x + ] + +-main4 = oldFunc -- comment here ++main4 = [ -- comment here + -- more comment + foo ++ , -- comment here ++ -- more comment ++ foo ++ ] diff --git a/tests/inputs/DependentStmt.custom b/tests/inputs/DependentStmt.custom new file mode 100644 --- /dev/null +++ b/tests/inputs/DependentStmt.custom @@ -0,0 +1,17 @@ +# 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. +# +=== + module DependentStmt where + + -- This test rewrites foo to baz, but only in scope of 'y'. + + main :: IO () + main = do + x <- bar 7 + foo x + y <- bar 54 +- foo y ++ baz y diff --git a/tests/inputs/Foo.test b/tests/inputs/Foo.test new file mode 100644 --- /dev/null +++ b/tests/inputs/Foo.test @@ -0,0 +1,15 @@ +# 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. +# +-u Foo.foo +=== + module Foo where + + foo :: [Int] -> [Int] + foo xs = xs ++ [1,2, 3] + + bar :: [Int] +-bar = foo [4,5,6] ++bar = [4,5,6] ++ [1,2, 3] diff --git a/tests/inputs/FooFold.test b/tests/inputs/FooFold.test new file mode 100644 --- /dev/null +++ b/tests/inputs/FooFold.test @@ -0,0 +1,27 @@ +# 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. +# +-f FooFold.foo +-f FooFold.baz +=== + module FooFold where + + import Foo + + foo :: [Int] -> [Int] + foo xs = xs ++ [1,2, 3] + + bar :: [Int] +-bar = [4,5,6] ++ [1,2,3] ++bar = foo [4,5,6] + + newtype Baz = Baz [Int] + + baz :: Baz -> [Int] + baz (Baz is) = is ++ bar + + quux :: [Int] +-quux = [7,8, 9 ] ++ bar ++quux = baz (Baz [7,8, 9 ]) diff --git a/tests/inputs/Imports.test b/tests/inputs/Imports.test new file mode 100644 --- /dev/null +++ b/tests/inputs/Imports.test @@ -0,0 +1,33 @@ +# 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. +# +-f Imports.foo +--import "import Bar" +--import "import Data.Coerce (coerce)" +--import "import qualified Data.Text as Text" +--import "import Foo" +--import "import Bar" +=== + module Imports where + + import Foo ++import Bar ++import Data.Coerce (coerce) ++import qualified Data.Text as Text + + foo :: [Int] -> [Int] + foo xs = xs ++ [1,2, 3] + + bar :: [Int] +-bar = [4,5,6] ++ [1,2,3] ++bar = foo [4,5,6] + + newtype Baz = Baz [Int] + + baz :: Baz -> [Int] + baz (Baz is) = is ++ bar + + quux :: [Int] + quux = [7,8, 9 ] ++ bar diff --git a/tests/inputs/Iterate.test b/tests/inputs/Iterate.test new file mode 100644 --- /dev/null +++ b/tests/inputs/Iterate.test @@ -0,0 +1,13 @@ +# 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. +# +--adhoc "forall x. succ x = succ (succ x)" +--iterate 4 +=== + module Iterate where + + main :: IO () +-main = print $ succ 54 ++main = print $ succ (succ (succ (succ (succ 54)))) diff --git a/tests/inputs/MatchGroup.test b/tests/inputs/MatchGroup.test new file mode 100644 --- /dev/null +++ b/tests/inputs/MatchGroup.test @@ -0,0 +1,20 @@ +# 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. +# +-u MatchGroup.foo +=== + module MatchGroup where + + foo :: [a] -> a + foo [] = error "foo: empty list" + foo (x:xs) = x + + main :: IO () + main = do + -- unfold tests +- print (foo []) ++ print (error "foo: empty list") +- print $ foo (1:[2]) ++ print $ 1 diff --git a/tests/inputs/Operator.test b/tests/inputs/Operator.test new file mode 100644 --- /dev/null +++ b/tests/inputs/Operator.test @@ -0,0 +1,76 @@ +# 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. +# +-l Operator.print +-l Operator.printAt +-u Operator.f +=== + module Operator where + + main :: IO () + main = do +- putStrLn $ show $ 3 + 4 ++ print $ 3 + 4 + -- lets make sure +- putStrLn .@@@ show .@@@ foo || ++ print $ foo || + -- that comments end up in the right place + bar || + baz && + -- even this one + quux + + -- lets also make sure +- putStrLn $ show $ foo ++ print $ foo + -- that these comments end up in the right place + || bar + || baz + -- even when the operator is leading + && quux + + return ({- comment -} x >= 1 || y >= 2) + +- putStrLn {- comment here -} $ show $ foo || bar +- putStrLn $ {- comment here -} show $ foo || bar +- putStrLn $ show {- comment here -} $ foo || bar +- putStrLn $ show $ {- comment here -} foo || bar +- putStrLn $ show $ foo {- comment here -} || bar +- putStrLn $ show $ foo || {- comment here -} bar +- putStrLn $ show $ foo || bar {- comment here -} ++ print $ foo || bar ++ print $ foo || bar ++ print $ foo || bar ++ print $ {- comment here -} foo || bar ++ print $ foo {- comment here -} || bar ++ print $ foo || {- comment here -} bar ++ print $ foo || bar {- comment here -} + +- putStrLn (show $ foo || bar) +- putStrLn (show (foo || bar)) ++ print $ foo || bar ++ print $ foo || bar + + {-# RULES "print" forall x. putStrLn $ show $ x = print $ x #-} + + f :: Int -> Bool + f x = x == 2 + + g :: Int -> Bool +-g y = f y /= False ++g y = (y == 2) /= False + + roundtrip :: IO [a] + roundtrip = return $ mconcat + [ timeToText $ time_enrolled - mod time_enrolled t + , ":" + ] + + -- Ensure local fixity declarations are handled properly + (.@@@) :: (a -> b) -> a -> b + f .@@@ x = f x + + infixr 0 .@@@ + {-# RULES "printAt" forall x. putStrLn .@@@ show .@@@ x = print $ x #-} diff --git a/tests/inputs/Parens.test b/tests/inputs/Parens.test new file mode 100644 --- /dev/null +++ b/tests/inputs/Parens.test @@ -0,0 +1,58 @@ +# 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. +# +-u Parens.foo +-u Parens.bar +-u Parens.quux +-u Parens.blarg +=== + module Parens where + + foo :: Int + foo = 3 + 4 + + bar :: Int +-bar = 5 * foo ++bar = 5 * (3 + 4) + + baz :: Int +-baz = quux bar ++baz = foo * bar + + baz2 :: Int +-baz2 = foo * bar ++baz2 = (3 + 4) * 5 * foo + + quux :: Int -> Int +-quux x = foo * x ++quux x = (3 + 4) * x + + splat :: Int +-splat = undefined foo ++splat = undefined (3 + 4) + + blarg :: Int -> Int + blarg = + case 54 of + 0 -> pred + _ -> succ + + blerg :: Int +-blerg = blarg 42 ++blerg = (case 54 of ++ 0 -> pred ++ _ -> succ) 42 + + jank :: IO (Int -> Int) +-jank = return blarg ++jank = return (case 54 of ++ 0 -> pred ++ _ -> succ) + + jenk :: IO Int +-jenk = return $ blarg 42 ++jenk = return $ (case 54 of ++ 0 -> pred ++ _ -> succ) 42 diff --git a/tests/inputs/PartialF.test b/tests/inputs/PartialF.test new file mode 100644 --- /dev/null +++ b/tests/inputs/PartialF.test @@ -0,0 +1,21 @@ +# 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. +# +-f PartialF.foo +=== + module PartialF where + + foo :: Int -> Int -> Int + foo x y = x + y + + main :: IO () + main = do + -- fold tests +- print (6 + 7) +- print $ map (\ y -> 5 + y) [1..4] +- print $ zipWith (\ x y -> x + y) [1..3] [10..] ++ print (foo 6 7) ++ print $ map (foo 5) [1..4] ++ print $ zipWith foo [1..3] [10..] diff --git a/tests/inputs/PartialU.test b/tests/inputs/PartialU.test new file mode 100644 --- /dev/null +++ b/tests/inputs/PartialU.test @@ -0,0 +1,21 @@ +# 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. +# +-u PartialU.foo +=== + module PartialU where + + foo :: Int -> Int -> Int + foo x y = x + y + + main :: IO () + main = do + -- unfold tests +- print (foo 6 7) +- print $ map (foo 5) [1..4] +- print $ zipWith foo [1..3] [10..] ++ print (6 + 7) ++ print $ map (\ y -> 5 + y) [1..4] ++ print $ zipWith (\ x y -> x + y) [1..3] [10..] diff --git a/tests/inputs/PatBind.test b/tests/inputs/PatBind.test new file mode 100644 --- /dev/null +++ b/tests/inputs/PatBind.test @@ -0,0 +1,29 @@ +# 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. +# +-l PatBind.rule +-l PatBind.infix +=== + module PatBind where + + {-# RULES + "rule" forall a. let (x,y) = one a in f x = let (y,x) = two a in f x + #-} + + {-# RULES + "infix" forall a. let x1:x2:xs = flipFirst a in f x2 x1 = let x1:x2:xs = a in f x1 x2 + #-} + + zzz :: () +-zzz = let (alpha, beta) = one global +- in f alpha ++zzz = let (y,x) = two global ++ in f x + + yyy :: () +-yyy = let snd:fst:xs = flipFirst global +- in f fst snd ++yyy = let x1:x2:xs = global ++ in f x1 x2 diff --git a/tests/inputs/Query.custom b/tests/inputs/Query.custom new file mode 100644 --- /dev/null +++ b/tests/inputs/Query.custom @@ -0,0 +1,10 @@ +# 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. +# +=== + module Query where + + main :: IO () + main = print $ succ (succ (succ 54)) diff --git a/tests/inputs/Readme.custom b/tests/inputs/Readme.custom new file mode 100644 --- /dev/null +++ b/tests/inputs/Readme.custom @@ -0,0 +1,17 @@ +# 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. +# +=== + module Readme where + + baz, bar, quux :: IO () +-baz = fooOld "foo" ++baz = fooNew Foo + +-bar = fooOld "bar" ++bar = fooNew Bar + +-quux = fooOld "quux" ++quux = fooNew (error "invalid argument: quux") diff --git a/tests/inputs/Readme1.test b/tests/inputs/Readme1.test new file mode 100644 --- /dev/null +++ b/tests/inputs/Readme1.test @@ -0,0 +1,21 @@ +# 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. +# +--type-backward Readme1.MyMaybe +=== + module Readme1 where + + maybe :: b -> (a -> b) -> Maybe a -> b + maybe d f mb = case mb of + Nothing -> d + Just x -> f x + + type MyMaybe = Maybe Int + + {-# RULES "myRule" forall x. maybe Nothing Just x = x #-} + +-foo :: Maybe Int ++foo :: MyMaybe + foo = maybe Nothing Just (Just 5) diff --git a/tests/inputs/Readme2.test b/tests/inputs/Readme2.test new file mode 100644 --- /dev/null +++ b/tests/inputs/Readme2.test @@ -0,0 +1,26 @@ +# 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. +# +--unfold Readme2.maybe +=== + module Readme2 where + + maybe :: b -> (a -> b) -> Maybe a -> b + maybe d f mb = case mb of + Nothing -> d + Just x -> f x + + type MyMaybe = Maybe Int + +-{-# RULES "myRule" forall x. maybe Nothing Just x = x #-} ++{-# RULES "myRule" forall x. case x of ++ Nothing -> Nothing ++ Just x1 -> Just x1 = x #-} + + foo :: MyMaybe +-foo = maybe Nothing Just (Just 5) ++foo = case Just 5 of ++ Nothing -> Nothing ++ Just x -> Just x diff --git a/tests/inputs/Readme3.test b/tests/inputs/Readme3.test new file mode 100644 --- /dev/null +++ b/tests/inputs/Readme3.test @@ -0,0 +1,26 @@ +# 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. +# +--fold Readme3.maybe +=== + module Readme3 where + + maybe :: b -> (a -> b) -> Maybe a -> b + maybe d f mb = case mb of + Nothing -> d + Just x -> f x + + type MyMaybe = Maybe Int + +-{-# RULES "myRule" forall x. case x of +- Nothing -> Nothing +- Just x1 -> Just x1 = x #-} ++{-# RULES "myRule" forall x. maybe Nothing Just x = x #-} + + foo :: MyMaybe +-foo = case Just 5 of +- Nothing -> Nothing +- Just x -> Just x ++foo = maybe Nothing Just (Just 5) diff --git a/tests/inputs/Readme4.test b/tests/inputs/Readme4.test new file mode 100644 --- /dev/null +++ b/tests/inputs/Readme4.test @@ -0,0 +1,21 @@ +# 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. +# +--rule-forward Readme4.myRule +=== + module Readme4 where + + maybe :: b -> (a -> b) -> Maybe a -> b + maybe d f mb = case mb of + Nothing -> d + Just x -> f x + + type MyMaybe = Maybe Int + + {-# RULES "myRule" forall x. maybe Nothing Just x = x #-} + + foo :: MyMaybe +-foo = maybe Nothing Just (Just 5) ++foo = Just 5 diff --git a/tests/inputs/Readme5.test b/tests/inputs/Readme5.test new file mode 100644 --- /dev/null +++ b/tests/inputs/Readme5.test @@ -0,0 +1,21 @@ +# 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. +# +--type-forward Readme5.MyMaybe +=== + module Readme5 where + + maybe :: b -> (a -> b) -> Maybe a -> b + maybe d f mb = case mb of + Nothing -> d + Just x -> f x + + type MyMaybe = Maybe Int + + {-# RULES "myRule" forall x. maybe Nothing Just x = x #-} + +-foo :: MyMaybe ++foo :: Maybe Int + foo = Just 5 diff --git a/tests/inputs/Records.test b/tests/inputs/Records.test new file mode 100644 --- /dev/null +++ b/tests/inputs/Records.test @@ -0,0 +1,24 @@ +# 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. +# +--adhoc "forall r i. r { rOne = i } = r { rOne = i + 12 }" +--adhoc "forall s. Record { rTwo = s } = Record { rTwo = s ++ s }" +=== + module Records where + + data Record = Record + { rOne :: Int + , rTwo :: String + } + + defR :: Record + defR = Record 1 "record" + + main :: IO () + main = do +- print $ defR { rOne = 42 } +- print $ Record { rTwo = "foo" } ++ print $ defR { rOne = 42 + 12 } ++ print $ Record { rTwo = "foo" ++ "foo" } diff --git a/tests/inputs/Records2.test b/tests/inputs/Records2.test new file mode 100644 --- /dev/null +++ b/tests/inputs/Records2.test @@ -0,0 +1,23 @@ +# 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. +# +--adhoc "forall one two three four. Record { rOne = one, rTwo = two, rThree = three, rFour = four } = foo mempty { fooOne = Bar one, fooTwo = Baz (baz four) four }" +=== + module Records2 where + + data Record = Record + { rOne :: String + , rTwo :: Int + , rThree :: Double + , rFour :: String + } + +-blah = Record +- { rOne = "one here" +- , rTwo = 54 +- , rThree = 1.1 +- , rFour = "and four" +- } ++blah = foo mempty { fooOne = Bar "one here", fooTwo = Baz (baz "and four") "and four" } diff --git a/tests/inputs/Recursion.test b/tests/inputs/Recursion.test new file mode 100644 --- /dev/null +++ b/tests/inputs/Recursion.test @@ -0,0 +1,58 @@ +# 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. +# +-f Recursion.foo +--type-backward Recursion.Foo +--rule-forward Recursion.foo +--rule-backward Recursion.foo +--adhoc "forall x y. blarg x y = dupa x y" +=== + module Recursion where + + -- Goal of these tests is to make sure rewriting doesn't introduce unintended + -- recursion. It doesn't protect against infinite mutual recursion, but we can + -- at least spot self-recursion. + + -- foo should not be rewritten + foo :: Int -> Int + foo = foldr bar baz + + quux :: Int -> Int +-quux = foldr bar baz ++quux = foo + + -- Foo should not be rewritten + type Foo a = Bar a Int +-type Quux b = Bar b Int ++type Quux b = Foo b + + -- The rule should not be rewritten + {-# RULES "foo" forall f g xs. map f (map g xs) = map (f . g) xs #-} +-blah = map succ (map pred [1..2]) ++blah = map (succ . pred) [1..2] + +-bleh = map (succ . pred) [1..10] ++bleh = map succ (map pred [1..10]) + + -- dupa should not be rewritten by the adhoc rule + dupa x y = blarg x y +-dupa2 = blarg some args ++dupa2 = dupa some args + + main :: IO () + main = do + let + dupa x y = blarg x y +- dupa2 = blarg some otherargs ++ dupa2 = dupa some otherargs + + dupa <- blarg "notok" "ok" +- dupa2 <- blarg "notok" "ok" ++ dupa2 <- dupa "notok" "ok" + + let + -- no args + dupa = blarg "foo" "bar" + return () diff --git a/tests/inputs/Shadowing.test b/tests/inputs/Shadowing.test new file mode 100644 --- /dev/null +++ b/tests/inputs/Shadowing.test @@ -0,0 +1,80 @@ +# 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. +# +-u Shadowing.foo +=== + module Shadowing where + + foo :: Int -> Int + foo = succ + + bar :: Int -> Int +-bar x = foo x ++bar x = succ x + + baz :: (Int -> Int) -> Int -> Int + baz foo = foo + + quux :: Int -> Int + quux x = + let foo = pred + in foo x + + boo :: Int -> Int + boo x = +- let bar = foo ++ let bar = succ + in let foo = pred + baz = foo + in foo x + + foomap :: Int -> Int +-foomap x = map (\ foo -> foo x) [succ, pred, foo] ++foomap x = map (\ foo -> foo x) [succ, pred, succ] + + foowhere :: Int -> Int +-foowhere x = foo (bar x) ++foowhere x = succ (bar x) + where +- bar = baz foo ++ bar = baz succ + baz foo = foo + + foowhere2 :: Int -> Int +-foowhere2 x = foo (bar x) ++foowhere2 x = succ (bar x) + where + bar = foo + where + foo = baz + baz = foo + + fooguards :: Int -> Int + fooguards x +- | Just bar <- return foo = bar (foo x) +- | Just foo <- return foo = foo x +- | Just foo <- return foo, Just bar <- return foo = bar (foo x) +- | otherwise = foo x ++ | Just bar <- return succ = bar (succ x) ++ | Just foo <- return succ = foo x ++ | Just foo <- return succ, Just bar <- return foo = bar (foo x) ++ | otherwise = succ x + + foomonadic :: Int -> Maybe Int + foomonadic x = do +- y <- return $ foo x +- foo <- return (foo . pred) ++ y <- return $ succ x ++ foo <- return (succ . pred) + z <- return $ foo y + return $ foo z + + foomonadic2 :: Int -> Maybe Int + foomonadic2 x = do +- y <- return $ foo x ++ y <- return $ succ x + let foo = pred + z = foo y + return $ foo x + z diff --git a/tests/inputs/Types.test b/tests/inputs/Types.test new file mode 100644 --- /dev/null +++ b/tests/inputs/Types.test @@ -0,0 +1,28 @@ +# 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. +# +-l Types.ascribe +-r Types.ascribe +--type-forward Types.Pointless +--type-forward Types.Fn +=== + module Types where + + {-# RULES "ascribe" forall a b c f x y. (f :: a -> b -> c) x y = f (x :: a) (y :: b) :: c #-} + +-main :: IO (Pointless ()) ++main :: IO () + main = do +- print $ (foo :: Int -> String -> Bool) 54 "yolo" +- print $ (bar ("swaggins" :: Text) (True :: Bool) :: Maybe Int) ++ print $ (foo (54 :: Int) ("yolo" :: String) :: Bool) ++ print $ (bar :: Text -> Bool -> Maybe Int) "swaggins" True + + type Pointless a = a + type Fn a b = a -> b + +-blah :: IO (Fn Int Bool) ++blah :: IO (Int -> Bool) + blah = return (> 0) diff --git a/tests/inputs/Types2.test b/tests/inputs/Types2.test new file mode 100644 --- /dev/null +++ b/tests/inputs/Types2.test @@ -0,0 +1,26 @@ +# 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. +# +--type-forward Types2.Foo +--type-forward Types2.MyMaybe +=== + module Types2 where + +-bleh :: HashMap Foo Foo ++bleh :: HashMap (Either String Bar) (Either String Bar) + bleh = HashMap.empty + +-blech :: Maybe Foo ++blech :: Maybe (Either String Bar) + blech = Just 54 + +-blech2 :: MyMaybe Bar ++blech2 :: Maybe Bar + blech2 = blech + + type Foo = Either String Bar + type Bar = Int + + type MyMaybe a = Maybe a diff --git a/tests/inputs/Types3.test b/tests/inputs/Types3.test new file mode 100644 --- /dev/null +++ b/tests/inputs/Types3.test @@ -0,0 +1,33 @@ +# 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. +# +--type-backward Types3.Foo +--type-backward Types3.Foo2 +--type-backward Types3.MyMaybe +=== + module Types3 where + + bleh :: HashMap Foo Foo + bleh = HashMap.empty + +-blech :: Maybe Foo ++blech :: MyMaybe Foo + blech = Just 54 + +-blech2 :: MyMaybe Bar ++blech2 :: MyMaybe Foo + blech2 = blech + +-blech3 :: MyMaybe (Either String Bar2) ++blech3 :: MyMaybe Foo2 + blech3 = Nothing + + type Foo = Bar + type Bar = Int + + type Foo2 = Either String Bar2 + type Bar2 = Int + + type MyMaybe a = Maybe a diff --git a/tests/inputs/Union.test b/tests/inputs/Union.test new file mode 100644 --- /dev/null +++ b/tests/inputs/Union.test @@ -0,0 +1,26 @@ +# 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. +# +-l Union.fi +-l Union.fo +=== + module Union where + + import qualified Data.Text as Text + + {-# RULES "fi" split " " = Text.splitOn " " #-} + {-# RULES "fo" split "," = Text.splitOn "," #-} + + main :: IO () + main = do + let t = "some text, with commas, and spaces" +- ts = split " " t +- tss = [ split "," t' | t' <- ts ] ++ ts = Text.splitOn " " t ++ tss = [ Text.splitOn "," t' | t' <- ts ] + print tss + + split :: Text -> Text -> [Text] + split = undefined