diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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. diff --git a/CODE_OF_CONDUCT.md b/CODE_OF_CONDUCT.md deleted file mode 100644 --- a/CODE_OF_CONDUCT.md +++ /dev/null @@ -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 . All -complaints will be reviewed and investigated and will result in a response that -is deemed necessary and appropriate to the circumstances. The project team is -obligated to maintain confidentiality with regard to the reporter of an incident. -Further details of specific enforcement policies may be posted separately. - -Project maintainers who do not follow or enforce the Code of Conduct in good -faith may face temporary or permanent repercussions as determined by other -members of the project's leadership. - -## Attribution - -This Code of Conduct is adapted from the [Contributor Covenant][homepage], version 1.4, -available at https://www.contributor-covenant.org/version/1/4/code-of-conduct.html - -[homepage]: https://www.contributor-covenant.org - -For answers to common questions about this code of conduct, see -https://www.contributor-covenant.org/faq diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md --- a/CONTRIBUTING.md +++ b/CONTRIBUTING.md @@ -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: +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 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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. diff --git a/Retrie.hs b/Retrie.hs --- a/Retrie.hs +++ b/Retrie.hs @@ -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. diff --git a/Retrie/AlphaEnv.hs b/Retrie/AlphaEnv.hs --- a/Retrie/AlphaEnv.hs +++ b/Retrie/AlphaEnv.hs @@ -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. diff --git a/Retrie/CPP.hs b/Retrie/CPP.hs --- a/Retrie/CPP.hs +++ b/Retrie/CPP.hs @@ -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 diff --git a/Retrie/Context.hs b/Retrie/Context.hs --- a/Retrie/Context.hs +++ b/Retrie/Context.hs @@ -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 diff --git a/Retrie/Debug.hs b/Retrie/Debug.hs --- a/Retrie/Debug.hs +++ b/Retrie/Debug.hs @@ -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. diff --git a/Retrie/Elaborate.hs b/Retrie/Elaborate.hs --- a/Retrie/Elaborate.hs +++ b/Retrie/Elaborate.hs @@ -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 diff --git a/Retrie/ExactPrint.hs b/Retrie/ExactPrint.hs --- a/Retrie/ExactPrint.hs +++ b/Retrie/ExactPrint.hs @@ -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', diff --git a/Retrie/ExactPrint/Annotated.hs b/Retrie/ExactPrint/Annotated.hs --- a/Retrie/ExactPrint/Annotated.hs +++ b/Retrie/ExactPrint/Annotated.hs @@ -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. diff --git a/Retrie/Expr.hs b/Retrie/Expr.hs --- a/Retrie/Expr.hs +++ b/Retrie/Expr.hs @@ -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 diff --git a/Retrie/Fixity.hs b/Retrie/Fixity.hs --- a/Retrie/Fixity.hs +++ b/Retrie/Fixity.hs @@ -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" diff --git a/Retrie/FreeVars.hs b/Retrie/FreeVars.hs --- a/Retrie/FreeVars.hs +++ b/Retrie/FreeVars.hs @@ -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) diff --git a/Retrie/GHC.hs b/Retrie/GHC.hs --- a/Retrie/GHC.hs +++ b/Retrie/GHC.hs @@ -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 diff --git a/Retrie/GroundTerms.hs b/Retrie/GroundTerms.hs --- a/Retrie/GroundTerms.hs +++ b/Retrie/GroundTerms.hs @@ -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. diff --git a/Retrie/Monad.hs b/Retrie/Monad.hs --- a/Retrie/Monad.hs +++ b/Retrie/Monad.hs @@ -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 diff --git a/Retrie/Options.hs b/Retrie/Options.hs --- a/Retrie/Options.hs +++ b/Retrie/Options.hs @@ -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 diff --git a/Retrie/PatternMap/Bag.hs b/Retrie/PatternMap/Bag.hs --- a/Retrie/PatternMap/Bag.hs +++ b/Retrie/PatternMap/Bag.hs @@ -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. diff --git a/Retrie/PatternMap/Class.hs b/Retrie/PatternMap/Class.hs --- a/Retrie/PatternMap/Class.hs +++ b/Retrie/PatternMap/Class.hs @@ -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. diff --git a/Retrie/PatternMap/Instances.hs b/Retrie/PatternMap/Instances.hs --- a/Retrie/PatternMap/Instances.hs +++ b/Retrie/PatternMap/Instances.hs @@ -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 diff --git a/Retrie/Pretty.hs b/Retrie/Pretty.hs --- a/Retrie/Pretty.hs +++ b/Retrie/Pretty.hs @@ -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 diff --git a/Retrie/Quantifiers.hs b/Retrie/Quantifiers.hs --- a/Retrie/Quantifiers.hs +++ b/Retrie/Quantifiers.hs @@ -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. diff --git a/Retrie/Query.hs b/Retrie/Query.hs --- a/Retrie/Query.hs +++ b/Retrie/Query.hs @@ -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. diff --git a/Retrie/Replace.hs b/Retrie/Replace.hs --- a/Retrie/Replace.hs +++ b/Retrie/Replace.hs @@ -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 diff --git a/Retrie/Rewrites.hs b/Retrie/Rewrites.hs --- a/Retrie/Rewrites.hs +++ b/Retrie/Rewrites.hs @@ -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) diff --git a/Retrie/Rewrites/Function.hs b/Retrie/Rewrites/Function.hs --- a/Retrie/Rewrites/Function.hs +++ b/Retrie/Rewrites/Function.hs @@ -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] diff --git a/Retrie/Rewrites/Patterns.hs b/Retrie/Rewrites/Patterns.hs --- a/Retrie/Rewrites/Patterns.hs +++ b/Retrie/Rewrites/Patterns.hs @@ -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] diff --git a/Retrie/Rewrites/Rules.hs b/Retrie/Rewrites/Rules.hs --- a/Retrie/Rewrites/Rules.hs +++ b/Retrie/Rewrites/Rules.hs @@ -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 diff --git a/Retrie/Rewrites/Types.hs b/Retrie/Rewrites/Types.hs --- a/Retrie/Rewrites/Types.hs +++ b/Retrie/Rewrites/Types.hs @@ -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 diff --git a/Retrie/Run.hs b/Retrie/Run.hs --- a/Retrie/Run.hs +++ b/Retrie/Run.hs @@ -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 diff --git a/Retrie/SYB.hs b/Retrie/SYB.hs --- a/Retrie/SYB.hs +++ b/Retrie/SYB.hs @@ -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 diff --git a/Retrie/Subst.hs b/Retrie/Subst.hs --- a/Retrie/Subst.hs +++ b/Retrie/Subst.hs @@ -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 diff --git a/Retrie/Substitution.hs b/Retrie/Substitution.hs --- a/Retrie/Substitution.hs +++ b/Retrie/Substitution.hs @@ -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. diff --git a/Retrie/Types.hs b/Retrie/Types.hs --- a/Retrie/Types.hs +++ b/Retrie/Types.hs @@ -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 diff --git a/Retrie/Universe.hs b/Retrie/Universe.hs --- a/Retrie/Universe.hs +++ b/Retrie/Universe.hs @@ -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. diff --git a/Retrie/Util.hs b/Retrie/Util.hs --- a/Retrie/Util.hs +++ b/Retrie/Util.hs @@ -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." ] diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -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. diff --git a/bin/Main.hs b/bin/Main.hs --- a/bin/Main.hs +++ b/bin/Main.hs @@ -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. diff --git a/demo/Main.hs b/demo/Main.hs --- a/demo/Main.hs +++ b/demo/Main.hs @@ -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. diff --git a/hse/Fixity.hs b/hse/Fixity.hs --- a/hse/Fixity.hs +++ b/hse/Fixity.hs @@ -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 diff --git a/retrie.cabal b/retrie.cabal --- a/retrie.cabal +++ b/retrie.cabal @@ -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 -maintainer: Andrew Farmer -copyright: Copyright (c) Facebook, Inc. and its affiliates. +author: Andrew Farmer +maintainer: Andrew Farmer +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 diff --git a/tests/AllTests.hs b/tests/AllTests.hs --- a/tests/AllTests.hs +++ b/tests/AllTests.hs @@ -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 diff --git a/tests/Annotated.hs b/tests/Annotated.hs --- a/tests/Annotated.hs +++ b/tests/Annotated.hs @@ -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 diff --git a/tests/CPP.hs b/tests/CPP.hs --- a/tests/CPP.hs +++ b/tests/CPP.hs @@ -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. diff --git a/tests/Demo.hs b/tests/Demo.hs --- a/tests/Demo.hs +++ b/tests/Demo.hs @@ -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. diff --git a/tests/Dependent.hs b/tests/Dependent.hs --- a/tests/Dependent.hs +++ b/tests/Dependent.hs @@ -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. diff --git a/tests/Exclude.hs b/tests/Exclude.hs --- a/tests/Exclude.hs +++ b/tests/Exclude.hs @@ -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, diff --git a/tests/Golden.hs b/tests/Golden.hs --- a/tests/Golden.hs +++ b/tests/Golden.hs @@ -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. diff --git a/tests/GroundTerms.hs b/tests/GroundTerms.hs --- a/tests/GroundTerms.hs +++ b/tests/GroundTerms.hs @@ -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. diff --git a/tests/Ignore.hs b/tests/Ignore.hs --- a/tests/Ignore.hs +++ b/tests/Ignore.hs @@ -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. diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -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 [] diff --git a/tests/ParseQualified.hs b/tests/ParseQualified.hs --- a/tests/ParseQualified.hs +++ b/tests/ParseQualified.hs @@ -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. diff --git a/tests/Targets.hs b/tests/Targets.hs --- a/tests/Targets.hs +++ b/tests/Targets.hs @@ -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" diff --git a/tests/Util.hs b/tests/Util.hs --- a/tests/Util.hs +++ b/tests/Util.hs @@ -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 diff --git a/tests/inputs/Adhoc.test b/tests/inputs/Adhoc.test --- a/tests/inputs/Adhoc.test +++ b/tests/inputs/Adhoc.test @@ -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. diff --git a/tests/inputs/Adhoc2.custom b/tests/inputs/Adhoc2.custom --- a/tests/inputs/Adhoc2.custom +++ b/tests/inputs/Adhoc2.custom @@ -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. diff --git a/tests/inputs/Backticks.test b/tests/inputs/Backticks.test --- a/tests/inputs/Backticks.test +++ b/tests/inputs/Backticks.test @@ -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. diff --git a/tests/inputs/Backticks2.test b/tests/inputs/Backticks2.test --- a/tests/inputs/Backticks2.test +++ b/tests/inputs/Backticks2.test @@ -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 diff --git a/tests/inputs/Backticks3.test b/tests/inputs/Backticks3.test new file mode 100644 --- /dev/null +++ b/tests/inputs/Backticks3.test @@ -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 diff --git a/tests/inputs/CPP.test b/tests/inputs/CPP.test --- a/tests/inputs/CPP.test +++ b/tests/inputs/CPP.test @@ -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 diff --git a/tests/inputs/CPPConflict.test b/tests/inputs/CPPConflict.test --- a/tests/inputs/CPPConflict.test +++ b/tests/inputs/CPPConflict.test @@ -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. diff --git a/tests/inputs/CPPLayout.test b/tests/inputs/CPPLayout.test new file mode 100644 --- /dev/null +++ b/tests/inputs/CPPLayout.test @@ -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 diff --git a/tests/inputs/Capture.test b/tests/inputs/Capture.test --- a/tests/inputs/Capture.test +++ b/tests/inputs/Capture.test @@ -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. diff --git a/tests/inputs/Combined.test b/tests/inputs/Combined.test --- a/tests/inputs/Combined.test +++ b/tests/inputs/Combined.test @@ -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 diff --git a/tests/inputs/Commas.test b/tests/inputs/Commas.test --- a/tests/inputs/Commas.test +++ b/tests/inputs/Commas.test @@ -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) diff --git a/tests/inputs/Comments.test b/tests/inputs/Comments.test --- a/tests/inputs/Comments.test +++ b/tests/inputs/Comments.test @@ -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] diff --git a/tests/inputs/DependentStmt.custom b/tests/inputs/DependentStmt.custom --- a/tests/inputs/DependentStmt.custom +++ b/tests/inputs/DependentStmt.custom @@ -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. diff --git a/tests/inputs/FixityAnnotations.test b/tests/inputs/FixityAnnotations.test new file mode 100644 --- /dev/null +++ b/tests/inputs/FixityAnnotations.test @@ -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 diff --git a/tests/inputs/Foo.test b/tests/inputs/Foo.test --- a/tests/inputs/Foo.test +++ b/tests/inputs/Foo.test @@ -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. diff --git a/tests/inputs/FooFold.test b/tests/inputs/FooFold.test --- a/tests/inputs/FooFold.test +++ b/tests/inputs/FooFold.test @@ -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. diff --git a/tests/inputs/Imports.test b/tests/inputs/Imports.test --- a/tests/inputs/Imports.test +++ b/tests/inputs/Imports.test @@ -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. diff --git a/tests/inputs/Iterate.test b/tests/inputs/Iterate.test --- a/tests/inputs/Iterate.test +++ b/tests/inputs/Iterate.test @@ -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. diff --git a/tests/inputs/Layout.test b/tests/inputs/Layout.test new file mode 100644 --- /dev/null +++ b/tests/inputs/Layout.test @@ -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 diff --git a/tests/inputs/MatchGroup.test b/tests/inputs/MatchGroup.test --- a/tests/inputs/MatchGroup.test +++ b/tests/inputs/MatchGroup.test @@ -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. diff --git a/tests/inputs/Operator.test b/tests/inputs/Operator.test --- a/tests/inputs/Operator.test +++ b/tests/inputs/Operator.test @@ -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. diff --git a/tests/inputs/Parens.test b/tests/inputs/Parens.test --- a/tests/inputs/Parens.test +++ b/tests/inputs/Parens.test @@ -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 diff --git a/tests/inputs/PartialF.test b/tests/inputs/PartialF.test --- a/tests/inputs/PartialF.test +++ b/tests/inputs/PartialF.test @@ -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. diff --git a/tests/inputs/PartialU.test b/tests/inputs/PartialU.test --- a/tests/inputs/PartialU.test +++ b/tests/inputs/PartialU.test @@ -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. diff --git a/tests/inputs/PatBind.test b/tests/inputs/PatBind.test --- a/tests/inputs/PatBind.test +++ b/tests/inputs/PatBind.test @@ -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. diff --git a/tests/inputs/PatternSyn1.test b/tests/inputs/PatternSyn1.test --- a/tests/inputs/PatternSyn1.test +++ b/tests/inputs/PatternSyn1.test @@ -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. diff --git a/tests/inputs/PatternSyn2.test b/tests/inputs/PatternSyn2.test --- a/tests/inputs/PatternSyn2.test +++ b/tests/inputs/PatternSyn2.test @@ -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. diff --git a/tests/inputs/Qualified.test b/tests/inputs/Qualified.test --- a/tests/inputs/Qualified.test +++ b/tests/inputs/Qualified.test @@ -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. diff --git a/tests/inputs/Query.custom b/tests/inputs/Query.custom --- a/tests/inputs/Query.custom +++ b/tests/inputs/Query.custom @@ -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. diff --git a/tests/inputs/Readme.custom b/tests/inputs/Readme.custom --- a/tests/inputs/Readme.custom +++ b/tests/inputs/Readme.custom @@ -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. diff --git a/tests/inputs/Readme1.test b/tests/inputs/Readme1.test --- a/tests/inputs/Readme1.test +++ b/tests/inputs/Readme1.test @@ -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. diff --git a/tests/inputs/Readme2.test b/tests/inputs/Readme2.test --- a/tests/inputs/Readme2.test +++ b/tests/inputs/Readme2.test @@ -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. diff --git a/tests/inputs/Readme3.test b/tests/inputs/Readme3.test --- a/tests/inputs/Readme3.test +++ b/tests/inputs/Readme3.test @@ -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. diff --git a/tests/inputs/Readme4.test b/tests/inputs/Readme4.test --- a/tests/inputs/Readme4.test +++ b/tests/inputs/Readme4.test @@ -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. diff --git a/tests/inputs/Readme5.test b/tests/inputs/Readme5.test --- a/tests/inputs/Readme5.test +++ b/tests/inputs/Readme5.test @@ -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. diff --git a/tests/inputs/Records.test b/tests/inputs/Records.test --- a/tests/inputs/Records.test +++ b/tests/inputs/Records.test @@ -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. diff --git a/tests/inputs/Records2.test b/tests/inputs/Records2.test --- a/tests/inputs/Records2.test +++ b/tests/inputs/Records2.test @@ -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. diff --git a/tests/inputs/Recursion.test b/tests/inputs/Recursion.test --- a/tests/inputs/Recursion.test +++ b/tests/inputs/Recursion.test @@ -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. diff --git a/tests/inputs/Shadowing.test b/tests/inputs/Shadowing.test --- a/tests/inputs/Shadowing.test +++ b/tests/inputs/Shadowing.test @@ -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. diff --git a/tests/inputs/TypeAbs.test b/tests/inputs/TypeAbs.test new file mode 100644 --- /dev/null +++ b/tests/inputs/TypeAbs.test @@ -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 diff --git a/tests/inputs/TypeParens.test b/tests/inputs/TypeParens.test new file mode 100644 --- /dev/null +++ b/tests/inputs/TypeParens.test @@ -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 diff --git a/tests/inputs/Types.test b/tests/inputs/Types.test --- a/tests/inputs/Types.test +++ b/tests/inputs/Types.test @@ -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) diff --git a/tests/inputs/Types2.test b/tests/inputs/Types2.test --- a/tests/inputs/Types2.test +++ b/tests/inputs/Types2.test @@ -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) diff --git a/tests/inputs/Types3.test b/tests/inputs/Types3.test --- a/tests/inputs/Types3.test +++ b/tests/inputs/Types3.test @@ -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. diff --git a/tests/inputs/Types4.test b/tests/inputs/Types4.test --- a/tests/inputs/Types4.test +++ b/tests/inputs/Types4.test @@ -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. diff --git a/tests/inputs/Union.test b/tests/inputs/Union.test --- a/tests/inputs/Union.test +++ b/tests/inputs/Union.test @@ -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. diff --git a/tests/inputs/WhereBindings.test b/tests/inputs/WhereBindings.test new file mode 100644 --- /dev/null +++ b/tests/inputs/WhereBindings.test @@ -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