packages feed

retrie (empty) → 0.1.0.0

raw patch · 90 files changed

+9469/−0 lines, 90 filesdep +HUnitdep +ansi-terminaldep +asyncsetup-changed

Dependencies added: HUnit, ansi-terminal, async, base, bytestring, containers, data-default, deepseq, directory, filepath, ghc, ghc-exactprint, ghc-paths, haskell-src-exts, mtl, optparse-applicative, process, random-shuffle, retrie, syb, tasty, tasty-hunit, temporary, text, transformers, unordered-containers

Files

+ CHANGELOG.md view
@@ -0,0 +1,3 @@+1.0.0 (March 16, 2020)++Initial release
+ CODE_OF_CONDUCT.md view
@@ -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 <opensource-conduct@fb.com>. 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
+ CONTRIBUTING.md view
@@ -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: <https://code.facebook.com/cla>++## 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.
+ LICENSE view
@@ -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.
+ README.md view
@@ -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.+
+ Retrie.hs view
@@ -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.
+ Retrie/AlphaEnv.hs view
@@ -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
+ Retrie/CPP.hs view
@@ -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
+ Retrie/Context.hs view
@@ -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
+ Retrie/Debug.hs view
@@ -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
+ Retrie/ExactPrint.hs view
@@ -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'
+ Retrie/ExactPrint/Annotated.hs view
@@ -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
+ Retrie/Expr.hs view
@@ -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
+ Retrie/Fixity.hs view
@@ -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
+ Retrie/FreeVars.hs view
@@ -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)
+ Retrie/GHC.hs view
@@ -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+  }
+ Retrie/GroundTerms.hs view
@@ -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]
+ Retrie/Monad.hs view
@@ -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)
+ Retrie/Options.hs view
@@ -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
+ Retrie/PatternMap/Bag.hs view
@@ -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)++------------------------------------------------------------------------
+ Retrie/PatternMap/Class.hs view
@@ -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))
+ Retrie/PatternMap/Instances.hs view
@@ -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)
+ Retrie/Pretty.hs view
@@ -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
+ Retrie/Quantifiers.hs view
@@ -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
+ Retrie/Query.hs view
@@ -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 ]
+ Retrie/Replace.hs view
@@ -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
+ Retrie/Rewrites.hs view
@@ -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 = "!#$%&*+./<=>?@\\^|-~"
+ Retrie/Rewrites/Function.hs view
@@ -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.
+ Retrie/Rewrites/Rules.hs view
@@ -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)
+ Retrie/Rewrites/Types.hs view
@@ -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
+ Retrie/Run.hs view
@@ -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+      ]
+ Retrie/SYB.hs view
@@ -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
+ Retrie/Subst.hs view
@@ -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
+ Retrie/Substitution.hs view
@@ -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
+ Retrie/Types.hs view
@@ -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)
+ Retrie/Universe.hs view
@@ -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+
+ Retrie/Util.hs view
@@ -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)
+ Setup.hs view
@@ -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
+ bin/Main.hs view
@@ -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
+ demo/Main.hs view
@@ -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
+ retrie.cabal view
@@ -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 <anfarmer@fb.com>+maintainer: Andrew Farmer <anfarmer@fb.com>+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
+ tests/AllTests.hs view
@@ -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+    ]
+ tests/Annotated.hs view
@@ -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
+ tests/CPP.hs view
@@ -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)
+ tests/Demo.hs view
@@ -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
+ tests/Dependent.hs view
@@ -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]+      , ..+      }
+ tests/Exclude.hs view
@@ -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
+ tests/Golden.hs view
@@ -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 /= ".."
+ tests/GroundTerms.hs view
@@ -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)+      ]+    ]
+ tests/Ignore.hs view
@@ -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
+ tests/Main.hs view
@@ -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
+ tests/ParseQualified.hs view
@@ -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)
+ tests/Targets.hs view
@@ -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 }
+ tests/Util.hs view
@@ -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
+ tests/inputs/Adhoc.test view
@@ -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
+ tests/inputs/Adhoc2.custom view
@@ -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
+ tests/inputs/Backticks.test view
@@ -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
+ tests/inputs/Backticks2.test view
@@ -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
+ tests/inputs/CPP.test view
@@ -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
+ tests/inputs/CPPConflict.test view
@@ -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
+ tests/inputs/Capture.test view
@@ -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)
+ tests/inputs/Combined.test view
@@ -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
+ tests/inputs/Commas.test view
@@ -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
+ tests/inputs/Comments.test view
@@ -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++  ]
+ tests/inputs/DependentStmt.custom view
@@ -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
+ tests/inputs/Foo.test view
@@ -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]
+ tests/inputs/FooFold.test view
@@ -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 ])
+ tests/inputs/Imports.test view
@@ -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
+ tests/inputs/Iterate.test view
@@ -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))))
+ tests/inputs/MatchGroup.test view
@@ -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
+ tests/inputs/Operator.test view
@@ -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 #-}
+ tests/inputs/Parens.test view
@@ -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
+ tests/inputs/PartialF.test view
@@ -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..]
+ tests/inputs/PartialU.test view
@@ -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..]
+ tests/inputs/PatBind.test view
@@ -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
+ tests/inputs/Query.custom view
@@ -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))
+ tests/inputs/Readme.custom view
@@ -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")
+ tests/inputs/Readme1.test view
@@ -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)
+ tests/inputs/Readme2.test view
@@ -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
+ tests/inputs/Readme3.test view
@@ -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)
+ tests/inputs/Readme4.test view
@@ -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
+ tests/inputs/Readme5.test view
@@ -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
+ tests/inputs/Records.test view
@@ -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" }
+ tests/inputs/Records2.test view
@@ -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" }
+ tests/inputs/Recursion.test view
@@ -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 ()
+ tests/inputs/Shadowing.test view
@@ -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
+ tests/inputs/Types.test view
@@ -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)
+ tests/inputs/Types2.test view
@@ -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
+ tests/inputs/Types3.test view
@@ -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
+ tests/inputs/Union.test view
@@ -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