retrie 1.2.3 → 2.0.0

raw patch · 104 files changed

+1891/−1071 lines, 104 filesdep −tasty-hunitdep ~ansi-terminaldep ~basedep ~containerssetup-changedPVP ok

version bump matches the API change (PVP)

Dependencies removed: tasty-hunit

Dependency ranges changed: ansi-terminal, base, containers, data-default, ghc, ghc-exactprint, haskell-src-exts

API changes (from Hackage documentation)

Files

• CHANGELOG.md +86/−13
• CODE_OF_CONDUCT.md +0/−76
• CONTRIBUTING.md +3/−17
• LICENSE +2/−1
• README.md +0/−2
• Retrie.hs +2/−1
• Retrie/AlphaEnv.hs +2/−1
• Retrie/CPP.hs +5/−23
• Retrie/Context.hs +80/−22
• Retrie/Debug.hs +2/−1
• Retrie/Elaborate.hs +3/−2
• Retrie/ExactPrint.hs +193/−201
• Retrie/ExactPrint/Annotated.hs +9/−8
• Retrie/Expr.hs +282/−115
• Retrie/Fixity.hs +7/−1
• Retrie/FreeVars.hs +3/−3
• Retrie/GHC.hs +54/−33
• Retrie/GroundTerms.hs +2/−1
• Retrie/Monad.hs +3/−3
• Retrie/Options.hs +67/−11
• Retrie/PatternMap/Bag.hs +2/−1
• Retrie/PatternMap/Class.hs +2/−1
• Retrie/PatternMap/Instances.hs +188/−285
• Retrie/Pretty.hs +2/−6
• Retrie/Quantifiers.hs +2/−1
• Retrie/Query.hs +2/−1
• Retrie/Replace.hs +35/−20
• Retrie/Rewrites.hs +2/−20
• Retrie/Rewrites/Function.hs +46/−21
• Retrie/Rewrites/Patterns.hs +42/−14
• Retrie/Rewrites/Rules.hs +2/−11
• Retrie/Rewrites/Types.hs +2/−5
• Retrie/Run.hs +2/−2
• Retrie/SYB.hs +3/−2
• Retrie/Subst.hs +20/−20
• Retrie/Substitution.hs +2/−1
• Retrie/Types.hs +3/−4
• Retrie/Universe.hs +2/−1
• Retrie/Util.hs +3/−2
• Setup.hs +2/−1
• bin/Main.hs +2/−1
• demo/Main.hs +2/−1
• hse/Fixity.hs +5/−2
• retrie.cabal +45/−23
• tests/AllTests.hs +8/−1
• tests/Annotated.hs +2/−8
• tests/CPP.hs +2/−1
• tests/Demo.hs +2/−1
• tests/Dependent.hs +2/−1
• tests/Exclude.hs +3/−2
• tests/Golden.hs +2/−1
• tests/GroundTerms.hs +2/−1
• tests/Ignore.hs +2/−1
• tests/Main.hs +19/−3
• tests/ParseQualified.hs +2/−1
• tests/Targets.hs +4/−3
• tests/Util.hs +28/−4
• tests/inputs/Adhoc.test +2/−1
• tests/inputs/Adhoc2.custom +2/−1
• tests/inputs/Backticks.test +2/−1
• tests/inputs/Backticks2.test +4/−3
• tests/inputs/Backticks3.test +45/−0
• tests/inputs/CPP.test +51/−8
• tests/inputs/CPPConflict.test +2/−1
• tests/inputs/CPPLayout.test +39/−0
• tests/inputs/Capture.test +2/−1
• tests/inputs/Combined.test +9/−8
• tests/inputs/Commas.test +28/−1
• tests/inputs/Comments.test +28/−3
• tests/inputs/DependentStmt.custom +2/−1
• tests/inputs/FixityAnnotations.test +26/−0
• tests/inputs/Foo.test +2/−1
• tests/inputs/FooFold.test +2/−1
• tests/inputs/Imports.test +2/−1
• tests/inputs/Iterate.test +2/−1
• tests/inputs/Layout.test +33/−0
• tests/inputs/MatchGroup.test +2/−1
• tests/inputs/Operator.test +2/−1
• tests/inputs/Parens.test +109/−5
• tests/inputs/PartialF.test +2/−1
• tests/inputs/PartialU.test +2/−1
• tests/inputs/PatBind.test +2/−1
• tests/inputs/PatternSyn1.test +2/−1
• tests/inputs/PatternSyn2.test +2/−1
• tests/inputs/Qualified.test +2/−1
• tests/inputs/Query.custom +2/−1
• tests/inputs/Readme.custom +2/−1
• tests/inputs/Readme1.test +2/−1
• tests/inputs/Readme2.test +2/−1
• tests/inputs/Readme3.test +2/−1
• tests/inputs/Readme4.test +2/−1
• tests/inputs/Readme5.test +2/−1
• tests/inputs/Records.test +2/−1
• tests/inputs/Records2.test +2/−1
• tests/inputs/Recursion.test +2/−1
• tests/inputs/Shadowing.test +2/−1
• tests/inputs/TypeAbs.test +23/−0
• tests/inputs/TypeParens.test +26/−0
• tests/inputs/Types.test +21/−1
• tests/inputs/Types2.test +8/−1
• tests/inputs/Types3.test +2/−1
• tests/inputs/Types4.test +2/−1
• tests/inputs/Union.test +2/−1
• tests/inputs/WhereBindings.test +76/−0

@@ -1,38 +1,111 @@-1.2.3.0 (January, 2024)+2.0.0 (October 4, 2026) -* Support for GHC 9.8.1 and 9.6.3 (Pranay Sashank)+* Project home moved from facebookincubator/retrie to xich/retrie. Report+  issues and send PRs to https://github.com/xich/retrie+* Support for GHC 9.14 (#13, @simonhorlick)+* Support for GHC 9.12 (#9, @pe200012)+* Dropped support for GHC < 9.6 (supported: 9.6, 9.8, 9.12, 9.14) (#3, @xich)+* Added -j/--jobs flag to bound the number of files rewritten concurrently.+  Defaults to the number of RTS capabilities, so peak memory use no longer+  grows with the number of target files. Fixes #10 (#18, @xich)+* Build the executables with the threaded RTS, so -j (or +RTS -N) actually+  rewrites files concurrently (#18, @xich)+* Require ghc-exactprint >= 1.12.1 (GHC 9.12) and >= 1.14.2 (GHC 9.14), which+  fix a space leak that caused high memory use on large files (#20, @xich)+* Split long grep/VCS invocations into chunks under the system argument limit,+  fixing failures with tens of thousands of target files+  (facebookincubator/retrie#63, @watashi)+* Fix missing parentheses in rewritten expressions and redundant parentheses+  in rewritten types (facebookincubator/retrie#69, @watashi)+* Don't strip the parentheses around sections, which produced malformed+  output (facebookincubator/retrie#70, @watashi)+* Add parentheses where needed when substituting into sections, record+  updates, record-dot projections and negation (#23, @simonhorlick)+* Backtick (infix) rewrites now work for functions of arity greater than two;+  previously these produced code that didn't compile (#14, @simonhorlick)+* Fix many exact-printing bugs in rewritten code: duplicated or misplaced+  trailing commas (e.g. "[succ 4,, ...]" or "(succ 1,)"), lost comments and+  syntax errors when a template has comments before a hole, stray spaces like+  "( Just x)", and lost annotations when reassociating infix operators and+  constructor patterns (#21, #26, @simonhorlick)+* Fix rewrites of expressions and patterns that were reassociated by fixity,+  which could replace the wrong source span (#21, @simonhorlick)+* Fix broken layout in CPP modules when a multi-line replacement lands+  somewhere other than column 1: continuation lines are now indented relative+  to where the replacement starts. Fixes #24 (#29, @xich)+* Preserve comments and layout when unfolding definitions with where clauses+  (#19, @simonhorlick)+* Unfolding works for constructor patterns with type applications+  (type arguments are ignored) (#13, @simonhorlick)+* Report unsupported type-variable binder syntax with the usual "missing+  syntax" error instead of crashing (#9, @pe200012) -1.2.0.0 (December 12, 2021)+1.2.3 (January 15, 2024) +* Support for GHC 9.8 (facebookincubator/retrie#61, @pranaysashank)+* Allow mtl 2.3 and transformers 0.6, as shipped with GHC 9.6+  (facebookincubator/retrie#56, @wz1000)++1.2.2 (March 24, 2023)++* Support for GHC 9.6 (facebookincubator/retrie#54, @wz1000)+* Allow optparse-applicative 0.17 (facebookincubator/retrie#53, @pepeiborra)++1.2.1.1 (November 17, 2022)++* Simplified build-depends: single ghc and ghc-exactprint bounds instead of+  per-GHC conditionals (facebookincubator/retrie#52, @pepeiborra)++1.2.1 (November 13, 2022)++* Support for GHC 9.4 (facebookincubator/retrie#49, @9999years)+* Escape single quotes in patterns passed to grep+  (facebookincubator/retrie#43, @nrnrnr)+* Support text 2.0 (facebookincubator/retrie#44, facebookincubator/retrie#45,+  @pepeiborra)+* Allow ghc-exactprint 1.5 (facebookincubator/retrie#47, @pepeiborra)++1.2.0.1 (January 3, 2022)++* Upgrade to ghc-exactprint 1.4 (facebookincubator/retrie#40, @pepeiborra)++1.2.0.0 (December 14, 2021)+ * Early support for GHC 9.2.1 (thanks to Alan Zimmerman) * Dropped support for GHC <9.2 (might readd it later)  1.1.0.0 (November 13, 2021)-* Remove dependency on xargs (#31)+* Remove dependency on xargs (facebookincubator/retrie#31) * Allow rewrite elaboration  1.0.0.0 (April 9, 2021) -* Added --adhoc-type flag (#13)-* Added --adhoc-pattern, --pattern-forward, --pattern-backward (#15)+* Added --adhoc-type flag (facebookincubator/retrie#13)+* Added --adhoc-pattern, --pattern-forward, --pattern-backward+  (facebookincubator/retrie#15) * Speed up file search when large number of files match. * Removed support for GHC 8.4 and 8.8 * Added support for GHC 9.0.1  0.1.1.1 (June 1, 2020) -* Remove dependency on haskell-src-exts from library (#9)-* Support additional pattern syntax when generating fold/unfold rewrites (#8)-* Limit partial-application rewrite variants to irrefutible patterns (#7)-* Fix handling of qualified names during substitution (#5)-* Fix self-recursion check for do-syntax binds (#5)-* Fix bug in grep invocation for relative target paths (#5)+* Remove dependency on haskell-src-exts from library+  (facebookincubator/retrie#9)+* Support additional pattern syntax when generating fold/unfold rewrites+  (facebookincubator/retrie#8)+* Limit partial-application rewrite variants to irrefutible patterns+  (facebookincubator/retrie#7)+* Fix handling of qualified names during substitution+  (facebookincubator/retrie#5)+* Fix self-recursion check for do-syntax binds (facebookincubator/retrie#5)+* Fix bug in grep invocation for relative target paths+  (facebookincubator/retrie#5)  0.1.1.0 (May 8, 2020)  * Support GHC 8.10.1 -0.1.0.1 (April 1, 2020)+0.1.0.1 (March 31, 2020)  * Don't fail if 'git' or 'hg' commands cannot be found. * Better error message when syntax support needs to be extended.

@@ -1,76 +0,0 @@-# 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

@@ -2,11 +2,6 @@ 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. @@ -14,21 +9,12 @@ 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>+5. Please add a line to the 'Unreleased' section of `CHANGELOG.md` as part of your pull request.  ## Issues-We use GitHub issues to track public bugs. Please ensure your description is+We use GitHub issues to track 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.+Ideally, add a failing test.  ## Coding Style   * 2 spaces for indentation rather than tabs

@@ -1,6 +1,7 @@ MIT License -Copyright (c) Facebook, Inc. and its affiliates.+Copyright (c) 2025 Andrew Farmer+Copyright (c) 2020-2024 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

@@ -296,8 +296,6 @@  To report other bugs, please create a GitHub issue. -[![Build Status](https://travis-ci.com/facebookincubator/retrie.svg?branch=master)](https://travis-ci.com/facebookincubator/retrie)- # License  Retrie is MIT licensed, as found in the [LICENSE](LICENSE) file.

@@ -1,4 +1,5 @@--- Copyright (c) Facebook, Inc. and its affiliates.+-- Copyright (c) 2025 Andrew Farmer+-- Copyright (c) 2020-2024 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.

@@ -1,4 +1,5 @@--- Copyright (c) Facebook, Inc. and its affiliates.+-- Copyright (c) 2025 Andrew Farmer+-- Copyright (c) 2020-2024 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.

@@ -1,9 +1,9 @@--- Copyright (c) Facebook, Inc. and its affiliates.+-- Copyright (c) 2025 Andrew Farmer+-- Copyright (c) 2020-2024 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 #-} {-# LANGUAGE RecordWildCards #-} module Retrie.CPP@@ -27,10 +27,7 @@ import Retrie.ExactPrint import Retrie.GHC import Retrie.Replace-#if __GLASGOW_HASKELL__ < 904-#else import GHC.Types.PkgQual-#endif  -- Note [CPP] -- We can't just run the pre-processor on files and then rewrite them, because@@ -108,7 +105,8 @@ printCPP :: [Replacement] -> CPP AnnotatedModule -> String printCPP _ (NoCPP m) = printA m -- printCPP _ (NoCPP m) = error $ "printCPP:m=" ++ showAstA m-printCPP repls (CPP orig is ms) = Text.unpack $ Text.unlines $+printCPP _ (CPP _ _ []) = error $ "printCPP: empty list of modules!"+printCPP repls (CPP orig is (m1:_)) = Text.unpack $ Text.unlines $   case is of     [] -> splice "" 1 1 sorted origLines     _ ->@@ -126,7 +124,7 @@       ]      origLines = Text.lines orig-    mbName = unLoc <$> hsmodName (unLoc $ astA $ head ms)+    mbName = unLoc <$> hsmodName (unLoc $ astA m1)     importLines = runIdentity $ fmap astA $ transformA (filterAndFlatten mbName is) $       mapM $ fmap (Text.pack . dropWhile isSpace . printA) . pruneA @@ -325,13 +323,8 @@ insertImports   :: Monad m   => [AnnotatedImports]   -- ^ imports and their annotations-#if __GLASGOW_HASKELL__ < 906-  -> Located HsModule     -- ^ target module-  -> TransformT m (Located HsModule)-#else   -> Located (HsModule GhcPs)     -- ^ target module   -> TransformT m (Located (HsModule GhcPs))-#endif insertImports is (L l m) = do   imps <- graftA $ filterAndFlatten (unLoc <$> hsmodName m) is   let@@ -351,25 +344,14 @@   ((==) `on` unLoc . ideclName) x y   && ((==) `on` ideclQualified) x y   && ((==) `on` ideclAs) x y-#if __GLASGOW_HASKELL__ <= 904-  && ((==) `on` ideclHiding) x y-#else   && ((==) `on` ideclImportList) x y-#endif-#if __GLASGOW_HASKELL__ < 904-  && ((==) `on` ideclPkgQual) x y-#else   && (eqRawPkgQual `on` ideclPkgQual) x y-#endif   && ((==) `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-#if __GLASGOW_HASKELL__ < 904-#else   where     eqRawPkgQual NoRawPkgQual NoRawPkgQual = True     eqRawPkgQual NoRawPkgQual (RawPkgQual _) = False     eqRawPkgQual (RawPkgQual _) NoRawPkgQual = False     eqRawPkgQual (RawPkgQual s) (RawPkgQual s') = s == s'-#endif

@@ -1,9 +1,11 @@--- Copyright (c) Facebook, Inc. and its affiliates.+-- Copyright (c) 2025 Andrew Farmer+-- Copyright (c) 2020-2024 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 #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -17,7 +19,9 @@ import Data.Char (isDigit) import Data.Either (partitionEithers) import Data.Generics hiding (Fixity)+#if __GLASGOW_HASKELL__ < 912 import Data.List+#endif import Data.Maybe  import Retrie.AlphaEnv@@ -54,43 +58,68 @@   where     neverParen = c { ctxtParentPrec = NeverParen } +    withOpPrec :: LHsExpr GhcPs -> Context     updExp :: HsExpr GhcPs -> Context-    updExp HsApp{} =-#if __GLASGOW_HASKELL__ < 908-      c { ctxtParentPrec = HasPrec $ Fixity (SourceText "HsApp") (10 + i - firstChild) InfixL }+    updType :: HsType GhcPs -> Context++    updType HsTupleTy{} = neverParen+    updType HsListTy{} = neverParen+    updType HsParTy{} = neverParen+#if __GLASGOW_HASKELL__ < 912+    updType HsAppTy{} = withPrec c (SourceText "HsAppTy") (getPrec appPrec) InfixL i+    updType HsFunTy{} = withPrec c (SourceText "HsFunTy") (getPrec funPrec) InfixR (i - 1)+    updType _ = withPrec c (SourceText "HsType") (getPrec appPrec) InfixN i++    withOpPrec op+      | Fixity source prec dir <- lookupOp op $ ctxtFixityEnv c =+        withPrec c source prec dir i++    updExp HsApp{} = withPrec c (SourceText "HsApp") 10 InfixL i+    updExp RecordUpd{}+      | i == firstChild = withPrec c (SourceText "RecordUpd") 11 InfixN i+    updExp HsGetField{}+      | i == firstChild = withPrec c (SourceText "HsGetField") 11 InfixN i+    updExp NegApp{} = withPrec c (SourceText "NegApp") 6 InfixN i+    updExp (HsLet _ _ lbs _ _) = addInScope neverParen $ collectLocalBinders CollNoDictBinders lbs #else-      c { ctxtParentPrec = HasPrec $ Fixity (SourceText (fsLit "HsApp")) (10 + i - firstChild) InfixL }-#endif-    -- 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)-    updExp (OpApp _ _ op _) = c { ctxtParentPrec = HasPrec $ lookupOp op (ctxtFixityEnv c) }-#if __GLASGOW_HASKELL__ < 904+    updType HsAppTy{} = withPrec c (getPrec appPrec) InfixL i+    updType HsFunTy{} = withPrec c (getPrec funPrec) InfixR (i - 1)+    updType _ = withPrec c (getPrec appPrec) InfixN i++    withOpPrec op+      | Fixity prec dir <- lookupOp op $ ctxtFixityEnv c =+        withPrec c prec dir i++    updExp HsApp{} = withPrec c 10 InfixL i+    updExp RecordUpd{}+      | i == firstChild = withPrec c 11 InfixN i+    updExp HsGetField{}+      | i == firstChild = withPrec c 11 InfixN i+    updExp NegApp{} = withPrec c 6 InfixN i     updExp (HsLet _ lbs _) = addInScope neverParen $ collectLocalBinders CollNoDictBinders lbs-#else-    updExp (HsLet _ _ lbs _ _) = addInScope neverParen $ collectLocalBinders CollNoDictBinders lbs #endif+    updExp (OpApp _ _ op _) = withOpPrec op+    updExp (SectionL _ _ op) = withOpPrec op+    updExp (SectionR _ op _) = withOpPrec op     updExp _ = neverParen -    updType :: HsType GhcPs -> Context-    updType HsAppTy{}-      | i > firstChild = c { ctxtParentPrec = IsHsAppsTy }-    updType _ = neverParen-     updMatch :: Match GhcPs (LHsExpr GhcPs) -> Context     updMatch       | i == 2  -- m_pats field+#if __GLASGOW_HASKELL__ < 912       = addInScope c{ctxtParentPrec = IsLhs} . collectPatsBinders CollNoDictBinders . m_pats       | otherwise = addInScope neverParen . collectPatsBinders CollNoDictBinders . m_pats+#else+      = addInScope c{ctxtParentPrec = IsLhs} . collectPatsBinders CollNoDictBinders . unLoc . m_pats+      | otherwise+      = addInScope neverParen . collectPatsBinders CollNoDictBinders . unLoc . m_pats+#endif       where      updGRHSs :: GRHSs GhcPs (LHsExpr GhcPs) -> Context     updGRHSs = addInScope neverParen . collectLocalBinders CollNoDictBinders . grhssLocalBinds      updGRHS :: GRHS GhcPs (LHsExpr GhcPs) -> Context-#if __GLASGOW_HASKELL__ < 900-    updGRHS XGRHS{} = neverParen-#endif     updGRHS (GRHS _ gs _)         -- binders are in scope over the body (right child) only       | i > firstChild = addInScope neverParen bs@@ -128,6 +157,29 @@     updPat :: Pat GhcPs -> Context     updPat _ = neverParen +getPrec :: PprPrec -> Int+getPrec (PprPrec prec) = prec++#if __GLASGOW_HASKELL__ < 912+withPrec :: Context -> SourceText -> Int -> FixityDirection -> Int -> Context+withPrec c source prec dir i = c{ ctxtParentPrec = HasPrec fixity }+  where+    fixity = Fixity source prec d+#else+withPrec :: Context -> Int -> FixityDirection -> Int -> Context+withPrec c prec dir i = c{ ctxtParentPrec = HasPrec fixity }+  where+    fixity = Fixity prec d+#endif+    d = case dir of+      InfixL+        | i == firstChild -> InfixL+        | otherwise -> InfixN+      InfixR+        | i == firstChild -> InfixN+        | otherwise -> InfixR+      InfixN -> InfixN+ -- | Create an empty 'Context' with given 'FixityEnv', rewriter, and dependent -- rewrite generator. emptyContext :: FixityEnv -> Rewriter -> Rewriter -> Context@@ -219,7 +271,7 @@ -- 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+renameBinder rdr fvs = headNoWarn   [ rdr'   | i <- [n..]   , let rdr' = mkVarUnqual $ mkFastString $ baseName ++ show i@@ -229,6 +281,12 @@     (ds, rest) = span isDigit $ reverse $ occNameString $ occName rdr      baseName = reverse rest++    -- We build with -Wall -Werror, and there is a warning about how `head` is+    -- partial. Using `head` is safe here because the list is infinite, so the+    -- nil case is impossible. Define our own to avoid the warning.+    headNoWarn (x:_) = x+    headNoWarn _ = error "headNoWarn: impossible!"      n :: Int     n | null ds = 1

@@ -1,4 +1,5 @@--- Copyright (c) Facebook, Inc. and its affiliates.+-- Copyright (c) 2025 Andrew Farmer+-- Copyright (c) 2020-2024 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.

@@ -1,4 +1,5 @@--- Copyright (c) Facebook, Inc. and its affiliates.+-- Copyright (c) 2025 Andrew Farmer+-- Copyright (c) 2020-2024 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.@@ -86,7 +87,7 @@       -- substitute for quantifiers in grafted template       r <- subst sub ctxt t'       -- copy appropriate annotations from old expression to template-      r0 <- addAllAnnsT e r+      r0 <- transferEntryAnnsT e r       -- add parens to template if needed       (mkM (parenify ctxt) `extM` parenifyT ctxt `extM` parenifyP ctxt) r0 

@@ -1,4 +1,5 @@--- Copyright (c) Facebook, Inc. and its affiliates.+-- Copyright (c) 2025 Andrew Farmer+-- Copyright (c) 2020-2024 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.@@ -8,6 +9,10 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-}+#if __GLASGOW_HASKELL__ < 912+#else+{-# OPTIONS_GHC -Wno-orphans #-}+#endif -- | Provides consistent interface with ghc-exactprint. module Retrie.ExactPrint   ( -- * Fixity re-association@@ -29,20 +34,18 @@   , swapEntryDPT   , transferAnnsT   , transferEntryAnnsT-  , transferEntryDPT-  -- , tryTransferEntryDPT-  , transferAnchor+  , setTrailingAnns+  , trailingAnns+  , stripOuterAnns     -- * Utils   , debugDump   , debugParse-  , debug   , 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   , module Language.Haskell.GHC.ExactPrint.Transform@@ -50,38 +53,73 @@  import Control.Exception import Control.Monad-import Control.Monad.State.Lazy hiding (fix)--- import Data.Function (on)+import Control.Monad.State.Lazy import Data.List (transpose)--- import Data.Maybe--- import qualified Data.Map as M import Text.Printf  import Language.Haskell.GHC.ExactPrint hiding-  (-   setEntryDP+  ( d1+#if __GLASGOW_HASKELL__ < 912+  , m1+  , mn+#endif+  , setEntryDP   , transferEntryDP   )--- import Language.Haskell.GHC.ExactPrint.ExactPrint (ExactPrint)-import Language.Haskell.GHC.ExactPrint.Utils hiding (debug)+import Language.Haskell.GHC.ExactPrint.Utils hiding+  ( rs+  ) import qualified Language.Haskell.GHC.ExactPrint.Parsers as Parsers import Language.Haskell.GHC.ExactPrint.Types   ( showGhc   )-import Language.Haskell.GHC.ExactPrint.Transform+import Language.Haskell.GHC.ExactPrint.Transform hiding+  ( d1+#if __GLASGOW_HASKELL__ < 912+  , m1+  , mn+#endif+  )  import Retrie.ExactPrint.Annotated import Retrie.Fixity import Retrie.GHC import Retrie.SYB hiding (ext1)-import Retrie.Util  import GHC.Stack-import Debug.Trace -debug :: c -> String -> c-debug c s = trace s c+#if __GLASGOW_HASKELL__ < 912+#else+import Data.Default+import Control.Applicative +instance Monoid AnnListItem where+  mempty = AnnListItem []++instance Default AnnListItem where+  def = AnnListItem []++instance Monoid (EpToken s) where+  mempty = NoEpTok+  mappend = (<>)++instance Semigroup (EpToken s) where+  _ <> _ = NoEpTok++instance Semigroup NameAnn where+  _ <> b = b -- Right biased for now++instance Monoid NameAnn where+  mempty = NameAnnTrailing []++instance (Monoid a) => Monoid (AnnList a) where+  mempty = AnnList Nothing ListNone [] mempty []++instance (Semigroup a) => Semigroup (AnnList a) where+  (AnnList a1 b1 s1 r1 t1) <> (AnnList a2 b2 s2 r2 t2) =+    AnnList (a1 <|> a2) (if b1 == ListNone then b2 else b1) (s1 <> s2) (r1 <> r2) (t1 <> t2)+#endif+ -- Fixity traversal -----------------------------------------------------------  -- | Re-associate AST using given 'FixityEnv'. (The GHC parser has no knowledge@@ -95,7 +133,11 @@  -- Should (x op1 y) op2 z be reassociated as x op1 (y op2 z)? associatesRight :: Fixity -> Fixity -> Bool+#if __GLASGOW_HASKELL__ < 912 associatesRight (Fixity _ p1 a1) (Fixity _ p2 _a2) =+#else+associatesRight (Fixity p1 a1) (Fixity p2 _a2) =+#endif   p2 > p1 || p1 == p2 && a1 == InfixR  -- We know GHC produces left-associated chains, so 'z' is never an@@ -106,33 +148,30 @@   => FixityEnv   -> LHsExpr GhcPs   -> TransformT m (LHsExpr GhcPs)-fixOneExpr env (L l2 (OpApp x2 ap1@(L l1 (OpApp x1 x op1 y)) op2 z))+fixOneExpr env (L l2 (OpApp x2 (L _ (OpApp x1 x op1 y)) op2 z))   | associatesRight (lookupOp op1 env) (lookupOp op2 env) = do-    -- lift $ liftIO $ debugPrint Loud "fixOneExpr:(l1,l2)="  [showAst (l1,l2)]-    let ap2' = L (stripComments l2) $ OpApp x2 y op2 z-    (ap1_0, ap2'_0) <- swapEntryDPT ap1 ap2'-    ap1_1 <- transferAnnsT isComma ap2'_0 ap1_0-    -- lift $ liftIO $ debugPrint Loud "fixOneExpr:recursing"  []-    rhs <- fixOneExpr env ap2'_0-    -- lift $ liftIO $ debugPrint Loud "fixOneExpr:returning"  [showAst (L l2 $ OpApp x1 x op1 rhs)]-    -- return $ L l1 $ OpApp x1 x op1 rhs+    let sp = combineSrcSpans (getLocA y) (getLocA z)+        ap2' = L (freshAnn sp) $ OpApp x2 y op2 z+    rhs <- fixOneExpr env ap2'     return $ L l2 $ OpApp x1 x op1 rhs fixOneExpr _ e = return e  fixOnePat :: Monad m => FixityEnv -> LPat GhcPs -> TransformT m (LPat GhcPs)-fixOnePat env (dLPat -> Just (L l2 (ConPat ext2 op2 (InfixCon (dLPat -> Just ap1@(L l1 (ConPat ext1 op1 (InfixCon x y)))) z))))+fixOnePat env (dLPat -> Just (L l2 (ConPat ext2 op2 (InfixCon (dLPat -> Just (L _ (ConPat ext1 op1 (InfixCon x y)))) z))))   | associatesRight (lookupOpRdrName op1 env) (lookupOpRdrName op2 env) = do-    let ap2' = L l2 (ConPat ext2 op2 (InfixCon y z))-    (ap1_0, ap2'_0) <- swapEntryDPT ap1 ap2'-    ap1_1 <- transferAnnsT isComma ap2' ap1-    rhs <- fixOnePat env (cLPat ap2'_0)-    return $ cLPat $ L l1 (ConPat ext1 op1 (InfixCon x rhs))+    let sp = combineSrcSpans (getLocA y) (getLocA z)+        ap2' = L (freshAnn sp) $ ConPat ext2 op2 (InfixCon y z)+    rhs <- fixOnePat env ap2'+    return $ L l2 $ ConPat ext1 op1 (InfixCon x rhs) fixOnePat _ e = return e --- TODO: move to ghc-exactprint-stripComments :: SrcAnn an -> SrcAnn an-stripComments (SrcSpanAnn EpAnnNotUsed l) = SrcSpanAnn EpAnnNotUsed l-stripComments (SrcSpanAnn (EpAnn anc an _) l) = SrcSpanAnn (EpAnn anc an emptyComments) l+#if __GLASGOW_HASKELL__ < 912+freshAnn :: Monoid an => SrcSpan -> SrcAnn an+freshAnn = noAnnSrcSpanDP0+#else+freshAnn :: NoAnn an => SrcSpan -> EpAnn an+freshAnn sp = EpAnn (EpaDelta sp (SameLine 0) []) noAnn emptyComments+#endif  -- Move leading whitespace from the left child of an operator application -- to the application itself. We need this so we have correct offsets when@@ -144,25 +183,6 @@   -> LocatedA a -- ^ Left child   -> TransformT m (LocatedA a, LocatedA a) fixOneEntry e x = do-  -- lift $ liftIO $ debugPrint Loud "fixOneEntry:(e,x)="  [showAst (e,x)]-  -- -- anns <- getAnnsT-  -- let-  --   zeros = SameLine 0-  --   (xdp, ard) =-  --     case M.lookup (mkAnnKey x) anns of-  --       Nothing -> (zeros, zeros)-  --       Just ann -> (annLeadingCommentEntryDelta ann, annEntryDelta ann)-  --   xr = getDeltaLine xdp-  --   xc = deltaColumn xdp-  --   actualRow = getDeltaLine ard-  --   edp =-  --     maybe zeros annLeadingCommentEntryDelta $ M.lookup (mkAnnKey e) anns-  --   er = getDeltaLine edp-  --   ec = deltaColumn edp-  -- when (actualRow == 0) $ do-  --   setEntryDPT e $ deltaPos (er, xc + ec)-  --   setEntryDPT x $ deltaPos (xr, 0)-   -- We assume that ghc-exactprint has converted all Anchor's to use their delta variants.   -- Get the dp for the x component   let xdp = entryDP x@@ -173,40 +193,44 @@   let er = getDeltaLine edp   let ec = deltaColumn edp   case xdp of-    SameLine n -> do+    SameLine _n -> do       -- lift $ liftIO $ debugPrint Loud "fixOneEntry:(xdp,edp)="  [showAst (xdp,edp)]       -- lift $ liftIO $ debugPrint Loud "fixOneEntry:(dpx,dpe)="  [showAst ((deltaPos er (xc + ec)),(deltaPos xr 0))]       -- lift $ liftIO $ debugPrint Loud "fixOneEntry:e'="  [showAst e]       -- lift $ liftIO $ debugPrint Loud "fixOneEntry:e'="  [showAst (setEntryDP e (deltaPos er (xc + ec)))]+#if __GLASGOW_HASKELL__ < 912       return ( setEntryDP e (deltaPos er (xc + ec))              , setEntryDP x (deltaPos xr 0))+#else+      -- In GHC 9.12+, setEntryDP applies the delta to the first comment if present,+      -- which can corrupt spacing. Skip adjustment when either e or x has comments+      -- directly attached to them (not in subtree), as setEntryDP will be called+      -- on these specific nodes.+      if hasComments e || hasComments x+        then return (e, x)+        else return ( setEntryDP e (deltaPos er (xc + ec))+                    , setEntryDP x (deltaPos xr 0))+#endif     _ -> return (e,x) -  -- 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- -- TODO: move this somewhere more appropriate entryDP :: LocatedA a -> DeltaPos+#if __GLASGOW_HASKELL__ < 912 entryDP (L (SrcSpanAnn EpAnnNotUsed _) _) = SameLine 1 entryDP (L (SrcSpanAnn (EpAnn anc _ _) _) _)   = case anchor_op anc of       UnchangedAnchor -> SameLine 1       MovedAnchor dp -> dp+#else+entryDP (L (EpAnn anc _ _) _)+  = case anc of+      EpaSpan _ -> SameLine 1+      EpaDelta _ dp _ -> dp+#endif   fixOneEntryExpr :: MonadIO m => LHsExpr GhcPs -> TransformT m (LHsExpr GhcPs)-fixOneEntryExpr e@(L l (OpApp a x b c)) = do+fixOneEntryExpr e@(L _ (OpApp a x b c)) = do   -- lift $ liftIO $ debugPrint Loud "fixOneEntryExpr:(e,x)="  [showAst (e,x)]   (e',x') <- fixOneEntry e x   -- lift $ liftIO $ debugPrint Loud "fixOneEntryExpr:(e',x')="  [showAst (e',x')]@@ -216,11 +240,7 @@  fixOneEntryPat :: MonadIO m => LPat GhcPs -> TransformT m (LPat GhcPs) fixOneEntryPat pat-#if __GLASGOW_HASKELL__ < 900-  | Just p@(L l (ConPatIn a (InfixCon x b))) <- dLPat pat = do-#else-  | Just p@(L l (ConPat a b (InfixCon x c))) <- dLPat pat = do-#endif+  | Just p@(L _ (ConPat a b (InfixCon x c))) <- dLPat pat = do     (p', x') <- fixOneEntry p (dLPatUnsafe x)     return (cLPat $ (L (getLoc p') (ConPat a b (InfixCon x' c))))   | otherwise = return pat@@ -228,6 +248,7 @@ -------------------------------------------------------------------------------  +#if __GLASGOW_HASKELL__ < 912 -- Swap entryDP and prior comments between the two args swapEntryDPT   :: (Data a, Data b, Monad m, Monoid a1, Monoid a2, Typeable a1, Typeable a2)@@ -236,22 +257,14 @@   b' <- transferEntryDP a b   a' <- transferEntryDP b a   return (a',b')---- swapEntryDPT---   :: (Data a, Data b, Monad m)---   => LocatedAn a1 a -> LocatedAn a2 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+#else+swapEntryDPT+  :: (Monad m, Typeable t2, Typeable t1)+  => LocatedAn t1 a+  -> LocatedAn t2 b+  -> m (LocatedAn t1 a, LocatedAn t2 b)+swapEntryDPT a b = return (transferEntryDP b a, transferEntryDP a b)+#endif  ------------------------------------------------------------------------------- @@ -262,13 +275,7 @@   r <- Parsers.parseModuleFromString libdir fp str   case r of     Left msg -> do-#if __GLASGOW_HASKELL__ < 900-      fail $ show msg-#elif __GLASGOW_HASKELL__ < 904-      fail $ show $ bagToList msg-#else       fail $ showSDoc dflags $ ppr msg-#endif     Right m -> return $ unsafeMkA (makeDeltaAst m) 0  parseContent :: Parsers.LibDir -> FixityEnv -> FilePath -> String -> IO AnnotatedModule@@ -306,7 +313,6 @@   -- debugPrint Loud "parseStmt:for" [str]   res <- parseHelper libdir "parseStmt" Parsers.parseStmt str   return (setEntryDPA res (DifferentLine 1 0))-  -- return res   -- | Parse a 'HsType'.@@ -317,13 +323,7 @@   => Parsers.LibDir -> FilePath -> Parsers.Parser a -> String -> IO (Annotated a) parseHelper libdir fp parser str = join $ Parsers.withDynFlags libdir $ \dflags ->   case parser dflags fp str of-#if __GLASGOW_HASKELL__ < 900-    Left (_, msg) -> throwIO $ ErrorCall msg-#elif __GLASGOW_HASKELL__ < 904-    Left errBag -> throwIO $ ErrorCall (show $ bagToList errBag)-#else     Left msg -> throwIO $ ErrorCall (showSDoc dflags $ ppr msg)-#endif     Right x -> return $ unsafeMkA (makeDeltaAst x) 0  -- type Parser a = GHC.DynFlags -> FilePath -> String -> ParseResult a@@ -352,122 +352,109 @@ -- 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   :: (HasCallStack, Data a, Data b, Monad m)-  => (TrailingAnn -> Bool)  -- transfer Anns matching predicate-  -> LocatedA a             -- from+  => LocatedA a             -- from   -> LocatedA b             -- to   -> TransformT m (LocatedA b)-transferEntryAnnsT p a b = do-  b' <- transferEntryDP a b-  transferAnnsT p a b'---- | 'Transform' monad version of 'transferEntryDP'-transferEntryDPT-  :: (HasCallStack, Data a, Data b, Monad m)-  => Located a -> Located b -> TransformT m ()--- transferEntryDPT a b = modifyAnnsT (transferEntryDP a b)-transferEntryDPT _a _b = error "transferEntryDPT"---- tryTransferEntryDPT---   :: (Data a, Data b, Monad m)---   => Located a -> Located b -> TransformT m ()--- tryTransferEntryDPT a b = modifyAnnsT $ \anns ->---   if M.member (mkAnnKey a) anns---     then transferEntryDP a b anns---     else anns+transferEntryAnnsT a b =+  return+    $ setTrailingAnns (trailingAnns a)+    $ pinPriorComments+    $ prependPriorComments (priorCommentsOf a)+    $ setEntryDelta (getEntryDP a) b --- This function fails if b is not in Anns, which seems dumb, since we are inserting it.--- transferEntryDP :: (HasCallStack, Data a, Data b) => Located a -> Located b -> Anns -> Anns--- transferEntryDP a b anns = setEntryDP b dp anns'---   where---     maybeAnns = do -- Maybe monad---       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+setEntryDelta :: DeltaPos -> LocatedA a -> LocatedA a+#if __GLASGOW_HASKELL__ < 912+-- always give the delta to the first prior comment+setEntryDelta dp (L (SrcSpanAnn (EpAnn anc@(Anchor _ (MovedAnchor _)) an cs) l) x)+  | (L ca c : rest) <- priorComments cs =+      let c' = L (Anchor (anchor ca) (MovedAnchor dp)) c+      in L (SrcSpanAnn (EpAnn anc an (setPriorComments cs (c' : rest))) l) x+#endif+setEntryDelta dp x = setEntryDP x dp  addAllAnnsT+#if __GLASGOW_HASKELL__ < 912   :: (HasCallStack, Monoid an, Data a, Data b, MonadIO m, Typeable an)   => LocatedAn an a -> LocatedAn an b -> TransformT m (LocatedAn an b) addAllAnnsT a b = do   -- AZ: to start with, just transfer the entry DP from a to b   transferEntryDP a b+#else+  :: (HasCallStack, Data a, Data b, Monad m, Typeable an)+  => LocatedAn an a -> LocatedAn an b -> TransformT m (LocatedAn an b)+addAllAnnsT a b = return $ transferEntryDP a b+#endif +setTrailingAnns :: [TrailingAnn] -> LocatedA a -> LocatedA a+#if __GLASGOW_HASKELL__ < 912+setTrailingAnns [] x@(L (SrcSpanAnn EpAnnNotUsed _) _) = x+setTrailingAnns ts (L (SrcSpanAnn EpAnnNotUsed l) x) =+  L (SrcSpanAnn (EpAnn (spanAsAnchor l) (AnnListItem ts) emptyComments) l) x+setTrailingAnns ts (L (SrcSpanAnn (EpAnn anc _ cs) l) x) =+  L (SrcSpanAnn (EpAnn anc (AnnListItem ts) cs) l) x+#else+setTrailingAnns ts (L (EpAnn anc _ cs) x) = L (EpAnn anc (AnnListItem ts) cs) x+#endif --- addAllAnnsT---   :: (HasCallStack, Data a, Data b, Monad m)---   => Located a -> Located b -> TransformT m ()--- addAllAnnsT a b = modifyAnnsT (addAllAnns a b)+trailingAnns :: LocatedA a -> [TrailingAnn]+#if __GLASGOW_HASKELL__ < 912+trailingAnns (L (SrcSpanAnn (EpAnn _ (AnnListItem ts) _) _) _) = ts+trailingAnns _ = []+#else+trailingAnns (L (EpAnn _ (AnnListItem ts) _) _) = ts+#endif --- addAllAnns :: (HasCallStack, 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'---           }+priorCommentsOf :: LocatedA a -> [LEpaComment]+#if __GLASGOW_HASKELL__ < 912+priorCommentsOf (L (SrcSpanAnn EpAnnNotUsed _) _) = []+priorCommentsOf (L (SrcSpanAnn (EpAnn _ _ cs) _) _) = priorComments cs+#else+priorCommentsOf (L (EpAnn _ _ cs) _) = priorComments cs+#endif -transferAnchor :: LocatedA a -> LocatedA b -> LocatedA b-transferAnchor (L (SrcSpanAnn EpAnnNotUsed l)    _) lb = setAnchorAn lb (spanAsAnchor l) emptyComments-transferAnchor (L (SrcSpanAnn (EpAnn anc _ _) _) _) lb = setAnchorAn lb anc              emptyComments+prependPriorComments :: [LEpaComment] -> LocatedA a -> LocatedA a+prependPriorComments [] x = x+#if __GLASGOW_HASKELL__ < 912+prependPriorComments new (L l x) =+  L (setCommentsSrcAnn l (EpaComments new <> epAnnComments (ann l))) x+#else+prependPriorComments new (L l x) =+  L (setCommentsEpAnn l (EpaComments new <> epAnnComments l)) x+#endif +pinPriorComments :: LocatedA a -> LocatedA a+#if __GLASGOW_HASKELL__ < 912+-- exactprint sorts prior comments by span and holds back any that+-- start after the node's anchor, pin them to the nodes anchor so order is+-- consistent across versions.+pinPriorComments (L (SrcSpanAnn (EpAnn anc an cs) l) x) =+  L (SrcSpanAnn (EpAnn anc an (setPriorComments cs (map pin (priorComments cs)))) l) x+  where+    pin (L (Anchor _ op) c) = L (Anchor (anchor anc) op) c+#endif+pinPriorComments x = x +-- | Drop anything that prints outside the node's span.+stripOuterAnns :: LocatedA a -> LocatedA a+stripOuterAnns (L an x) = L (freshAnn (locA an)) x+ isComma :: TrailingAnn -> Bool isComma (AddCommaAnn _) = True isComma _ = False -isCommentKeyword :: AnnKeywordId -> Bool--- isCommentKeyword (AnnComment _) = True-isCommentKeyword _ = False---- isCommentAnnotation :: Annotation -> Bool--- isCommentAnnotation Ann{..} =---   (not . null $ annPriorComments)---   || (not . null $ annFollowingComments)---   || any (isCommentKeyword . fst) annsDP- hasComments :: LocatedAn an a -> Bool+#if __GLASGOW_HASKELL__ < 912 hasComments (L (SrcSpanAnn EpAnnNotUsed _) _) = False-hasComments (L (SrcSpanAnn (EpAnn anc _ cs) _) _)-  = case cs of-      EpaComments [] -> False-      EpaCommentsBalanced [] [] -> False-      _ -> True---- 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+hasComments (L (SrcSpanAnn (EpAnn _ _ cs) _) _) =+#else+hasComments (L (EpAnn _ _ cs) _) =+#endif+  case cs of+    EpaComments [] -> False+    EpaCommentsBalanced [] [] -> False+    _ -> True  transferAnnsT   :: (Data a, Data b, Monad m)@@ -475,13 +462,18 @@   -> LocatedA a                 -- from   -> LocatedA b                 -- to   -> TransformT m (LocatedA b)-transferAnnsT p (L (SrcSpanAnn EpAnnNotUsed _) _) b = return b-transferAnnsT p (L (SrcSpanAnn (EpAnn anc (AnnListItem ts) cs) l) a) (L (SrcSpanAnn an lb) b) = do+#if __GLASGOW_HASKELL__ < 912+transferAnnsT _ (L (SrcSpanAnn EpAnnNotUsed _) _) b = return b+transferAnnsT p (L (SrcSpanAnn (EpAnn _ (AnnListItem ts) _) _) _) (L (SrcSpanAnn an lb) b) = do   let ps = filter p ts   let an' = case an of         EpAnnNotUsed -> EpAnn (spanAsAnchor lb) (AnnListItem ps) emptyComments         EpAnn ancb (AnnListItem tsb) csb -> EpAnn ancb (AnnListItem (tsb++ps)) csb   return (L (SrcSpanAnn an' lb) b)+#else+transferAnnsT p (L (EpAnn _ (AnnListItem ts) _) _) (L (EpAnn ancb (AnnListItem tsb) csb) b) =+  return $ L (EpAnn ancb (AnnListItem (tsb ++ filter p ts)) csb) b+#endif   -- -- | 'Transform' monad version of 'setEntryDP',

@@ -1,14 +1,15 @@--- Copyright (c) Facebook, Inc. and its affiliates.+-- Copyright (c) 2025 Andrew Farmer+-- Copyright (c) 2020-2024 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 DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE CPP #-} module Retrie.ExactPrint.Annotated   ( -- * Annotated     Annotated@@ -36,7 +37,7 @@   , unsafeMkA   ) where -import Control.Monad.State.Lazy hiding (fix)+import Control.Monad.State.Lazy import Data.Default as D  import Data.Functor.Identity@@ -61,11 +62,7 @@ type AnnotatedHsType = Annotated (LHsType GhcPs) type AnnotatedImport = Annotated (LImportDecl GhcPs) type AnnotatedImports = Annotated [LImportDecl GhcPs]-#if __GLASGOW_HASKELL__ >= 906 type AnnotatedModule = Annotated (Located (HsModule GhcPs))-#else-type AnnotatedModule = Annotated (Located HsModule)-#endif type AnnotatedPat = Annotated (LPat GhcPs) type AnnotatedStmt = Annotated (LStmt GhcPs (LHsExpr GhcPs)) @@ -153,8 +150,12 @@     nil :: Annotated ()     nil = mempty +#if __GLASGOW_HASKELL__ < 912 setEntryDPA :: (Default an)             => Annotated (LocatedAn an ast) -> DeltaPos -> Annotated (LocatedAn an ast)+#else+setEntryDPA :: Annotated (LocatedAn an ast) -> DeltaPos -> Annotated (LocatedAn an ast)+#endif setEntryDPA (Annotated ast s) dp = Annotated (setEntryDP ast dp) s  -- | Exactprint an 'Annotated' thing.

@@ -1,9 +1,11 @@--- Copyright (c) Facebook, Inc. and its affiliates.+-- Copyright (c) 2025 Andrew Farmer+-- Copyright (c) 2020-2024 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 #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TupleSections #-}@@ -21,6 +23,7 @@   , mkLoc   , mkLocA   , mkLocatedHsVar+  , mkParen   , mkVarPat   , mkTyVar   , parenify@@ -37,33 +40,20 @@  import Control.Monad import Control.Monad.State.Lazy-import Data.Functor.Identity--- import qualified Data.Map as M-import Data.Maybe--- import Data.Void -import Retrie.AlphaEnv import Retrie.ExactPrint import Retrie.Fixity import Retrie.GHC import Retrie.SYB import Retrie.Types-import Retrie.Util  -------------------------------------------------------------------------------  mkLocatedHsVar :: Monad m => LocatedN RdrName -> TransformT m (LHsExpr GhcPs)-mkLocatedHsVar ln@(L l n) = 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-  -- return (L (moveAnchor l)  (HsVar noExtField n))+mkLocatedHsVar (L l n) = do   mkLocA (SameLine 0)  (HsVar noExtField (L (setMoveAnchor (SameLine 0) l) n)) +#if __GLASGOW_HASKELL__ < 912 -- TODO: move to ghc-exactprint setMoveAnchor :: (Monoid an) => DeltaPos -> SrcAnn an -> SrcAnn an setMoveAnchor dp (SrcSpanAnn EpAnnNotUsed l)@@ -74,7 +64,19 @@ -- TODO: move to ghc-exactprint dpAnchor :: SrcSpan -> DeltaPos -> Anchor dpAnchor l dp = Anchor (realSrcSpan l) (MovedAnchor dp)+#else+-- TODO: move to ghc-exactprint+setMoveAnchor :: (Monoid an) => DeltaPos -> EpAnn an -> EpAnn an+setMoveAnchor dp (EpAnn (EpaSpan l) an cs)+  = EpAnn (dpAnchor l dp) an cs+setMoveAnchor dp (EpAnn (EpaDelta l _ _) an cs)+  = EpAnn (dpAnchor l dp) an cs +-- TODO: move to ghc-exactprint+dpAnchor :: SrcSpan -> DeltaPos -> EpaLocation+dpAnchor l dp = EpaDelta l dp []+#endif+ -------------------------------------------------------------------------------  -- setAnnsFor :: (Data e, Monad m)@@ -89,6 +91,7 @@ mkLoc e = do   L <$> uniqueSrcSpanT <*> pure e +#if __GLASGOW_HASKELL__ < 912 -- ++AZ++:TODO: move to ghc-exactprint mkLocA :: (Data e, Monad m, Monoid an)   => DeltaPos -> e -> TransformT m (LocatedAn an e)@@ -112,9 +115,35 @@ mkAnchor dp = do   l <- uniqueSrcSpanT   return (Anchor (realSrcSpan l) (MovedAnchor dp))+#else+-- ++AZ++:TODO: move to ghc-exactprint+mkLocA :: (Data e, Monad m, Monoid an)+  => DeltaPos -> e -> TransformT m (LocatedAn an e)+mkLocA dp e = mkLocAA dp mempty e +-- ++AZ++:TODO: move to ghc-exactprint+mkLocAA :: (Data e, Monad m) => DeltaPos -> an -> e -> TransformT m (LocatedAn an e)+mkLocAA dp an e = do+  l <- uniqueSrcSpanT+  let anc = EpaDelta l dp []+  return (L (EpAnn anc an emptyComments) e)+++-- ++AZ++:TODO: move to ghc-exactprint+mkEpAnn :: Monad m => DeltaPos -> an -> TransformT m (EpAnn an)+mkEpAnn dp an = do+  anc <- mkAnchor dp+  return $ EpAnn anc an emptyComments++mkAnchor :: Monad m => DeltaPos -> TransformT m (EpaLocation)+mkAnchor dp = do+  l <- uniqueSrcSpanT+  return (EpaDelta l dp [])+#endif+ ------------------------------------------------------------------------------- +#if __GLASGOW_HASKELL__ < 912 mkLams   :: [LPat GhcPs]   -> LHsExpr GhcPs@@ -127,57 +156,102 @@     ga = GrhsAnn Nothing (AddEpAnn AnnRarrow (EpaDelta (SameLine 1) []))     ang = EpAnn ancg ga emptyComments     anm = EpAnn ancm [(AddEpAnn AnnLam (EpaDelta (SameLine 0) []))] emptyComments-    L l (Match x ctxt pats (GRHSs cs grhs binds)) = mkMatch LambdaExpr vs e emptyLocalBinds+    L l (Match _ ctxt pats (GRHSs cs grhs binds)) = mkMatch LambdaExpr vs e emptyLocalBinds     grhs' = case grhs of-      [L lg (GRHS an guards rhs)] -> [L lg (GRHS ang guards rhs)]+      [L lg (GRHS _ guards rhs)] -> [L lg (GRHS ang guards rhs)]       _ -> fail "mkLams: lambda expression can only have a single grhs!"   matches <- mkLocA (SameLine 0) [L l (Match anm ctxt pats (GRHSs cs grhs' binds))]   let-    mg = #if __GLASGOW_HASKELL__ < 908-      mkMatchGroup Generated matches+    mg = mkMatchGroup Generated matches #else-      mkMatchGroup (Generated SkipPmc) matches+    mg = mkMatchGroup (Generated SkipPmc) matches #endif   mkLocA (SameLine 1) $ HsLam noExtField mg+#else+mkLams+  :: [LPat GhcPs]+  -> LHsExpr GhcPs+  -> TransformT IO (LHsExpr GhcPs)+mkLams [] e = return e+mkLams (p:ps) e = do+  ancg <- mkAnchor (SameLine 1)+  ancm <- mkAnchor (SameLine 0)+  ancGrhs <- mkAnchor (SameLine 0)+  let+    rarrow = EpUniTok ancg NormalSyntax+    ga = GrhsAnn Nothing (Right rarrow)+    anGrhs = EpAnn ancGrhs ga emptyComments+    +    lamTok = EpTok ancm+    lamAnn = EpAnnLam lamTok Nothing +    -- Ensure space after lambda+    vs' = setEntryDP p (SameLine 1) : ps+    +    L l (Match _ ctxt pats (GRHSs cs grhs binds)) = mkMatch (LamAlt LamSingle) (L (EpaSpan noSrcSpan) vs') e emptyLocalBinds+    grhs' = case grhs of+      [L lg (GRHS _ guards rhs)] -> [L lg (GRHS anGrhs guards rhs)]+      _ -> error "mkLams: lambda expression can only have a single grhs!"+  matches <- mkLocA (SameLine 0) [L l (Match noExtField ctxt pats (GRHSs cs grhs' binds))]+  let+    mg = mkMatchGroup (Generated OtherExpansion SkipPmc) matches+  mkLocA (SameLine 1) $ HsLam lamAnn LamSingle mg+#endif+ mkLet :: Monad m => HsLocalBinds GhcPs -> LHsExpr GhcPs -> TransformT m (LHsExpr GhcPs) mkLet EmptyLocalBinds{} e = return e mkLet lbs e = do-#if __GLASGOW_HASKELL__ < 904-  an <- mkEpAnn (DifferentLine 1 5)-                (AnnsLet {-                   alLet = EpaDelta (SameLine 0) [],-                   alIn = EpaDelta (DifferentLine 1 1) []-                 })-  le <- mkLocA (SameLine 1) $ HsLet an lbs e-  return le-#else-  an <- mkEpAnn (DifferentLine 1 5) NoEpAnns+#if __GLASGOW_HASKELL__ < 912+  an <- mkEpAnn (SameLine 0) NoEpAnns   let tokLet = L (TokenLoc (EpaDelta (SameLine 0) [])) HsTok       tokIn = L (TokenLoc (EpaDelta (DifferentLine 1 1) [])) HsTok   le <- mkLocA (SameLine 1) $ HsLet an tokLet lbs tokIn e-  return le+#else+  letTokLoc <- mkAnchor (SameLine 0)+  inTokLoc <- mkAnchor (DifferentLine 1 1)+  let tokLet = EpTok letTokLoc+      tokIn = EpTok inTokLoc+  le <- mkLocA (SameLine 1) $ HsLet (tokLet, tokIn) lbs e #endif+  transferBinds le +transferBinds :: Monad m => LHsExpr GhcPs -> TransformT m (LHsExpr GhcPs)+#if __GLASGOW_HASKELL__ < 912+transferBinds le = hsDecls le >>= replaceDecls le+#else+transferBinds le = return $ replaceDecls le (hsDecls le)+#endif+ mkApps :: MonadIO m => LHsExpr GhcPs -> [LHsExpr GhcPs] -> TransformT m (LHsExpr GhcPs) mkApps e []     = return e mkApps f (a:as) = do   -- lift $ liftIO $ debugPrint Loud "mkApps:f="  [showAst f]-  f' <- mkLocA (SameLine 0) (HsApp noAnn f a)+  let a' = setEntryDP a (SameLine 1)+#if __GLASGOW_HASKELL__ < 912+  f' <- mkLocA (SameLine 0) (HsApp noAnn f a')+#else+  f' <- mkLocA (SameLine 0) (HsApp noExtField f a')+#endif   mkApps f' as  -- GHC never generates HsAppTy in the parser, using HsAppsTy to keep a list -- of types. mkHsAppsTy :: Monad m => [LHsType GhcPs] -> TransformT m (LHsType GhcPs) mkHsAppsTy [] = error "mkHsAppsTy: empty list"-mkHsAppsTy (t:ts) = foldM (\t1 t2 -> mkLocA (SameLine 1) (HsAppTy noExtField t1 t2)) t ts+mkHsAppsTy (t:ts) = do+  let t' = setEntryDP t (SameLine 0)+  foldM (\t1 t2 -> mkLocA (SameLine 1) (HsAppTy noExtField t1 t2)) t' ts  mkTyVar :: Monad m => LocatedN RdrName -> TransformT m (LHsType GhcPs) mkTyVar nm = do+#if __GLASGOW_HASKELL__ < 912   tv <- mkLocA (SameLine 1) (HsTyVar noAnn NotPromoted nm)+#else+  tv <- mkLocA (SameLine 1) (HsTyVar NoEpTok NotPromoted nm)+#endif   -- _ <- setAnnsFor nm [(G AnnVal, DP (0,0))]-  (tv', nm') <- swapEntryDPT tv nm+  (tv', _) <- swapEntryDPT tv nm   return tv'  mkVarPat :: Monad m => LocatedN RdrName -> TransformT m (LPat GhcPs)@@ -192,7 +266,11 @@   -- -> HsConDetails Void (LocatedN RdrName) [RecordPatSynField GhcPs]   -> TransformT m (LPat GhcPs) mkConPatIn patName params = do+#if __GLASGOW_HASKELL__ < 912   p <- mkLocA (SameLine 0) $ ConPat noAnn patName params+#else+  p <- mkLocA (SameLine 0) $ ConPat (Nothing, Nothing) patName params+#endif   -- setEntryDPT p (DP (0,0))   return p @@ -221,49 +299,48 @@ 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 (patToExpr $ cLPat p) (wildSupplyAlphaEnv env, [])- patToExpr :: MonadIO m => LPat GhcPs -> PatQ m (LHsExpr GhcPs) patToExpr orig = case dLPat orig of   Nothing -> error "patToExpr: called on unlocated Pat!"   Just lp@(L _ p) -> do     e <- go p+#if __GLASGOW_HASKELL__ < 912     lift $ transferEntryDP lp e+#else+    return $ transferEntryDP lp e+#endif   where     -- go :: Pat GhcPs -> PatQ m (LHsExpr GhcPs)     go WildPat{} = do       w <- newWildVar       v <- lift $ mkLocA (SameLine 1) w       lift $ mkLocatedHsVar v-#if __GLASGOW_HASKELL__ < 900-    go XPat{} = error "patToExpr XPat"-    go CoPat{} = error "patToExpr CoPat"-    go (ConPatIn con ds) = conPatHelper con ds-    go ConPatOut{} = error "patToExpr ConPatOut" -- only exists post-tc-#else     go (ConPat _ con ds) = conPatHelper con ds-#endif     go (LazyPat _ pat) = patToExpr pat     go (BangPat _ pat) = patToExpr pat     go (ListPat _ ps) = do       ps' <- mapM patToExpr ps       lift $ do+#if __GLASGOW_HASKELL__ < 912         an <- mkEpAnn (SameLine 1)                       (AnnList Nothing (Just (AddEpAnn AnnOpenS d0)) (Just (AddEpAnn AnnCloseS d0)) [] [])+#else+        anc1 <- mkAnchor (SameLine 0)+        anc2 <- mkAnchor (SameLine 0)+        let open = EpTok anc1+            close = EpTok anc2+            an = AnnList Nothing (ListSquare open close) [] () []+#endif         el <- mkLocA (SameLine 1) $ ExplicitList an ps'         -- setAnnsFor el [(G AnnOpenS, DP (0,0)), (G AnnCloseS, DP (0,0))]         return el+#if __GLASGOW_HASKELL__ < 912     go (LitPat _ lit) = lift $ do       -- lit' <- cloneT lit       mkLocA (SameLine 1) $ HsLit noAnn lit@@ -273,22 +350,42 @@       negE <- maybe (return e) (mkLocA (SameLine 0) . NegApp noAnn e) mbNeg       -- addAllAnnsT llit negE       return negE-#if __GLASGOW_HASKELL__ < 904-    go (ParPat an p') = do-      p <- patToExpr p'-      lift $ mkLocA (SameLine 1) (HsPar an p)-#else     go (ParPat an _ p' _) = do       p <- patToExpr p'       let tokLP = L (TokenLoc (EpaDelta (SameLine 0) [])) HsTok           tokRP = L (TokenLoc (EpaDelta (SameLine 0) [])) HsTok       lift $ mkLocA (SameLine 1) (HsPar an tokLP p tokRP)+#else+    go (LitPat _ lit) = lift $ do+      -- lit' <- cloneT lit+      mkLocA (SameLine 1) $ HsLit noExtField lit+    go (NPat _ llit mbNeg _) = lift $ do+      -- L _ lit <- cloneT llit+      e <- mkLocA (SameLine 1) $ HsOverLit noExtField (unLoc llit)+      case mbNeg of+        Nothing -> return e+        Just _ -> do+          anc <- mkAnchor (SameLine 0)+          let minusTok = EpTok anc+          mkLocA (SameLine 0) (NegApp minusTok e noSyntaxExpr)+      -- addAllAnnsT llit negE+    go (ParPat _ p') = do+      p <- patToExpr p'+      anc1 <- lift $ mkAnchor (SameLine 0)+      anc2 <- lift $ mkAnchor (SameLine 0)+      let tokLP = EpTok anc1+          tokRP = EpTok anc2+      lift $ mkLocA (SameLine 1) (HsPar (tokLP, tokRP) p) #endif     go SigPat{} = error "patToExpr SigPat"     go (TuplePat an ps boxity) = do       es <- forM ps $ \pat -> do         e <- patToExpr pat+#if __GLASGOW_HASKELL__ < 912         return $ Present noAnn e+#else+        return $ Present noExtField e+#endif       lift $ mkLocA (SameLine 1) $ ExplicitTuple an es boxity     go (VarPat _ i) = lift $ mkLocatedHsVar i     go AsPat{} = error "patToExpr AsPat"@@ -296,6 +393,12 @@     go SplicePat{} = error "patToExpr SplicePat"     go SumPat{} = error "patToExpr SumPat"     go ViewPat{} = error "patToExpr ViewPat"+#if __GLASGOW_HASKELL__ < 912+#else+    go OrPat{} = error "patToExpr OrPat"+    go EmbTyPat{} = error "patToExpr EmbTyPat"+    go InvisPat{} = error "patToExpr InvisPat"+#endif  conPatHelper :: MonadIO m              => LocatedN RdrName@@ -303,13 +406,22 @@              -> PatQ m (LHsExpr GhcPs) conPatHelper con (InfixCon x y) =   lift . mkLocA (SameLine 1)+#if __GLASGOW_HASKELL__ < 912                =<< OpApp <$> pure noAnn+#else+               =<< OpApp <$> pure noExtField+#endif                          <*> patToExpr x                          <*> lift (mkLocatedHsVar con)                          <*> patToExpr y-conPatHelper con (PrefixCon tyargs xs) = do+#if __GLASGOW_HASKELL__ < 914+-- TODO(xich): Properly handle tyargs here!+conPatHelper con (PrefixCon _tyargs xs) = do+#else+conPatHelper con (PrefixCon xs) = do+#endif   f <- lift $ mkLocatedHsVar con-  as <- mapM patToExpr xs+  as <- mapM patToExpr $ dropInvisPats xs   -- lift $ lift $ liftIO $ debugPrint Loud "conPatHelper:f="  [showAst f]   lift $ mkApps f as conPatHelper _ _ = error "conPatHelper RecCon"@@ -319,15 +431,14 @@ grhsToExpr :: LGRHS GhcPs (LHsExpr GhcPs) -> LHsExpr GhcPs grhsToExpr (L _ (GRHS _ [] e)) = e grhsToExpr (L _ (GRHS _ (_:_) e)) = e -- not sure about this-grhsToExpr _ = error "grhsToExpr"  -------------------------------------------------------------------------------  precedence :: FixityEnv -> HsExpr GhcPs -> Maybe Fixity-#if __GLASGOW_HASKELL__ < 908-precedence _        (HsApp {})       = Just $ Fixity (SourceText "HsApp") 10 InfixL+#if __GLASGOW_HASKELL__ < 912+precedence _        (HsApp {})       = Just $ Fixity NoSourceText 10 InfixL #else-precedence _        (HsApp {})       = Just $ Fixity (SourceText (fsLit "HsApp")) 10 InfixL+precedence _        (HsApp {})       = Just $ Fixity 10 InfixL #endif precedence fixities (OpApp _ _ op _) = Just $ lookupOp op fixities precedence _        _                = Nothing@@ -335,75 +446,89 @@ parenify   :: Monad m => Context -> LHsExpr GhcPs -> TransformT m (LHsExpr GhcPs) parenify Context{..} le@(L _ e)-#if __GLASGOW_HASKELL__ < 904   | needed ctxtParentPrec (precedence ctxtFixityEnv e) && needsParens e =-    mkParen' (getEntryDP le) (\an -> HsPar an (setEntryDP le (SameLine 0)))-#else-  | needed ctxtParentPrec (precedence ctxtFixityEnv e) && needsParens e = do-    let tokLP = L (TokenLoc (EpaDelta (SameLine 0) [])) HsTok-        tokRP = L (TokenLoc (EpaDelta (SameLine 0) [])) HsTok-     in mkParen' (getEntryDP le) (\an -> HsPar an tokLP (setEntryDP le (SameLine 0)) tokRP)-#endif+    mkParen le   | otherwise = return le   where            {- parent -}               {- child -}+#if __GLASGOW_HASKELL__ < 912     needed (HasPrec (Fixity _ p1 d1)) (Just (Fixity _ p2 d2)) =+#else+    needed (HasPrec (Fixity p1 d1)) (Just (Fixity p2 d2)) =+#endif       p1 > p2 || (p1 == p2 && (d1 /= d2 || d2 == InfixN))     needed NeverParen _ = False     needed _ Nothing = True     needed _ _ = False +-- | Wrap in parentheses.+mkParen :: Monad m => LHsExpr GhcPs -> TransformT m (LHsExpr GhcPs)+mkParen le = do+  let inner = setTrailingAnns [] (setEntryDP le (SameLine 0))+#if __GLASGOW_HASKELL__ < 912+  let tokLP = L (TokenLoc (EpaDelta (SameLine 0) [])) HsTok+      tokRP = L (TokenLoc (EpaDelta (SameLine 0) [])) HsTok+  p <- mkLocA (getEntryDP le) (HsPar noAnn tokLP inner tokRP)+#else+  anc1 <- mkAnchor (SameLine 0)+  anc2 <- mkAnchor (SameLine 0)+  let tokLP = EpTok anc1+      tokRP = EpTok anc2+  p <- mkParen' (getEntryDP le) (\_ -> HsPar (tokLP, tokRP) inner)+#endif+  transferAnnsT (const True) le p+ getUnparened :: Data k => k -> k getUnparened = mkT unparen `extT` unparenT `extT` unparenP  -- TODO: what about comments? unparen :: LHsExpr GhcPs -> LHsExpr GhcPs-#if __GLASGOW_HASKELL__ < 904-unparen (L _ (HsPar _ e)) = e+unparen expr = case expr of+#if __GLASGOW_HASKELL__ < 912+  L _ (HsPar _ _ e _) #else-unparen (L _ (HsPar _ _ e _)) = e+  L _ (HsPar _ e) #endif-unparen e = e+    -- see Note [Sections in HsSyn] in GHC.Hs.Expr+    | L _ SectionL{} <- e -> expr+    | L _ SectionR{} <- e -> expr+    | otherwise -> e+  _ -> expr  -- | hsExprNeedsParens is not always up-to-date, so this allows us to override needsParens :: HsExpr GhcPs -> Bool needsParens = hsExprNeedsParens (PprPrec 10) -mkParen :: (Data x, Monad m, Monoid an, Typeable an)-  => (LocatedAn an x -> x) -> LocatedAn an x -> TransformT m (LocatedAn an x)-mkParen k e = do-  pe <- mkLocA (SameLine 1) (k e)-  -- _ <- setAnnsFor pe [(G AnnOpenP, DP (0,0)), (G AnnCloseP, DP (0,0))]-  (e0,pe0) <- swapEntryDPT e pe-  return pe0--#if __GLASGOW_HASKELL__ < 904-mkParen' :: (Data x, Monad m, Monoid an)-         => DeltaPos -> (EpAnn AnnParen -> x) -> TransformT m (LocatedAn an x)-mkParen' dp k = do-  let an = AnnParen AnnParens d0 d0-  l <- uniqueSrcSpanT-  let anc = Anchor (realSrcSpan l) (MovedAnchor (SameLine 0))-  pe <- mkLocA dp (k (EpAnn anc an emptyComments))-  return pe+#if __GLASGOW_HASKELL__ < 912 #else mkParen' :: (Data x, Monad m, Monoid an)-         => DeltaPos -> (EpAnn NoEpAnns -> x) -> TransformT m (LocatedAn an x)+         => DeltaPos -> (EpAnn AnnListItem -> x) -> TransformT m (LocatedAn an x) mkParen' dp k = do-  let an = NoEpAnns+  let an = AnnListItem []   l <- uniqueSrcSpanT-  let anc = Anchor (realSrcSpan l) (MovedAnchor (SameLine 0))+  let anc = EpaDelta l dp []   pe <- mkLocA dp (k (EpAnn anc an emptyComments))   return pe+#endif +#if __GLASGOW_HASKELL__ < 912 mkParenTy :: (Data x, Monad m, Monoid an)          => DeltaPos -> (EpAnn AnnParen -> x) -> TransformT m (LocatedAn an x) mkParenTy dp k = do-  let an = AnnParen AnnParens d0 d0+  let an = AnnParen AnnParens (EpaDelta (SameLine 0) []) (EpaDelta (SameLine 0) [])   l <- uniqueSrcSpanT   let anc = Anchor (realSrcSpan l) (MovedAnchor (SameLine 0))   pe <- mkLocA dp (k (EpAnn anc an emptyComments))   return pe+#else+mkParenTy :: (Data x, Monad m, Monoid an)+         => DeltaPos -> (EpAnn AnnListItem -> x) -> TransformT m (LocatedAn an x)+mkParenTy dp k = do+  let an = AnnListItem []+  l <- uniqueSrcSpanT+  let anc = EpaDelta l dp []+  pe <- mkLocA dp (k (EpAnn anc an emptyComments))+  return pe #endif  -- This explicitly operates on 'Located (Pat GhcPs)' instead of 'LPat GhcPs'@@ -413,17 +538,27 @@   => Context   -> LPat GhcPs   -> TransformT m (LPat GhcPs)+#if __GLASGOW_HASKELL__ < 912 parenifyP Context{..} p@(L _ pat)   | IsLhs <- ctxtParentPrec-  , needed pat =-#if __GLASGOW_HASKELL__ < 904-    mkParen' (getEntryDP p) (\an -> ParPat an (setEntryDP p (SameLine 0)))-#else+  , needed pat = do     let tokLP = L (TokenLoc (EpaDelta (SameLine 0) [])) HsTok         tokRP = L (TokenLoc (EpaDelta (SameLine 0) [])) HsTok-     in mkParen' (getEntryDP p) (\an -> ParPat an tokLP (setEntryDP p (SameLine 0)) tokRP)-#endif+    pe <- mkLocA (getEntryDP p) (ParPat noAnn tokLP inner tokRP)+    transferAnnsT (const True) p pe   | otherwise = return p+#else+parenifyP Context{..} p@(L _ pat)+  | IsLhs <- ctxtParentPrec+  , needed pat = do+    anc1 <- mkAnchor (SameLine 0)+    anc2 <- mkAnchor (SameLine 0)+    let tokLP = EpTok anc1+        tokRP = EpTok anc2+    pe <- mkParen' (getEntryDP p) (\_ -> ParPat (tokLP, tokRP) inner)+    transferAnnsT (const True) p pe+  | otherwise = return p+#endif   where     needed BangPat{}                          = False     needed LazyPat{}                          = False@@ -434,44 +569,62 @@     needed TuplePat{}                         = False     needed VarPat{}                           = False     needed WildPat{}                          = False-#if __GLASGOW_HASKELL__ < 900-    needed (ConPatIn _ (PrefixCon []))        = False-    needed ConPatOut{pat_args = PrefixCon []} = False-#else+#if __GLASGOW_HASKELL__ < 914     needed (ConPat _ _ (PrefixCon _ []))      = False+#else+    needed (ConPat _ _ (PrefixCon []))        = False #endif     needed _                                  = True+    inner = setTrailingAnns [] (setEntryDP p (SameLine 0))  parenifyT   :: Monad m => Context -> LHsType GhcPs -> TransformT m (LHsType GhcPs)+#if __GLASGOW_HASKELL__ < 912 parenifyT Context{..} lty@(L _ ty)-  | needed ty =-#if __GLASGOW_HASKELL__ < 904-      mkParen' (getEntryDP lty) (\an -> HsParTy an (setEntryDP lty (SameLine 0)))+  | needed ty = do+      p <- mkParenTy (getEntryDP lty) (\an -> HsParTy an inner)+      transferAnnsT (const True) lty p+  | otherwise = return lty+  where+    needed t = case ctxtParentPrec of+      HasPrec (Fixity _ prec InfixN) -> hsTypeNeedsParens (PprPrec prec) t+      HasPrec (Fixity _ prec _) -> hsTypeNeedsParens (PprPrec $ prec - 1) t+      IsLhs -> False+      NeverParen -> False #else-      mkParenTy (getEntryDP lty) (\an -> HsParTy an (setEntryDP lty (SameLine 0)))-#endif+parenifyT Context{..} lty@(L _ ty)+  | needed ty = do+      anc1 <- mkAnchor (SameLine 0)+      anc2 <- mkAnchor (SameLine 0)+      let tokLP = EpTok anc1+          tokRP = EpTok anc2+      p <- mkParenTy (getEntryDP lty) (\_ -> HsParTy (tokLP, tokRP) inner)+      transferAnnsT (const True) lty p   | otherwise = return lty   where-    needed HsAppTy{}-      | IsHsAppsTy <- ctxtParentPrec = True-      | otherwise = False-    needed t = hsTypeNeedsParens (PprPrec 10) t+    needed t = case ctxtParentPrec of+      HasPrec (Fixity prec InfixN) -> hsTypeNeedsParens (PprPrec prec) t+      HasPrec (Fixity prec _) -> hsTypeNeedsParens (PprPrec $ prec - 1) t+      IsLhs -> False+      NeverParen -> False+#endif+    inner = setTrailingAnns [] (setEntryDP lty (SameLine 0))  unparenT :: LHsType GhcPs -> LHsType GhcPs unparenT (L _ (HsParTy _ ty)) = ty unparenT ty = ty  unparenP :: LPat GhcPs -> LPat GhcPs-#if __GLASGOW_HASKELL__ < 904-unparenP (L _ (ParPat _ p)) = p-#else+#if __GLASGOW_HASKELL__ < 912 unparenP (L _ (ParPat _ _ p _)) = p+#else+unparenP (L _ (ParPat _ p)) = p #endif unparenP p = p  -------------------------------------------------------------------- +#if __GLASGOW_HASKELL__ < 914 bitraverseHsConDetails   :: Applicative m   => ([tyarg] -> m [tyarg'])@@ -485,3 +638,17 @@   RecCon <$> recf r bitraverseHsConDetails _ argf _ (InfixCon a1 a2) =   InfixCon <$> argf a1 <*> argf a2+#else+bitraverseHsConDetails+  :: Applicative m+  => (arg -> m arg')+  -> (rec -> m rec')+  -> HsConDetails arg rec+  -> m (HsConDetails arg' rec')+bitraverseHsConDetails argf _ (PrefixCon args) =+  PrefixCon <$> (argf `traverse` args)+bitraverseHsConDetails _ recf (RecCon r) =+  RecCon <$> recf r+bitraverseHsConDetails argf _ (InfixCon a1 a2) =+  InfixCon <$> argf a1 <*> argf a2+#endif

@@ -1,8 +1,10 @@--- Copyright (c) Facebook, Inc. and its affiliates.+-- Copyright (c) 2025 Andrew Farmer+-- Copyright (c) 2020-2024 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 #-} module Retrie.Fixity   ( FixityEnv@@ -45,7 +47,11 @@ ppFixityEnv :: FixityEnv -> String ppFixityEnv = unlines . map ppFixity . nonDetEltsUFM . unFixityEnv   where+#if __GLASGOW_HASKELL__ < 912     ppFixity (fs, Fixity _ p d) = unwords+#else+    ppFixity (fs, Fixity p d) = unwords+#endif       [ case d of           InfixN -> "infix"           InfixL -> "infixl"

@@ -1,4 +1,5 @@--- Copyright (c) Facebook, Inc. and its affiliates.+-- Copyright (c) 2025 Andrew Farmer+-- Copyright (c) 2020-2024 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.@@ -25,11 +26,10 @@ emptyFVs = FreeVars emptyUniqSet  instance Semigroup FreeVars where-  (<>) = mappend+  (FreeVars s1) <> (FreeVars s2) = FreeVars $ s1 <> s2  instance Monoid FreeVars where   mempty = emptyFVs-  mappend (FreeVars s1) (FreeVars s2) = FreeVars $ s1 <> s2  instance Show FreeVars where   show (FreeVars m) = show (nonDetEltsUniqSet m)

@@ -1,4 +1,5 @@--- Copyright (c) Facebook, Inc. and its affiliates.+-- Copyright (c) 2025 Andrew Farmer+-- Copyright (c) 2020-2024 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.@@ -53,14 +54,14 @@ import GHC.Types.Unique import GHC.Types.Unique.FM import GHC.Types.Unique.Set-#if __GLASGOW_HASKELL__ >= 906 import Language.Haskell.Syntax.Basic as GHC.Unit.Module.Name-#else-import GHC.Unit.Module.Name-#endif import GHC.Utils.Outputable (Outputable (ppr))  import Data.Bifunctor (second)+#if __GLASGOW_HASKELL__ < 914+#else+import qualified Data.List.NonEmpty as NE+#endif import Data.Maybe  cLPat :: LPat (GhcPass p) -> LPat (GhcPass p)@@ -74,10 +75,11 @@ dLPatUnsafe :: LPat (GhcPass p) -> LPat (GhcPass p) dLPatUnsafe = id -#if __GLASGOW_HASKELL__ == 808-stripSrcSpanPat :: LPat (GhcPass p) -> Pat (GhcPass p)-stripSrcSpanPat (XPat (L _  p)) = stripSrcSpanPat p-stripSrcSpanPat p = p+getMatchPats :: Match GhcPs (LHsExpr GhcPs) -> [LPat GhcPs]+#if __GLASGOW_HASKELL__ < 912+getMatchPats = m_pats+#else+getMatchPats = unLoc . m_pats #endif  rdrFS :: RdrName -> FastString@@ -87,20 +89,42 @@ fsDot :: FastString fsDot = mkFastString "." +#if __GLASGOW_HASKELL__ < 914 varRdrName :: HsExpr p -> Maybe (LIdP p)+#else+varRdrName :: HsExpr p -> Maybe (LIdOccP p)+#endif varRdrName (HsVar _ n) = Just n varRdrName _ = Nothing +#if __GLASGOW_HASKELL__ < 914 tyvarRdrName :: HsType p -> Maybe (LIdP p)+#else+tyvarRdrName :: HsType p -> Maybe (LIdOccP p)+#endif tyvarRdrName (HsTyVar _ _ n) = Just n tyvarRdrName _ = Nothing --- fixityDecls :: HsModule -> [(LIdP p, Fixity)]-#if __GLASGOW_HASKELL__ >= 906-fixityDecls :: HsModule GhcPs -> [(LocatedN RdrName, Fixity)]+-- | On GHC >= 9.14 constructor-pattern type arguments are invisible+-- patterns in the PrefixCon argument list rather than a separate tyargs+-- field. Retrie ignores them, as it ignored the tyargs field on older GHCs.+-- TODO: Handle this case properly.+dropInvisPats :: [LPat GhcPs] -> [LPat GhcPs]+#if __GLASGOW_HASKELL__ < 914+dropInvisPats = id #else-fixityDecls :: HsModule -> [(LocatedN RdrName, Fixity)]+dropInvisPats = dropHsConPatTyArgs #endif++grhssList :: GRHSs GhcPs body -> [LGRHS GhcPs body]+#if __GLASGOW_HASKELL__ < 914+grhssList = grhssGRHSs+#else+grhssList = NE.toList . grhssGRHSs+#endif++-- fixityDecls :: HsModule -> [(LIdP p, Fixity)]+fixityDecls :: HsModule GhcPs -> [(LocatedN RdrName, Fixity)] fixityDecls m =   [ (nm, fixity)   | L _ (SigD _ (FixSig _ (FixitySig _ nms fixity))) <- hsmodDecls m@@ -108,10 +132,10 @@   ]  ruleInfo :: RuleDecl GhcPs -> [RuleInfo]-#if __GLASGOW_HASKELL__ >= 906+#if __GLASGOW_HASKELL__ < 914 ruleInfo (HsRule _ (L _ riName) _ tyBs valBs riLHS riRHS) = #else-ruleInfo (HsRule _ (L _ (_, riName)) _ tyBs valBs riLHS riRHS) =+ruleInfo (HsRule _ (L _ riName) _ (RuleBndrs _ tyBs valBs) riLHS riRHS) = #endif   let     riQuantifiers =@@ -128,11 +152,21 @@   ]  tyBindersToLocatedRdrNames :: [LHsTyVarBndr s GhcPs] -> [LocatedN RdrName]-tyBindersToLocatedRdrNames vars = catMaybes-  [ case var of-      UserTyVar _ _ v -> Just v-      KindedTyVar _ _ v _ -> Just v-  | L _ var <- vars ]+#if __GLASGOW_HASKELL__ < 912+tyBindersToLocatedRdrNames = map getTyVarLName+  where+    getTyVarLName (L _ (UserTyVar _ _ ln)) = ln+    getTyVarLName (L _ (KindedTyVar _ _ ln _)) = ln+    getTyVarLName (L _ (XTyVarBndr _)) = error "tyBindersToLocatedRdrNames: XTyVarBndr not supported"+#else+-- Note: we can't use 'hsLTyVarNames' here because it throws away the wildcards,+-- and we _must_ preserve the length of the list. Also can't use some of the+-- other single-binder variants of hsTyVarLName because they throw away the+-- location on the RdrName result.+tyBindersToLocatedRdrNames = map (fromMaybe mkWildcard . hsTyVarLName . unLoc)+  where+    mkWildcard = error "tyBindersToLocatedRdrNames: wildcard type binder not supported"+#endif  data RuleInfo = RuleInfo   { riName :: RuleName@@ -141,11 +175,6 @@   , riRHS :: LHsExpr GhcPs   } -#if __GLASGOW_HASKELL__ < 810-noExtField :: NoExt-noExtField = noExt-#endif- overlaps :: SrcSpan -> SrcSpan -> Bool overlaps (RealSrcSpan s1 _) (RealSrcSpan s2 _) =      srcSpanFile s1 == srcSpanFile s2 &&@@ -173,17 +202,9 @@ uniqBag = listToUFM_C (++) . map (second pure)  getRealLoc :: SrcLoc -> Maybe RealSrcLoc-#if __GLASGOW_HASKELL__ < 900-getRealLoc (RealSrcLoc l) = Just l-#else getRealLoc (RealSrcLoc l _) = Just l-#endif getRealLoc _ = Nothing  getRealSpan :: SrcSpan -> Maybe RealSrcSpan-#if __GLASGOW_HASKELL__ < 900-getRealSpan (RealSrcSpan s) = Just s-#else getRealSpan (RealSrcSpan s _) = Just s-#endif getRealSpan _ = Nothing

@@ -1,4 +1,5 @@--- Copyright (c) Facebook, Inc. and its affiliates.+-- Copyright (c) 2025 Andrew Farmer+-- Copyright (c) 2020-2024 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.

@@ -1,4 +1,5 @@--- Copyright (c) Facebook, Inc. and its affiliates.+-- Copyright (c) 2025 Andrew Farmer+-- Copyright (c) 2020-2024 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.@@ -37,7 +38,7 @@  import Retrie.Context import Retrie.CPP-import Retrie.ExactPrint hiding (rs)+import Retrie.ExactPrint import Retrie.Fixity import Retrie.GroundTerms import Retrie.Query@@ -124,7 +125,6 @@   (<*>) = ap  instance Monad Retrie where-  return = Pure   (>>=) = Bind  instance MonadIO Retrie where

@@ -1,10 +1,12 @@--- Copyright (c) Facebook, Inc. and its affiliates.+-- Copyright (c) 2025 Andrew Farmer+-- Copyright (c) 2020-2024 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 NumericUnderscores #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} module Retrie.Options@@ -26,7 +28,11 @@   , GrepCommands(..)   ) where +import Control.Concurrent+  (getNumCapabilities, rtsSupportsBoundThreads, setNumCapabilities) import Control.Concurrent.Async (mapConcurrently)+import Control.Concurrent.QSem+import Control.Exception (bracket_) import Control.Monad (when, foldM) import Data.Bool import Data.Char (isAlphaNum, isSpace)@@ -103,6 +109,11 @@     -- ^ 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.+  , jobs :: Maybe Int+    -- ^ Maximum number of target modules to rewrite concurrently. 'Nothing'+    -- (the default) means one per RTS capability, which is one unless the+    -- program is run with @+RTS -N@. Specified by the command-line flag '-j'.+    -- Peak memory use is roughly proportional to this number.   , noDefaultElaborations :: Bool     -- ^ Do not apply any of the built in elaborations in 'defaultElaborations'.   , randomOrder :: Bool@@ -136,6 +147,7 @@   , extraIgnores = []   , fixityEnv = mempty   , iterateN = 1+  , jobs = Nothing   , noDefaultElaborations = False   , randomOrder = False   , rewrites = D.def@@ -208,6 +220,16 @@     , value 1     , help "Iterate rewrites up to N times."     ]+  jobs <- optional $ option (eitherReader jobsReader) $ mconcat+    [ long "jobs"+    , short 'j'+    , metavar "N"+    , help $ unwords+      [ "Rewrite up to N target files concurrently, using N RTS capabilities."+      , "Defaults to the number of capabilities (1 unless run with +RTS -N)."+      , "Peak memory use grows with N."+      ]+    ]    executionMode <- parseMode   rewrites <- parseRewriteSpecOptions@@ -342,6 +364,11 @@ verbosityHelp :: String verbosityHelp = "0: silent, 1: normal, 2: loud (implies --single-threaded)" +jobsReader :: String -> Either String Int+jobsReader s = case reads s of+  [(n, "")] | n >= 1 -> Right n+  _ -> Left "invalid number of jobs. Must be a positive integer."+ -------------------------------------------------------------------------------  -- | Options that have been parsed, but not fully resolved.@@ -352,6 +379,7 @@ -- declared fixities in the target directory. resolveOptions :: LibDir -> ProtoOptions -> IO Options resolveOptions libdir protoOpts = do+  setJobs (jobs protoOpts)   absoluteTargetDir <- makeAbsolute (targetDir protoOpts)   opts@Options{..} <-     addLocalFixities libdir protoOpts { targetDir = absoluteTargetDir }@@ -391,15 +419,28 @@    return opts { fixityEnv = foldr ($) (fixityEnv opts) fixFns } --- | 'forM', but concurrency and input order controled by 'Options'.+-- | Set the number of RTS capabilities to the requested number of jobs, so+-- '-j' parallelizes without also requiring @+RTS -N@. Only possible with the+-- threaded RTS. Without it, concurrent jobs still interleave on one core,+-- which costs memory without any speedup.+setJobs :: Maybe Int -> IO ()+setJobs (Just n) | rtsSupportsBoundThreads = setNumCapabilities n+setJobs _ = return ()++-- | 'forM', but concurrency and input order controlled by 'Options'.+-- At most 'jobs' actions run at once, so peak memory use is bounded by the+-- number of jobs rather than the number of inputs. forFn :: Options_ x y -> [a] -> (a -> IO b) -> IO [b] forFn Options{..} c f-  | randomOrder = fn f =<< shuffleM c-  | otherwise = fn f c+  | randomOrder = fn =<< shuffleM c+  | otherwise = fn c   where-    fn-      | singleThreaded = mapM-      | otherwise = mapConcurrently+    fn xs+      | singleThreaded = mapM f xs+      | otherwise = do+          n <- maybe getNumCapabilities return jobs+          sem <- newQSem (max 1 n)+          mapConcurrently (bracket_ (waitQSem sem) (signalQSem sem) . f) xs  -- | Find all files to target for rewriting. getTargetFiles :: Options_ a b -> [GroundTerms] -> IO [FilePath]@@ -487,13 +528,28 @@  -- | run a command with a list of files as quoted arguments commandStep :: FilePath -> Verbosity -> [FilePath]-> CommandLine -> IO [FilePath]-commandStep targetDir verbosity files cmd = doCmd targetDir verbosity (cmd <> formatPaths files)- where-    formatPaths [] = ""-    formatPaths xs = " " <> unwords (map quotePath xs)+commandStep targetDir verbosity files cmd =+  fmap concat $ forM (chunkifyArgs $ map quotePath files) $ \args ->+    doCmd targetDir verbosity $ cmd <> " " <> unwords args+ quotePath :: FilePath -> FilePath quotePath x = "'" <> x <> "'" +-- Split arguments into chunks whose size does not exceed 'argMax'.+-- Note that @chunkifyArgs []@ returns @[[]]@ intentionally.+chunkifyArgs :: [String] -> [[String]]+chunkifyArgs = go 0 []+  where+    go _ acc [] = [reverse acc]+    go n acc (arg: args)+      | n <= 0 || n + len <= argMax = go (n + len) (arg: acc) args+      | otherwise = reverse acc: go len [arg] args+      where+        len = length arg + 1++-- | Hardcoded default @--max-args=max-args@ used by @xargs@.+argMax :: Int+argMax = 128 * 1024  doCmd :: FilePath -> Verbosity -> String -> IO [FilePath] doCmd targetDir verbosity shellCmd = do

@@ -1,4 +1,5 @@--- Copyright (c) Facebook, Inc. and its affiliates.+-- Copyright (c) 2025 Andrew Farmer+-- Copyright (c) 2020-2024 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.

@@ -1,4 +1,5 @@--- Copyright (c) Facebook, Inc. and its affiliates.+-- Copyright (c) 2025 Andrew Farmer+-- Copyright (c) 2020-2024 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.

@@ -1,4 +1,5 @@--- Copyright (c) Facebook, Inc. and its affiliates.+-- Copyright (c) 2025 Andrew Farmer+-- Copyright (c) 2020-2024 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.@@ -54,18 +55,12 @@   mAlter env vs tupArg f m = go tupArg     where       go (Present _ e) = m { tamPresent = mAlter env vs e  f (tamPresent m) }-#if __GLASGOW_HASKELL__ < 900-      go XTupArg{} = missingSyntax "XTupArg"-#endif       go (Missing _) = m { tamMissing = mAlter env vs () f (tamMissing m) }    mMatch :: MatchEnv -> Key TupArgMap -> (Substitution, TupArgMap a) -> [(Substitution, a)]   mMatch env = go     where       go (Present _ e) = mapFor tamPresent >=> mMatch env e-#if __GLASGOW_HASKELL__ < 900-      go XTupArg{} = const []-#endif       go (Missing _) = mapFor tamMissing >=> mMatch env ()  ------------------------------------------------------------------------@@ -182,13 +177,25 @@       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 _ _ _) = missingSyntax "HsInteger"+#if __GLASGOW_HASKELL__ < 914+      go HsInteger{} = missingSyntax "HsInteger"       go HsRat{} = missingSyntax "HsRat"+#endif       go HsFloatPrim{} = missingSyntax "HsFloatPrim"       go HsDoublePrim{} = missingSyntax "HsDoublePrim"-#if __GLASGOW_HASKELL__ < 900-      go XLit{} = missingSyntax "XLit"+#if __GLASGOW_HASKELL__ < 908+#else+      go HsInt8Prim{} = missingSyntax "HsInt8Prim"+      go HsInt16Prim{} = missingSyntax "HsInt16Prim"+      go HsInt32Prim{} = missingSyntax "HsInt32Prim"+      go HsWord8Prim{} = missingSyntax "HsWord8Prim"+      go HsWord16Prim{} = missingSyntax "HsWord16Prim"+      go HsWord32Prim{} = missingSyntax "HsWord32Prim" #endif+#if __GLASGOW_HASKELL__ < 912+#else+      go HsMultilineString{} = missingSyntax "HsMultilineString"+#endif    mMatch :: MatchEnv -> Key LMap -> (Substitution, LMap a) -> [(Substitution, a)]   mMatch _   _   (_,LMEmpty) = []@@ -264,9 +271,6 @@ -- 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.@@ -278,7 +282,11 @@        , emIPVar :: FSEnv a        , emOverLit :: OLMap a        , emLit   :: LMap a-       , emLam   :: MGMap a -- See Note [Lambdas]+#if __GLASGOW_HASKELL__ < 912+       , emLam   :: MGMap a+#else+       , emLam   :: LVMap (MGMap a)+#endif        , emApp   :: EMap (EMap a)        , emOpApp :: EMap (EMap (EMap a)) -- op, lhs, rhs        , emNegApp :: EMap a@@ -353,101 +361,77 @@         m { emCase = mAlter env vs s (toA (mAlter env vs mg f)) (emCase m) }       go (HsDo _ sc ss) =         m { emDo = mAlter env vs sc (toA (mAlter env vs (unLoc ss) f)) (emDo m) }-#if __GLASGOW_HASKELL__ < 900-      go (HsIf _ _ c tr fl) =-#else       go (HsIf _ c tr fl) =-#endif         m { emIf = mAlter env vs c                       (toA (mAlter env vs tr                           (toA (mAlter env vs fl f)))) (emIf m) }       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) }+#if __GLASGOW_HASKELL__ < 912+      go (HsLam _ mg) = m { emLam = mAlter env vs mg f (emLam m) }+#else+      go (HsLam _ v mg) = m { emLam = mAlter env vs v (toA (mAlter env vs mg f)) (emLam m) }+#endif       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) }-#if __GLASGOW_HASKELL__ < 904-      go (HsPar _ e') = m { emPar  = mAlter env vs e' f (emPar m) }-#else+#if __GLASGOW_HASKELL__ < 912       go (HsPar _ _ e' _) = m { emPar  = mAlter env vs e' f (emPar m) }+#else+      go (HsPar _ e') = m { emPar  = mAlter env vs e' f (emPar m) } #endif       go (OpApp _ l o r) =         m { emOpApp = mAlter env vs o (toA (mAlter env vs l (toA (mAlter env vs r f)))) (emOpApp m) }-#if __GLASGOW_HASKELL__ < 904       go (RecordCon _ v fs) =-        m { emRecordCon = mAlter env vs (unLoc v) (toA (mAlter env vs (fieldsToRdrNames $ rec_flds fs) f)) (emRecordCon m) }-#else-      go (RecordCon _ v fs) =         m { emRecordCon = mAlter env vs (unLoc v :: RdrName) (toA (mAlter env vs (rec_flds fs) f)) (emRecordCon m) }-#endif       go (RecordUpd _ e' fs) =         m { emRecordUpd = mAlter env vs e' (toA (mAlter env vs (fieldsToRdrNamesUpd 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) }-#if __GLASGOW_HASKELL__ < 904-      go (HsLet _ lbs e') =-#else+#if __GLASGOW_HASKELL__ < 912       go (HsLet _ _ lbs _ e') =+#else+      go (HsLet _ lbs e') = #endif         let           bs = collectLocalBinders CollNoDictBinders lbs           env' = foldr extendAlphaEnvInternal env bs           vs' = vs `exceptQ` bs         in m { emLet = mAlter env vs lbs (toA (mAlter env' vs' e' f)) (emLet m) }+#if __GLASGOW_HASKELL__ < 912       go HsLamCase{} = missingSyntax "HsLamCase"+      go HsRecSel{} = missingSyntax "HsRecSel"+#endif       go HsMultiIf{} = missingSyntax "HsMultiIf"       go (ExplicitList _ es) = m { emExplicitList = mAlter env vs es f (emExplicitList m) }       go ArithSeq{} = missingSyntax "ArithSeq"       go (ExprWithTySig _ e' (HsWC _ (L _ (HsSig _ _ ty)))) =         m { emExprWithTySig = mAlter env vs e' (toA (mAlter env vs ty f)) (emExprWithTySig m) }-#if __GLASGOW_HASKELL__ < 900-      go XExpr{} = missingSyntax "XExpr"-      go ExprWithTySig{} = missingSyntax "ExprWithTySig"-      go HsSCC{} = missingSyntax "HsSCC"-      go HsCoreAnn{} = missingSyntax "HsCoreAnn"-      go HsTickPragma{} = missingSyntax "HsTickPragma"-      go HsWrap{} = missingSyntax "HsWrap"-#else       go HsPragE{} = missingSyntax "HsPragE"-#endif-#if __GLASGOW_HASKELL__ < 904-      go HsBracket{} = missingSyntax "HsBracket"-      go HsRnBracketOut{} = missingSyntax "HsRnBracketOut"-      go HsTcBracketOut{} = missingSyntax "HsTcBracketOut"-      go HsSpliceE{} = missingSyntax "HsSpliceE"-      go HsProc{} = missingSyntax "HsProc"-      go HsStatic{} = missingSyntax "HsStatic"-#else       go HsTypedBracket{} = missingSyntax "HsTypedBracket"       go HsUntypedBracket{} = missingSyntax "HsUntypedBracket"-#if __GLASGOW_HASKELL__ < 906-      go HsSpliceE{} = missingSyntax "HsSpliceE"-#endif-#endif-#if __GLASGOW_HASKELL__ < 810-      go HsArrApp{} = missingSyntax "HsArrApp"-      go HsArrForm{} = missingSyntax "HsArrForm"-      go EWildPat{} = missingSyntax "EWildPat"-      go EAsPat{} = missingSyntax "EAsPat"-      go EViewPat{} = missingSyntax "EViewPat"-      go ELazyPat{} = missingSyntax "ELazyPat"-#endif-#if __GLASGOW_HASKELL__ < 904-      go HsTick{} = missingSyntax "HsTick"-      go HsBinTick{} = missingSyntax "HsBinTick"-#endif+#if __GLASGOW_HASKELL__ < 914       go HsUnboundVar{} = missingSyntax "HsUnboundVar"-#if __GLASGOW_HASKELL__ < 904-      go HsRecFld{} = missingSyntax "HsRecFld"+#else+      go HsHole{} = missingSyntax "HsHole" #endif       go HsOverLabel{} = missingSyntax "HsOverLabel"       go HsAppType{} = missingSyntax "HsAppType"-#if __GLASGOW_HASKELL__ < 904-      go HsConLikeOut{} = missingSyntax "HsConLikeOut"-#endif       go ExplicitSum{} = missingSyntax "ExplicitSum"+      go HsGetField{} = missingSyntax "HsGetField"+      go HsProjection{} = missingSyntax "HsProjection"+      go HsTypedSplice{} = missingSyntax "HsTypedSplice"+      go HsUntypedSplice{} = missingSyntax "HsUntypedSplice"+      go HsProc{} = missingSyntax "HsProc"+      go HsStatic{} = missingSyntax "HsStatic"+#if __GLASGOW_HASKELL__ < 912+#else+      go HsEmbTy{} = missingSyntax "HsEmbTy"+      go HsForAll{} = missingSyntax "HsForAll"+      go HsQual{} = missingSyntax "HsQual"+      go HsFunArr{} = missingSyntax "HsFunArr"+#endif    mMatch :: MatchEnv -> Key EMap -> (Substitution, EMap a) -> [(Substitution, a)]   mMatch _   _ (_,EMEmpty) = []@@ -459,40 +443,35 @@       go (HsApp _ l r) = mapFor emApp >=> mMatch env l >=> mMatch env r       go (HsCase _ s mg) = mapFor emCase >=> mMatch env s >=> mMatch env mg       go (HsDo _ sc ss) = mapFor emDo >=> mMatch env sc >=> mMatch env (unLoc ss)-#if __GLASGOW_HASKELL__ < 900-      go (HsIf _ _ c tr fl) =-#else       go (HsIf _ c tr fl) =-#endif         mapFor emIf >=> mMatch env c >=> mMatch env tr >=> mMatch env fl       go (HsIPVar _ (HsIPName ip)) = mapFor emIPVar >=> mMatch env ip+#if __GLASGOW_HASKELL__ < 912       go (HsLam _ mg) = mapFor emLam >=> mMatch env mg+#else+      go (HsLam _ v mg) = mapFor emLam >=> mMatch env v >=> mMatch env mg+#endif       go (HsLit _ l) = mapFor emLit >=> mMatch env l       go (HsOverLit _ ol) = mapFor emOverLit >=> mMatch env (ol_val ol)-#if __GLASGOW_HASKELL__ < 904-      go (HsPar _ e') = mapFor emPar >=> mMatch env e'-#else+#if __GLASGOW_HASKELL__ < 912       go (HsPar _ _ e' _) = mapFor emPar >=> mMatch env e'+#else+      go (HsPar _ e') = mapFor emPar >=> mMatch env e' #endif       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'-#if __GLASGOW_HASKELL__ < 904       go (RecordCon _ v fs) =-        mapFor emRecordCon >=> mMatch env (unLoc v) >=> mMatch env (fieldsToRdrNames $ rec_flds fs)-#else-      go (RecordCon _ v fs) =         mapFor emRecordCon >=> mMatch env (unLoc v) >=> mMatch env (rec_flds fs)-#endif       go (RecordUpd _ e' fs) =         mapFor emRecordUpd >=> mMatch env e' >=> mMatch env (fieldsToRdrNamesUpd 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-#if __GLASGOW_HASKELL__ < 904-      go (HsLet _ lbs e') =-#else+#if __GLASGOW_HASKELL__ < 912       go (HsLet _ _ lbs _ e') =+#else+      go (HsLet _ lbs e') = #endif         let           bs = collectLocalBinders CollNoDictBinders lbs@@ -534,15 +513,61 @@  ------------------------------------------------------------------------ +#if __GLASGOW_HASKELL__ < 912+#else+data LVMap a+  = EmptyLVMap+  | LVMap+      { lvmSingle :: MaybeMap a+      , lvmCase :: MaybeMap a+      , lvmCases :: MaybeMap a+      }+  deriving (Functor)++instance PatternMap LVMap where+  type Key LVMap = HsLamVariant++  mEmpty :: LVMap a+  mEmpty = EmptyLVMap++  mUnion :: LVMap a -> LVMap a -> LVMap a+  mUnion EmptyLVMap m = m+  mUnion m EmptyLVMap = m+  mUnion m1 m2 = LVMap+    { lvmSingle = unionOn lvmSingle m1 m2+    , lvmCase = unionOn lvmCase m1 m2+    , lvmCases = unionOn lvmCases m1 m2+    }++  mAlter+    :: AlphaEnv -> Quantifiers -> Key LVMap -> A a -> LVMap a -> LVMap a+  mAlter env qs lv f EmptyLVMap = mAlter env qs lv f (LVMap mEmpty mEmpty mEmpty)+  mAlter env qs lv f m@LVMap{} = go lv+    where+      go LamSingle = m { lvmSingle = mAlter env qs () f (lvmSingle m) }+      go LamCase = m { lvmCase = mAlter env qs () f (lvmCase m) }+      go LamCases = m { lvmCases = mAlter env qs () f (lvmCases m) }++  mMatch+    :: MatchEnv+    -> Key LVMap+    -> (Substitution, LVMap a)+    -> [(Substitution, a)]+  mMatch _ _ (_, EmptyLVMap) = []+  mMatch env lv hs@(_, LVMap{}) = go lv hs+    where+      go LamSingle = mapFor lvmSingle >=> mMatch env ()+      go LamCase = mapFor lvmCase >=> mMatch env ()+      go LamCases = mapFor lvmCases >=> mMatch env ()+#endif++------------------------------------------------------------------------+ data SCMap a   = SCEmpty   | SCM { scmListComp :: MaybeMap a         , scmMonadComp :: MaybeMap a-#if __GLASGOW_HASKELL__ < 900-        , scmDoExpr :: MaybeMap a-#else         , scmDoExpr :: FSEnv a -- We use empty string when modulename is Nothing-#endif         -- TODO: the rest         }   deriving (Functor)@@ -551,15 +576,7 @@ emptySCMapWrapper = SCM mEmpty mEmpty mEmpty  instance PatternMap SCMap where-#if __GLASGOW_HASKELL__ < 900-  type Key SCMap = HsStmtContext Name -- see comment on HsDo in GHC-#elif __GLASGOW_HASKELL__ < 902-  type Key SCMap = HsStmtContext GhcRn-#elif __GLASGOW_HASKELL__ < 904-  type Key SCMap = HsStmtContext (HsDoRn GhcPs)-#else   type Key SCMap = HsDoFlavour-#endif    mEmpty :: SCMap a   mEmpty = SCEmpty@@ -579,18 +596,8 @@     where       go ListComp = m { scmListComp = mAlter env vs () f (scmListComp m) }       go MonadComp = m { scmMonadComp = mAlter env vs () f (scmMonadComp m) }-#if __GLASGOW_HASKELL__ < 900-      go DoExpr = m { scmDoExpr = mAlter env vs () f (scmDoExpr m) }-#else       go (DoExpr mname) = m { scmDoExpr = mAlter env vs (maybe "" moduleNameFS mname) f (scmDoExpr m) }-#endif       go MDoExpr{} = missingSyntax "MDoExpr"-#if __GLASGOW_HASKELL__ < 904-      go ArrowExpr = missingSyntax "ArrowExpr"-      go (PatGuard _) = missingSyntax "PatGuard"-      go (ParStmtCtxt _) = missingSyntax "ParStmtCtxt"-      go (TransStmtCtxt _) = missingSyntax "TransStmtCtxt"-#endif       go GhciStmtCtxt = missingSyntax "GhciStmtCtxt"    mMatch :: MatchEnv -> Key SCMap -> (Substitution, SCMap a) -> [(Substitution, a)]@@ -599,11 +606,7 @@     where       go ListComp = mapFor scmListComp >=> mMatch env ()       go MonadComp = mapFor scmMonadComp >=> mMatch env ()-#if __GLASGOW_HASKELL__ < 900-      go DoExpr = mapFor scmDoExpr >=> mMatch env ()-#else       go (DoExpr mname) = mapFor scmDoExpr >=> mMatch env (maybe "" moduleNameFS mname)-#endif       go _ = const [] -- TODO  ------------------------------------------------------------------------@@ -648,17 +651,18 @@    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 CollNoDictBinders lpats-        env' = foldr extendAlphaEnvInternal env pbs-        vs' = vs `exceptQ` pbs+    let+      lpats = getMatchPats match+      pbs = collectPatsBinders CollNoDictBinders 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+      lpats = getMatchPats match       pbs = collectPatsBinders CollNoDictBinders lpats       env' = extendMatchEnv env pbs @@ -676,14 +680,10 @@ emptyCDMapWrapper = CDMap mEmpty mEmpty  instance PatternMap CDMap where-#if __GLASGOW_HASKELL__ < 810-  type Key CDMap = HsConDetails (LPat GhcPs) (HsRecFields GhcPs (LPat GhcPs))-#elif __GLASGOW_HASKELL__ < 906-  -- We must manually expand 'LPat' to avoid UndecidableInstances in GHC 8.10+-  type Key CDMap = HsConDetails (HsPatSigType GhcPs) (LocatedA (Pat GhcPs)) (HsRecFields GhcPs (LocatedA (Pat GhcPs)))-  -- type HsConPatDetails p = HsConDetails (HsPatSigType (NoGhcTc p)) (LPat p) (HsRecFields p (LPat p))-#else+#if __GLASGOW_HASKELL__ < 914   type Key CDMap = HsConDetails (HsConPatTyArg GhcPs) (LocatedA (Pat GhcPs)) (HsRecFields GhcPs (LocatedA (Pat GhcPs)))+#else+  type Key CDMap = HsConDetails (LocatedA (Pat GhcPs)) (HsRecFields GhcPs (LocatedA (Pat GhcPs))) #endif    mEmpty :: CDMap a@@ -701,7 +701,12 @@   mAlter env vs d f CDEmpty   = mAlter env vs d f emptyCDMapWrapper   mAlter env vs d f m@CDMap{} = go d     where-      go (PrefixCon tyargs ps) = m { cdPrefixCon = mAlter env vs ps f (cdPrefixCon m) }+#if __GLASGOW_HASKELL__ < 914+      -- TODO(xich): properly handle tyargs here!+      go (PrefixCon _tyargs ps) = m { cdPrefixCon = mAlter env vs ps f (cdPrefixCon m) }+#else+      go (PrefixCon ps) = m { cdPrefixCon = mAlter env vs (dropInvisPats ps) f (cdPrefixCon m) }+#endif       go (RecCon _) = missingSyntax "RecCon"       go (InfixCon p1 p2) = m { cdInfixCon = mAlter env vs p1                                               (toA (mAlter env vs p2 f))@@ -711,7 +716,12 @@   mMatch _   _ (_ ,CDEmpty)   = []   mMatch env d (hs,m@CDMap{}) = go d (hs,m)     where-      go (PrefixCon tyargs ps) = mapFor cdPrefixCon >=> mMatch env ps+#if __GLASGOW_HASKELL__ < 914+      -- TODO(xich): properly handle tyargs here!+      go (PrefixCon _tyargs ps) = mapFor cdPrefixCon >=> mMatch env ps+#else+      go (PrefixCon ps) = mapFor cdPrefixCon >=> mMatch env (dropInvisPats ps)+#endif       go (InfixCon p1 p2) = mapFor cdInfixCon >=> mMatch env p1 >=> mMatch env p2       go _ = const [] -- TODO @@ -737,12 +747,8 @@ emptyPatMapWrapper = PatMap mEmpty mEmpty mEmpty mEmpty mEmpty mEmpty  instance PatternMap PatMap where-#if __GLASGOW_HASKELL__ < 810-  type Key PatMap = LPat GhcPs-#else   -- We must manually expand 'LPat' to avoid UndecidableInstances in GHC 8.10+   type Key PatMap = LocatedA (Pat GhcPs)-#endif    mEmpty :: PatMap a   mEmpty = PatEmpty@@ -771,29 +777,28 @@       go AsPat{} = missingSyntax "AsPat"       go BangPat{} = missingSyntax "BangPat"       go ListPat{} = missingSyntax "ListPat"-#if __GLASGOW_HASKELL__ < 900-      go XPat{} = missingSyntax "XPat"-      go CoPat{} = missingSyntax "CoPat"-      go ConPatOut{} = missingSyntax "ConPatOut"-      go (ConPatIn c d) =-#else       go (ConPat _ c d) =-#endif         m { pmConPatIn = mAlter env vs (rdrFS (unLoc c)) (toA (mAlter env vs d f)) (pmConPatIn m) }       go ViewPat{} = missingSyntax "ViewPat"       go SplicePat{} = missingSyntax "SplicePat"       go LitPat{} = missingSyntax "LitPat"       go NPat{} = missingSyntax "NPat"       go NPlusKPat{} = missingSyntax "NPlusKPat"-#if __GLASGOW_HASKELL__ < 904-      go (ParPat _ p) = m { pmParPat = mAlter env vs p f (pmParPat m) }-#else+#if __GLASGOW_HASKELL__ < 912       go (ParPat _ _ p _) = m { pmParPat = mAlter env vs p f (pmParPat m) }+#else+      go (ParPat _ p) = m { pmParPat = mAlter env vs p f (pmParPat m) } #endif       go (TuplePat _ ps b) =         m { pmTuplePat = mAlter env vs b (toA (mAlter env vs ps f)) (pmTuplePat m) }       go SigPat{} = missingSyntax "SigPat"       go SumPat{} = missingSyntax "SumPat"+#if __GLASGOW_HASKELL__ < 912+#else+      go OrPat{} = missingSyntax "OrPat"+      go EmbTyPat{} = missingSyntax "EmbTyPat"+      go InvisPat{} = missingSyntax "InvisPat"+#endif    mMatch :: MatchEnv -> Key PatMap -> (Substitution, PatMap a) -> [(Substitution, a)]   mMatch _   _   (_, PatEmpty)   = []@@ -804,18 +809,14 @@       hss lp = extendResult (pmHole m) (HolePat $ mePruneA env lp) hs        go (WildPat _) = mapFor pmWild >=> mMatch env ()-#if __GLASGOW_HASKELL__ < 904-      go (ParPat _ p) = mapFor pmParPat >=> mMatch env p-#else+#if __GLASGOW_HASKELL__ < 912       go (ParPat _ _ p _) = mapFor pmParPat >=> mMatch env p+#else+      go (ParPat _ p) = mapFor pmParPat >=> mMatch env p #endif       go (TuplePat _ ps b) = mapFor pmTuplePat >=> mMatch env b >=> mMatch env ps       go (VarPat _ _) = mapFor pmVar >=> mMatch env ()-#if __GLASGOW_HASKELL__ < 900-      go (ConPatIn c d) =-#else       go (ConPat _ c d) =-#endif         mapFor pmConPatIn >=> mMatch env (rdrFS (unLoc c)) >=> mMatch env d       go _ = const [] -- TODO @@ -840,11 +841,11 @@         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)+                  (toA (mAlter env' vs' (map unLoc $ grhssList 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)+                      >=> mMatch env' (map unLoc $ grhssList grhss)     where       lbs = grhssLocalBinds  grhss       bs = collectLocalBinders CollNoDictBinders lbs@@ -865,9 +866,6 @@   mUnion (GRHSMap m1) (GRHSMap m2) = GRHSMap (mUnion m1 m2)    mAlter :: AlphaEnv -> Quantifiers -> Key GRHSMap -> A a -> GRHSMap a -> GRHSMap a-#if __GLASGOW_HASKELL__ < 900-  mAlter _ _ XGRHS{} _ _ = missingSyntax "XGRHS"-#endif   mAlter env vs (GRHS _ gs b) f (GRHSMap m) =     let bs = collectLStmtsBinders CollNoDictBinders gs         env' = foldr extendAlphaEnvInternal env bs@@ -875,9 +873,6 @@     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__ < 900-  mMatch _ XGRHS{} = const []-#endif   mMatch env (GRHS _ gs b) =     mapFor unGRHSMap >=> mMatch env gs >=> mMatch env' b     where@@ -969,9 +964,6 @@   mAlter env vs lbs f m@LB{}  = go lbs     where       go (EmptyLocalBinds _) = m { lbEmpty = mAlter env vs () f (lbEmpty m) }-#if __GLASGOW_HASKELL__ < 900-      go XHsLocalBindsLR{} = missingSyntax "XHsLocalBindsLR"-#endif       go (HsValBinds _ vbs) =         let           bs = collectHsValBinders CollNoDictBinders vbs@@ -993,7 +985,11 @@       go _ = const [] -- TODO  deValBinds :: HsValBinds GhcPs -> [HsBind GhcPs]+#if __GLASGOW_HASKELL__ < 912 deValBinds (ValBinds _ lbs _) = map unLoc (bagToList lbs)+#else+deValBinds (ValBinds _ lbs _) = map unLoc lbs+#endif deValBinds _ = error "deValBinds ValBindsOut"  ------------------------------------------------------------------------@@ -1033,33 +1029,19 @@   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__ < 900-      go XHsBindsLR{} = missingSyntax "XHsBindsLR"-      go (FunBind _ _ mg _ _) = m { bmFunBind = mAlter env vs mg f (bmFunBind m) }-      go (VarBind _ _ e _) = m { bmVarBind = mAlter env vs e f (bmVarBind m) }-#else       go (FunBind{fun_matches = mg}) = m { bmFunBind = mAlter env vs mg f (bmFunBind m) }       go (VarBind _ _ e) = m { bmVarBind = mAlter env vs e f (bmVarBind m) }-#endif       go (PatBind{pat_lhs=lhs, pat_rhs=rhs}) =         m { bmPatBind = mAlter env vs lhs               (toA $ mAlter env vs rhs f) (bmPatBind m) }-#if __GLASGOW_HASKELL__ < 904-      go AbsBinds{} = missingSyntax "AbsBinds"-#endif       go PatSynBind{} = missingSyntax "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__ < 900-      go (FunBind _ _ mg _ _) = mapFor bmFunBind >=> mMatch env mg-      go (VarBind _ _ e _) = mapFor bmVarBind >=> mMatch env e-#else       go (FunBind{fun_matches = mg}) = mapFor bmFunBind >=> mMatch env mg       go (VarBind _ _ e) = mapFor bmVarBind >=> mMatch env e-#endif       go (PatBind{pat_lhs=lhs, pat_rhs=rhs})         = mapFor bmPatBind >=> mMatch env lhs >=> mMatch env rhs       go _ = const [] -- TODO@@ -1099,12 +1081,7 @@     where       go (BodyStmt _ e _ _) = m { smBodyStmt = mAlter env vs e f (smBodyStmt m) }       go (LastStmt _ e _ _)   = m { smLastStmt = mAlter env vs e f (smLastStmt m) }-#if __GLASGOW_HASKELL__ < 900-      go XStmtLR{} = missingSyntax "XStmtLR"-      go (BindStmt _ p e _ _) =-#else       go (BindStmt _ p e) =-#endif         let bs = collectPatBinders CollNoDictBinders p             env' = foldr extendAlphaEnvInternal env bs             vs' = vs `exceptQ` bs@@ -1114,7 +1091,9 @@       go ParStmt{} = missingSyntax "ParStmt"       go TransStmt{} = missingSyntax "TransStmt"       go RecStmt{} = missingSyntax "RecStmt"+#if __GLASGOW_HASKELL__ < 912       go ApplicativeStmt{} = missingSyntax "ApplicativeStmt"+#endif    mMatch :: MatchEnv -> Key SMap -> (Substitution, SMap a) -> [(Substitution, a)]   mMatch _   _   (_,SMEmpty) = []@@ -1122,11 +1101,7 @@     where       go (BodyStmt _ e _ _) = mapFor smBodyStmt >=> mMatch env e       go (LastStmt _ e _ _) = mapFor smLastStmt >=> mMatch env e-#if __GLASGOW_HASKELL__ < 900-      go (BindStmt _ p e _ _) =-#else       go (BindStmt _ p e) =-#endif         let bs = collectPatBinders CollNoDictBinders p             env' = extendMatchEnv env bs         in mapFor smBindStmt >=> mMatch env p >=> mMatch env' e@@ -1139,11 +1114,7 @@   | TM { tyHole    :: Map RdrName a -- See Note [Holes]        , tyHsTyVar :: VMap a        , tyHsAppTy :: TyMap (TyMap a)-#if __GLASGOW_HASKELL__ < 810-       , tyHsForAllTy :: ForAllTyMap a -- See Note [Telescope]-#else        , tyHsForAllTy :: ForallVisMap (ForAllTyMap a) -- See Note [Telescope]-#endif        , tyHsFunTy :: TyMap (TyMap a)        , tyHsListTy :: TyMap a        , tyHsParTy :: TyMap a@@ -1194,31 +1165,18 @@       go HsKindSig{} = missingSyntax "HsKindSig"       go HsSpliceTy{} = missingSyntax "HsSpliceTy"       go HsDocTy{} = missingSyntax "HsDocTy"+#if __GLASGOW_HASKELL__ < 914       go HsBangTy{} = missingSyntax "HsBangTy"       go HsRecTy{} = missingSyntax "HsRecTy"+#endif       go (HsAppTy _ ty1 ty2) = m { tyHsAppTy = mAlter env vs ty1 (toA (mAlter env vs ty2 f)) (tyHsAppTy m) }-#if __GLASGOW_HASKELL__ < 810-      go (HsForAllTy _ bndrs ty') = m { tyHsForAllTy = mAlter env vs (map extractBinderInfo bndrs, ty') f (tyHsForAllTy m) }-#elif __GLASGOW_HASKELL__ < 900-      go (HsForAllTy _ vis bndrs ty') =-        m { tyHsForAllTy = mAlter env vs (vis == ForallVis) (toA (mAlter env vs (map extractBinderInfo bndrs, ty') f)) (tyHsForAllTy m) }-#else       go (HsForAllTy _ vis ty') | (isVisible, bndrs) <- splitVisBinders vis =         m { tyHsForAllTy = mAlter env vs isVisible (toA (mAlter env vs (bndrs, ty') f)) (tyHsForAllTy m) }-#endif-#if __GLASGOW_HASKELL__ < 900-      go (HsFunTy _ ty1 ty2) = m { tyHsFunTy = mAlter env vs ty1 (toA (mAlter env vs ty2 f)) (tyHsFunTy m) }-#else       go (HsFunTy _ _ ty1 ty2) = m { tyHsFunTy = mAlter env vs ty1 (toA (mAlter env vs ty2 f)) (tyHsFunTy m) }-#endif       go (HsListTy _ ty') = m { tyHsListTy = mAlter env vs ty' f (tyHsListTy m) }       go (HsParTy _ ty') = m { tyHsParTy = mAlter env vs ty' f (tyHsParTy m) }       go (HsQualTy _ cons ty') =-#if __GLASGOW_HASKELL__ < 904-        m { tyHsQualTy = mAlter env vs ty' (toA (mAlter env vs (fromMaybeContext cons) f)) (tyHsQualTy m) }-#else         m { tyHsQualTy = mAlter env vs ty' (toA (mAlter env vs (fromMaybeContext (Just cons)) f)) (tyHsQualTy m) }-#endif       go HsStarTy{} = missingSyntax "HsStarTy"       go (HsSumTy _ tys) = m { tyHsSumTy = mAlter env vs tys f (tyHsSumTy m) }       go (HsTupleTy _ ts tys) =@@ -1238,40 +1196,17 @@       hss = extendResult (tyHole m) (HoleType $ mePruneA env ty) hs        go (HsAppTy _ ty1 ty2) = mapFor tyHsAppTy >=> mMatch env ty1 >=> mMatch env ty2-#if __GLASGOW_HASKELL__ < 810-      go (HsForAllTy _ bndrs ty') = mapFor tyHsForAllTy >=> mMatch env (map extractBinderInfo bndrs, ty')-#elif __GLASGOW_HASKELL__ < 900-      go (HsForAllTy _ vis bndrs ty') =-        mapFor tyHsForAllTy >=> mMatch env (vis == ForallVis) >=> mMatch env (map extractBinderInfo bndrs, ty')-#else       go (HsForAllTy _ telescope ty') | (isVisible, bndrs) <- splitVisBinders telescope =         mapFor tyHsForAllTy >=> mMatch env isVisible >=> mMatch env (bndrs, ty')-#endif-#if __GLASGOW_HASKELL__ < 900-      go (HsFunTy _ ty1 ty2) = mapFor tyHsFunTy >=> mMatch env ty1 >=> mMatch env ty2-#else       go (HsFunTy _ _ ty1 ty2) = mapFor tyHsFunTy >=> mMatch env ty1 >=> mMatch env ty2-#endif       go (HsListTy _ ty') = mapFor tyHsListTy >=> mMatch env ty'       go (HsParTy _ ty') = mapFor tyHsParTy >=> mMatch env ty'-#if __GLASGOW_HASKELL__ < 904-      go (HsQualTy _ cons ty') = mapFor tyHsQualTy >=> mMatch env ty' >=> mMatch env (fromMaybeContext cons)-#else       go (HsQualTy _ cons ty') = mapFor tyHsQualTy >=> mMatch env ty' >=> mMatch env (fromMaybeContext (Just cons))-#endif       go (HsSumTy _ tys) = mapFor tyHsSumTy >=> mMatch env tys       go (HsTupleTy _ ts tys) = mapFor tyHsTupleTy >=> mMatch env ts >=> mMatch env tys       go (HsTyVar _ _ v) = mapFor tyHsTyVar >=> mMatch env (unLoc v)       go _                  = const [] -- TODO -#if __GLASGOW_HASKELL__ < 900-extractBinderInfo :: LHsTyVarBndr GhcPs -> (RdrName, Maybe (LHsKind GhcPs))-extractBinderInfo = go . unLoc-  where-    go (UserTyVar _ v) = (unLoc v, Nothing)-    go (KindedTyVar _ v k) = (unLoc v, Just k)-    go XTyVarBndr{} = missingSyntax "XTyVarBndr"-#else splitVisBinders :: HsForAllTelescope GhcPs -> (Bool, [(RdrName, Maybe (LHsKind GhcPs))]) splitVisBinders HsForAllVis{..} = (True, map extractBinderInfo hsf_vis_bndrs) splitVisBinders HsForAllInvis{..} = (False, map extractBinderInfo hsf_invis_bndrs)@@ -1279,8 +1214,19 @@ extractBinderInfo :: LHsTyVarBndr flag GhcPs -> (RdrName, Maybe (LHsKind GhcPs)) extractBinderInfo = go . unLoc   where+#if __GLASGOW_HASKELL__ < 912     go (UserTyVar _ _ v) = (unLoc v, Nothing)     go (KindedTyVar _ _ v k) = (unLoc v, Just k)+    go (XTyVarBndr _) = missingSyntax "XTyVarBndr"+#else+    go HsTvb{..} =+      case tvb_var of+        HsBndrVar _ rdr ->+            case tvb_kind of+              HsBndrKind _ lkind -> (unLoc rdr, Just lkind)+              _ -> (unLoc rdr, Nothing)+        HsBndrWildCard _ -> missingSyntax "HsBndrWildCard"+        XBndrVar _ -> missingSyntax "XBndrVar"     go XTyVarBndr{} = missingSyntax "XTyVarBndr" #endif @@ -1290,11 +1236,7 @@   deriving (Functor)  instance PatternMap RFMap where-#if __GLASGOW_HASKELL__ < 904-  type Key RFMap = LocatedA (HsRecField' RdrName (LocatedA (HsExpr GhcPs)))-#else   type Key RFMap = LocatedA (HsRecField GhcPs (LocatedA (HsExpr GhcPs)))-#endif    mEmpty :: RFMap a   mEmpty = RFM mEmpty@@ -1305,24 +1247,14 @@   mAlter :: AlphaEnv -> Quantifiers -> Key RFMap -> A a -> RFMap a -> RFMap a   mAlter env vs lf f m = go (unLoc lf)     where-#if __GLASGOW_HASKELL__ < 904-      go (HsRecField _ lbl arg _pun) =-        m { rfmField = mAlter env vs (unLoc lbl) (toA (mAlter env vs arg f)) (rfmField m) }-#else       go (HsFieldBind _ lbl arg _pun) =         m { rfmField = mAlter env vs (unLoc (foLabel (unLoc lbl))) (toA (mAlter env vs arg f)) (rfmField m) }-#endif    mMatch :: MatchEnv -> Key RFMap -> (Substitution, RFMap a) -> [(Substitution, a)]   mMatch env lf (hs,m) = go (unLoc lf) (hs,m)     where-#if __GLASGOW_HASKELL__ < 904-      go (HsRecField _ lbl arg _pun) =-        mapFor rfmField >=> mMatch env (unLoc lbl) >=> mMatch env arg-#else       go (HsFieldBind _ lbl arg _pun) =         mapFor rfmField >=> mMatch env (unLoc (foLabel (unLoc lbl))) >=> mMatch env arg-#endif  -- Helper class to collapse the complex encoding of record fields into RdrNames. -- (The complexity is to support punning/duplicate/overlapping fields, which@@ -1330,59 +1262,33 @@ class RecordFieldToRdrName f where   recordFieldToRdrName :: f -> RdrName +#if __GLASGOW_HASKELL__ < 912 instance RecordFieldToRdrName (AmbiguousFieldOcc GhcPs) where #if __GLASGOW_HASKELL__ < 908   recordFieldToRdrName = rdrNameAmbiguousFieldOcc #else   recordFieldToRdrName = ambiguousFieldOccRdrName #endif+#endif -#if __GLASGOW_HASKELL__ < 904-instance RecordFieldToRdrName (FieldOcc p) where-  recordFieldToRdrName = unLoc . rdrNameFieldOcc-#else instance RecordFieldToRdrName (FieldOcc GhcPs) where   recordFieldToRdrName = unLoc . foLabel-#endif  instance RecordFieldToRdrName (FieldLabelStrings GhcPs) where-  recordFieldToRdrName = error "TBD"+  recordFieldToRdrName =+    error "recordFieldToRdrName FieldLabelStrings: unimplemented" -#if __GLASGOW_HASKELL__ < 904--- Either [LHsRecUpdField GhcPs] [LHsRecUpdProj GhcPs]-fieldsToRdrNamesUpd-  :: Either [LHsRecUpdField GhcPs] [LHsRecUpdProj GhcPs]-  -> [LHsRecField' GhcPs RdrName (LHsExpr GhcPs)]-fieldsToRdrNamesUpd (Left fs) = map go fs-  where-    go (L l (HsRecField a (L l2 f) arg pun)) =-      L l (HsRecField a (L l2 (recordFieldToRdrName f)) arg pun)-fieldsToRdrNamesUpd (Right fs) = map go fs-  where-    go (L l (HsRecField a (L l2 f) arg pun)) =-      L l (HsRecField a (L l2 (recordFieldToRdrName f)) arg pun)-#elif __GLASGOW_HASKELL__ < 908+#if __GLASGOW_HASKELL__ < 912+#if __GLASGOW_HASKELL__ < 908 fieldsToRdrNamesUpd :: Either [LHsRecUpdField GhcPs] [LHsRecUpdProj GhcPs]   -> [LHsRecField GhcPs (LHsExpr GhcPs)]-fieldsToRdrNamesUpd (Left xs) = map go xs-  where-    go (L l (HsFieldBind a (L l2 f) arg pun)) =-      let lrdrName = case f of-            Unambiguous _ n -> n-            Ambiguous _ n -> n-            XAmbiguousFieldOcc{} -> error "XAmbiguousFieldOcc"-          f' = FieldOcc NoExtField lrdrName-       in L l (HsFieldBind a (L l2 f') arg pun)-fieldsToRdrNamesUpd (Right xs) = map go xs-  where-    go (L l (HsFieldBind a (L l2 _f) arg pun)) =-      let lrdrName = error "TBD" -- same as GHC 9.2-          f' = FieldOcc NoExtField lrdrName-       in L l (HsFieldBind a (L l2 f') arg pun)+fieldsToRdrNamesUpd (Left xs) = #else fieldsToRdrNamesUpd :: LHsRecUpdFields GhcPs   -> [LHsRecField GhcPs (LHsExpr GhcPs)]-fieldsToRdrNamesUpd (RegularRecUpdFields _ xs) = map go xs+fieldsToRdrNamesUpd (RegularRecUpdFields _ xs) =+#endif+  map go xs   where     go (L l (HsFieldBind a (L l2 f) arg pun)) =       let lrdrName = case f of@@ -1391,23 +1297,23 @@             XAmbiguousFieldOcc{} -> error "XAmbiguousFieldOcc"           f' = FieldOcc NoExtField lrdrName        in L l (HsFieldBind a (L l2 f') arg pun)-fieldsToRdrNamesUpd (OverloadedRecUpdFields _ xs) = map go xs+#if __GLASGOW_HASKELL__ < 908+fieldsToRdrNamesUpd (Right xs) =+#else+fieldsToRdrNamesUpd (OverloadedRecUpdFields _ xs) =+#endif+  map go xs   where     go (L l (HsFieldBind a (L l2 _f) arg pun)) =       let lrdrName = error "TBD" -- same as GHC 9.2           f' = FieldOcc NoExtField lrdrName        in L l (HsFieldBind a (L l2 f') arg pun)-#endif--#if __GLASGOW_HASKELL__ < 904-fieldsToRdrNames-  :: RecordFieldToRdrName f-  => [LHsRecField' GhcPs f arg]-  -> [LHsRecField' GhcPs RdrName arg]-fieldsToRdrNames = map go-  where-    go (L l (HsRecField a (L l2 f) arg pun)) =-      L l (HsRecField a (L l2 (recordFieldToRdrName f)) arg pun)+#else+-- GHC 9.12+fieldsToRdrNamesUpd :: LHsRecUpdFields GhcPs+  -> [LHsRecField GhcPs (LHsExpr GhcPs)]+fieldsToRdrNamesUpd RegularRecUpdFields{..} = recUpdFields+fieldsToRdrNamesUpd OverloadedRecUpdFields{} = error "fieldsToRdrNamesUpd: OverloadedRecUpdFields unsupported!" #endif  ------------------------------------------------------------------------@@ -1496,8 +1402,6 @@     where       env' = extendMatchEnv env [v] -#if __GLASGOW_HASKELL__ < 810-#else newtype ForallVisMap a = ForallVisMap { favBoolMap :: BoolMap a }   deriving (Functor) @@ -1515,4 +1419,3 @@    mMatch :: MatchEnv -> Key ForallVisMap -> (Substitution, ForallVisMap a) -> [(Substitution, a)]   mMatch env b = mapFor favBoolMap >=> mMatch env b-#endif

@@ -1,9 +1,9 @@--- Copyright (c) Facebook, Inc. and its affiliates.+-- Copyright (c) 2025 Andrew Farmer+-- Copyright (c) 2020-2024 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 #-} module Retrie.Pretty   ( noColor   , addColor@@ -38,11 +38,7 @@ ppSrcSpan :: ColoriseFun -> SrcSpan -> String ppSrcSpan colorise spn = case srcSpanStart spn of   UnhelpfulLoc x -> unpackFS x-#if __GLASGOW_HASKELL__ < 900-  RealSrcLoc loc -> intercalate (colorise Dull Cyan ":")-#else   RealSrcLoc loc _ -> intercalate (colorise Dull Cyan ":")-#endif     [ colorise Dull Magenta $ unpackFS $ srcLocFile loc     , colorise Dull Green $ show $ srcLocLine loc     , colorise Dull Green $ show $ srcLocCol loc

@@ -1,4 +1,5 @@--- Copyright (c) Facebook, Inc. and its affiliates.+-- Copyright (c) 2025 Andrew Farmer+-- Copyright (c) 2020-2024 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.

@@ -1,4 +1,5 @@--- Copyright (c) Facebook, Inc. and its affiliates.+-- Copyright (c) 2025 Andrew Farmer+-- Copyright (c) 2020-2024 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.

@@ -1,4 +1,5 @@--- Copyright (c) Facebook, Inc. and its affiliates.+-- Copyright (c) 2025 Andrew Farmer+-- Copyright (c) 2020-2024 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.@@ -16,6 +17,7 @@ import Control.Monad.Trans.Class import Control.Monad.Writer.Strict import Data.Char (isSpace)+import Data.List (intercalate, isSuffixOf) import Data.Generics  import Retrie.ExactPrint@@ -25,7 +27,6 @@ import Retrie.Subst import Retrie.Types import Retrie.Universe-import Retrie.Util  ------------------------------------------------------------------------ @@ -80,19 +81,16 @@       t' <- graftA tTemplate       -- substitute for quantifiers in grafted template       r <- subst sub c t'-      -- copy appropriate annotations from old expression to template-      r0 <- addAllAnnsT e r       -- add parens to template if needed-      res' <- (mkM (parenify c) `extM` parenifyT c `extM` parenifyP c) r0-      -- Make sure the replacement has the same anchor as the thing-      -- being replaced-      let res = transferAnchor e res'--      -- prune the resulting expression and log it with location-      orig <- printNoLeadingSpaces <$> pruneA e-      -- orig <- printA' <$> pruneA e+      r' <- (mkM (parenify c) `extM` parenifyT c `extM` parenifyP c) r+      -- copy appropriate annotations from old expression to template+      res <- transferEntryAnnsT e r' -      repl <- printNoLeadingSpaces <$> pruneA res+      -- 'getLocA' excludes e's trailing anns and comments, so strip+      -- them from the original. print the template without its trailing+      -- anns+      orig <- printNoLeadingSpaces <$> pruneA (stripOuterAnns e)+      repl <- reindentAt (getLocA e) <$> pruneA r'       -- repl <- printA' <$> pruneA r       -- repl <- printA' <$> pruneA res       -- repl <- return $ showAst t'@@ -102,14 +100,14 @@        -- lift $ liftIO $ debugPrint Loud "replaceImpl:e="  [showAst e]       -- lift $ liftIO $ debugPrint Loud "replaceImpl:r="  [showAst r]-      -- lift $ liftIO $ debugPrint Loud "replaceImpl:r0="  [showAst r0]+      -- lift $ liftIO $ debugPrint Loud "replaceImpl:r'="  [showAst r']       -- lift $ liftIO $ debugPrint Loud "replaceImpl:t'=" [showAst t']       -- lift $ liftIO $ debugPrint Loud "replaceImpl:res=" [showAst res]        let replacement = Replacement (getLocA e) orig repl       TransformT $ lift $ tell $ Change [replacement] [tImports]       -- make the actual replacement-      return res'+      return res   -- | Records a replacement made. In cases where we cannot use ghc-exactprint@@ -126,14 +124,13 @@ data Change = NoChange | Change [Replacement] [AnnotatedImports]  instance Semigroup Change where-  (<>) = mappend+  NoChange         <> other            = other+  other            <> NoChange         = other+  (Change rs1 is1) <> (Change rs2 is2) =+    Change (rs1 <> rs2) (is1 <> is2)  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)  -- 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@@ -144,3 +141,21 @@ -- drop leading spaces like this. printNoLeadingSpaces :: (Data k, ExactPrint k) => Annotated k -> String printNoLeadingSpaces = dropWhile isSpace . printA++-- | Print a replacement that will be spliced in as text starting at the given+-- location. Continuation lines are shifted by however far the first token+-- moves, so they keep their position relative to it (and thus any layout+-- blocks opened on the first line stay aligned).+reindentAt :: (Data k, ExactPrint k) => SrcSpan -> Annotated k -> String+reindentAt loc a = case (lines rest, srcSpanStartCol <$> getRealSpan loc) of+  (l:ls, Just c1) | shift <- c1 - s, shift /= 0 ->+    intercalate "\n" (l : map (reindent shift) ls) ++ trailingNl+  _ -> rest+  where+    (lead, rest) = span isSpace (printA a)+    s = 1 + length (takeWhile (/= '\n') (reverse lead))+    trailingNl = if "\n" `isSuffixOf` rest then "\n" else ""+    reindent n ln+      | all isSpace ln = ln+      | n > 0 = replicate n ' ' ++ ln+      | otherwise = drop (min (negate n) (length (takeWhile (== ' ') ln))) ln

@@ -1,10 +1,10 @@ {-# LANGUAGE RecordWildCards #-}--- Copyright (c) Facebook, Inc. and its affiliates.+-- Copyright (c) 2025 Andrew Farmer+-- Copyright (c) 2020-2024 Facebook, Inc. and its affiliates. -- -- This source code is licensed under the MIT license found in the -- LICENSE file in the root directory of this source tree. ---{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Retrie.Rewrites   ( RewriteSpec(..)@@ -17,7 +17,6 @@ import Control.Exception import qualified Data.Map as Map import Data.Maybe-import Data.Data hiding (Fixity) import qualified Data.Text as Text import Data.Traversable import System.FilePath@@ -25,18 +24,13 @@ import Retrie.CPP import Retrie.ExactPrint import Retrie.Fixity-#if __GLASGOW_HASKELL__ < 904 import Retrie.GHC-#else-import Retrie.GHC hiding (Pattern)-#endif import Retrie.Rewrites.Function import Retrie.Rewrites.Patterns import Retrie.Rewrites.Rules import Retrie.Rewrites.Types import Retrie.Types import Retrie.Universe-import Retrie.Util  -- | A qualified name. (e.g. @"Module.Name.functionName"@) type QualifiedName = String@@ -169,10 +163,6 @@       ]  -showCpp :: (Data ast, ExactPrint ast) => CPP (Annotated ast) -> String-showCpp (NoCPP c) = showAstA c-showCpp (CPP{}) = "CPP{}"- parseAdhocTypes :: LibDir -> FixityEnv -> [String] -> IO [Rewrite Universe] parseAdhocTypes _ _ [] = return [] parseAdhocTypes libdir fixities tySyns = do@@ -233,21 +223,13 @@   -> FileBasedTy   -> [(FastString, Direction)]   -> AnnotatedModule-#if __GLASGOW_HASKELL__ < 900-  -> IO (UniqFM [Rewrite Universe])-#else   -> IO (UniqFM FastString [Rewrite Universe])-#endif tyBuilder libdir FoldUnfold specs am = promote <$> dfnsToRewrites libdir specs am tyBuilder _libdir Rule specs am = promote <$> rulesToRewrites specs am tyBuilder _libdir Type specs am = promote <$> typeSynonymsToRewrites specs am tyBuilder libdir Pattern specs am = patternSynonymsToRewrites libdir specs am -#if __GLASGOW_HASKELL__ < 900-promote :: Matchable a => UniqFM [Rewrite a] -> UniqFM [Rewrite Universe]-#else promote :: Matchable a => UniqFM k [Rewrite a] -> UniqFM k [Rewrite Universe]-#endif promote = fmap (map toURewrite)  parseQualified :: String -> Either String (FilePath, FastString)

@@ -1,4 +1,5 @@--- Copyright (c) Facebook, Inc. and its affiliates.+-- Copyright (c) 2025 Andrew Farmer+-- Copyright (c) 2020-2024 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.@@ -22,7 +23,6 @@ import Retrie.GHC import Retrie.Quantifiers import Retrie.Types-import Retrie.Util  dfnsToRewrites   :: LibDir@@ -63,9 +63,8 @@   -> LMatch GhcPs (LHsExpr GhcPs)   -> TransformT IO [Rewrite (LHsExpr GhcPs)] matchToRewrites e imps dir (L _ alt) = do-  -- lift $ debugPrint Loud "matchToRewrites:e="  [showAst e]   let-    pats = m_pats alt+    pats = getMatchPats alt     grhss = m_grhss alt   qss <- for (zip (inits pats) (tails pats)) $     makeFunctionQuery e imps dir grhss mkApps@@ -81,15 +80,12 @@     go WildPat{} = True     go VarPat{} = True     go (LazyPat _ p) = irrefutablePat p-#if __GLASGOW_HASKELL__ <= 904-    go (AsPat _ _ p) = irrefutablePat p-#else+#if __GLASGOW_HASKELL__ < 912     go (AsPat _ _ _ p) = irrefutablePat p-#endif-#if __GLASGOW_HASKELL__ < 904-    go (ParPat _ p) = irrefutablePat p-#else     go (ParPat _ _ p _) = irrefutablePat p+#else+    go (AsPat _ _ p) = irrefutablePat p+    go (ParPat _ p) = irrefutablePat p #endif     go (BangPat _ p) = irrefutablePat p     go _ = False@@ -106,13 +102,14 @@   | any (not . irrefutablePat) bndpats = return []   | otherwise = do     let-      GRHSs _ rhss lbs = grhss+      GRHSs _ _ lbs = grhss+      rhssList = grhssList grhss       bs = collectPatsBinders CollNoDictBinders argpats     -- See Note [Wildcards]     (es,(_,bs')) <- runStateT (mapM patToExpr argpats) (wildSupply bs, bs)     -- lift $ debugPrint Loud "makeFunctionQuery:e="  [showAst e]     lhs <- mkAppFn e es-    for rhss $ \ grhs -> do+    for rhssList $ \ grhs -> do       le <- mkLet lbs (grhsToExpr grhs)       rhs <- mkLams bndpats le       let@@ -131,21 +128,49 @@   -> GRHSs GhcPs (LHsExpr GhcPs)   -> [LPat GhcPs]   -> TransformT IO [Rewrite (LHsExpr GhcPs)]-backtickRules e imps dir@LeftToRight grhss ps@[p1, p2] = do+backtickRules e imps dir@LeftToRight grhss (p1:p2:rest) = do   let+#if __GLASGOW_HASKELL__ < 912+    na = noAnn+#else+    na = noExtField+#endif++    wrapOpApps op [] = pure op+    wrapOpApps op extra = do+      o <- mkParen op+      mkApps o extra+     both, left, right :: AppBuilder-    both op [l, r] = mkLocA (SameLine 1) (OpApp noAnn l op r)+    -- A function of arity greater than two used infix supplies its+    -- first two arguments via the operator and the rest by application.+    both op (l:r:extra) = do+      opApp <- mkLocA (SameLine 1) (OpApp na l op r)+      wrapOpApps opApp extra     both _ _ = fail "backtickRules - both: impossible!" -    left op [l] = mkLocA (SameLine 1) (SectionL noAnn l op)+    left op (l:extra) = do+      opSecL <- mkLocA (SameLine 1) (SectionL na l op)+      wrapOpApps opSecL extra     left _ _ = fail "backtickRules - left: impossible!" -    right op [r] = mkLocA (SameLine 1) (SectionR noAnn op r)+    right op (r:extra) = do+      opSecR <- mkLocA (SameLine 1) (SectionR na op r)+      wrapOpApps opSecR extra     right _ _ = fail "backtickRules - right: impossible!"-  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++    splits r = for (zip (inits r) (tails r))++  -- (p1 `op` p2) rest+  qss <- splits rest $ \(ri, rt) ->+    makeFunctionQuery e imps dir grhss both (p1 : p2 : ri, rt)+  -- (p1 `op`) p2 rest+  qsl <- splits (p2:rest) $ \(ri, rt) ->+    makeFunctionQuery e imps dir grhss left (p1 : ri, rt)+  -- (`op` p2) p1 rest+  qsr <- splits (p1:rest) $ \(ri, rt) ->+    makeFunctionQuery e imps dir grhss right (p2 : ri, rt)+  return $ concat qss ++ concat qsl ++ concat qsr backtickRules _ _ _ _ _ = return []  -- Note [fold only]

@@ -1,4 +1,5 @@--- Copyright (c) Facebook, Inc. and its affiliates.+-- Copyright (c) 2025 Andrew Farmer+-- Copyright (c) 2020-2024 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.@@ -9,11 +10,13 @@ {-# LANGUAGE RecordWildCards #-} module Retrie.Rewrites.Patterns (patternSynonymsToRewrites) where -import Control.Monad.State (StateT(runStateT), lift)+import Control.Monad.State (StateT(runStateT)) import Control.Monad import Control.Monad.IO.Class import Data.Maybe+#if __GLASGOW_HASKELL__ < 914 import Data.Void+#endif  import Retrie.ExactPrint import Retrie.Expr@@ -50,7 +53,11 @@   :: Direction   -> AnnotatedImports   -> LocatedN RdrName+#if __GLASGOW_HASKELL__ < 914   -> HsConDetails Void (LocatedN RdrName) [RecordPatSynField GhcPs]+#else+  -> HsConDetails (LocatedN RdrName) [RecordPatSynField GhcPs]+#endif   -> LPat GhcPs   -> TransformT IO (Rewrite (LPat GhcPs)) mkPatRewrite dir imports patName params rhs = do@@ -76,6 +83,7 @@       = (L l (ConPat x (setEntryDP nm dp) args))     setEntryDPTunderConPatIn p _ = p +#if __GLASGOW_HASKELL__ < 914 asPat   :: Monad m   => LocatedN RdrName@@ -86,43 +94,55 @@   mkConPatIn patName params'   where -#if __GLASGOW_HASKELL__ <= 904-    convertTyVars :: (Monad m) => [Void] -> TransformT m [HsPatSigType GhcPs]-#else     convertTyVars :: (Monad m) => [Void] -> TransformT m [HsConPatTyArg GhcPs]-#endif     convertTyVars _ = return []+#else+asPat+  :: Monad m+  => LocatedN RdrName+  -> HsConDetails (LocatedN RdrName) [RecordPatSynField GhcPs]+  -> TransformT m (LPat GhcPs)+asPat patName params = do+  params' <- bitraverseHsConDetails mkVarPat convertFields params+  mkConPatIn patName params'+  where+#endif      convertFields :: (Monad m) => [RecordPatSynField GhcPs]                       -> TransformT m (HsRecFields GhcPs (LPat GhcPs))     convertFields fields =+#if __GLASGOW_HASKELL__ < 912       HsRecFields <$> traverse convertField fields <*> pure Nothing+#else+      HsRecFields noExtField <$> traverse convertField fields <*> pure Nothing+#endif      convertField :: (Monad m) => RecordPatSynField GhcPs                       -> TransformT m (LHsRecField GhcPs (LPat GhcPs))     convertField RecordPatSynField{..} = do-#if __GLASGOW_HASKELL__ < 904-      hsRecFieldLbl <- mkLoc $ recordPatSynField-      hsRecFieldArg <- mkVarPat recordPatSynPatVar-      let hsRecPun = False-      let hsRecFieldAnn = noAnn-      mkLocA (SameLine 0) HsRecField{..}-#else+#if __GLASGOW_HASKELL__ < 912       s <- uniqueSrcSpanT       an <- mkEpAnn (SameLine 0) NoEpAnns       let srcspan = SrcSpanAnn an s           hfbLHS = L srcspan recordPatSynField+#else+      an <- mkEpAnn (SameLine 0) noAnn+      let hfbLHS = L an recordPatSynField+#endif       hfbRHS <- mkVarPat recordPatSynPatVar       let hfbPun = False           hfbAnn = noAnn       mkLocA (SameLine 0) HsFieldBind{..}-#endif  mkExpRewrite   :: Direction   -> AnnotatedImports   -> LocatedN RdrName+#if __GLASGOW_HASKELL__ < 914   -> HsConDetails Void (LocatedN RdrName) [RecordPatSynField GhcPs]+#else+  -> HsConDetails (LocatedN RdrName) [RecordPatSynField GhcPs]+#endif   -> LPat GhcPs   -> HsPatSynDir GhcPs   -> TransformT IO [Rewrite (LHsExpr GhcPs)]@@ -130,7 +150,11 @@   fe <- mkLocatedHsVar patName   -- lift $ debugPrint Loud "mkExpRewrite:fe="  [showAst fe]   let altsFromParams = case params of+#if __GLASGOW_HASKELL__ < 914         PrefixCon _tyargs names -> buildMatch names rhs+#else+        PrefixCon names -> buildMatch names rhs+#endif         InfixCon a1 a2 -> buildMatch [a1, a2] rhs         RecCon{} -> missingSyntax "RecCon"   alts <- case patDir of@@ -148,5 +172,9 @@   pats <- traverse mkVarPat names   let bs = collectPatBinders CollNoDictBinders rhs   (rhsExpr,(_,_bs')) <- runStateT (patToExpr rhs) (wildSupply bs, bs)+#if __GLASGOW_HASKELL__ < 912   let alt = mkMatch PatSyn pats rhsExpr emptyLocalBinds+#else+  let alt = mkMatch PatSyn (noLocA pats) rhsExpr emptyLocalBinds+#endif   return [alt]

@@ -1,9 +1,9 @@--- Copyright (c) Facebook, Inc. and its affiliates.+-- Copyright (c) 2025 Andrew Farmer+-- Copyright (c) 2020-2024 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.Rewrites.Rules (rulesToRewrites) where @@ -14,20 +14,11 @@ import Retrie.GHC import Retrie.Quantifiers import Retrie.Types-import Retrie.Util-import Retrie.Monad-import Control.Monad-import Control.Monad.IO.Class-import Control.Monad.Trans.Class  rulesToRewrites   :: [(FastString, Direction)]   -> AnnotatedModule-#if __GLASGOW_HASKELL__ < 900-  -> IO (UniqFM [Rewrite (LHsExpr GhcPs)])-#else   -> IO (UniqFM RuleName [Rewrite (LHsExpr GhcPs)])-#endif rulesToRewrites specs am = fmap astA $ transformA am $ \ m -> do   let     fsMap = uniqBag specs

@@ -1,4 +1,5 @@--- Copyright (c) Facebook, Inc. and its affiliates.+-- Copyright (c) 2025 Andrew Farmer+-- Copyright (c) 2020-2024 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.@@ -21,11 +22,7 @@ typeSynonymsToRewrites   :: [(FastString, Direction)]   -> AnnotatedModule-#if __GLASGOW_HASKELL__ < 900-  -> IO (UniqFM [Rewrite (LHsType GhcPs)])-#else   -> IO (UniqFM FastString [Rewrite (LHsType GhcPs)])-#endif typeSynonymsToRewrites specs am = fmap astA $ transformA am $ \ m -> do   let     fsMap = uniqBag specs

@@ -1,4 +1,5 @@--- Copyright (c) Facebook, Inc. and its affiliates.+-- Copyright (c) 2025 Andrew Farmer+-- Copyright (c) 2020-2024 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.@@ -19,7 +20,6 @@   ) where  import Control.Monad-import Control.Monad.State.Strict import Data.Char import Data.List import Data.Monoid

@@ -1,4 +1,5 @@--- Copyright (c) Facebook, Inc. and its affiliates.+-- Copyright (c) 2025 Andrew Farmer+-- Copyright (c) 2020-2024 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.@@ -19,7 +20,7 @@   ) where  import Control.Monad-import Data.Generics hiding (Fixity(..))+import Data.Generics hiding (Fixity(..), ext2)  -- | Monadic rewrite with context type GenericMC m c = forall a. Data a => c -> a -> m a

@@ -1,4 +1,5 @@--- Copyright (c) Facebook, Inc. and its affiliates.+-- Copyright (c) 2025 Andrew Farmer+-- Copyright (c) 2020-2024 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.@@ -17,7 +18,6 @@ import Retrie.Substitution import Retrie.SYB import Retrie.Types-import Retrie.Util  ------------------------------------------------------------------------ @@ -56,15 +56,12 @@       -- lift $ liftIO $ debugPrint Loud "substExpr:HoleExpr:e" [showAst e]       -- lift $ liftIO $ debugPrint Loud "substExpr:HoleExpr:eA" [showAst eA]       e0 <- graftA (unparen <$> eA)-      let comments = hasComments e0-      -- unless comments $ transferEntryDPT e e'-      e1 <- if comments-               then return e0-               else transferEntryDP e e0-      e2 <- transferAnnsT isComma e e1-      -- let e'' = setEntryDP e' (SameLine 1)-      -- lift $ liftIO $ debugPrint Loud "substExpr:HoleExpr:e2" [showAst e2]-      parenify ctxt e2+      -- copy over the template hole's entry delta and transfer any+      -- annotations such as trailing commas. we should only ever take the+      -- trailing annotations from the template, rather than whatever was+      -- attached to the expression in its previous location.+      e1 <- transferEntryAnnsT e e0+      parenify ctxt e1     Just (HoleRdr rdr) ->       return $ L l1 $ HsVar x $ L l2 rdr     _ -> return e@@ -81,7 +78,7 @@       -- lift $ liftIO $ debugPrint Loud "substPat:HolePat:p" [showAst p]       -- lift $ liftIO $ debugPrint Loud "substPat:HolePat:pA" [showAst pA]       p' <- graftA (unparenP <$> pA)-      p0 <- transferEntryAnnsT isComma p p'+      p0 <- transferEntryAnnsT p p'       -- the relevant entry delta is sometimes attached to       -- the OccName and not to the VarPat.       -- This seems to be the case only when the pattern comes from a lhs,@@ -104,7 +101,7 @@     -- lift $ liftIO $ debugPrint Loud "substType:HoleType:ty" [showAst ty]     -- lift $ liftIO $ debugPrint Loud "substType:HoleType:tyA" [showAst tyA]     ty' <- graftA (unparenT <$> tyA)-    ty0 <- transferEntryAnnsT isComma ty ty'+    ty0 <- transferEntryAnnsT ty ty'     parenifyT ctxt ty0 substType _ ty = return ty @@ -114,16 +111,19 @@ substHsMatchContext   :: Monad m   => Context-#if __GLASGOW_HASKELL__ < 900-  -> HsMatchContext RdrName-  -> TransformT m (HsMatchContext RdrName)-#else+#if __GLASGOW_HASKELL__ < 912   -> HsMatchContext GhcPs   -> TransformT m (HsMatchContext GhcPs)-#endif substHsMatchContext ctxt (FunRhs (L l v) f s)-  | Just (HoleRdr rdr) <- lookupHoleVar v ctxt =-    return $ FunRhs (L l rdr) f s+  | Just (HoleRdr rdr) <- lookupHoleVar v ctxt+  = return $ FunRhs (L l rdr) f s+#else+  -> HsMatchContext (LIdP GhcPs)+  -> TransformT m (HsMatchContext (LIdP GhcPs))+substHsMatchContext ctxt (FunRhs (L l v) f s _)+  | Just (HoleRdr rdr) <- lookupHoleVar v ctxt+  = return $ FunRhs (L l rdr) f s (AnnFunRhs NoEpTok [] [])+#endif substHsMatchContext _ other = return other  substBind

@@ -1,4 +1,5 @@--- Copyright (c) Facebook, Inc. and its affiliates.+-- Copyright (c) 2025 Andrew Farmer+-- Copyright (c) 2020-2024 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.

@@ -1,4 +1,5 @@--- Copyright (c) Facebook, Inc. and its affiliates.+-- Copyright (c) 2025 Andrew Farmer+-- Copyright (c) 2020-2024 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.@@ -91,7 +92,6 @@ data ParentPrec   = HasPrec Fixity -- ^ Parent has precedence info.   | IsLhs      -- ^ We are a pattern in a left-hand-side-  | IsHsAppsTy -- ^ Parent is HsAppsTy   | NeverParen -- ^ Based on parent, we should never add parentheses.  ------------------------------------------------------------------------@@ -130,11 +130,10 @@ -- See Note [AlphaEnv Offset] for details.  instance Semigroup (Matcher a) where-  (<>) = mappend+  (Matcher m1) <> (Matcher m2) = Matcher (I.unionWith mUnion m1 m2)  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

@@ -1,4 +1,5 @@--- Copyright (c) Facebook, Inc. and its affiliates.+-- Copyright (c) 2025 Andrew Farmer+-- Copyright (c) 2020-2024 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.

@@ -1,4 +1,5 @@--- Copyright (c) Facebook, Inc. and its affiliates.+-- Copyright (c) 2025 Andrew Farmer+-- Copyright (c) 2020-2024 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.@@ -106,6 +107,6 @@ missingSyntax :: String -> a missingSyntax constructor = error $ unlines   [ "Missing syntax support: " ++ constructor-  , "Please file an issue at https://github.com/facebookincubator/retrie/issues"+  , "Please file an issue at https://github.com/xich/retrie/issues"   , "with an example of the rewrite you are attempting and we'll add it."   ]

@@ -1,4 +1,5 @@--- Copyright (c) Facebook, Inc. and its affiliates.+-- Copyright (c) 2025 Andrew Farmer+-- Copyright (c) 2020-2024 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.

@@ -1,4 +1,5 @@--- Copyright (c) Facebook, Inc. and its affiliates.+-- Copyright (c) 2025 Andrew Farmer+-- Copyright (c) 2020-2024 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.

@@ -1,4 +1,5 @@--- Copyright (c) Facebook, Inc. and its affiliates.+-- Copyright (c) 2025 Andrew Farmer+-- Copyright (c) 2020-2024 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.

@@ -1,4 +1,5 @@--- Copyright (c) Facebook, Inc. and its affiliates.+-- Copyright (c) 2025 Andrew Farmer+-- Copyright (c) 2020-2024 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.@@ -33,8 +34,10 @@ hseToGHC (HSE.Fixity assoc p nm) = #if __GLASGOW_HASKELL__ < 908   (fs, (fs, Fixity (SourceText nm') p (dir assoc)))-#else+#elif __GLASGOW_HASKELL__ < 912   (fs, (fs, Fixity (SourceText (fsLit nm')) p (dir assoc)))+#else+  (fs, (fs, Fixity p (dir assoc))) #endif    where

@@ -1,29 +1,31 @@--- Copyright (c) Facebook, Inc. and its affiliates.+-- Copyright (c) 2025 Andrew Farmer+-- Copyright (c) 2020-2024 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: 1.2.3+version: 2.0.0 synopsis: A powerful, easy-to-use codemodding tool for Haskell.-homepage: https://github.com/facebookincubator/retrie-bug-reports: https://github.com/facebookincubator/retrie/issues+homepage: https://github.com/xich/retrie+bug-reports: https://github.com/xich/retrie/issues 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.+author: Andrew Farmer <andrew@andrewfarmer.name>+maintainer: Andrew Farmer <andrew@andrewfarmer.name>+copyright:+  Copyright (c) 2025 Andrew Farmer+  Copyright (c) 2020-2024 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 ==9.2.1, GHC ==9.4.1, GHC ==9.6.1, GHC ==9.8.1+tested-with: GHC ==9.6.7, GHC ==9.8.4, GHC ==9.12.4, GHC ==9.14.1  description:   Retrie is a tool for codemodding Haskell. Key goals include:@@ -74,17 +76,20 @@     Retrie.Universe,     Retrie.Util   GHC-Options: -Wall+  if flag(Werror)+    GHC-Options: -Werror+  if impl(ghc >= 9.10)+    GHC-Options: -Wno-incomplete-record-selectors   build-depends:-    ansi-terminal >= 0.10.3 && < 1.1,+    ansi-terminal >= 0.10.3 && < 1.2,     async >= 2.2.2 && < 2.3,-    base >= 4.11 && < 4.20,+    base >= 4.11 && < 4.23,     bytestring >= 0.10.8 && < 0.13,-    containers >= 0.5.11 && < 0.8,-    data-default >= 0.7.1 && < 0.8,+    containers >= 0.5.11 && < 0.9,+    data-default >= 0.7.1 && < 0.9,     directory >= 1.3.1 && < 1.4,     filepath >= 1.4.2 && < 1.6,-    ghc >= 9.2 && < 9.9,-    ghc-exactprint >= 1.5.0 && < 1.9,+    ghc >= 9.6 && < 9.9 || >= 9.12 && < 9.13 || >= 9.14 && < 9.15,     list-t >= 1.0.4 && < 1.1,     mtl >= 2.2.2 && < 2.4,     optparse-applicative >= 0.15.1 && < 0.19,@@ -94,12 +99,26 @@     text >= 1.2.3 && < 2.2,     transformers >= 0.5.5 && < 0.7,     unordered-containers >= 0.2.10 && < 0.3+  -- Each ghc-exactprint major series only builds against one GHC series.+  if impl(ghc >= 9.14 && < 9.15)+    build-depends: ghc-exactprint >= 1.14.2 && < 1.15+  if impl(ghc >= 9.12 && < 9.13)+    build-depends: ghc-exactprint >= 1.12.1 && < 1.13+  if impl(ghc < 9.12)+    build-depends: ghc-exactprint >= 1.7.1 && < 1.12   default-language: Haskell2010  Flag BuildExecutable   Description: build the retrie executable   Default: True +-- Off by default because Hackage rejects packages that build with -Werror+-- unconditionally. cabal.project turns it on for development and CI.+Flag Werror+  Description: build with -Werror+  Default: False+  Manual: True+ executable retrie   if flag(BuildExecutable)     Buildable: True@@ -109,11 +128,13 @@     Main.hs   hs-source-dirs: bin hse   other-modules: Fixity-  GHC-Options: -Wall+  GHC-Options: -Wall -threaded+  if flag(Werror)+    GHC-Options: -Werror   build-depends:     retrie,-    base >= 4.11 && < 4.20,-    haskell-src-exts >= 1.23.0 && < 1.24,+    base >= 4.11 && < 4.23,+    haskell-src-exts >= 1.23.0 && < 1.25,     ghc-paths   default-language: Haskell2010 @@ -126,11 +147,13 @@     Main.hs   hs-source-dirs: demo hse   other-modules: Fixity-  GHC-Options: -Wall+  GHC-Options: -Wall -threaded+  if flag(Werror)+    GHC-Options: -Werror   build-depends:     retrie,-    base >= 4.11 && < 4.20,-    haskell-src-exts >= 1.23.0 && < 1.24,+    base >= 4.11 && < 4.23,+    haskell-src-exts >= 1.23.0 && < 1.25,     ghc-paths   default-language: Haskell2010 @@ -173,11 +196,10 @@     process,     syb,     tasty,-    tasty-hunit,     temporary,     text,     unordered-containers  source-repository head   type:     git-  location: https://github.com/facebookincubator/retrie+  location: https://github.com/xich/retrie

@@ -1,4 +1,5 @@--- Copyright (c) Facebook, Inc. and its affiliates.+-- Copyright (c) 2025 Andrew Farmer+-- Copyright (c) 2020-2024 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.@@ -44,6 +45,12 @@       [ TestLabel rtName $ TestCase $ runTest libdir p RetrieTest{..}       | testFile <- testFiles       , takeExtension testFile == ".test"+#if __GLASGOW_HASKELL__ < 908+      -- The TypeAbstractions pragma is unknown to the GHC 9.6 parser, so+      -- retrie cannot parse this test's target module there. The pre-9.14+      -- code path it exercises is still covered by the 9.8/9.12 runs.+      , testFile /= "TypeAbs.test"+#endif       , let           rtName = dropExtension testFile           rtTest = testFile

@@ -1,9 +1,9 @@--- Copyright (c) Facebook, Inc. and its affiliates.+-- Copyright (c) 2025 Andrew Farmer+-- Copyright (c) 2020-2024 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 ScopedTypeVariables #-} module Annotated (annotatedTest) where@@ -16,9 +16,7 @@ -- import Data.Maybe import qualified GHC.Paths as GHC.Paths import Test.HUnit-#if MIN_VERSION_mtl(2, 3, 0) import Control.Monad ((>=>))-#endif  import Retrie.ExactPrint import Retrie.GHC@@ -203,11 +201,7 @@ -- assertExactPrintAnns :: Anns -> Anns -> IO () -- assertExactPrintAnns annsPreGraft annsPostGraft = --   forM_ newKeys $ \(AnnKey ss _) ->--- #if __GLASGOW_HASKELL__ < 900---     assertGoodSrcSpan ss--- #else --     assertGoodRealSrcSpan ss--- #endif --   where --     newKeys :: S.Set AnnKey --     newKeys = M.keysSet annsPostGraft `S.difference` M.keysSet annsPreGraft

@@ -1,4 +1,5 @@--- Copyright (c) Facebook, Inc. and its affiliates.+-- Copyright (c) 2025 Andrew Farmer+-- Copyright (c) 2020-2024 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.

@@ -1,4 +1,5 @@--- Copyright (c) Facebook, Inc. and its affiliates.+-- Copyright (c) 2025 Andrew Farmer+-- Copyright (c) 2020-2024 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.

@@ -1,4 +1,5 @@--- Copyright (c) Facebook, Inc. and its affiliates.+-- Copyright (c) 2025 Andrew Farmer+-- Copyright (c) 2020-2024 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.

@@ -1,4 +1,5 @@--- Copyright (c) Facebook, Inc. and its affiliates.+-- Copyright (c) 2025 Andrew Farmer+-- Copyright (c) 2020-2024 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.@@ -30,7 +31,7 @@ excludeTest :: Verbosity -> Test excludeTest v = TestLabel "exclude path prefixes" $   TestCase $ do-    withFakeHgRepo [] allFiles $ \dir -> do+    withFakeGitRepo [] allFiles $ \dir -> do       let opts = optionsWithDefaultFixities $ optionsWithExtraIgnores dir v       filepaths <- getTargetFiles opts []       assertBool (unlines ["Expected ", show excludedPaths,

@@ -1,4 +1,5 @@--- Copyright (c) Facebook, Inc. and its affiliates.+-- Copyright (c) 2025 Andrew Farmer+-- Copyright (c) 2020-2024 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.

@@ -1,4 +1,5 @@--- Copyright (c) Facebook, Inc. and its affiliates.+-- Copyright (c) 2025 Andrew Farmer+-- Copyright (c) 2020-2024 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.

@@ -1,4 +1,5 @@--- Copyright (c) Facebook, Inc. and its affiliates.+-- Copyright (c) 2025 Andrew Farmer+-- Copyright (c) 2020-2024 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.

@@ -1,22 +1,38 @@--- Copyright (c) Facebook, Inc. and its affiliates.+-- Copyright (c) 2025 Andrew Farmer+-- Copyright (c) 2020-2024 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 Control.Exception import Test.HUnit import Test.Tasty-import Test.Tasty.HUnit+import Test.Tasty.Providers+import Test.Tasty.Runners (Result(..))  import qualified GHC.Paths as GHC.Paths import Retrie import AllTests+import Util (SkipTest(..))  main :: IO () main = allTests GHC.Paths.libdir Silent >>= defaultMain . toTasty . TestLabel "retrie"  toTasty :: Test -> TestTree-toTasty (TestLabel lbl (TestCase io)) = testCase lbl io+toTasty (TestLabel lbl (TestCase io)) = singleTest lbl (SkippableCase io) toTasty (TestLabel lbl (TestList ts)) = testGroup lbl (map toTasty ts) toTasty t = error $ "toTasty: unlabeled test " ++ show t++-- | Like tasty-hunit's 'testCase', but a 'SkipTest' exception reports the test+-- as SKIPPED (which does not fail the run) instead of failing it.+newtype SkippableCase = SkippableCase Assertion++instance IsTest SkippableCase where+  run _ (SkippableCase io) _ = do+    r <- try io+    return $ case r of+      Left (SkipTest why) -> (testPassed why) { resultShortDescription = "SKIPPED" }+      Right () -> testPassed ""+  testOptions = return []

@@ -1,4 +1,5 @@--- Copyright (c) Facebook, Inc. and its affiliates.+-- Copyright (c) 2025 Andrew Farmer+-- Copyright (c) 2020-2024 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.

@@ -1,4 +1,5 @@--- Copyright (c) Facebook, Inc. and its affiliates.+-- Copyright (c) 2025 Andrew Farmer+-- Copyright (c) 2020-2024 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.@@ -27,7 +28,7 @@     where       gts = [HashSet.fromList ["Groundterm"]]       targetFps = retrieTargetFiles-      -- 'withFakeHgRepo' creates every file with its own name as the contents+      -- 'withFakeGitRepo' creates every file with its own name as the contents       expectedFps = ["targeted" </> "Groundterm.hs"]  assertFileListEqual@@ -36,7 +37,7 @@   -> [FilePath]   -> Assertion assertFileListEqual expected gts targetFps =-  withFakeHgRepo [] allFiles $ \dir -> do+  withFakeGitRepo [] allFiles $ \dir -> do     let opts = optionsWithTargetFiles dir targetFps     filepaths <- getTargetFiles opts gts     assertPermutationOf "Targeted files should be all of those specified"

@@ -1,12 +1,15 @@--- Copyright (c) Facebook, Inc. and its affiliates.+-- Copyright (c) 2025 Andrew Farmer+-- Copyright (c) 2020-2024 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.Exception import Control.Monad-import System.Directory (createDirectoryIfMissing)+import System.Directory (createDirectoryIfMissing, findExecutable)+import System.Environment (lookupEnv) import System.Exit import System.FilePath import System.IO.Temp@@ -39,7 +42,8 @@       writeFile filePath fp  withFakeHgRepo :: [FilePath] -> [FilePath] -> (FilePath -> IO ()) -> IO ()-withFakeHgRepo ignoredFiles allFiles f =+withFakeHgRepo ignoredFiles allFiles f = do+  requireExecutable "hg"   withFakeRepoCmds "hg init" ".hgignore" ignoredFiles allFiles $ \dir -> do     -- Tell 'hg' which ignore file to use for the repo, because Facebook's     -- 'hg' looks at .gitignore by default.@@ -50,7 +54,27 @@     f dir  withFakeGitRepo :: [FilePath] -> [FilePath] -> (FilePath -> IO ()) -> IO ()-withFakeGitRepo = withFakeRepoCmds "git init" ".gitignore"+withFakeGitRepo ignoredFiles allFiles f = do+  requireExecutable "git"+  withFakeRepoCmds "git init" ".gitignore" ignoredFiles allFiles f++-- | Thrown to mark a test as skipped rather than failed. See 'toTasty' in Main.+newtype SkipTest = SkipTest String+  deriving Show++instance Exception SkipTest++-- | Skip the test if the given executable is not on the PATH. On CI (where the+-- CI environment variable is set) every executable should be installed, so+-- fail instead.+requireExecutable :: String -> IO ()+requireExecutable exe = do+  found <- findExecutable exe+  onCI <- maybe False (not . null) <$> lookupEnv "CI"+  when (null found) $+    if onCI+      then assertFailure $ exe ++ " is not installed, but is required on CI"+      else throwIO $ SkipTest $ exe ++ " is not installed"  doOrDie :: FilePath -> String -> IO () doOrDie dir cmd = do

@@ -1,4 +1,5 @@-# Copyright (c) Facebook, Inc. and its affiliates.+# Copyright (c) 2025 Andrew Farmer+# Copyright (c) 2020-2024 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.

@@ -1,4 +1,5 @@-# Copyright (c) Facebook, Inc. and its affiliates.+# Copyright (c) 2025 Andrew Farmer+# Copyright (c) 2020-2024 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.

@@ -1,4 +1,5 @@-# Copyright (c) Facebook, Inc. and its affiliates.+# Copyright (c) 2025 Andrew Farmer+# Copyright (c) 2020-2024 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.

@@ -1,4 +1,5 @@-# Copyright (c) Facebook, Inc. and its affiliates.+# Copyright (c) 2025 Andrew Farmer+# Copyright (c) 2020-2024 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.@@ -12,9 +13,9 @@ -  print $ foo `bar` [1..10] +  print $ foo + sum [1..10] -  print $ (foo `bar`) [1..10]-+  print $ (\ xs -> foo + sum xs) [1..10]++  print $ foo + sum [1..10] -  print $ (`bar` [1..10]) foo-+  print $ (\ x -> x + sum [1..10]) foo++  print $ foo + sum [1..10]    foo :: Int  foo = baz `div` quux 10

@@ -0,0 +1,45 @@+# Unfolding a function of arity greater than two used in backtick+# form.+-u Backticks3.bar -u Backticks3.quux+===+ module Backticks3 where++ main :: IO ()+ main = do+-  print $ (1 `bar` 2) 3++  print $ 1 + 2 * 3+-  print $ (foo `bar` 2) 4++  print $ foo + 2 * 4+-  print $ (foo `bar`) 2 5++  print $ foo + 2 * 5+-  print $ (`bar` 2) foo 6++  print $ foo + 2 * 6+-  print $ zipWith (foo `bar`) [7] [8]++  print $ zipWith (\ y z -> foo + y * z) [7] [8]+-  print $ zipWith (`bar` 2) [foo] [9]++  print $ zipWith (\ x z -> x + 2 * z) [foo] [9]+-  print $ map ((foo `bar`) 2) [10]++  print $ map (\ z -> foo + 2 * z) [10]+-  print $ map ((`bar` 2) foo) [11]++  print $ map (\ z -> foo + 2 * z) [11]+-  print $ map (foo `bar` 2) [12]++  print $ map (\ z -> foo + 2 * z) [12]+-  print $ foo `bar` 2 $ 13++  print $ (\ z -> foo + 2 * z) $ 13+-  print $ (foo `quux` 2) 3 14++  print $ foo + 2 * 3 - 14+-  print $ (foo `quux`) 2 3 15++  print $ foo + 2 * 3 - 15+-  print $ (`quux` 2) foo 3 16++  print $ foo + 2 * 3 - 16+-  print $ map ((foo `quux` 2) 3) [17]++  print $ map (\ d -> foo + 2 * 3 - d) [17]++ foo :: Int+ foo = 100++ bar :: Int -> Int -> Int -> Int+ bar x y z = x + y * z++ quux :: Int -> Int -> Int -> Int -> Int+ quux a b c d = a + b * c - d

@@ -1,24 +1,30 @@-# Copyright (c) Facebook, Inc. and its affiliates.+# Copyright (c) 2025 Andrew Farmer+# Copyright (c) 2020-2024 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+--adhoc "forall a b. a * b = mul a b"+--pattern-backward CPP.One+-u CPP.baz+-u CPP.baz2 ===  {-# LANGUAGE CPP #-}+ {-# LANGUAGE PatternSynonyms #-}  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)@@ -27,7 +33,28 @@ +    zs = map ((+1) . (*3)) ys  #endif + pattern One :: a -> [a]+ pattern One y = y : []+  #if TRUE+ fixityExpr :: Int -> Int -> Int -> Int+-fixityExpr x y w = x + y * w++fixityExpr x y w = x + mul y w++ fixityPat :: [Int] -> Int+-fixityPat (x : y : []) = x++fixityPat (x : One y) = x++ fixityExpr3 :: (Int -> Int) -> Int -> Int -> Int -> Int+-fixityExpr3 f p q z = f $ p + q * z++fixityExpr3 f p q z = f $ p + mul q z++ fixityPat3 :: [Int] -> Int+-fixityPat3 ( a  :   b    :     c      :       d        :         []) = a++fixityPat3 ( a  :   b    :     c      :       One d) = a+ #endif++ #if TRUE  bar2 :: [Int] -> Int  bar2 ys = length (filter even zs)    where@@ -48,14 +75,30 @@  useit :: Int -useit = otherthing (Just 54) +useit = case Just 54 of-+  Just{} -> 1-+  Nothing -> 0++         Just{} -> 1++         Nothing -> 0   #if TRUE  useit2 :: Int -useit2 = otherthing (Just 42) +useit2 = case Just 42 of-+  Just{} -> 1-+  Nothing -> 0++          Just{} -> 1++          Nothing -> 0  #endif  #endif++ anns :: IO ()+-anns = print [baz, pred baz, baz]++anns = print [succ 4, pred (succ 4), succ 4]++ baz :: Int+ baz = succ 4++ baz2 :: Int+ baz2 =+   -- one+   1++-comment = baz2++comment = -- one++          1

@@ -1,4 +1,5 @@-# Copyright (c) Facebook, Inc. and its affiliates.+# Copyright (c) 2025 Andrew Farmer+# Copyright (c) 2020-2024 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.

@@ -0,0 +1,39 @@+# Copyright (c) 2025 Andrew Farmer+#+# This source code is licensed under the MIT license found in the+# LICENSE file in the root directory of this source tree.+#+# https://github.com/xich/retrie/issues/24+# A multi-line replacement spliced in as text (CPP module) must have its+# continuation lines re-indented relative to the destination column, not+# the column of the template in its original definition.+-u CPPLayout.foo+-u CPPLayout.baz+===+ {-# LANGUAGE CPP #-}+ module CPPLayout where++ #define KEEP 1++ foo :: Int+ foo =+   succ+     1++ bar :: Int+ bar = x+   where+-    x = foo++    x = succ++          1++ baz :: IO ()+ baz = do print 1+          print 2++ qux :: IO ()+ qux = x+   where+-    x = baz++    x = do print 1++           print 2

@@ -1,4 +1,5 @@-# Copyright (c) Facebook, Inc. and its affiliates.+# Copyright (c) 2025 Andrew Farmer+# Copyright (c) 2020-2024 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.

@@ -1,4 +1,5 @@-# Copyright (c) Facebook, Inc. and its affiliates.+# Copyright (c) 2025 Andrew Farmer+# Copyright (c) 2020-2024 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.@@ -46,7 +47,7 @@    baz2 :: Int -baz2 = foo * bar-+baz2 = (3 + 4) * 5 * foo++baz2 = (3 + 4) * (5 `quot` foo)    quux :: Int -> Int -quux x = foo * x@@ -65,20 +66,20 @@  blerg :: Int -blerg = blarg 42 +blerg = (case 54 of-+    0 -> pred-+    _ -> succ) 42++          0 -> pred++          _ -> succ) 42    jank :: IO (Int -> Int) -jank = return blarg +jank = return (case 54 of-+    0 -> pred-+    _ -> succ)++                0 -> pred++                _ -> succ)    jenk :: IO Int -jenk = return $ blarg 42 +jenk = return $ (case 54 of-+    0 -> pred-+    _ -> succ) 42++                  0 -> pred++                  _ -> succ) 42   mneh :: Bool -mneh = 3 == 2

@@ -1,9 +1,13 @@-# Copyright (c) Facebook, Inc. and its affiliates.+# Copyright (c) 2025 Andrew Farmer+# Copyright (c) 2020-2024 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+--adhoc "forall a b. f [a, b] = g [a, b]"+--adhoc "forall a b. h [a, b] = k a b"+--type-backward Commas.Pair ===  module Commas where  @@ -15,3 +19,26 @@    foo :: Int  foo = succ 4++ test2 :: IO ()+-test2 = print (f [succ 1, 2])++test2 = print (g [succ 1, 2])+ + test3 :: IO ()+-test3 = print (h [succ 1, 2])++test3 = print (k (succ 1) 2)++ type Pair a = (a, a)++-test4 :: (Maybe Int, Maybe Int)++test4 :: Pair (Maybe Int)+ test4 = (Nothing, Nothing)++ test5 :: IO ()+-test5 = print (h [succ 1 {- t -}, 2])++test5 = print (k (succ 1) 2)++ test6 :: IO ()+-test6 = print (h [ succ 1+-                 , 2 ])++test6 = print (k (succ 1) 2)

@@ -1,4 +1,5 @@-# Copyright (c) Facebook, Inc. and its affiliates.+# Copyright (c) 2025 Andrew Farmer+# Copyright (c) 2020-2024 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.@@ -7,12 +8,15 @@ -l Comments.swap  -l Comments.convt  -u Comments.oldFunc+-l Comments.tmpl+-u Comments.idFunc ===  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 #-}+ {-# RULES "tmpl" forall x. h x = k {- template comment -} x #-}    main1 :: IO ()  main1 =@@ -23,9 +27,9 @@  main2 :: IO ()  main2 = -   swapFunc-+   newSwapFunc arg2-      -- note: swap args and update+-     -- note: swap args and update -     arg1 arg2++   newSwapFunc arg2 -- note: swap args and update +     arg1    main3 :: IO ()@@ -54,3 +58,24 @@ +  -- more comment +    foo +  ]++-main5 = h 1++main5 = k {- template comment -} 1++ idFunc x = x++-main6 = idFunc -- note++main6 = -- note+   1++-main7 = idFunc {- c -} 2++main7 = {- c -} 2++-main8 = [3, {- d -} idFunc 4, 5]++main8 = [3, {- d -} 4, 5]++ main9 = [6,+   -- e+-  idFunc -- f++  -- f+     7]

@@ -1,4 +1,5 @@-# Copyright (c) Facebook, Inc. and its affiliates.+# Copyright (c) 2025 Andrew Farmer+# Copyright (c) 2020-2024 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.

@@ -0,0 +1,26 @@+# Unfold foo to reprint the whole module. Fixity reassociation rotates+# x : y : zs and x + y * w. This test ensures the annotations, spacing and+# comments are untouched.+-u FixityAnnotations.foo+===+ module FixityAnnotations where++ f :: ([Int], Int) -> [Int]+ f ( x : y : zs, w) = [x + y * w, w]++ b :: ([Int], Int) -> [Int]+ b ({- a -} x : y : zs {- b -}, w) = [x + y * w, w]++ c :: ([Int], Int) -> [Int]+ c (x : y : zs+   , w) = [x + y * w, w]++ g :: [[Int]] -> Int+ g [x : y : zs, _] = x++ h :: Int+-h = foo++h = 1++ foo :: Int+ foo = 1

@@ -1,4 +1,5 @@-# Copyright (c) Facebook, Inc. and its affiliates.+# Copyright (c) 2025 Andrew Farmer+# Copyright (c) 2020-2024 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.

@@ -1,4 +1,5 @@-# Copyright (c) Facebook, Inc. and its affiliates.+# Copyright (c) 2025 Andrew Farmer+# Copyright (c) 2020-2024 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.

@@ -1,4 +1,5 @@-# Copyright (c) Facebook, Inc. and its affiliates.+# Copyright (c) 2025 Andrew Farmer+# Copyright (c) 2020-2024 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.

@@ -1,4 +1,5 @@-# Copyright (c) Facebook, Inc. and its affiliates.+# Copyright (c) 2025 Andrew Farmer+# Copyright (c) 2020-2024 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.

@@ -0,0 +1,33 @@+# Copyright (c) 2025 Andrew Farmer+#+# This source code is licensed under the MIT license found in the+# LICENSE file in the root directory of this source tree.+#+# Non-CPP counterpart of CPPLayout.test (issue #24): exactprint path.+-u Layout.foo+-u Layout.baz+===+ module Layout where++ foo :: Int+ foo =+   succ+     1++ bar :: Int+ bar = x+   where+-    x = foo++    x = succ++        1++ baz :: IO ()+ baz = do print 1+          print 2++ qux :: IO ()+ qux = x+   where+-    x = baz++    x = do print 1++           print 2

@@ -1,4 +1,5 @@-# Copyright (c) Facebook, Inc. and its affiliates.+# Copyright (c) 2025 Andrew Farmer+# Copyright (c) 2020-2024 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.

@@ -1,4 +1,5 @@-# Copyright (c) Facebook, Inc. and its affiliates.+# Copyright (c) 2025 Andrew Farmer+# Copyright (c) 2020-2024 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.

@@ -1,4 +1,5 @@-# Copyright (c) Facebook, Inc. and its affiliates.+# Copyright (c) 2025 Andrew Farmer+# Copyright (c) 2020-2024 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.@@ -7,23 +8,33 @@ -u Parens.bar  -u Parens.quux  -u Parens.blarg+-u Parens.shl1+-u Parens.neg+-u Parens.two+-u Parens.mkR+--adhoc "forall a. a . id = a"+--type-forward Parens.Fn+--type-forward Parens.MaybeInt ===+ {-# LANGUAGE OverloadedRecordDot #-}  module Parens where  + import Data.Bits+   foo :: Int  foo = 3 + 4    bar :: Int--bar = 5 * foo-+bar = 5 * (3 + 4)+-bar = 5 `quot` foo++bar = 5 `quot` (3 + 4)    baz :: Int -baz = quux bar +baz = foo * bar    baz2 :: Int--baz2 = foo * bar-+baz2 = (3 + 4) * 5 * foo+-baz2 = foo `quot` bar++baz2 = (3 + 4) `quot` (5 `quot` foo)    quux :: Int -> Int -quux x = foo * x@@ -56,3 +67,96 @@ +jenk = return $ (case 54 of +    0 -> pred +    _ -> succ) 42+ + shl1 :: Int -> Int+ shl1 n = n `shiftL` 1+ + shl2 :: Int -> Int+-shl2 = (`shiftL` 2) . id++shl2 = (`shiftL` 2)+ + shl3 :: Int -> Int+-shl3 n = shl1 n `shiftL` 2++shl3 n = n `shiftL` 1 `shiftL` 2+ + shl4 :: Int -> Int+-shl4 n = n `shiftL` shl1 2++shl4 n = n `shiftL` (2 `shiftL` 1)+ + mixedDirs :: Int+-mixedDirs = shl1 3 ^ shl1 4++mixedDirs = (3 `shiftL` 1) ^ (4 `shiftL` 1)+ + sectL :: Int -> Int+-sectL = (foo +)++sectL = (3 + 4 +)+ + sectR :: Int -> Int+-sectR = (+ foo)++sectR = (+ (3 + 4))+ + neg :: Int+ neg = negate $ 1+ + sectLower :: [Int] -> [Int]+-sectLower = (neg :)++sectLower = ((negate $ 1) :)+ + two :: [Int]+ two = [1] ++ [2]+ + sectAssoc :: [Int] -> [Int]+-sectAssoc = (two ++)++sectAssoc = (([1] ++ [2]) ++)+ + -- a record update's head must be atomic+ data R = R { r1 :: Int, r2 :: Int }+ + mkR :: R+ mkR = let x = 1 in R x 2+ + updR :: R+-updR = mkR { r2 = 3 }++updR = (let x = 1 in R x 2) { r2 = 3 }++ -- a projection's head must be atomic+ proj :: Int+-proj = mkR.r1++proj = (let x = 1 in R x 2).r1++ -- prefix minus binds like an infix-6 operator+ negFoo :: Int+-negFoo = - foo++negFoo = - (3 + 4)++ negBar :: Int+-negBar = - bar++negBar = - 5 `quot` foo++ type Fn a b = a -> b+ type MaybeInt = Maybe Int+ +-($!) :: Fn (a -> b) (a -> b)++($!) :: (a -> b) -> a -> b+ f $! x = f (x)+ +-(&!) :: a -> Fn (a -> b) b++(&!) :: a -> (a -> b) -> b+ (&!) x f = (f) x+ +-konst :: b -> Fn a b++konst :: b -> a -> b+ konst x _ = x+ +-noop :: Fn a a++noop :: a -> a+ noop x = x+ +-idMaybeInt :: MaybeInt -> MaybeInt++idMaybeInt :: Maybe Int -> Maybe Int+ idMaybeInt x = x+ +-swapEither :: (Either MaybeInt Int) -> Either Int MaybeInt++swapEither :: (Either (Maybe Int) Int) -> Either Int (Maybe Int)+ swapEither (Left x) = Right x+ swapEither (Right x) = Left x

@@ -1,4 +1,5 @@-# Copyright (c) Facebook, Inc. and its affiliates.+# Copyright (c) 2025 Andrew Farmer+# Copyright (c) 2020-2024 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.

@@ -1,4 +1,5 @@-# Copyright (c) Facebook, Inc. and its affiliates.+# Copyright (c) 2025 Andrew Farmer+# Copyright (c) 2020-2024 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.

@@ -1,4 +1,5 @@-# Copyright (c) Facebook, Inc. and its affiliates.+# Copyright (c) 2025 Andrew Farmer+# Copyright (c) 2020-2024 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.

@@ -1,4 +1,5 @@-# Copyright (c) Facebook, Inc. and its affiliates.+# Copyright (c) 2025 Andrew Farmer+# Copyright (c) 2020-2024 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.

@@ -1,4 +1,5 @@-# Copyright (c) Facebook, Inc. and its affiliates.+# Copyright (c) 2025 Andrew Farmer+# Copyright (c) 2020-2024 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.

@@ -1,4 +1,5 @@-# Copyright (c) Facebook, Inc. and its affiliates.+# Copyright (c) 2025 Andrew Farmer+# Copyright (c) 2020-2024 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.

@@ -1,4 +1,5 @@-# Copyright (c) Facebook, Inc. and its affiliates.+# Copyright (c) 2025 Andrew Farmer+# Copyright (c) 2020-2024 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.

@@ -1,4 +1,5 @@-# Copyright (c) Facebook, Inc. and its affiliates.+# Copyright (c) 2025 Andrew Farmer+# Copyright (c) 2020-2024 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.

@@ -1,4 +1,5 @@-# Copyright (c) Facebook, Inc. and its affiliates.+# Copyright (c) 2025 Andrew Farmer+# Copyright (c) 2020-2024 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.

@@ -1,4 +1,5 @@-# Copyright (c) Facebook, Inc. and its affiliates.+# Copyright (c) 2025 Andrew Farmer+# Copyright (c) 2020-2024 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.

@@ -1,4 +1,5 @@-# Copyright (c) Facebook, Inc. and its affiliates.+# Copyright (c) 2025 Andrew Farmer+# Copyright (c) 2020-2024 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.

@@ -1,4 +1,5 @@-# Copyright (c) Facebook, Inc. and its affiliates.+# Copyright (c) 2025 Andrew Farmer+# Copyright (c) 2020-2024 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.

@@ -1,4 +1,5 @@-# Copyright (c) Facebook, Inc. and its affiliates.+# Copyright (c) 2025 Andrew Farmer+# Copyright (c) 2020-2024 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.

@@ -1,4 +1,5 @@-# Copyright (c) Facebook, Inc. and its affiliates.+# Copyright (c) 2025 Andrew Farmer+# Copyright (c) 2020-2024 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.

@@ -1,4 +1,5 @@-# Copyright (c) Facebook, Inc. and its affiliates.+# Copyright (c) 2025 Andrew Farmer+# Copyright (c) 2020-2024 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.

@@ -1,4 +1,5 @@-# Copyright (c) Facebook, Inc. and its affiliates.+# Copyright (c) 2025 Andrew Farmer+# Copyright (c) 2020-2024 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.

@@ -1,4 +1,5 @@-# Copyright (c) Facebook, Inc. and its affiliates.+# Copyright (c) 2025 Andrew Farmer+# Copyright (c) 2020-2024 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.

@@ -0,0 +1,23 @@+# This source code is licensed under the MIT license found in the+# LICENSE file in the root directory of this source tree.+#+# Regression test for type applications in constructor patterns. On+# GHC >= 9.14 the type argument is an InvisPat element of the PrefixCon+# pattern list (older GHCs kept it in a separate tyargs field that retrie+# ignored). Unfolding baz runs patToExpr over its argument pattern+# (Just @Int x), which must ignore the type argument rather than crash+# with 'patToExpr InvisPat'.+-u TypeAbs.baz+===+ {-# LANGUAGE TypeApplications #-}+ {-# LANGUAGE TypeAbstractions #-}+ + module TypeAbs where+ + baz :: Maybe Int -> Int+ baz (Just @Int x) = x+ baz Nothing = 0+ + f :: Int+-f = baz (Just 1)++f = 1

@@ -0,0 +1,26 @@+# Types substituted into tuple, list and paren components must not be+# parenthesized because the enclosing brackets already delimit them.+--adhoc-type "T a b = U (a, b)"+--adhoc-type "L a = M [a]"+--adhoc-type "P a = Q (a)"+===+ module TypeParens where++ data T a b = T a b+ data U a = U a+ data L a = L a+ data M a = M a+ data P a = P a+ data Q a = Q a++-tup :: T (Maybe Int) (Int -> Bool)++tup :: U (Maybe Int, Int -> Bool)+ tup = T Nothing even++-lst :: L (Int -> Bool)++lst :: M [Int -> Bool]+ lst = L even++-par :: P (Maybe Int)++par :: Q (Maybe Int)+ par = P Nothing

@@ -1,4 +1,5 @@-# Copyright (c) Facebook, Inc. and its affiliates.+# Copyright (c) 2025 Andrew Farmer+# Copyright (c) 2020-2024 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.@@ -22,6 +23,25 @@    type Pointless a = a  type Fn a b = a -> b+ + data Meh = Meh+-  { entryKey :: Pointless (Int -> String)+-  , entryVal :: Fn Int String++  { entryKey :: Int -> String++  , entryVal :: Int -> String+   }+ +-getKey :: Meh -> Pointless (Int -> String)++getKey :: Meh -> Int -> String+ getKey m x = entryKey m x+ +-setKey :: Pointless (Int -> String) -> Meh -> Meh++setKey :: (Int -> String) -> Meh -> Meh+ setKey m k = m{ entryKey = k }+ +-errorKey :: Fn Int String++errorKey :: Int -> String+ errorKey = getKey undefined   -blah :: IO (Fn Int Bool) +blah :: IO (Int -> Bool)

@@ -1,10 +1,12 @@-# Copyright (c) Facebook, Inc. and its affiliates.+# Copyright (c) 2025 Andrew Farmer+# Copyright (c) 2020-2024 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+--type-forward Types2.Pair ===  module Types2 where  @@ -20,7 +22,12 @@ +blech2 :: Maybe Bar  blech2 = blech  +-blech3 :: Pair (Maybe Bar)++blech3 :: (Maybe Bar, Maybe Bar)+ blech3 = (blech2, blech2)+   type Foo = Either String Bar  type Bar = Int    type MyMaybe a = Maybe a+ type Pair a = (a, a)

@@ -1,4 +1,5 @@-# Copyright (c) Facebook, Inc. and its affiliates.+# Copyright (c) 2025 Andrew Farmer+# Copyright (c) 2020-2024 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.

@@ -1,4 +1,5 @@-# Copyright (c) Facebook, Inc. and its affiliates.+# Copyright (c) 2025 Andrew Farmer+# Copyright (c) 2020-2024 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.

@@ -1,4 +1,5 @@-# Copyright (c) Facebook, Inc. and its affiliates.+# Copyright (c) 2025 Andrew Farmer+# Copyright (c) 2020-2024 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.

@@ -0,0 +1,76 @@+# Unfolding a definition with a where clause moves the bindings into a let+-u WhereBindings.empty+-u WhereBindings.plain+-u WhereBindings.sig+-u WhereBindings.subst+-u WhereBindings.partial+-u WhereBindings.comm+===+ module WhereBindings where++ -- empty where bindings translate into empty let bindings+ empty x = x+   where++-test1 a = empty a++test1 a = let++           in a++ -- a single binding+ plain x = f x+   where+     f y = y + 1++-test2 x = plain x++test2 x = let++            f y = y + 1++           in f x++ -- binding with signature+ sig x = f x+   where+     f :: Int -> Int+     f y = y + 1++-test3 x = sig x++test3 x = let++            f :: Int -> Int++            f y = y + 1++           in f x++ -- ensure bindings are substituted+ subst x = y+   where+     y = x + 1++-test4 = subst 1++test4 = let++          y = 1 + 1++         in y++ -- check that the let is wrapped with a lambda correctly+ partial :: Int -> Int+ partial x = x * two+   where+     two = 2++-test5 = map partial [1, 2, 3]++test5 = map (\ x -> let++                      two = 2++                     in x * two) [1, 2, 3]++ -- make sure comments are preserved+ comm x = f x + h x+   -- a+   where+     f y = y + 1+     -- b+     h y = y++-test6 a = comm a++test6 a = let++            -- a++            f y = y + 1++            -- b++            h y = y++           in f a + h a