diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,41 @@ +## Tilia 0.1.2.0 + +* A comment written beside the `..` of an item of an import or export list, + as in `T ({- c -} ..)`, stays inside its parentheses rather than moving to + the item after it. [Issue 254](https://github.com/mrkkrp/tilia/issues/254). +* A fixity declaration written without a precedence, such as + ``infixr `cons` ``, comes out without one rather than with the `9` it + defaults to. [Issue 267](https://github.com/mrkkrp/tilia/issues/267). +* The `where` of a module header written once after the `#endif` of a + conditional around the export list stays there rather than being copied + into each branch, and comments written right before or after it stay on + their side of it. [Issue 266](https://github.com/mrkkrp/tilia/issues/266). +* Code that one branch of a conditional puts a prefix in front of, such as + `again $`, comes out once after the `#endif` rather than in each branch + where it is written at the column of the prefix. + [Issue 263](https://github.com/mrkkrp/tilia/issues/263). +* A comment carrying on the remark that ends the line above stays with that + remark where it is lined up under it and the code under the comment begins + at the same column, or where it is indented further than the remark, + rather than going with the code that follows. + [Issue 255](https://github.com/mrkkrp/tilia/issues/255). +* With `UnboxedTuples` on, as with `UnboxedSums` already, an operator that + begins with `#` keeps the space after an opening parenthesis, as in + `( #<| )` and the section `( #<| x)`, and `#` alone the space before a + closing one, as in `(x # )`, rather than coming out as `(#` or `#)`, which + do not parse. [Issue 273](https://github.com/mrkkrp/tilia/issues/273). +* A comment under a quasi-quotation written over several lines stays out of + it, rather than being moved before its `|]`, which changed what was + quoted. [Issue 274](https://github.com/mrkkrp/tilia/issues/274). +* A module that begins with a byte order mark, which GHC skips, is + formatted and keeps the mark, and fixities are taken from a project module + that begins with one, rather than its not parsing. + [Issue 275](https://github.com/mrkkrp/tilia/issues/275). +* `Tilia.Editor.compiledSession` builds a session from what a program that + has compiled the project already knows, such as a language server, so that + formatting needs neither Cabal nor the sources of dependencies. + [Issue 234](https://github.com/mrkkrp/tilia/issues/234). + ## Tilia 0.1.1.0 * Keep code that every configuration prints alike out of the branches of a diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -45,6 +45,7 @@ * `lib:tilia` or `tilia:lib:tilia` * `exe:tilia` or `tilia:exe:tilia` * `test:tests` or `tilia:test:tests`, or just `tests` +* `bench:bench` or `tilia:bench:bench`, or just `bench` It may be surprising that we talk about components rather than individual files. Well, formatting a Haskell module, fortunately or unfortunately, diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -17,7 +17,7 @@ import GHC.IO.Encoding (TextEncoding (textEncodingName)) import Options.Applicative import Paths_tilia (version) -import System.Directory (makeRelativeToCurrentDirectory) +import System.Directory (getCurrentDirectory, makeRelativeToCurrentDirectory) import System.Exit (ExitCode (..)) import System.Exit qualified import System.IO @@ -43,7 +43,7 @@ import Tilia.Editor (editorSession, formatBuffer) import Tilia.Fixity.Debug (renderFixityNotes) import Tilia.Format - ( FormatError (Unreadable), + ( FormatError (NoProject, Unreadable), PlanSource (..), Session, describeFormatError, @@ -106,7 +106,7 @@ =<< filesOfComponents root components session <- newSession - "." + root ( case optBuildPlan of Nothing -> PlanFromCabal (mapMaybe componentInPlan components) Just givenPlan -> GivenPlan givenPlan @@ -217,8 +217,7 @@ componentsFor :: Palette -> Target -> IO (ProjectRoot, [Component]) componentsFor palette target = findProjectRoot "." >>= \case - Nothing -> - die 2 palette "no cabal.project or .cabal file at or above the working directory" + Nothing -> dieFormatting palette . NoProject =<< getCurrentDirectory Just root -> componentsOfTarget root target >>= \case Left problem -> diff --git a/bench/Tilia/Bench/Cases.hs b/bench/Tilia/Bench/Cases.hs --- a/bench/Tilia/Bench/Cases.hs +++ b/bench/Tilia/Bench/Cases.hs @@ -22,13 +22,11 @@ import Data.Traversable (for) import GHC.LanguageExtensions.Type (Extension) import Tilia.Corpus (Example (..)) -import Tilia.Cpp (everyBranch, formatWithCpp, usesCpp) -import Tilia.Doc (defaultRenderOptions, printDoc) +import Tilia.Cpp (usesCpp) import Tilia.Format (rewritten) -import Tilia.Parser (parseModule, parserConfigFor) -import Tilia.Pragma (effectiveExtensions) -import Tilia.Render (defaultRenderConfig, renderModule) -import Tilia.TestConfig (exampleRenderConfig) +import Tilia.Parser (parseModule) +import Tilia.TestConfig (formatCppExample, printExample) +import Tilia.TestUtils (effectiveExtensionsFor, parserConfigFor) -- | What part of a run a benchmark measures. data Stage @@ -147,10 +145,10 @@ -- | Modules made to stress one part of the formatter each. syntheticSubjects :: [Subject] syntheticSubjects = - [ subjectOf [] False "synthetic/comments" commented, - subjectOf [] False "synthetic/imports" imported, - subjectOf [] False "synthetic/conditionals" conditional, - subjectOf [] False "synthetic/nesting" nested + [ subjectOf Nothing False "synthetic/comments" commented, + subjectOf Nothing False "synthetic/imports" imported, + subjectOf Nothing False "synthetic/conditionals" conditional, + subjectOf Nothing False "synthetic/nesting" nested ] where commented = @@ -205,7 +203,7 @@ -- | A module to format, and to check what that printed where it is -- checked. -subjectOf :: [Extension] -> Bool -> Text -> Text -> Subject +subjectOf :: Maybe [Extension] -> Bool -> Text -> Text -> Subject subjectOf package isChecked name source = Subject { subjectName = name, @@ -219,29 +217,19 @@ where path = T.unpack name parser = parserConfigFor package - cpp = usesCpp (effectiveExtensions package source) source + cpp = usesCpp (effectiveExtensionsFor package source) source tree | cpp = Nothing | otherwise = either (const Nothing) Just (parseModule parser path source) -- | What formatting a module prints, as the corpus does it, or 'Nothing' -- where it is declined. -formatted :: [Extension] -> FilePath -> Text -> Maybe Text +formatted :: Maybe [Extension] -> FilePath -> Text -> Maybe Text formatted package path source - | usesCpp (effectiveExtensions package source) source = - either (const Nothing) Just (formatWithCpp parser configured path source) - | otherwise = case parseModule parser path source of - Left _ -> Nothing - Right p -> - Just - ( printDoc - defaultRenderOptions - (renderModule (exampleRenderConfig package source (pure p)) p) - ) - where - parser = parserConfigFor package - configured = - maybe - defaultRenderConfig - (exampleRenderConfig package source) - (everyBranch parser path source) + | usesCpp (effectiveExtensionsFor package source) source = + either (const Nothing) Just (formatCppExample package path source) + | otherwise = + either + (const Nothing) + (Just . printExample package source) + (parseModule (parserConfigFor package) path source) diff --git a/bench/Tilia/Bench/Fixity.hs b/bench/Tilia/Bench/Fixity.hs --- a/bench/Tilia/Bench/Fixity.hs +++ b/bench/Tilia/Bench/Fixity.hs @@ -30,11 +30,12 @@ doesFileExist, removePathForcibly, ) -import System.Environment (lookupEnv, setEnv, unsetEnv) import System.FilePath ((<.>), ()) import System.Process (getCurrentPid) import Text.Printf (printf) import Tilia.Bench.Cases (Benchmark (..), Stage (..)) +import Tilia.Cabal.Package (newPackageReader) +import Tilia.Cabal.Plan import Tilia.Corpus (Corpus (..), Source (..), corpusCache, hackagePackages) import Tilia.Fixity.Cabal (packageModules) import Tilia.Fixity.Cache (Cache, PlanToken (..), openCache) @@ -46,6 +47,7 @@ readInstalledPackages, ) import Tilia.Fixity.Plan +import Tilia.TestUtils (withEnvironment) -- | The packages of the Hackage corpus whose every module is read. resolved :: [Text] @@ -207,7 +209,8 @@ cache <- cacheUnder (dir "cache") interfaces <- interfacesOf decoded let reading kept modules = do - resolver <- newResolverWith [FromSource] kept [] tarballs plan + packageReader <- newPackageReader (plannedCompiler plan) + resolver <- newResolverWith [FromSource] kept [] tarballs packageReader plan pure $ do answers <- traverse (askModule resolver) modules length <$> evaluate (force answers) @@ -248,12 +251,10 @@ -- | A cache of fixities in a directory. cacheUnder :: FilePath -> IO Cache -cacheUnder dir = do - before <- lookupEnv "XDG_CACHE_HOME" - setEnv "XDG_CACHE_HOME" dir - cache <- openCache (Do #useCache) (PlanToken "benchmarks") - maybe (unsetEnv "XDG_CACHE_HOME") (setEnv "XDG_CACHE_HOME") before - pure cache +cacheUnder dir = + withEnvironment + [("XDG_CACHE_HOME", dir)] + (openCache (Do #useCache) (PlanToken "benchmarks")) -- | The interfaces of every module of the installed packages named, each -- package by its name and version. diff --git a/bench/bench.record b/bench/bench.record --- a/bench/bench.record +++ b/bench/bench.record @@ -31,13 +31,13 @@ # stage allocated instructions benchmark check 272354648 575981358 Agda-2.8.0/src/full/Agda/Syntax/Translation/ConcreteToAbstract.hs check 411823456 855523727 ShellCheck-0.11.0/src/ShellCheck/Analytics.hs -check 260526152 461063479 aeson-2.3.1.0/src/Data/Aeson/KeyMap.hs +check 260497296 461063479 aeson-2.3.1.0/src/Data/Aeson/KeyMap.hs check 196550504 511610069 blaze-html-0.9.2.0/src/Text/Blaze/Html5/Attributes.hs check 63623696 127394098 brittany-0.14.0.2/source/library/Language/Haskell/Brittany/Internal/Transformations/Alt.hs check 84949968 171830970 distributed-process-0.7.8/src/Control/Distributed/Process/Node.hs check 127362696 266504214 esqueleto-3.6.0.3/test/PostgreSQL/Test.hs check 506858784 923788756 haxl-2.5.1.1/Haxl/Core/Monad.hs -check 215891816 451467945 idris-1.3.4/src/Idris/Elab/Term.hs +check 215914784 451467945 idris-1.3.4/src/Idris/Elab/Term.hs check 333601000 572292120 lifted-base-0.2.3.12/Control/Exception/Lifted.hs check 60171824 128139113 megaparsec-9.8.1/Text/Megaparsec/Internal.hs check 81898560 173856514 optparse-applicative-0.19.0.0/tests/test.hs @@ -61,61 +61,61 @@ decode 42252744 55499725 ghc-internal-9.1003.0 decode 11189560 15486875 template-haskell-2.22.0.0 decode 6097120 6605095 text-2.1.3 -format 586993080 1135630753 Agda-2.8.0/src/full/Agda/Syntax/Translation/ConcreteToAbstract.hs -format 4059772616 8036874388 QuickCheck-2.18.0.0/src/Test/QuickCheck/Arbitrary.hs +format 587068744 1136108572 Agda-2.8.0/src/full/Agda/Syntax/Translation/ConcreteToAbstract.hs +format 4060865072 8041341103 QuickCheck-2.18.0.0/src/Test/QuickCheck/Arbitrary.hs format 907373856 1723990920 ShellCheck-0.11.0/src/ShellCheck/Analytics.hs -format 330306320 571456793 aeson-2.3.1.0/src/Data/Aeson/KeyMap.hs -format 174818320 326282752 blaze-html-0.9.2.0/src/Text/Blaze/Html5/Attributes.hs -format 125893136 239428886 brittany-0.14.0.2/source/library/Language/Haskell/Brittany/Internal/Transformations/Alt.hs -format 181975648 344891996 distributed-process-0.7.8/src/Control/Distributed/Process/Node.hs -format 313302256 590497159 esqueleto-3.6.0.3/test/PostgreSQL/Test.hs -format 772624688 1542323569 haxl-2.5.1.1/Haxl/Core/Monad.hs -format 505622568 964281131 idris-1.3.4/src/Idris/Elab/Term.hs +format 330450600 571670315 aeson-2.3.1.0/src/Data/Aeson/KeyMap.hs +format 175030840 326850369 blaze-html-0.9.2.0/src/Text/Blaze/Html5/Attributes.hs +format 125920744 239525469 brittany-0.14.0.2/source/library/Language/Haskell/Brittany/Internal/Transformations/Alt.hs +format 182428296 345883719 distributed-process-0.7.8/src/Control/Distributed/Process/Node.hs +format 313363824 590647912 esqueleto-3.6.0.3/test/PostgreSQL/Test.hs +format 773029152 1543414928 haxl-2.5.1.1/Haxl/Core/Monad.hs +format 505953528 965039048 idris-1.3.4/src/Idris/Elab/Term.hs format 1340529160 2711040392 lens-5.3.6/src/Control/Lens/Wrapped.hs -format 403478464 737112328 lifted-base-0.2.3.12/Control/Exception/Lifted.hs -format 115314000 221071613 megaparsec-9.8.1/Text/Megaparsec/Internal.hs +format 403596632 737287954 lifted-base-0.2.3.12/Control/Exception/Lifted.hs +format 115350240 221131009 megaparsec-9.8.1/Text/Megaparsec/Internal.hs format 152138968 278467498 optparse-applicative-0.19.0.0/tests/test.hs -format 54506128 96618849 pandoc-3.10.2/src/Text/Pandoc/Class/PandocPure.hs -format 377550600 719032510 pandoc-3.10.2/src/Text/Pandoc/Readers/Markdown.hs -format 466875216 881659030 pandoc-3.10.2/src/Text/Pandoc/Writers/Powerpoint/Output.hs -format 374789216 709072870 purescript-0.15.15/src/Language/PureScript/Errors.hs -format 157590744 293012445 purescript-0.15.15/src/Language/PureScript/TypeChecker/Types.hs -format 129266384 233552107 recursion-schemes-5.2.3/src/Data/Functor/Foldable.hs -format 173044184 323789142 servant-server-0.20.3.0/src/Servant/Server/Internal.hs -format 174955608 327851739 swagger2-2.9.1/src/Data/Swagger/Internal.hs -format 716397560 1506784284 synthetic/comments -format 107750736 237375293 synthetic/conditionals -format 75942320 112110399 synthetic/imports +format 54554184 96700081 pandoc-3.10.2/src/Text/Pandoc/Class/PandocPure.hs +format 377676272 719453674 pandoc-3.10.2/src/Text/Pandoc/Readers/Markdown.hs +format 466875216 881809887 pandoc-3.10.2/src/Text/Pandoc/Writers/Powerpoint/Output.hs +format 375024840 709592247 purescript-0.15.15/src/Language/PureScript/Errors.hs +format 157667592 293149746 purescript-0.15.15/src/Language/PureScript/TypeChecker/Types.hs +format 129432696 233813267 recursion-schemes-5.2.3/src/Data/Functor/Foldable.hs +format 173127584 323770122 servant-server-0.20.3.0/src/Servant/Server/Internal.hs +format 175020056 327970368 swagger2-2.9.1/src/Data/Swagger/Internal.hs +format 716528888 1507106872 synthetic/comments +format 107796160 237491710 synthetic/conditionals +format 77608272 114637794 synthetic/imports format 99934472 207607344 synthetic/nesting -format 838934536 1651811978 text-2.1.4/src/Data/Text/Internal/Fusion/CaseMapping.hs -format 223463632 390867496 text-2.1.4/tests/Tests/Properties/Folds.hs -format 139006432 258150558 time-1.16.0.1/test/main/Test/Format/ParseTime.hs -format 139530880 263037198 tls-2.4.3/Network/TLS/Extension.hs -format 1012732608 1984898669 unordered-containers-0.2.21/Data/HashMap/Internal.hs -format 509614800 951730877 unpacked-containers-0/src/Map/Internal.hs -format 551766528 1043391813 vector-0.13.2.0/src/Data/Vector/Generic.hs -format 139402192 260910396 xmonad-0.18.1/src/XMonad/Operations.hs -recall 5159192 11629716 aeson-2.3.1.0 -recall 2222736 5117209 conduit-1.3.6.1 -recall 1711296 3256971 free-5.2 -recall 11087912 34729465 lens-5.3.6 -recall 1794808 3797182 megaparsec-9.8.1 -recall 2130864 4316158 mtl-2.3.2 -recall 1290456 2773511 optics-0.4.2.1 -recall 1533048 3627916 pandoc-types-1.23.1.2 -recall 2303032 4716532 semigroupoids-6.0.2 -recall 3296464 6712375 servant-0.20.3.0 -recall 5195216 9137639 text-2.1.4 -recall 4064960 8696024 vector-0.13.2.0 -resolve 1871048824 3295554158 aeson-2.3.1.0 -resolve 444504256 757669620 conduit-1.3.6.1 -resolve 487648992 826960067 free-5.2 -resolve 3076558528 5353588555 lens-5.3.6 -resolve 216507192 378740037 megaparsec-9.8.1 -resolve 233565064 403415365 mtl-2.3.2 -resolve 65725248 132703282 optics-0.4.2.1 -resolve 78157216 145313962 pandoc-types-1.23.1.2 -resolve 138235048 248322418 semigroupoids-6.0.2 -resolve 219372680 404689330 servant-0.20.3.0 -resolve 1185759448 2051011736 text-2.1.4 -resolve 2471261160 4205683979 vector-0.13.2.0 +format 839857072 1653646287 text-2.1.4/src/Data/Text/Internal/Fusion/CaseMapping.hs +format 223534696 391051730 text-2.1.4/tests/Tests/Properties/Folds.hs +format 139006432 258193642 time-1.16.0.1/test/main/Test/Format/ParseTime.hs +format 139928120 263889581 tls-2.4.3/Network/TLS/Extension.hs +format 1012993016 1985300102 unordered-containers-0.2.21/Data/HashMap/Internal.hs +format 509562512 951647762 unpacked-containers-0/src/Map/Internal.hs +format 551911832 1043593184 vector-0.13.2.0/src/Data/Vector/Generic.hs +format 139491808 261133367 xmonad-0.18.1/src/XMonad/Operations.hs +recall 5154088 11631440 aeson-2.3.1.0 +recall 2222200 5118396 conduit-1.3.6.1 +recall 1709976 3278498 free-5.2 +recall 11088696 34739875 lens-5.3.6 +recall 1793600 3797411 megaparsec-9.8.1 +recall 2129136 4316346 mtl-2.3.2 +recall 1289808 2773580 optics-0.4.2.1 +recall 1532472 3627916 pandoc-types-1.23.1.2 +recall 2301760 4717796 semigroupoids-6.0.2 +recall 3293336 6712858 servant-0.20.3.0 +recall 5188496 9120737 text-2.1.4 +recall 4061800 8698087 vector-0.13.2.0 +resolve 1810656152 3180580388 aeson-2.3.1.0 +resolve 435325168 738034252 conduit-1.3.6.1 +resolve 471290256 797760851 free-5.2 +resolve 2974846416 5176070738 lens-5.3.6 +resolve 210109008 366801169 megaparsec-9.8.1 +resolve 225682064 388972813 mtl-2.3.2 +resolve 64290384 128790701 optics-0.4.2.1 +resolve 77403992 142729351 pandoc-types-1.23.1.2 +resolve 133167224 239714598 semigroupoids-6.0.2 +resolve 213362072 390356497 servant-0.20.3.0 +resolve 1159785776 1994326073 text-2.1.4 +resolve 2408709680 4066724655 vector-0.13.2.0 diff --git a/corpora/hackage/hackage.manifest b/corpora/hackage/hackage.manifest --- a/corpora/hackage/hackage.manifest +++ b/corpora/hackage/hackage.manifest @@ -22,7 +22,7 @@ formatted a5e37499e9c4 Agda-2.8.0/src/full/Agda/Compiler/MAlonzo/Encode.hs formatted be07bfaffa2e Agda-2.8.0/src/full/Agda/Compiler/MAlonzo/HaskellTypes.hs formatted aa62f795f1b2 Agda-2.8.0/src/full/Agda/Compiler/MAlonzo/Misc.hs -formatted 70bbea601ddf Agda-2.8.0/src/full/Agda/Compiler/MAlonzo/Pragmas.hs +formatted 3102bb30026e Agda-2.8.0/src/full/Agda/Compiler/MAlonzo/Pragmas.hs formatted 76490fc3bd40 Agda-2.8.0/src/full/Agda/Compiler/MAlonzo/Pretty.hs formatted 92ef6a29a48a Agda-2.8.0/src/full/Agda/Compiler/MAlonzo/Primitives.hs formatted cd156da2fa25 Agda-2.8.0/src/full/Agda/Compiler/MAlonzo/Strict.hs @@ -42,7 +42,7 @@ formatted 4795b9a43709 Agda-2.8.0/src/full/Agda/Compiler/Treeless/Simplify.hs formatted 80fddf5d858f Agda-2.8.0/src/full/Agda/Compiler/Treeless/Subst.hs formatted 83543a8ec338 Agda-2.8.0/src/full/Agda/Compiler/Treeless/Uncase.hs -formatted 24aeb7ff3365 Agda-2.8.0/src/full/Agda/Compiler/Treeless/Unused.hs +formatted 9bc8388d8beb Agda-2.8.0/src/full/Agda/Compiler/Treeless/Unused.hs formatted 3985ec175c5f Agda-2.8.0/src/full/Agda/ImpossibleTest.hs formatted 4bfae407a40f Agda-2.8.0/src/full/Agda/Interaction/AgdaTop.hs formatted f35eb355b24e Agda-2.8.0/src/full/Agda/Interaction/Base.hs @@ -52,7 +52,7 @@ formatted e4f2d0d2088e Agda-2.8.0/src/full/Agda/Interaction/CommandLine.hs formatted f2285f3b69f7 Agda-2.8.0/src/full/Agda/Interaction/EmacsCommand.hs formatted 555155a56d86 Agda-2.8.0/src/full/Agda/Interaction/EmacsTop.hs -formatted 720e5305288c Agda-2.8.0/src/full/Agda/Interaction/ExitCode.hs +formatted 05a9823fff57 Agda-2.8.0/src/full/Agda/Interaction/ExitCode.hs formatted e06156bc2afa Agda-2.8.0/src/full/Agda/Interaction/FindFile.hs formatted 3170eb1921b4 Agda-2.8.0/src/full/Agda/Interaction/Highlighting/Common.hs formatted 1fb0462a1b45 Agda-2.8.0/src/full/Agda/Interaction/Highlighting/Dot.hs @@ -202,7 +202,7 @@ formatted 59bd9e3da33e Agda-2.8.0/src/full/Agda/TypeChecking/DiscrimTree.hs formatted c17cb27af1b5 Agda-2.8.0/src/full/Agda/TypeChecking/DiscrimTree/Types.hs formatted ee105b08c0e0 Agda-2.8.0/src/full/Agda/TypeChecking/DisplayForm.hs -formatted fa3908c1bf4b Agda-2.8.0/src/full/Agda/TypeChecking/DropArgs.hs +formatted 2c03c6d0d27b Agda-2.8.0/src/full/Agda/TypeChecking/DropArgs.hs formatted c4bcc3ec3efc Agda-2.8.0/src/full/Agda/TypeChecking/Empty.hs formatted 546e2690c8bd Agda-2.8.0/src/full/Agda/TypeChecking/Empty.hs-boot formatted d796fe01f1e9 Agda-2.8.0/src/full/Agda/TypeChecking/Errors.hs @@ -473,7 +473,7 @@ formatted 09230f4d022f QuickCheck-2.18.0.0/src/Test/QuickCheck/Monadic.hs formatted a94b9d13da2f QuickCheck-2.18.0.0/src/Test/QuickCheck/Monoids.hs formatted 0c4f8c706edf QuickCheck-2.18.0.0/src/Test/QuickCheck/Poly.hs -formatted 7ad2b4286dd4 QuickCheck-2.18.0.0/src/Test/QuickCheck/Property.hs +formatted 3c937d9861f1 QuickCheck-2.18.0.0/src/Test/QuickCheck/Property.hs formatted d248979763fb QuickCheck-2.18.0.0/src/Test/QuickCheck/Random.hs formatted 67a6c49f2d76 QuickCheck-2.18.0.0/src/Test/QuickCheck/State.hs formatted d6690aaf2529 QuickCheck-2.18.0.0/src/Test/QuickCheck/Test.hs @@ -612,7 +612,7 @@ formatted e865ae48f11b ansi-terminal-1.1.5/Setup.hs formatted 075adef817c3 ansi-terminal-1.1.5/app/Example.hs formatted 5cffc9cf8231 ansi-terminal-1.1.5/src/System/Console/ANSI.hs -formatted 46d19416edeb ansi-terminal-1.1.5/unix/System/Console/ANSI/Internal.hs +formatted 820497cc6023 ansi-terminal-1.1.5/unix/System/Console/ANSI/Internal.hs formatted 1cc713a3f254 ansi-terminal-1.1.5/win/System/Console/ANSI/Internal.hs formatted 1aaa3e2316a9 ansi-terminal-1.1.5/win/System/Console/ANSI/Windows/Foreign.hs formatted e763680dce5b ansi-terminal-1.1.5/win/System/Console/ANSI/Windows/Win32/Types.hs @@ -651,7 +651,7 @@ formatted 8fa6e462f95f attoparsec-0.14.4/benchmarks/Links.hs formatted f582abe3e244 attoparsec-0.14.4/benchmarks/Numbers.hs formatted 696be472825c attoparsec-0.14.4/benchmarks/Sets.hs -formatted 0d64d700acb4 attoparsec-0.14.4/benchmarks/TextFastSet.hs +formatted f19602a9ee09 attoparsec-0.14.4/benchmarks/TextFastSet.hs formatted 2b16e18cd8c0 attoparsec-0.14.4/benchmarks/Warp.hs formatted 0328e73e6175 attoparsec-0.14.4/benchmarks/warp-3.0.1.1/Network/Wai/Handler/Warp/ReadInt.hs formatted 1f7d3a417fb5 attoparsec-0.14.4/benchmarks/warp-3.0.1.1/Network/Wai/Handler/Warp/RequestHeader.hs @@ -663,13 +663,13 @@ formatted f21e47830b1f attoparsec-0.14.4/internal/Data/Attoparsec/Internal/Compat.hs formatted 4498fcbfa61f attoparsec-0.14.4/internal/Data/Attoparsec/Internal/Fhthagn.hs formatted bc12b2ada3b5 attoparsec-0.14.4/internal/Data/Attoparsec/Text/Buffer.hs -formatted b2e14e3c02d3 attoparsec-0.14.4/internal/Data/Attoparsec/Text/FastSet.hs +formatted ecad246a959e attoparsec-0.14.4/internal/Data/Attoparsec/Text/FastSet.hs formatted ccaeb87485db attoparsec-0.14.4/tests/QC.hs formatted c4481214d6c0 attoparsec-0.14.4/tests/QC/Buffer.hs formatted ae7fa7b38a4b attoparsec-0.14.4/tests/QC/ByteString.hs formatted 455e4866502a attoparsec-0.14.4/tests/QC/Combinator.hs formatted 2bd326ae7162 attoparsec-0.14.4/tests/QC/Common.hs -formatted 7558d60104bb attoparsec-0.14.4/tests/QC/IPv6/Internal.hs +formatted 394bfa5dcceb attoparsec-0.14.4/tests/QC/IPv6/Internal.hs formatted 0692feda416d attoparsec-0.14.4/tests/QC/IPv6/Types.hs formatted 08452f3d9508 attoparsec-0.14.4/tests/QC/Rechunked.hs formatted 0bab40e54197 attoparsec-0.14.4/tests/QC/Simple.hs @@ -787,9 +787,9 @@ formatted 001f1d1eb163 aws-0.25.3/tests/Utils.hs formatted 10172e7983b9 base64-bytestring-1.2.1.0/Data/ByteString/Base64.hs formatted 8d1de483b9c4 base64-bytestring-1.2.1.0/Data/ByteString/Base64/Internal.hs -formatted dae9abac8bd0 base64-bytestring-1.2.1.0/Data/ByteString/Base64/Lazy.hs +formatted 20780be77581 base64-bytestring-1.2.1.0/Data/ByteString/Base64/Lazy.hs formatted efdde917444c base64-bytestring-1.2.1.0/Data/ByteString/Base64/URL.hs -formatted 0d8bf6b77f56 base64-bytestring-1.2.1.0/Data/ByteString/Base64/URL/Lazy.hs +formatted 4ea9b39db86f base64-bytestring-1.2.1.0/Data/ByteString/Base64/URL/Lazy.hs formatted e865ae48f11b base64-bytestring-1.2.1.0/Setup.hs formatted 0328dc0c3c7c base64-bytestring-1.2.1.0/benchmarks/BM.hs formatted e856b328c01f base64-bytestring-1.2.1.0/tests/Tests.hs @@ -1466,18 +1466,18 @@ formatted 62f91f308c2e brittany-0.14.0.2/source/library/Language/Haskell/Brittany/Internal/Backend.hs formatted b114e1735e96 brittany-0.14.0.2/source/library/Language/Haskell/Brittany/Internal/BackendUtils.hs formatted 4db6008c162f brittany-0.14.0.2/source/library/Language/Haskell/Brittany/Internal/Config.hs -formatted b3a115fdcb04 brittany-0.14.0.2/source/library/Language/Haskell/Brittany/Internal/Config/Types.hs +formatted 47cac5b50849 brittany-0.14.0.2/source/library/Language/Haskell/Brittany/Internal/Config/Types.hs formatted 3479d640d39c brittany-0.14.0.2/source/library/Language/Haskell/Brittany/Internal/Config/Types/Instances.hs formatted 3a7e4e0507b6 brittany-0.14.0.2/source/library/Language/Haskell/Brittany/Internal/ExactPrintUtils.hs formatted 5d4339023e83 brittany-0.14.0.2/source/library/Language/Haskell/Brittany/Internal/LayouterBasics.hs formatted e6236562836a brittany-0.14.0.2/source/library/Language/Haskell/Brittany/Internal/Layouters/DataDecl.hs -formatted ee47e6ccde82 brittany-0.14.0.2/source/library/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +formatted 4259510f3316 brittany-0.14.0.2/source/library/Language/Haskell/Brittany/Internal/Layouters/Decl.hs formatted 85310fee66ef brittany-0.14.0.2/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs formatted 63ac93aa854f brittany-0.14.0.2/source/library/Language/Haskell/Brittany/Internal/Layouters/Expr.hs-boot formatted f730e71a6728 brittany-0.14.0.2/source/library/Language/Haskell/Brittany/Internal/Layouters/IE.hs formatted 4647ea64ed39 brittany-0.14.0.2/source/library/Language/Haskell/Brittany/Internal/Layouters/Import.hs formatted 455e49f342e4 brittany-0.14.0.2/source/library/Language/Haskell/Brittany/Internal/Layouters/Module.hs -formatted 1f83e29fdd09 brittany-0.14.0.2/source/library/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs +formatted 94a22988945f brittany-0.14.0.2/source/library/Language/Haskell/Brittany/Internal/Layouters/Pattern.hs formatted d46ed5a9675b brittany-0.14.0.2/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs formatted 08c3e5d27dd4 brittany-0.14.0.2/source/library/Language/Haskell/Brittany/Internal/Layouters/Stmt.hs-boot formatted 757402eae174 brittany-0.14.0.2/source/library/Language/Haskell/Brittany/Internal/Layouters/Type.hs @@ -1941,7 +1941,7 @@ formatted 891834d5aec2 fay-0.24.2.0/src/Fay/Compiler/Desugar.hs formatted 570ca805808c fay-0.24.2.0/src/Fay/Compiler/Desugar/Name.hs formatted fe53147a7e33 fay-0.24.2.0/src/Fay/Compiler/Desugar/Types.hs -formatted cd957c0884e8 fay-0.24.2.0/src/Fay/Compiler/Exp.hs +formatted de04ffc1e73c fay-0.24.2.0/src/Fay/Compiler/Exp.hs formatted cfc0f0f46b43 fay-0.24.2.0/src/Fay/Compiler/FFI.hs formatted 69fd6dd80a66 fay-0.24.2.0/src/Fay/Compiler/GADT.hs formatted bcb9d437929e fay-0.24.2.0/src/Fay/Compiler/Import.hs @@ -2240,7 +2240,7 @@ formatted 92f9ffbc940f free-5.2/src/Control/Monad/Free/Ap.hs formatted 93c96d44b956 free-5.2/src/Control/Monad/Free/Church.hs formatted 39bf4e33f6e2 free-5.2/src/Control/Monad/Free/Class.hs -formatted d6318fb07edb free-5.2/src/Control/Monad/Free/TH.hs +formatted ff2776be0a4c free-5.2/src/Control/Monad/Free/TH.hs formatted a51821c826a6 free-5.2/src/Control/Monad/Trans/Free.hs formatted b9554e2bf6b2 free-5.2/src/Control/Monad/Trans/Free/Ap.hs formatted 91e1c571caac free-5.2/src/Control/Monad/Trans/Free/Church.hs @@ -2713,7 +2713,7 @@ formatted a8f154205e55 idris-1.3.4/src/Idris/AbsSyntax.hs formatted f6be69b820bf idris-1.3.4/src/Idris/AbsSyntaxTree.hs formatted 9f032fa98b74 idris-1.3.4/src/Idris/Apropos.hs -formatted 1b17f73d1ed1 idris-1.3.4/src/Idris/CaseSplit.hs +formatted dc91bae3387b idris-1.3.4/src/Idris/CaseSplit.hs formatted 887228791bf4 idris-1.3.4/src/Idris/Chaser.hs formatted a47646c618f2 idris-1.3.4/src/Idris/CmdOptions.hs formatted 4da7f931a59f idris-1.3.4/src/Idris/Colours.hs @@ -2724,11 +2724,11 @@ formatted 32e1f1dc7a41 idris-1.3.4/src/Idris/Core/DeepSeq.hs formatted 3b956c85cb93 idris-1.3.4/src/Idris/Core/Elaborate.hs formatted d0216dc5a258 idris-1.3.4/src/Idris/Core/Evaluate.hs -formatted 9e811f74925b idris-1.3.4/src/Idris/Core/Execute.hs +formatted 5c128b375f3d idris-1.3.4/src/Idris/Core/Execute.hs formatted a0c632cd26d6 idris-1.3.4/src/Idris/Core/ProofState.hs formatted 0ccd6a932fe8 idris-1.3.4/src/Idris/Core/ProofTerm.hs formatted cd52f6495e8c idris-1.3.4/src/Idris/Core/TT.hs -formatted d6069959015f idris-1.3.4/src/Idris/Core/Typecheck.hs +formatted 86a2b33d069a idris-1.3.4/src/Idris/Core/Typecheck.hs formatted 7872856d0301 idris-1.3.4/src/Idris/Core/Unify.hs formatted 01a710f67630 idris-1.3.4/src/Idris/Core/WHNF.hs formatted 36e22c48009d idris-1.3.4/src/Idris/Coverage.hs @@ -2740,7 +2740,7 @@ formatted d3d91df82106 idris-1.3.4/src/Idris/Docs.hs formatted a485f5642886 idris-1.3.4/src/Idris/Docstrings.hs formatted a1c474156864 idris-1.3.4/src/Idris/Elab/AsPat.hs -formatted 0c12951dd00e idris-1.3.4/src/Idris/Elab/Clause.hs +formatted fc2ff424b9e3 idris-1.3.4/src/Idris/Elab/Clause.hs formatted 9e5c2909e062 idris-1.3.4/src/Idris/Elab/Data.hs formatted 8513eb951865 idris-1.3.4/src/Idris/Elab/Implementation.hs formatted 9349c5236898 idris-1.3.4/src/Idris/Elab/Interface.hs @@ -2749,7 +2749,7 @@ formatted 229f49cf1c9d idris-1.3.4/src/Idris/Elab/Record.hs formatted 187fb9ddcd79 idris-1.3.4/src/Idris/Elab/Rewrite.hs formatted 77ebc33633f8 idris-1.3.4/src/Idris/Elab/RunElab.hs -formatted 5ca384198b92 idris-1.3.4/src/Idris/Elab/Term.hs +formatted 711d76a30f2c idris-1.3.4/src/Idris/Elab/Term.hs formatted 43565a6d9bac idris-1.3.4/src/Idris/Elab/Transform.hs formatted cf8cbbec4fe7 idris-1.3.4/src/Idris/Elab/Type.hs formatted b3e66f72a9ac idris-1.3.4/src/Idris/Elab/Utils.hs @@ -2780,9 +2780,9 @@ formatted de7138f89659 idris-1.3.4/src/Idris/Parser/Helpers.hs formatted edc130411af1 idris-1.3.4/src/Idris/Parser/Ops.hs formatted 3f33ff4561d4 idris-1.3.4/src/Idris/Parser/Stack.hs -formatted 7f8889e1a85a idris-1.3.4/src/Idris/PartialEval.hs +formatted d415f9474dc1 idris-1.3.4/src/Idris/PartialEval.hs formatted 58ad84ded5d8 idris-1.3.4/src/Idris/Primitives.hs -formatted 429ec8a4efee idris-1.3.4/src/Idris/ProofSearch.hs +formatted 03bf99a63aa4 idris-1.3.4/src/Idris/ProofSearch.hs formatted 168d70e142b3 idris-1.3.4/src/Idris/Prover.hs formatted ad0ff1beaf54 idris-1.3.4/src/Idris/Providers.hs formatted c47d07c305a7 idris-1.3.4/src/Idris/REPL.hs @@ -2790,7 +2790,7 @@ formatted 586418ee0cf6 idris-1.3.4/src/Idris/REPL/Commands.hs formatted f36f6bde407f idris-1.3.4/src/Idris/REPL/Parser.hs formatted a35f4ee64226 idris-1.3.4/src/Idris/Reflection.hs -formatted d8e303fd1eef idris-1.3.4/src/Idris/Termination.hs +formatted 434ab5e35b0e idris-1.3.4/src/Idris/Termination.hs formatted 6837e439e7d6 idris-1.3.4/src/Idris/Transforms.hs formatted 06befdb6fc0c idris-1.3.4/src/Idris/TypeSearch.hs formatted 528c0d503ddd idris-1.3.4/src/Idris/Unlit.hs @@ -2811,7 +2811,7 @@ formatted 72999d5c814e intero-0.1.40/src/GhciTypes.hs declined - intero-0.1.40/src/InteractiveUI.hs formatted d3b894941b5e intero-0.1.40/src/Intero/Compat.hs -partly-checked f1e8bf4ae69f intero-0.1.40/src/Main.hs +partly-checked 650cf9fb288c intero-0.1.40/src/Main.hs formatted 13b22f1a2f96 intero-0.1.40/src/test/Main.hs formatted 4fe73bbfe233 leksah-0.16.2.2/data/leksah-welcome/src/Main.hs formatted 1cefb44a49bc leksah-0.16.2.2/data/leksah-welcome/test/Main.hs @@ -2856,7 +2856,7 @@ formatted 575af73a6da8 leksah-0.16.2.2/src/IDE/Pane/PackageEditor.hs formatted f0501c777408 leksah-0.16.2.2/src/IDE/Pane/PackageFlags.hs formatted b852a84764b6 leksah-0.16.2.2/src/IDE/Pane/Search.hs -formatted fb6b3817d585 leksah-0.16.2.2/src/IDE/Pane/SourceBuffer.hs +formatted 1833ee2b3dc9 leksah-0.16.2.2/src/IDE/Pane/SourceBuffer.hs formatted 17fd33faa199 leksah-0.16.2.2/src/IDE/Pane/Trace.hs formatted 42dcc1c61a8c leksah-0.16.2.2/src/IDE/Pane/Variables.hs formatted 402db82d0213 leksah-0.16.2.2/src/IDE/Pane/WebKit/Documentation.hs @@ -3281,10 +3281,10 @@ formatted 9366da9eb866 pandoc-3.10.2/src/Text/Pandoc/Writers/Docx/Table.hs formatted a7b1f18b1b94 pandoc-3.10.2/src/Text/Pandoc/Writers/Docx/Types.hs formatted 393f60564bb0 pandoc-3.10.2/src/Text/Pandoc/Writers/DokuWiki.hs -formatted 63bfa4a35c66 pandoc-3.10.2/src/Text/Pandoc/Writers/EPUB.hs +formatted 34d053463a70 pandoc-3.10.2/src/Text/Pandoc/Writers/EPUB.hs formatted 18a7003d6454 pandoc-3.10.2/src/Text/Pandoc/Writers/FB2.hs formatted c4b4f9d5a6e4 pandoc-3.10.2/src/Text/Pandoc/Writers/GridTable.hs -formatted 52d1f99c1ff0 pandoc-3.10.2/src/Text/Pandoc/Writers/HTML.hs +formatted 98453ee060f9 pandoc-3.10.2/src/Text/Pandoc/Writers/HTML.hs formatted 6dff5ff11e27 pandoc-3.10.2/src/Text/Pandoc/Writers/Haddock.hs formatted c124279e4c0c pandoc-3.10.2/src/Text/Pandoc/Writers/ICML.hs formatted dd0566d62914 pandoc-3.10.2/src/Text/Pandoc/Writers/Ipynb.hs @@ -3302,7 +3302,7 @@ formatted a4eb629d0029 pandoc-3.10.2/src/Text/Pandoc/Writers/LaTeX/Types.hs formatted f86bcaf0241e pandoc-3.10.2/src/Text/Pandoc/Writers/LaTeX/Util.hs formatted 85fcfddb12db pandoc-3.10.2/src/Text/Pandoc/Writers/Man.hs -formatted b9f4a40b59a1 pandoc-3.10.2/src/Text/Pandoc/Writers/Markdown.hs +formatted d09a03d82e74 pandoc-3.10.2/src/Text/Pandoc/Writers/Markdown.hs formatted a7a53336237a pandoc-3.10.2/src/Text/Pandoc/Writers/Markdown/Inline.hs formatted c57101b9ec66 pandoc-3.10.2/src/Text/Pandoc/Writers/Markdown/Table.hs formatted 02c7eb593d88 pandoc-3.10.2/src/Text/Pandoc/Writers/Markdown/Types.hs @@ -3315,7 +3315,7 @@ formatted 780b39e3c620 pandoc-3.10.2/src/Text/Pandoc/Writers/OOXML.hs formatted 4c4123778a13 pandoc-3.10.2/src/Text/Pandoc/Writers/OPML.hs formatted 11f3bed781a4 pandoc-3.10.2/src/Text/Pandoc/Writers/OpenDocument.hs -formatted 7d585a078c42 pandoc-3.10.2/src/Text/Pandoc/Writers/Org.hs +formatted 4bae1768478d pandoc-3.10.2/src/Text/Pandoc/Writers/Org.hs formatted 74e7486aeef1 pandoc-3.10.2/src/Text/Pandoc/Writers/Powerpoint.hs formatted 9b93eaeae21e pandoc-3.10.2/src/Text/Pandoc/Writers/Powerpoint/Output.hs formatted 3cbe72b20538 pandoc-3.10.2/src/Text/Pandoc/Writers/Powerpoint/Presentation.hs @@ -4368,7 +4368,7 @@ formatted 015e3efd2d86 stack-9.9.9/src/System/Process/PagerEditor.hs formatted bc60fdf030d4 stack-9.9.9/src/System/Process/Read.hs formatted c40dad9ce8ee stack-9.9.9/src/System/Process/Run.hs -formatted e9412f975a02 stack-9.9.9/src/main/Main.hs +formatted 9366d8a339a8 stack-9.9.9/src/main/Main.hs formatted 4eec70869c80 stack-9.9.9/src/main/Plugins.hs formatted 50b246d28182 stack-9.9.9/src/main/Plugins/Commands.hs formatted 65c8c298f7aa stack-9.9.9/src/test/Spec.hs @@ -4567,7 +4567,7 @@ formatted a0bdad468ca4 text-2.1.4/scripts/CaseMapping.hs formatted 57e97be5ba61 text-2.1.4/scripts/SpecialCasing.hs formatted d775bb623580 text-2.1.4/scripts/UnicodeData.hs -partly-checked 0abe70d97042 text-2.1.4/src/Data/Text.hs +partly-checked 1e55021d157f text-2.1.4/src/Data/Text.hs formatted d3ff1f08422c text-2.1.4/src/Data/Text/Array.hs formatted 4970b89f4e7e text-2.1.4/src/Data/Text/Encoding.hs formatted d6231f7ebe99 text-2.1.4/src/Data/Text/Encoding/Error.hs @@ -4582,20 +4582,20 @@ formatted ab51e88834e1 text-2.1.4/src/Data/Text/Internal/Builder/RealFloat/Functions.hs formatted 7fa192160c9b text-2.1.4/src/Data/Text/Internal/ByteStringCompat.hs formatted 4815054ed2f6 text-2.1.4/src/Data/Text/Internal/Encoding.hs -formatted 43a1a670b3db text-2.1.4/src/Data/Text/Internal/Encoding/Fusion.hs +formatted 389325b86129 text-2.1.4/src/Data/Text/Internal/Encoding/Fusion.hs formatted 88e5c54a218b text-2.1.4/src/Data/Text/Internal/Encoding/Fusion/Common.hs formatted 875961737225 text-2.1.4/src/Data/Text/Internal/Encoding/Utf16.hs formatted 48ea4745d7e8 text-2.1.4/src/Data/Text/Internal/Encoding/Utf32.hs -formatted 999f28ae046f text-2.1.4/src/Data/Text/Internal/Encoding/Utf8.hs +formatted 26b2c3b56203 text-2.1.4/src/Data/Text/Internal/Encoding/Utf8.hs formatted da5c175cb49c text-2.1.4/src/Data/Text/Internal/Fusion.hs formatted 9ae139203b50 text-2.1.4/src/Data/Text/Internal/Fusion/CaseMapping.hs formatted 82caff784f76 text-2.1.4/src/Data/Text/Internal/Fusion/Common.hs formatted a3b0b51a0759 text-2.1.4/src/Data/Text/Internal/Fusion/Size.hs formatted 3c7c18d05ebf text-2.1.4/src/Data/Text/Internal/Fusion/Types.hs -formatted 32b50634031b text-2.1.4/src/Data/Text/Internal/IO.hs +formatted 54f6c2576b08 text-2.1.4/src/Data/Text/Internal/IO.hs formatted e2bb47936e11 text-2.1.4/src/Data/Text/Internal/IsAscii.hs formatted 538632ba614a text-2.1.4/src/Data/Text/Internal/Lazy.hs -formatted 76efe1116cd2 text-2.1.4/src/Data/Text/Internal/Lazy/Encoding/Fusion.hs +formatted 24939d0b9b8b text-2.1.4/src/Data/Text/Internal/Lazy/Encoding/Fusion.hs formatted c627413119e8 text-2.1.4/src/Data/Text/Internal/Lazy/Fusion.hs formatted a3c76abdf09c text-2.1.4/src/Data/Text/Internal/Lazy/Search.hs formatted e22062ee35e8 text-2.1.4/src/Data/Text/Internal/Measure.hs @@ -4621,7 +4621,7 @@ formatted 4053796b9111 text-2.1.4/src/Data/Text/Lazy/Read.hs formatted 95185ba2e9b4 text-2.1.4/src/Data/Text/Read.hs formatted a764e2fbcaba text-2.1.4/src/Data/Text/Show.hs -formatted 5aa1e6b706a4 text-2.1.4/src/Data/Text/Unsafe.hs +formatted ce35262cd7ed text-2.1.4/src/Data/Text/Unsafe.hs formatted 8c35444bb7ce text-2.1.4/tests/LiteralRuleTest.hs formatted 6c129d5c79c5 text-2.1.4/tests/Tests.hs formatted 8c9ba4deec7f text-2.1.4/tests/Tests/Lift.hs @@ -4644,7 +4644,7 @@ formatted f4e9f36f6be9 text-2.1.4/tests/Tests/SlowFunctions.hs formatted 375091fbe743 text-2.1.4/tests/Tests/Utils.hs formatted e865ae48f11b th-abstraction-0.7.2.0/Setup.hs -formatted 48b10de7e3db th-abstraction-0.7.2.0/src/Language/Haskell/TH/Datatype.hs +formatted ebfea5ec7f1c th-abstraction-0.7.2.0/src/Language/Haskell/TH/Datatype.hs formatted b67b7b9c968e th-abstraction-0.7.2.0/src/Language/Haskell/TH/Datatype/Internal.hs formatted 505471744185 th-abstraction-0.7.2.0/src/Language/Haskell/TH/Datatype/TyVarBndr.hs formatted fad455f51be7 th-abstraction-0.7.2.0/test/Harness.hs @@ -4966,7 +4966,7 @@ formatted e97eca400518 uuid-types-1.0.6.1/src/Data/UUID/Types.hs formatted a09b001e6a41 uuid-types-1.0.6.1/src/Data/UUID/Types/Internal.hs formatted d63508f44841 uuid-types-1.0.6.1/src/Data/UUID/Types/Internal/Builder.hs -formatted 14a92dc8286f uuid-types-1.0.6.1/tests/TestUUID.hs +formatted ed86f094a194 uuid-types-1.0.6.1/tests/TestUUID.hs formatted e865ae48f11b vector-0.13.2.0/Setup.hs formatted cb65eb293bd5 vector-0.13.2.0/benchlib/Bench/Vector/Algo/AwShCC.hs formatted 8a7c35b680c0 vector-0.13.2.0/benchlib/Bench/Vector/Algo/FindIndexR.hs @@ -5033,7 +5033,7 @@ formatted 385f1aecc6ac vector-algorithms-0.9.1.0/src/Data/Vector/Algorithms/Insertion.hs formatted c2cb20f40fd9 vector-algorithms-0.9.1.0/src/Data/Vector/Algorithms/Intro.hs formatted 4a50f751547a vector-algorithms-0.9.1.0/src/Data/Vector/Algorithms/Merge.hs -formatted 0d30a08d3940 vector-algorithms-0.9.1.0/src/Data/Vector/Algorithms/Optimal.hs +formatted f86bd27d6c5a vector-algorithms-0.9.1.0/src/Data/Vector/Algorithms/Optimal.hs formatted b7b0f718deb2 vector-algorithms-0.9.1.0/src/Data/Vector/Algorithms/Radix.hs formatted 47f1d28b6145 vector-algorithms-0.9.1.0/src/Data/Vector/Algorithms/Search.hs formatted 0a376532e9cb vector-algorithms-0.9.1.0/src/Data/Vector/Algorithms/Tim.hs diff --git a/corpora/vendored/declaration/value/fixity-local-to-a-binding-out.hs b/corpora/vendored/declaration/value/fixity-local-to-a-binding-out.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/declaration/value/fixity-local-to-a-binding-out.hs @@ -0,0 +1,29 @@ +-- A fixity declared among local bindings decides the layout of the operator +-- they bind. +module Setting.Fallback where + +import Text.Read (readMaybe) + +data Setting = Number Int | Switch Bool | Word String + +parsed :: String -> Maybe Setting +parsed input = + Number + <$> readMaybe input + Switch + <$> readMaybe input + pure (Word input) + where + infixl 3 + Nothing y = y + x _ = x + +firstOf :: Maybe Int -> Maybe Int -> Maybe Int -> Maybe Int +firstOf a b c = + let infixr 3 + Nothing y = y + x _ = x + in negate + <$> a + b + c diff --git a/corpora/vendored/declaration/value/fixity-local-to-a-binding.hs b/corpora/vendored/declaration/value/fixity-local-to-a-binding.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/declaration/value/fixity-local-to-a-binding.hs @@ -0,0 +1,29 @@ +-- A fixity declared among local bindings decides the layout of the operator +-- they bind. +module Setting.Fallback where + +import Text.Read (readMaybe) + +data Setting = Number Int | Switch Bool | Word String + +parsed :: String -> Maybe Setting +parsed input = + Number + <$> readMaybe input + Switch + <$> readMaybe input + pure (Word input) + where + infixl 3 + Nothing y = y + x _ = x + +firstOf :: Maybe Int -> Maybe Int -> Maybe Int -> Maybe Int +firstOf a b c = + let infixr 3 + Nothing y = y + x _ = x + in negate + <$> a + b + c diff --git a/corpora/vendored/declaration/value/fixity-without-a-precedence-out.hs b/corpora/vendored/declaration/value/fixity-without-a-precedence-out.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/declaration/value/fixity-without-a-precedence-out.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE ExplicitNamespaces #-} + +-- A fixity declaration written without a precedence stays without one. +module Rope.Join where + +infixr `joinedTo` + +infixl 5 `besides` + +infix <~>, `against` + +infixr type :~ + +class Splice r where + infixl `splice` + splice :: r -> r -> r + +data a :~ b = a :~ b + +joinedTo, besides, (<~>), against :: String -> String -> String +joinedTo = (++) +besides = (++) +(<~>) = (++) +against = (++) diff --git a/corpora/vendored/declaration/value/fixity-without-a-precedence.hs b/corpora/vendored/declaration/value/fixity-without-a-precedence.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/declaration/value/fixity-without-a-precedence.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE ExplicitNamespaces #-} + +-- A fixity declaration written without a precedence stays without one. +module Rope.Join where + +infixr `joinedTo` +infixl 5 `besides` +infix <~>, `against` +infixr type :~ + +class Splice r where + infixl `splice` + splice :: r -> r -> r + +data a :~ b = a :~ b + +joinedTo, besides, (<~>), against :: String -> String -> String +joinedTo = (++) +besides = (++) +(<~>) = (++) +against = (++) diff --git a/corpora/vendored/declaration/value/layout-as-written-out.hs b/corpora/vendored/declaration/value/layout-as-written-out.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/declaration/value/layout-as-written-out.hs @@ -0,0 +1,8 @@ +module M where + +onOneLine x = (x, x) + +spreadOut x = + ( x, + x + ) diff --git a/corpora/vendored/declaration/value/layout-as-written.hs b/corpora/vendored/declaration/value/layout-as-written.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/declaration/value/layout-as-written.hs @@ -0,0 +1,8 @@ +module M where + +onOneLine x = (x, x) + +spreadOut x = + ( x, + x + ) diff --git a/corpora/vendored/declaration/value/operator-beginning-with-a-hash-out.hs b/corpora/vendored/declaration/value/operator-beginning-with-a-hash-out.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/declaration/value/operator-beginning-with-a-hash-out.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE UnboxedTuples #-} + +-- With unboxed tuples on, an operator that begins with # keeps the space +-- after an opening parenthesis, and # alone the space before a closing one, +-- so that neither reads as half of an unboxed tuple. +module Builder.Append + ( ( #<| ), + (<|#), + ( # ), + prepended, + ) +where + +( #<| ), (<|#), ( # ) :: String -> String -> String +x #<| y = x ++ y +x <|# y = y ++ x +x # y = x ++ " " ++ y + +infixr 5 #<| + +prepended :: [String] -> [String] +prepended = + map ( #<| "!") . map ("?" <|#) . map ("a" # ) . foldr (( #<| ) . pure) [] diff --git a/corpora/vendored/declaration/value/operator-beginning-with-a-hash.hs b/corpora/vendored/declaration/value/operator-beginning-with-a-hash.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/declaration/value/operator-beginning-with-a-hash.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE UnboxedTuples #-} + +-- With unboxed tuples on, an operator that begins with # keeps the space +-- after an opening parenthesis, and # alone the space before a closing one, +-- so that neither reads as half of an unboxed tuple. +module Builder.Append + ( ( #<| ), + (<|#), + ( # ), + prepended, + ) +where + +( #<| ), (<|#), ( # ) :: String -> String -> String +x #<| y = x ++ y +x <|# y = y ++ x +x # y = x ++ " " ++ y + +infixr 5 #<| + +prepended :: [String] -> [String] +prepended = + map ( #<| "!") . map ("?" <|#) . map ("a" # ) . foldr (( #<| ) . pure) [] diff --git a/corpora/vendored/declaration/value/operator-chains-out.hs b/corpora/vendored/declaration/value/operator-chains-out.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/declaration/value/operator-chains-out.hs @@ -0,0 +1,18 @@ +module M where + +atTheLoosest = + a * b + + c * d + +capturedLocally = + a + * b + + c + * d + where + infixl 8 + + x + y = x + +blockHandedOn = g $ do + h + i diff --git a/corpora/vendored/declaration/value/operator-chains.hs b/corpora/vendored/declaration/value/operator-chains.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/declaration/value/operator-chains.hs @@ -0,0 +1,16 @@ +module M where + +atTheLoosest = + a * b + + c * d + +capturedLocally = + a * b + + c * d + where + infixl 8 + + x + y = x + +blockHandedOn = g $ do + h + i diff --git a/corpora/vendored/import/qualified-after-the-module-name-out.hs b/corpora/vendored/import/qualified-after-the-module-name-out.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/import/qualified-after-the-module-name-out.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE ImportQualifiedPost #-} + +module M where + +import Data.Map qualified as M +import Data.Set qualified as S diff --git a/corpora/vendored/import/qualified-after-the-module-name.hs b/corpora/vendored/import/qualified-after-the-module-name.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/import/qualified-after-the-module-name.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE ImportQualifiedPost #-} +module M where +import Data.Map qualified as M +import qualified Data.Set as S diff --git a/corpora/vendored/import/qualified-before-the-module-name-out.hs b/corpora/vendored/import/qualified-before-the-module-name-out.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/import/qualified-before-the-module-name-out.hs @@ -0,0 +1,4 @@ +module M where + +import qualified Data.Map as M +import qualified Data.Set as S diff --git a/corpora/vendored/import/qualified-before-the-module-name.hs b/corpora/vendored/import/qualified-before-the-module-name.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/import/qualified-before-the-module-name.hs @@ -0,0 +1,3 @@ +module M where +import Data.Map qualified as M +import qualified Data.Set as S diff --git a/corpora/vendored/other/comment-beside-a-wildcard-out.hs b/corpora/vendored/other/comment-beside-a-wildcard-out.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/comment-beside-a-wildcard-out.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE PatternSynonyms #-} + +-- A comment written beside the wildcard of an item stays inside its +-- parentheses. +module Ledger.Entry + ( Entry ({- fields too -} ..), + Side (Debit, {- and the rest -} ..), + total, + ) +where + +import Ledger.Money (Money (.. {- abstract upstream -}), add) + +data Entry = Entry{entrySide :: Side, entryAmount :: Money} + +data Side = Debit | Credit + +total :: [Entry] -> Money +total = foldr (add . entryAmount) mempty diff --git a/corpora/vendored/other/comment-beside-a-wildcard.hs b/corpora/vendored/other/comment-beside-a-wildcard.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/comment-beside-a-wildcard.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE PatternSynonyms #-} + +-- A comment written beside the wildcard of an item stays inside its +-- parentheses. +module Ledger.Entry + ( Entry({- fields too -}..) + , Side(Debit, {- and the rest -} ..) + , total + ) where + +import Ledger.Money (Money(.. {- abstract upstream -}), add) + +data Entry = Entry { entrySide :: Side, entryAmount :: Money } + +data Side = Debit | Credit + +total :: [Entry] -> Money +total = foldr (add . entryAmount) mempty diff --git a/corpora/vendored/other/comment-carried-on-under-a-remark-and-more-out.hs b/corpora/vendored/other/comment-carried-on-under-a-remark-and-more-out.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/comment-carried-on-under-a-remark-and-more-out.hs @@ -0,0 +1,20 @@ +-- A comment under the remark that ends the line above, lined up with it or +-- indented further, carries the remark on, even where the code under it +-- begins at the same column. +data AttrTable a -- for all attribute identifiers not contained in the + -- finite map the value is 'undef' + = SoftTable a -- updated attributes + | FrozenTable a + +data Part + = Literal String -- a literal string + | Variable String -- some input; the + -- string names the variable + | Optional Part + +decode :: String -> Either String String +decode b = -- returning an Either means the whole result + -- is in memory at once anyway + case reverse b of + [] -> Left "empty" + s -> Right s diff --git a/corpora/vendored/other/comment-carried-on-under-a-remark-and-more.hs b/corpora/vendored/other/comment-carried-on-under-a-remark-and-more.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/comment-carried-on-under-a-remark-and-more.hs @@ -0,0 +1,20 @@ +-- A comment under the remark that ends the line above, lined up with it or +-- indented further, carries the remark on, even where the code under it +-- begins at the same column. +data AttrTable a = -- for all attribute identifiers not contained in the + -- finite map the value is 'undef' + SoftTable a -- updated attributes + | FrozenTable a + +data Part + = Literal String -- a literal string + | Variable String -- some input; the + -- string names the variable + | Optional Part + +decode :: String -> Either String String +decode b = -- returning an Either means the whole result + -- is in memory at once anyway + case reverse b of + [] -> Left "empty" + s -> Right s diff --git a/corpora/vendored/other/comment-under-a-quasi-quotation-out.hs b/corpora/vendored/other/comment-under-a-quasi-quotation-out.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/comment-under-a-quasi-quotation-out.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE QuasiQuotes #-} + +-- A comment under a quasi-quotation written over several lines stays out of +-- it. +module Physics.Body (setAngle, reindexed) where + +setAngle :: Ptr Body -> Double -> IO () +setAngle bodyPtr angle = [C.block| void { + cpBodySetAngle($(cpBody* bodyPtr), $(double angle)); + } |] + -- FIXME reindex + +reindexed :: Ptr Body -> IO () +reindexed bodyPtr = do + [C.block| void { + cpSpaceReindexShapesForBody($(cpBody* bodyPtr)); + } |] + -- once per body + pure () diff --git a/corpora/vendored/other/comment-under-a-quasi-quotation.hs b/corpora/vendored/other/comment-under-a-quasi-quotation.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/comment-under-a-quasi-quotation.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE QuasiQuotes #-} + +-- A comment under a quasi-quotation written over several lines stays out of +-- it. +module Physics.Body (setAngle, reindexed) where + +setAngle :: Ptr Body -> Double -> IO () +setAngle bodyPtr angle = [C.block| void { + cpBodySetAngle($(cpBody* bodyPtr), $(double angle)); + } |] + -- FIXME reindex + +reindexed :: Ptr Body -> IO () +reindexed bodyPtr = do + [C.block| void { + cpSpaceReindexShapesForBody($(cpBody* bodyPtr)); + } |] + -- once per body + pure () diff --git a/corpora/vendored/other/comments-beside-an-alternative-and-a-bracket-out.hs b/corpora/vendored/other/comments-beside-an-alternative-and-a-bracket-out.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/comments-beside-an-alternative-and-a-bracket-out.hs @@ -0,0 +1,16 @@ +module M where + +atTheEnd = case x of + a -> -- why + b + +onItsOwnLine = case x of + a -> + -- why + b + +beforeTheClosingBracket = + [ a, + b + -- and that is all + ] diff --git a/corpora/vendored/other/comments-beside-an-alternative-and-a-bracket.hs b/corpora/vendored/other/comments-beside-an-alternative-and-a-bracket.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/comments-beside-an-alternative-and-a-bracket.hs @@ -0,0 +1,16 @@ +module M where + +atTheEnd = case x of + a -> -- why + b + +onItsOwnLine = case x of + a -> + -- why + b + +beforeTheClosingBracket = + [ a, + b + -- and that is all + ] diff --git a/corpora/vendored/other/comments-beside-the-where-of-the-header-out.hs b/corpora/vendored/other/comments-beside-the-where-of-the-header-out.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/comments-beside-the-where-of-the-header-out.hs @@ -0,0 +1,10 @@ +-- Comments written before and after the where of the module header stay on +-- their side of it. +module Ledger.Book +-- everything is exported +where {- until the API settles -} + +import Ledger.Entry (Entry) + +opening :: Entry -> Int +opening _ = 0 diff --git a/corpora/vendored/other/comments-beside-the-where-of-the-header.hs b/corpora/vendored/other/comments-beside-the-where-of-the-header.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/comments-beside-the-where-of-the-header.hs @@ -0,0 +1,10 @@ +-- Comments written before and after the where of the module header stay on +-- their side of it. +module Ledger.Book + -- everything is exported + where {- until the API settles -} + +import Ledger.Entry (Entry) + +opening :: Entry -> Int +opening _ = 0 diff --git a/corpora/vendored/other/comments-kept-where-written-out.hs b/corpora/vendored/other/comments-kept-where-written-out.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/comments-kept-where-written-out.hs @@ -0,0 +1,17 @@ +module M where + +-- a note +between = 1 + +inside = g + where + -- about g + g = 1 + +selfDelimiting = + {- here -} 1 + +notOnOneLine = + ( -- here + 1 + ) diff --git a/corpora/vendored/other/comments-kept-where-written.hs b/corpora/vendored/other/comments-kept-where-written.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/comments-kept-where-written.hs @@ -0,0 +1,17 @@ +module M where + +-- a note +between = 1 + +inside = g + where + -- about g + g = 1 + +selfDelimiting = + {- here -} 1 + +notOnOneLine = + ( -- here + 1 + ) diff --git a/corpora/vendored/other/comments-where-they-are-hard-to-put-back-out.hs b/corpora/vendored/other/comments-where-they-are-hard-to-put-back-out.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/comments-where-they-are-hard-to-put-back-out.hs @@ -0,0 +1,25 @@ +module M where + +-- | A heading + +-- and a note under it +data T = T + { a :: Int, -- the first + -- the second + b :: Int + } + +f x -- what to do with this? + | x > 0 = g x + | otherwise = h x + where + g = id + + -- about h + h = negate + +xs = + [ one, + {- inline -} two + -- last + ] diff --git a/corpora/vendored/other/comments-where-they-are-hard-to-put-back.hs b/corpora/vendored/other/comments-where-they-are-hard-to-put-back.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/comments-where-they-are-hard-to-put-back.hs @@ -0,0 +1,25 @@ +module M where + +-- | A heading + +-- and a note under it +data T = T + { a :: Int, -- the first + -- the second + b :: Int + } + +f x -- what to do with this? + | x > 0 = g x + | otherwise = h x + where + g = id + + -- about h + h = negate + +xs = + [ one, + {- inline -} two + -- last + ] diff --git a/corpora/vendored/other/cpp/code-after-an-optional-prefix-out.hs b/corpora/vendored/other/cpp/code-after-an-optional-prefix-out.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/cpp/code-after-an-optional-prefix-out.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE CPP #-} + +-- Code that one branch puts a prefix in front of, written at the column of +-- the prefix, comes out once after the conditional. +module Properties.Json (jsonIso, label, retried) where + +jsonIso :: Proxy a -> Property +jsonIso _ = +#if MIN_VERSION_QuickCheck(2,9,0) + again $ +#endif + MkProperty $ + arbitrary >>= \x -> + counterexample "decoded" (Just x == decode (encode x)) + +label :: String -> Property -> Property +label s = +#ifndef LAZY_LABELS + s `seq` +#endif + mapTotalResult $ + \res -> res{labels = s : labels res} + +-- Written in each branch, it stays in each. +retried :: Property -> Property +retried p = +#if MIN_VERSION_QuickCheck(2,9,0) + again $ + once p +#else + once p +#endif diff --git a/corpora/vendored/other/cpp/code-after-an-optional-prefix.hs b/corpora/vendored/other/cpp/code-after-an-optional-prefix.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/cpp/code-after-an-optional-prefix.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE CPP #-} + +-- Code that one branch puts a prefix in front of, written at the column of +-- the prefix, comes out once after the conditional. +module Properties.Json (jsonIso, label, retried) where + +jsonIso :: Proxy a -> Property +jsonIso _ = +#if MIN_VERSION_QuickCheck(2,9,0) + again $ +#endif + MkProperty $ + arbitrary >>= \x -> + counterexample "decoded" (Just x == decode (encode x)) + +label :: String -> Property -> Property +label s = +#ifndef LAZY_LABELS + s `seq` +#endif + mapTotalResult $ + \res -> res {labels = s : labels res} + +-- Written in each branch, it stays in each. +retried :: Property -> Property +retried p = +#if MIN_VERSION_QuickCheck(2,9,0) + again $ + once p +#else + once p +#endif diff --git a/corpora/vendored/other/cpp/where-after-an-export-list-in-a-conditional-out.hs b/corpora/vendored/other/cpp/where-after-an-export-list-in-a-conditional-out.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/cpp/where-after-an-export-list-in-a-conditional-out.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE CPP #-} + +-- | Shapes, with an export list unless the doctests read the module. +module Shapes +#ifndef DOCTEST + ( Shape (..), + area, + ) +#endif +where + +data Shape = Square Double | Circle Double + +area :: Shape -> Double +area (Square a) = a * a +area (Circle r) = pi * r * r diff --git a/corpora/vendored/other/cpp/where-after-an-export-list-in-a-conditional.hs b/corpora/vendored/other/cpp/where-after-an-export-list-in-a-conditional.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/cpp/where-after-an-export-list-in-a-conditional.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE CPP #-} +-- | Shapes, with an export list unless the doctests read the module. +module Shapes +#ifndef DOCTEST + ( Shape (..) + , area + ) +#endif +where + +data Shape = Square Double | Circle Double + +area :: Shape -> Double +area (Square a) = a * a +area (Circle r) = pi * r * r diff --git a/corpora/vendored/other/extension-pack-before-what-it-enables-out.hs b/corpora/vendored/other/extension-pack-before-what-it-enables-out.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/extension-pack-before-what-it-enables-out.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE GHC2021 #-} +{-# LANGUAGE ApplicativeDo #-} + +module M where diff --git a/corpora/vendored/other/extension-pack-before-what-it-enables.hs b/corpora/vendored/other/extension-pack-before-what-it-enables.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/extension-pack-before-what-it-enables.hs @@ -0,0 +1,3 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE GHC2021 #-} +module M where diff --git a/corpora/vendored/other/extension-taken-back-from-the-edition-out.hs b/corpora/vendored/other/extension-taken-back-from-the-edition-out.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/extension-taken-back-from-the-edition-out.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE NoStarIsType #-} + +module M (type (*)) where + +import GHC.TypeLits (type (*)) diff --git a/corpora/vendored/other/extension-taken-back-from-the-edition.hs b/corpora/vendored/other/extension-taken-back-from-the-edition.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/extension-taken-back-from-the-edition.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE NoStarIsType #-} +{-# LANGUAGE TypeOperators #-} +module M (type (*)) where +import GHC.TypeLits (type (*)) diff --git a/corpora/vendored/other/language-pragmas-split-and-sorted-out.hs b/corpora/vendored/other/language-pragmas-split-and-sorted-out.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/language-pragmas-split-and-sorted-out.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} + +module M where diff --git a/corpora/vendored/other/language-pragmas-split-and-sorted.hs b/corpora/vendored/other/language-pragmas-split-and-sorted.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/language-pragmas-split-and-sorted.hs @@ -0,0 +1,2 @@ +{-# LANGUAGE OverloadedStrings, GADTs #-} +module M where diff --git a/corpora/vendored/signature/abstract-data-with-a-kind-out.hsig b/corpora/vendored/signature/abstract-data-with-a-kind-out.hsig new file mode 100644 --- /dev/null +++ b/corpora/vendored/signature/abstract-data-with-a-kind-out.hsig @@ -0,0 +1,7 @@ +signature Shape where + +import Data.Kind (Type) + +data Shape :: Type + +data Pair :: Type -> Type -> Type diff --git a/corpora/vendored/signature/abstract-data-with-a-kind.hsig b/corpora/vendored/signature/abstract-data-with-a-kind.hsig new file mode 100644 --- /dev/null +++ b/corpora/vendored/signature/abstract-data-with-a-kind.hsig @@ -0,0 +1,6 @@ +signature Shape where + +import Data.Kind (Type) + +data Shape :: Type +data Pair :: Type -> Type -> Type diff --git a/corpora/vendored/signature/class-and-instances-out.hsig b/corpora/vendored/signature/class-and-instances-out.hsig new file mode 100644 --- /dev/null +++ b/corpora/vendored/signature/class-and-instances-out.hsig @@ -0,0 +1,10 @@ +signature Ordered where + +data Item + +class Sized a where + size :: a -> Int + +instance Sized Item + +instance Eq Item diff --git a/corpora/vendored/signature/class-and-instances.hsig b/corpora/vendored/signature/class-and-instances.hsig new file mode 100644 --- /dev/null +++ b/corpora/vendored/signature/class-and-instances.hsig @@ -0,0 +1,10 @@ +signature Ordered where + +data Item + +class Sized a where + size :: a -> Int + +instance Sized Item + +instance Eq Item diff --git a/corpora/vendored/signature/comments-after-the-last-declaration-out.hsig b/corpora/vendored/signature/comments-after-the-last-declaration-out.hsig new file mode 100644 --- /dev/null +++ b/corpora/vendored/signature/comments-after-the-last-declaration-out.hsig @@ -0,0 +1,10 @@ +signature Ledger where + +data Entry + +instance Show Entry + +post :: Entry -> IO () -- posted before the period closes, + -- and never after + +-- the journal is append-only diff --git a/corpora/vendored/signature/comments-after-the-last-declaration.hsig b/corpora/vendored/signature/comments-after-the-last-declaration.hsig new file mode 100644 --- /dev/null +++ b/corpora/vendored/signature/comments-after-the-last-declaration.hsig @@ -0,0 +1,10 @@ +signature Ledger where + +data Entry + +instance Show Entry + +post :: Entry -> IO () -- posted before the period closes, + -- and never after + +-- the journal is append-only diff --git a/corpora/vendored/signature/comments-in-a-signature-out.hsig b/corpora/vendored/signature/comments-in-a-signature-out.hsig new file mode 100644 --- /dev/null +++ b/corpora/vendored/signature/comments-in-a-signature-out.hsig @@ -0,0 +1,10 @@ +signature Ledger where + +-- the amounts are always in minor units +data Amount + +data Entry -- one line of the journal + +-- posted before the period closes, +-- and never after +post :: Entry -> IO () diff --git a/corpora/vendored/signature/comments-in-a-signature.hsig b/corpora/vendored/signature/comments-in-a-signature.hsig new file mode 100644 --- /dev/null +++ b/corpora/vendored/signature/comments-in-a-signature.hsig @@ -0,0 +1,10 @@ +signature Ledger where + +-- the amounts are always in minor units +data Amount + +data Entry -- one line of the journal + +-- posted before the period closes, +-- and never after +post :: Entry -> IO () diff --git a/corpora/vendored/signature/consecutive-type-signatures-out.hsig b/corpora/vendored/signature/consecutive-type-signatures-out.hsig new file mode 100644 --- /dev/null +++ b/corpora/vendored/signature/consecutive-type-signatures-out.hsig @@ -0,0 +1,7 @@ +signature Store where + +data Handle + +open :: FilePath -> IO Handle + +close :: Handle -> IO () diff --git a/corpora/vendored/signature/consecutive-type-signatures.hsig b/corpora/vendored/signature/consecutive-type-signatures.hsig new file mode 100644 --- /dev/null +++ b/corpora/vendored/signature/consecutive-type-signatures.hsig @@ -0,0 +1,5 @@ +signature Store where + +data Handle +open :: FilePath -> IO Handle +close :: Handle -> IO () diff --git a/corpora/vendored/signature/documented-declarations-out.hsig b/corpora/vendored/signature/documented-declarations-out.hsig new file mode 100644 --- /dev/null +++ b/corpora/vendored/signature/documented-declarations-out.hsig @@ -0,0 +1,7 @@ +signature Clock where + +-- | A reading of the wall clock. +data Instant + +-- | The moment this was asked for. +now :: IO Instant diff --git a/corpora/vendored/signature/documented-declarations.hsig b/corpora/vendored/signature/documented-declarations.hsig new file mode 100644 --- /dev/null +++ b/corpora/vendored/signature/documented-declarations.hsig @@ -0,0 +1,7 @@ +signature Clock where + +-- | A reading of the wall clock. +data Instant + +-- | The moment this was asked for. +now :: IO Instant diff --git a/corpora/vendored/signature/everything-above-the-keyword-out.hsig b/corpora/vendored/signature/everything-above-the-keyword-out.hsig new file mode 100644 --- /dev/null +++ b/corpora/vendored/signature/everything-above-the-keyword-out.hsig @@ -0,0 +1,8 @@ +{-# LANGUAGE RoleAnnotations #-} + +-- the parser leaves these in its own state, not in the tree +signature Buffer where + +type role Buffer nominal + +data Buffer a diff --git a/corpora/vendored/signature/everything-above-the-keyword.hsig b/corpora/vendored/signature/everything-above-the-keyword.hsig new file mode 100644 --- /dev/null +++ b/corpora/vendored/signature/everything-above-the-keyword.hsig @@ -0,0 +1,8 @@ +{-# LANGUAGE RoleAnnotations #-} + +-- the parser leaves these in its own state, not in the tree +signature Buffer where + +type role Buffer nominal + +data Buffer a diff --git a/corpora/vendored/signature/exports-listed-out.hsig b/corpora/vendored/signature/exports-listed-out.hsig new file mode 100644 --- /dev/null +++ b/corpora/vendored/signature/exports-listed-out.hsig @@ -0,0 +1,12 @@ +signature Codec + ( Codec, + encode, + decode, + ) +where + +data Codec + +encode :: Codec -> String + +decode :: String -> Maybe Codec diff --git a/corpora/vendored/signature/exports-listed.hsig b/corpora/vendored/signature/exports-listed.hsig new file mode 100644 --- /dev/null +++ b/corpora/vendored/signature/exports-listed.hsig @@ -0,0 +1,12 @@ +signature Codec + ( Codec, + encode, + decode, + ) +where + +data Codec + +encode :: Codec -> String + +decode :: String -> Maybe Codec diff --git a/corpora/vendored/signature/fixity-declaration-out.hsig b/corpora/vendored/signature/fixity-declaration-out.hsig new file mode 100644 --- /dev/null +++ b/corpora/vendored/signature/fixity-declaration-out.hsig @@ -0,0 +1,7 @@ +signature Combine where + +data Chunk + +infixr 5 <+> + +(<+>) :: Chunk -> Chunk -> Chunk diff --git a/corpora/vendored/signature/fixity-declaration.hsig b/corpora/vendored/signature/fixity-declaration.hsig new file mode 100644 --- /dev/null +++ b/corpora/vendored/signature/fixity-declaration.hsig @@ -0,0 +1,7 @@ +signature Combine where + +data Chunk + +infixr 5 <+> + +(<+>) :: Chunk -> Chunk -> Chunk diff --git a/corpora/vendored/signature/type-family-out.hsig b/corpora/vendored/signature/type-family-out.hsig new file mode 100644 --- /dev/null +++ b/corpora/vendored/signature/type-family-out.hsig @@ -0,0 +1,11 @@ +{-# LANGUAGE TypeFamilies #-} + +signature Element where + +data Container + +type family Elem c + +type Name = String + +elems :: Container -> [Elem Container] diff --git a/corpora/vendored/signature/type-family.hsig b/corpora/vendored/signature/type-family.hsig new file mode 100644 --- /dev/null +++ b/corpora/vendored/signature/type-family.hsig @@ -0,0 +1,11 @@ +{-# LANGUAGE TypeFamilies #-} + +signature Element where + +data Container + +type family Elem c + +type Name = String + +elems :: Container -> [Elem Container] diff --git a/corpora/vendored/signature/type-role-annotation-out.hsig b/corpora/vendored/signature/type-role-annotation-out.hsig new file mode 100644 --- /dev/null +++ b/corpora/vendored/signature/type-role-annotation-out.hsig @@ -0,0 +1,7 @@ +{-# LANGUAGE RoleAnnotations #-} + +signature Cache where + +type role Cache nominal representational + +data Cache k v diff --git a/corpora/vendored/signature/type-role-annotation.hsig b/corpora/vendored/signature/type-role-annotation.hsig new file mode 100644 --- /dev/null +++ b/corpora/vendored/signature/type-role-annotation.hsig @@ -0,0 +1,7 @@ +{-# LANGUAGE RoleAnnotations #-} + +signature Cache where + +type role Cache nominal representational + +data Cache k v diff --git a/src/Tilia/Cabal/Package.hs b/src/Tilia/Cabal/Package.hs --- a/src/Tilia/Cabal/Package.hs +++ b/src/Tilia/Cabal/Package.hs @@ -8,6 +8,8 @@ module Tilia.Cabal.Package ( PackageProblem (..), describePackageProblem, + readPackageDescription, + declaredModules, PackageReader, newPackageReader, ComponentSection (..), @@ -18,6 +20,7 @@ benchmarkBranches, addedSources, sourceExtensions, + isDeclaredModule, joined, setupScript, ) @@ -27,7 +30,7 @@ import Data.ByteString qualified as BS import Data.Generics.Schemes (listify) import Data.IORef -import Data.List (isSuffixOf, sortOn) +import Data.List (sortOn) import Data.List.NonEmpty qualified as NE import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map @@ -68,7 +71,7 @@ import GHC.Driver.Session qualified as GHC import GHC.LanguageExtensions.Type (Extension) import Language.Haskell.Extension qualified as Cabal -import System.Directory (canonicalizePath, doesDirectoryExist, listDirectory) +import System.Directory (canonicalizePath, doesDirectoryExist) import System.FilePath ( dropExtension, equalFilePath, @@ -79,7 +82,8 @@ takeExtension, (), ) -import Tilia.Pragma (lookupExtension) +import Tilia.Cabal.Project (cabalFilesIn) +import Tilia.Pragma (applyExtensionName, lookupEdition) import Tilia.Process (readProgramOutput) import Tilia.Utils (attempted, quietly) @@ -132,7 +136,7 @@ findCabalFile covering from >>= \case Nothing -> pure (Left NoPackageFile) Just cabalFile -> - componentsOf compiler described cabalFile >>= \case + componentBranchesOf compiler described cabalFile >>= \case Left problem -> pure (Left problem) Right components | equalFilePath file (takeDirectory cabalFile setupScript) -> @@ -172,15 +176,24 @@ covered = not . null . covering named c = any (declares c) (covering c) declares c d = - let path = under d - in Set.member path (componentEntries c) - || ( takeExtension path `elem` sourceExtensions - && Set.member (dropExtension path) (componentModules c) - ) + isDeclaredModule (componentModules c) (componentEntries c) (under d) under d = joinPath (drop (length (splitDirectories d)) (splitDirectories file)) nearness = maximum . fmap length . covering covering c = [d | d <- componentDirs c, d `covers` file] +-- | Is a file, named relative to a source directory, one of the modules or +-- entry points declared there? +isDeclaredModule :: + -- | The modules, without their extensions. + Set FilePath -> + -- | The entry points. + Set FilePath -> + FilePath -> + Bool +isDeclaredModule modules entries path = + takeExtension path `elem` sourceExtensions + && (Set.member path entries || Set.member (dropExtension path) modules) + -- | Whether a file is somewhere under a directory. covers :: FilePath -> FilePath -> Bool covers directory file = go (splitDirectories directory) (splitDirectories file) @@ -209,9 +222,8 @@ case Map.lookup directory known of Just answer -> settle passed answer Nothing -> do - entries <- quietly [] (listDirectory directory) - case filter (".cabal" `isSuffixOf`) entries of - (named : _) -> settle (directory : passed) (Just (directory named)) + cabalFilesIn directory >>= \case + (found : _) -> settle (directory : passed) (Just found) [] -> let parent = takeDirectory directory in if parent == directory @@ -222,12 +234,12 @@ pure answer -- | What a @.cabal@ file amounts to. -componentsOf :: +componentBranchesOf :: IO (Maybe Version) -> IORef (Map FilePath (Either PackageProblem [ComponentBranch])) -> FilePath -> IO (Either PackageProblem [ComponentBranch]) -componentsOf compiler ref cabalFile = do +componentBranchesOf compiler ref cabalFile = do known <- readIORef ref case Map.lookup cabalFile known of Just answer -> pure answer @@ -237,18 +249,26 @@ pure answer where settle = - attempted (BS.readFile cabalFile) >>= \case - Left why -> pure (Left (PackageUnreadable cabalFile why)) - Right bytes -> - case snd (runParseResult (parseGenericPackageDescription bytes)) of - Left (_, complaints) -> - pure (Left (PackageMalformed cabalFile (fmap said (NE.toList complaints)))) - Right description -> do - valueOf <- conditionValues compiler description - Right - <$> traverse - (componentBranch (takeDirectory cabalFile)) - (sectionsInForce valueOf description) + readPackageDescription cabalFile >>= \case + Left problem -> pure (Left problem) + Right description -> do + valueOf <- conditionValues compiler description + Right + <$> traverse + (componentBranch (takeDirectory cabalFile)) + (sectionsInForce valueOf description) + +-- | Read and parse a @.cabal@ file, or say why it cannot be. +readPackageDescription :: FilePath -> IO (Either PackageProblem GenericPackageDescription) +readPackageDescription cabalFile = + attempted (BS.readFile cabalFile) >>= \case + Left why -> pure (Left (PackageUnreadable cabalFile why)) + Right bytes -> + pure $ case snd (runParseResult (parseGenericPackageDescription bytes)) of + Left (_, complaints) -> + Left (PackageMalformed cabalFile (fmap said (NE.toList complaints))) + Right description -> Right description + where said = T.pack . showPError cabalFile -- | The value a build of a package on this platform gives each variable its @@ -314,14 +334,29 @@ <> ownSection <> ComponentSection (builtSettings valueOf) [] [] ) - <$> concat - [ foldMap libraryBranches (condLibrary described), - concatMap (libraryBranches . snd) (condSubLibraries described), - concatMap (executableBranches . snd) (condExecutables described), - concatMap (suiteBranches . snd) (condTestSuites described), - concatMap (benchmarkBranches . snd) (condBenchmarks described) - ] + <$> packageBranches described +-- | Every branch of every component of a package, in the order declared. +packageBranches :: GenericPackageDescription -> [BranchSections] +packageBranches described = + concat + [ foldMap libraryBranches (condLibrary described), + concatMap (libraryBranches . snd) (condSubLibraries described), + concatMap (executableBranches . snd) (condExecutables described), + concatMap (suiteBranches . snd) (condTestSuites described), + concatMap (benchmarkBranches . snd) (condBenchmarks described) + ] + +-- | Every module any branch of a package declares, with where it would be +-- written relative to the package, without an extension. +declaredModules :: GenericPackageDescription -> [(Text, FilePath)] +declaredModules described = + [ (T.intercalate "." (fmap T.pack (splitDirectories sub <> [name])), joined d (joined sub name)) + | branch <- packageBranches described, + (d, section) <- addedSources branch, + (sub, name) <- sectionModules section + ] + -- | What one branch of a component declares. data ComponentSection = ComponentSection { -- | Its build settings. @@ -476,13 +511,11 @@ where edition = ghcLanguage (fromMaybe Cabal.Haskell98 (defaultLanguage bi)) apply acc = \case - Cabal.EnableExtension e - | Just on <- named e, on `notElem` acc -> acc <> [on] - Cabal.DisableExtension e - | Just off <- named e -> filter (/= off) acc + Cabal.EnableExtension e -> applyExtensionName acc (named e) + Cabal.DisableExtension e -> applyExtensionName acc ("No" <> named e) _ -> acc - named = lookupExtension . T.pack . show + named = T.pack . show -- | GHC's name for a language edition, when it has one. ghcLanguage :: Cabal.Language -> Maybe GHC.Language -ghcLanguage l = lookup (show l) [(show e, e) | e <- [minBound .. maxBound]] +ghcLanguage = lookupEdition . T.pack . show diff --git a/src/Tilia/Cabal/Plan.hs b/src/Tilia/Cabal/Plan.hs new file mode 100644 --- /dev/null +++ b/src/Tilia/Cabal/Plan.hs @@ -0,0 +1,824 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | A project's build plan, and the @cabal@ runs that make it ready to read. +module Tilia.Cabal.Plan + ( -- * Build plans + PlanPackage (..), + PackageSource (..), + isFetchable, + sourceHashOf, + cacheKey, + BuildPlan (..), + readBuildPlan, + readGivenPlan, + fetchUninstalled, + getInstalledPackages, + tokenForEnvAndBuildPlan, + tokenForBuildPlan, + macrosOf, + versionMacros, + plannedCompiler, + generatedModules, + + -- * Readiness + Readiness (..), + PlanComponent (..), + spellPlanComponent, + plannedComponents, + planPathFor, + checkReadiness, + plannedTarballs, + packageCacheRoot, + guessedPackageCacheRoot, + Futility (..), + undiscoveredFutility, + futilityFor, + prepareWith, + loadPlan, + ) +where + +import Control.Monad (filterM, join, void) +import Data.Aeson + ( FromJSON (..), + Value, + decodeStrict, + eitherDecodeFileStrict, + withObject, + (.:), + (.:?), + ) +import Data.Aeson.Types (parseMaybe) +import Data.Choice (Choice, isTrue) +import Data.Foldable (toList, traverse_) +import Data.List qualified +import Data.List.NonEmpty (NonEmpty ((:|))) +import Data.List.NonEmpty qualified as NE +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Maybe (fromMaybe, listToMaybe) +import Data.Set (Set) +import Data.Set qualified as Set +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.Encoding qualified as T +import Data.Text.Read qualified as T +import Data.Time (UTCTime, getCurrentTime) +import Distribution.Version (Version, mkVersion) +import GHC.IO.Handle (hDuplicate) +import System.Directory + ( XdgDirectory (XdgCache), + doesFileExist, + getAppUserDataDirectory, + getModificationTime, + getXdgDirectory, + listDirectory, + ) +import System.Environment (lookupEnv) +import System.Exit (ExitCode (..)) +import System.FilePath (isRelative, takeDirectory, ()) +import System.IO (hClose, hFlush, stderr) +import System.Info qualified +import System.Process + ( StdStream (CreatePipe, Inherit, UseHandle), + createProcess, + cwd, + proc, + std_err, + std_in, + std_out, + waitForProcess, + ) +import Tilia.Cabal.Project (cabalFilesIn) +import Tilia.Cpp.Macros (Macros (..)) +import Tilia.Fixity.Cache +import Tilia.Fixity.PackageDb +import Tilia.Process (readProgramOutput) +import Tilia.Utils (quietly, readFileText, sha256Of) + +---------------------------------------------------------------------------- +-- The plan + +-- | One package of a build plan. +data PlanPackage = PlanPackage + { -- | Package name + ppName :: Text, + -- | Package version + ppVersion :: Text, + -- | Package source + ppSource :: PackageSource, + -- | Which components of the package the entry is about. + -- + -- Usually one, because @cabal@ configures a package one component at a + -- time and gives each its own entry. A package it cannot take apart—one + -- with a @Custom@ build type, whose @Setup.hs@ is entitled to do as it + -- pleases—is planned whole instead, and its entry is about every + -- component at once. + ppComponents :: [Text] + } + deriving (Eq, Show) + +-- | Where a package's source is. +data PackageSource + = -- | Already installed, so @cabal@ will not build it. + -- + -- Not the same as "ships with the compiler", though it includes those. + PreExisting + | -- | A directory on this machine—the project being formatted, or a + -- sibling of it in the same repository. + LocalPackage FilePath + | -- | Fetched from a repository as a tarball, with the SHA-256 the plan + -- expects it to have and where it was fetched from. + RepoPackage (Maybe Text) RepoProvenance + | -- | A @source-repository-package@ we have not found the sources of. + SourceRepo + | -- | The same, found unpacked under the project's own @dist-newstyle@. + CheckedOut FilePath + deriving (Eq, Show) + +-- | Which repository a package was fetched from, as far as it bears on +-- finding the tarball afterwards. +data RepoProvenance + = -- | One @cabal@ downloads from, named by its URI. The tarball goes into + -- the package cache, in a directory named after the repository as the + -- configuration spells it. + RepoDownloaded Text + | -- | A directory of tarballs, named by @file+noindex@. Nothing is + -- downloaded and nothing is cached: the tarball is already sitting + -- there, beside the index @cabal@ wrote for it. + RepoFromDirectory FilePath + | -- | A plan that does not say. Older @cabal@ wrote nothing here, and + -- Hackage is the only guess worth making. + RepoNoProvenance + deriving (Eq, Show) + +-- | Is there a tarball to go and read? +isFetchable :: PlanPackage -> Bool +isFetchable p = case ppSource p of + RepoPackage _ _ -> True + _ -> False + +-- | Every package the compiler can see. +getInstalledPackages :: Cache -> IO [InstalledPackage] +getInstalledPackages cache = + cachedInstalled cache >>= \case + Just packages -> pure packages + Nothing -> do + found <- readInstalledPackages + storeInstalled cache found + pure (installedPackages found) + +-- | Summarize a 'BuildPlan', and the environment it will be read in, by +-- hashing over both. +tokenForBuildPlan :: BuildPlan -> IO PlanToken +tokenForBuildPlan plan = do + environment <- compilerIdentity + pure (tokenForEnvAndBuildPlan environment plan) + +-- | Similar to 'tokenForBuildPlan', but allows passing a compiler identity +-- as an argument. +tokenForEnvAndBuildPlan :: Text -> BuildPlan -> PlanToken +tokenForEnvAndBuildPlan environment plan = + PlanToken + . T.take 16 + . sha256Of + $ T.intercalate + "\n" + ( environment + : bpCompiler plan + : Data.List.sort (fmap cacheKey (bpPackages plan)) + ) + +-- | The SHA-256 the plan expects this package's tarball to have. +sourceHashOf :: PlanPackage -> Maybe Text +sourceHashOf p = case ppSource p of + RepoPackage hash _ -> hash + _ -> Nothing + +-- | How a package's cached answers are filed. +cacheKey :: PlanPackage -> Text +cacheKey p = + ppName p <> "-" <> ppVersion p <> maybe "" (("-" <>) . T.take 16) (sourceHashOf p) + +-- | A resolved build plan. +data BuildPlan = BuildPlan + { bpCompiler :: Text, + bpPackages :: [PlanPackage] + } + deriving (Eq, Show) + +instance FromJSON BuildPlan where + parseJSON = withObject "BuildPlan" $ \o -> + BuildPlan + <$> o .: "compiler-id" + <*> o .: "install-plan" + +instance FromJSON PlanPackage where + parseJSON = withObject "PlanPackage" $ \o -> do + name <- o .: "pkg-name" + version <- o .: "pkg-version" + kind <- o .:? "type" + sourceKind <- o .:? "pkg-src" >>= traverse (.: "type") + sourcePath <- o .:? "pkg-src" >>= traverse (.:? "path") + sourceHash <- o .:? "pkg-src-sha256" + repo <- o .:? "pkg-src" >>= traverse (.:? "repo") + repoKind <- traverse (traverse (.:? "type")) repo + repoUri <- traverse (traverse (.:? "uri")) repo + repoPath <- traverse (traverse (.:? "path")) repo + named <- o .:? "component-name" + whole <- o .:? "components" + pure + PlanPackage + { ppName = name, + ppVersion = version, + ppComponents = componentsOf named whole, + ppSource = case (kind :: Maybe Text, sourceKind :: Maybe Text) of + (Just "pre-existing", _) -> PreExisting + (_, Just "repo-tar") -> + RepoPackage + sourceHash + ( case ( join (join repoKind) :: Maybe Text, + join (join repoPath), + join (join repoUri) + ) of + (Just "local-repo-no-index", Just dir, _) -> + RepoFromDirectory (T.unpack dir) + (_, _, Just uri) -> RepoDownloaded uri + _ -> RepoNoProvenance + ) + (_, Just "local") -> LocalPackage (maybe "" T.unpack (join sourcePath)) + (_, Just "source-repo") -> SourceRepo + -- Anything else is treated as already present. + _ -> PreExisting + } + +-- | The components one plan entry is about. +-- +-- @cabal@ writes this two ways. An entry for a single component names it in +-- @component-name@; an entry for a package planned whole carries a +-- @components@ object instead, keyed by the very same spellings. Reading +-- only the first would leave every @Custom@ package looking like one the +-- plan says nothing about, and a run would keep asking @cabal@ to solve +-- again for components a fresh solve would file exactly where this one did. +-- +-- @setup@ is dropped. It is the @Setup.hs@ program @cabal@ builds in order +-- to build the package, not a component of the package, and nothing in the +-- project will ever be formatted as part of it. +componentsOf :: Maybe Text -> Maybe (Map Text Value) -> [Text] +componentsOf named whole = case named of + Just component -> [component] + Nothing -> filter (/= "setup") (Map.keys (fromMaybe Map.empty whole)) + +-- | Read @plan.json@. +readBuildPlan :: FilePath -> IO (Either Text BuildPlan) +readBuildPlan path = + decodePlan path >>= traverse (checkedOutIn (takeDirectory (takeDirectory path))) + +-- | Read a plan that is to be trusted as up to date. +readGivenPlan :: + -- | The project root. + FilePath -> + -- | The plan. + FilePath -> + IO (Either Text BuildPlan) +readGivenPlan root path = + fmap (\plan -> plan{bpPackages = fmap rooted (bpPackages plan)}) + <$> decodePlan path + where + rooted p = case ppSource p of + LocalPackage dir + | isRelative dir -> + p{ppSource = LocalPackage (root dir)} + _ -> p + +-- | Decode a plan, or say why it cannot be. +decodePlan :: FilePath -> IO (Either Text BuildPlan) +decodePlan path = + doesFileExist path >>= \case + False -> pure (Left ("no build plan at " <> T.pack path)) + True -> either (Left . T.pack) Right <$> eitherDecodeFileStrict path + +-- | Find where @cabal@ unpacked each @source-repository-package@. +checkedOutIn :: FilePath -> BuildPlan -> IO BuildPlan +checkedOutIn distDir plan = do + packages <- traverse locate (bpPackages plan) + pure plan{bpPackages = packages} + where + locate p = case ppSource p of + SourceRepo -> + clonesOf p >>= \case + (dir : _) -> pure p{ppSource = CheckedOut dir} + [] -> pure p + _ -> pure p + clonesOf p = quietly [] $ do + entries <- listDirectory (distDir "src") + filterM + (isThePackage p) + [ distDir "src" e + | e <- Data.List.sort entries, + (ppName p <> "-") `T.isPrefixOf` T.pack e + ] + isThePackage p dir = quietly False $ do + contents <- readFileText (dir T.unpack (ppName p) <> ".cabal") + pure (maybe False (describes p) contents) + describes p text = + any (names "name:" (ppName p)) (T.lines text) + && any (names "version:" (ppVersion p)) (T.lines text) + names field value line = case T.stripPrefix field (T.toLower (T.strip line)) of + Just rest -> T.strip rest == T.toLower value + Nothing -> False + +-- | The version macros a plan settles. +macrosOf :: BuildPlan -> Macros +macrosOf plan = + ( versionMacros + (numberedVersion =<< T.stripPrefix "ghc-" (bpCompiler plan)) + (Map.mapMaybe sole versions) + ) + { macroPlannedPackages = + Just (Set.fromList [underscored (ppName p) | p <- bpPackages plan]) + } + where + versions = + Map.fromListWith + Set.union + [ (ppName p, Set.singleton v) + | p <- bpPackages plan, + Just v <- [numberedVersion (ppVersion p)] + ] + sole vs = case Set.toList vs of + [v] -> Just v + _ -> Nothing + +-- | The version macros the compiler's version and each package's settle. +versionMacros :: + -- | The compiler's version. + Maybe [Integer] -> + -- | Each package's version, by name. + Map Text [Integer] -> + Macros +versionMacros given versions = + mempty + { macroExactVersions = + Map.fromList + ( [ ("MIN_VERSION_" <> underscored name, version) + | (name, version) <- Map.toList versions + ] + <> [("MIN_VERSION_GLASGOW_HASKELL", v) | v <- toList compiler] + ), + macroExactNumbers = + Map.fromList + [ entry + | (major : minor : patches) <- toList compiler, + entry <- + [ ("__GLASGOW_HASKELL__", major * 100 + minor), + ("__GLASGOW_HASKELL_PATCHLEVEL1__", nth 0 patches), + ("__GLASGOW_HASKELL_PATCHLEVEL2__", nth 1 patches) + ] + ], + macroUndefined = + if null compiler + then Set.empty + else Set.fromList ["__MHS__", "__HUGS__"] + } + where + compiler = case given of + Just parts@(_ : _ : _) -> Just (take 4 (parts <> repeat 0)) + _ -> Nothing + nth i xs = if i < length xs then xs !! i else 0 + +-- | The version of GHC a plan is for, where it is for GHC. +plannedCompiler :: BuildPlan -> Maybe Version +plannedCompiler plan = + mkVersion . fmap fromInteger + <$> (numberedVersion =<< T.stripPrefix "ghc-" (bpCompiler plan)) + +-- | The modules @cabal@ writes itself for a plan's packages. +generatedModules :: BuildPlan -> Set Text +generatedModules plan = + Set.fromList + [ prefix <> underscored (ppName p) + | p <- bpPackages plan, + prefix <- ["Paths_", "PackageInfo_"] + ] + +-- | A package's name as a module name spells it, which is with the hyphens +-- turned into underscores. @cabal@ does this for the version macros and for +-- the modules it generates alike. +underscored :: Text -> Text +underscored = T.map (\c -> if c == '-' then '_' else c) + +-- | A version as its numbers, or 'Nothing' where any of them is not one. +numberedVersion :: Text -> Maybe [Integer] +numberedVersion = traverse number . T.splitOn "." + where + number part = case T.decimal part of + Right (n, rest) | T.null rest -> Just n + _ -> Nothing + +---------------------------------------------------------------------------- +-- Readiness + +-- | A component of the project. +data PlanComponent = PlanComponent + { -- | The package it belongs to. + pcPackage :: Text, + -- | @lib@, @exe:name@, @test:name@, @bench:name@. + pcName :: Text + } + deriving (Eq, Ord, Show) + +-- | A component as it would be written on the command line. +spellPlanComponent :: PlanComponent -> Text +spellPlanComponent c = pcPackage c <> ":" <> pcName c + +-- | The components of the project's own packages that a plan covers. +plannedComponents :: BuildPlan -> [PlanComponent] +plannedComponents plan = + [ PlanComponent (ppName p) component + | p <- bpPackages plan, + LocalPackage _ <- [ppSource p], + component <- ppComponents p + ] + +-- | Whether everything the resolver needs is on disk. +data Readiness + = -- | Nothing to do. + Ready + | -- | No build plan; @cabal@ has not solved this project yet. + PlanMissing + | -- | The plan is older than the files that determine it. + PlanStale [FilePath] + | -- | The plan says nothing about components the run is about to format. + PlanNarrow [Text] + | -- | The plan is there, and some packages have neither been downloaded + -- nor built. The names are listed so that a caller can say what it is + -- waiting for. + -- + -- Built counts as having them: their interfaces provide everything the + -- source tarball would. + SourcesMissing [Text] + deriving (Eq, Show) + +-- | Where @cabal@ writes the plan for a project. +planPathFor :: FilePath -> FilePath +planPathFor projectDir = projectDir "dist-newstyle" "cache" "plan.json" + +-- | Check what is missing. +-- +-- One read of the plan and one @stat@ per package, so this is fast enough +-- to run before every format. +checkReadiness :: Choice "useCache" -> [PlanComponent] -> FilePath -> IO Readiness +checkReadiness caching wanted projectDir = + readBuildPlan (planPathFor projectDir) >>= \case + Left _ -> pure PlanMissing + Right plan -> do + solved <- cachedSolveTime =<< openCache caching =<< tokenForBuildPlan plan + newer <- filesNewerThanPlan plan projectDir solved + let covered = plannedComponents plan + missing = [spellPlanComponent c | c <- wanted, c `notElem` covered] + case (newer, missing) of + (_ : _, _) -> pure (PlanStale newer) + ([], _ : _) -> pure (PlanNarrow missing) + ([], []) -> + sourcesShortOf caching plan >>= \case + [] -> pure Ready + ps -> pure (SourcesMissing (fmap ppName ps)) + +-- | The packages the plan expects to fetch whose sources are not here. +sourcesShortOf :: Choice "useCache" -> BuildPlan -> IO [PlanPackage] +sourcesShortOf caching plan = do + cache <- openCache caching =<< tokenForBuildPlan plan + tarballs <- filter (isFetchable . fst) <$> plannedTarballs cache plan + absent <- fmap fst <$> filterM (fmap not . doesFileExist . snd) tarballs + if null absent + then pure [] + else do + installed <- getInstalledPackages cache + pure (filter (not . builtAlready installed) absent) + +-- | Has the compiler got this package already? +builtAlready :: [InstalledPackage] -> PlanPackage -> Bool +builtAlready installed p = any matches installed + where + matches i = ipName i == ppName p && ipVersion i == ppVersion p + +-- | The project files that have changed since the plan was written, and +-- since the last solve, which leaves a plan it would not change as it was. +filesNewerThanPlan :: BuildPlan -> FilePath -> Maybe UTCTime -> IO [FilePath] +filesNewerThanPlan plan projectDir solved = quietly [] $ do + written <- getModificationTime (planPathFor projectDir) + let planTime = maybe written (max written) solved + atRoot <- quietly [] (listDirectory projectDir) + atRootPackage <- cabalFilesIn projectDir + inPackages <- concat <$> traverse cabalFilesIn (localDirs plan) + let candidates = + [projectDir f | f <- atRoot, f `elem` projectFiles] + <> atRootPackage + <> inPackages + newer <- traverse (isNewerThan planTime) candidates + pure [f | Just f <- newer] + where + projectFiles = + ["cabal.project", "cabal.project.local", "cabal.project.freeze"] + localDirs p = + Data.List.nub [dir | LocalPackage dir <- fmap ppSource (bpPackages p)] + isNewerThan planTime path = quietly Nothing $ do + t <- getModificationTime path + pure (if t > planTime then Just path else Nothing) + +-- | An account of actions we know are not worth attempting. +data Futility = Futility + { -- | Has solving this plan already been tried and left it as narrow? + solveWasFutile :: IO Bool, + -- | Record that a solve has been run and left it narrow, which is what + -- 'solveWasFutile' answers from afterwards. + rememberFutileSolve :: IO (), + -- | The packages an earlier fetch was still short of afterwards. + fetchWasFutileFor :: IO [Text], + -- | Remember what a fetch left missing. + rememberFutileFetch :: [Text] -> IO (), + -- | Remember when a solve started, so that no change made before it + -- makes the plan stale. + rememberSolveTime :: UTCTime -> IO () + } + +-- | The state when we know nothing about futile actions yet. +undiscoveredFutility :: Futility +undiscoveredFutility = + Futility + { solveWasFutile = pure False, + rememberFutileSolve = pure (), + fetchWasFutileFor = pure [], + rememberFutileFetch = const (pure ()), + rememberSolveTime = const (pure ()) + } + +-- | A memory kept in the cache, under the plan the project has now. +futilityFor :: Choice "useCache" -> FilePath -> Futility +futilityFor caching projectDir = + Futility + { solveWasFutile = withCache False cachedFutileSolve, + rememberFutileSolve = withCache () storeFutileSolve, + fetchWasFutileFor = withCache [] cachedFutileFetch, + rememberFutileFetch = \packages -> + withCache () (`storeFutileFetch` packages), + rememberSolveTime = \started -> withCache () (`storeSolveTime` started) + } + where + withCache fallback use = + readBuildPlan (planPathFor projectDir) >>= \case + Left _ -> pure fallback + Right plan -> use =<< openCache caching =<< tokenForBuildPlan plan + +-- | Do whatever is missing, given a way to run @cabal@ and a memory of what +-- earlier attempts came to. +prepareWith :: + -- | Whether to use the cache. + Choice "useCache" -> + -- | Whether to download what is missing. + Choice "download" -> + -- | Run @cabal@ with these arguments. + ([String] -> IO (Either Text ())) -> + -- | What earlier attempts came to. + Futility -> + -- | The components the run is about to format. + [PlanComponent] -> + -- | The project being prepared. + FilePath -> + -- | What it was found to be short of. + Readiness -> + IO (Either Text ()) +prepareWith caching downloading cabal futility wanted projectDir = \case + Ready -> pure (Right ()) + SourcesMissing _ -> fetch + PlanMissing -> solveThenFetch + PlanStale _ -> solveThenFetch + PlanNarrow _ -> + solveWasFutile futility >>= \case + True -> fetchWhatIsShort + False -> solveThenFetch + where + wholeProject = ["--enable-tests", "--enable-benchmarks"] + tryWholeProject args = + cabal (args <> wholeProject) >>= \case + Right () -> pure (Right ()) + Left _ -> cabal args + fetch + | isTrue downloading = tryWholeProject ["build", ":all", "--only-download"] + | otherwise = pure (Right ()) + fetchWhatIsShort = + readBuildPlan (planPathFor projectDir) >>= \case + Left _ -> pure (Right ()) + Right plan -> do + short <- fmap ppName <$> sourcesShortOf caching plan + refused <- fetchWasFutileFor futility + if null short || all (`elem` refused) short + then pure (Right ()) + else + fetch >>= \case + Left err -> pure (Left err) + Right () -> do + left <- sourcesShortOf caching plan + rememberFutileFetch futility (fmap ppName left) + pure (Right ()) + solveThenFetch = do + started <- getCurrentTime + tryWholeProject ["build", ":all", "--dry-run"] >>= \case + Left err -> pure (Left err) + Right () -> do + rememberSolveTime futility started + checkReadiness caching wanted projectDir >>= \case + SourcesMissing _ -> fetch + PlanNarrow _ -> rememberFutileSolve futility >> fetchWhatIsShort + _ -> pure (Right ()) + +-- | Run @cabal@ in a project directory, letting it speak for itself. +runCabal :: FilePath -> [String] -> IO (Either Text ()) +runCabal projectDir args = quietly (Left "could not run cabal") $ do + hFlush stderr + -- A duplicate because 'createProcess' closes the handle it is given once + -- the child has it, and closing the real standard error would leave + -- nothing to report the failure on. + passed <- hDuplicate stderr + -- A pipe closed at once rather than our standard input, which in an + -- editor's process carries what the editor says to it. + (toChild, _, _, running) <- + createProcess + (proc "cabal" args) + { cwd = Just projectDir, + std_in = CreatePipe, + std_out = UseHandle passed, + std_err = Inherit + } + traverse_ hClose toChild + code <- waitForProcess running + pure $ case code of + ExitSuccess -> Right () + _ -> Left ("cabal " <> T.unwords (fmap T.pack args) <> " failed; see above") + +-- | Fetch the sources of a trusted plan's dependencies that are neither +-- installed nor fetched already, at the versions the plan names. +fetchUninstalled :: + -- | Whether to use the cache. + Choice "useCache" -> + -- | The project the plan is for. + FilePath -> + -- | The build plan to use. + BuildPlan -> + IO () +fetchUninstalled caching projectDir plan = + sourcesShortOf caching plan >>= \case + [] -> pure () + short -> + void . runCabal projectDir $ + "fetch" + : "--no-dependencies" + : [T.unpack (ppName p <> "-" <> ppVersion p) | p <- short] + +-- | Get a plan that is safe to use, doing whatever @cabal@ work is needed. +loadPlan :: + -- | Whether to use the cache. + Choice "useCache" -> + -- | Whether to download what is missing. + Choice "download" -> + -- | The components the run is about to format, so that a plan which says + -- nothing about them is solved again rather than trusted. + [PlanComponent] -> + -- | The project whose plan it is. + FilePath -> + IO (Either Text BuildPlan) +loadPlan caching downloading wanted projectDir = do + readiness <- checkReadiness caching wanted projectDir + prepareWith + caching + downloading + (runCabal projectDir) + (futilityFor caching projectDir) + wanted + projectDir + readiness + >>= \case + Left err -> pure (Left err) + _ -> readBuildPlan (planPathFor projectDir) + +-- | Every planned package whose source could be in the package cache, with +-- where that would be: under the package cache @cabal@ last named, unless +-- a tarball it downloads is not there, when @cabal@ is asked again. +plannedTarballs :: Cache -> BuildPlan -> IO [(PlanPackage, FilePath)] +plannedTarballs cache plan = + cachedPackageCache cache >>= \case + Just remembered -> do + tarballs <- under remembered + absent <- + filterM + (fmap not . doesFileExist . snd) + (filter (isFetchable . fst) tarballs) + if null absent then pure tarballs else asked + Nothing -> asked + where + asked = do + cacheRoot <- packageCacheRoot + storePackageCache cache cacheRoot + under cacheRoot + under cacheRoot = do + repos <- quietly [] (Data.List.sort <$> listDirectory cacheRoot) + traverse + (\p -> (,) p <$> tarballFor cacheRoot repos p) + [p | p <- bpPackages plan, not (isLocal p)] + isLocal p = case ppSource p of + LocalPackage _ -> True + CheckedOut _ -> True + _ -> False + +-- | Where @cabal@ keeps downloaded package sources, one directory per +-- repository it downloads from. +packageCacheRoot :: IO FilePath +packageCacheRoot = + readProgramOutput + "cabal" + ["path", "--remote-repo-cache", "--output-format=json"] + >>= \case + Just said | Just dir <- remoteRepoCacheIn said -> pure dir + _ -> guessedPackageCacheRoot + +-- | The package cache directory, out of what @cabal path@ printed. +remoteRepoCacheIn :: Text -> Maybe FilePath +remoteRepoCacheIn said = do + spoken <- + listToMaybe $ + reverse (filter (not . T.null) (fmap T.strip (T.lines said))) + value <- decodeStrict (T.encodeUtf8 spoken) + parseMaybe (withObject "cabal path" (.: "remote-repo-cache")) value + +-- | Where @cabal@ probably keeps its downloaded packages. +guessedPackageCacheRoot :: IO FilePath +guessedPackageCacheRoot = + lookupEnv "CABAL_DIR" >>= \case + Just dir -> pure (dir "packages") + Nothing -> do + places <- cabalDirs + found <- filterM holdsAnIndex (toList places) + pure (fromMaybe (NE.head places) (listToMaybe found)) + where + holdsAnIndex dir = + quietly False (doesFileExist (dir hackage "01-index.tar")) + hackage = "hackage.haskell.org" + +-- | Every directory @cabal@ could be keeping a package cache in, the +-- platform's own default first. +cabalDirs :: IO (NonEmpty FilePath) +cabalDirs = do + appData <- getAppUserDataDirectory "cabal" + xdg <- quietly Nothing (Just <$> getXdgDirectory XdgCache "cabal") + pure . fmap ( "packages") $ case xdg of + Just dir | not onWindows -> dir :| [appData] + Just dir -> appData :| [dir] + Nothing -> appData :| [] + +-- | Whether this is a Windows build, for the places that differ there. +onWindows :: Bool +onWindows = System.Info.os == "mingw32" + +-- | The repository @cabal@ would have kept a package's sources under. +hackageByDefault :: FilePath +hackageByDefault = "hackage.haskell.org" + +-- | Where a package's source tarball is, or where fetching would put it. +tarballFor :: FilePath -> [FilePath] -> PlanPackage -> IO FilePath +tarballFor cacheRoot repos p = case provenanceOf p of + RepoFromDirectory dir -> pure (dir flat) + RepoDownloaded uri -> searched (hostOf uri) + RepoNoProvenance -> searched Nothing + where + flat = T.unpack (ppName p <> "-" <> ppVersion p <> ".tar.gz") + under repo = + cacheRoot + repo + T.unpack (ppName p) + T.unpack (ppVersion p) + flat + searched preferred = do + let first' = fromMaybe hackageByDefault preferred + rest = filter (/= first') repos + found <- filterM doesFileExist (fmap under (first' : rest)) + pure (fromMaybe (under first') (listToMaybe found)) + +-- | Which repository a package came from, where it came from one. +provenanceOf :: PlanPackage -> RepoProvenance +provenanceOf p = case ppSource p of + RepoPackage _ repo -> repo + _ -> RepoNoProvenance + +-- | The host a URI names, which is what @cabal@ conventionally calls the +-- repository that lives there. +hostOf :: Text -> Maybe FilePath +hostOf uri = case T.breakOn "//" uri of + (_, rest) + | not (T.null rest), + host <- T.takeWhile (/= '/') (T.drop 2 rest), + not (T.null host) -> + Just (T.unpack host) + _ -> Nothing diff --git a/src/Tilia/Cabal/Project.hs b/src/Tilia/Cabal/Project.hs --- a/src/Tilia/Cabal/Project.hs +++ b/src/Tilia/Cabal/Project.hs @@ -7,17 +7,20 @@ Marker (..), markerFile, findProjectRoot, + cabalFilesIn, ) where -import Data.List (isSuffixOf) +import Control.Monad (filterM) +import Data.List (isSuffixOf, sort) import Data.Maybe (listToMaybe) import System.Directory ( canonicalizePath, doesDirectoryExist, + doesFileExist, listDirectory, ) -import System.FilePath (takeDirectory) +import System.FilePath (takeDirectory, takeFileName, ()) import Tilia.Utils (quietly) -- | A project, and what marked it out. @@ -61,9 +64,15 @@ markersIn directory = quietly ([], []) $ do entries <- listDirectory directory + packages <- cabalFilesIn directory pure ( [ProjectRoot directory ProjectFile | "cabal.project" `elem` entries], - [ ProjectRoot directory (PackageFile named) - | named <- take 1 (filter (".cabal" `isSuffixOf`) entries) - ] + [ProjectRoot directory (PackageFile (takeFileName p)) | p <- take 1 packages] ) + +-- | The @.cabal@ files sitting directly in a directory, in order. +cabalFilesIn :: FilePath -> IO [FilePath] +cabalFilesIn directory = quietly [] $ do + entries <- listDirectory directory + let named = sort (filter (".cabal" `isSuffixOf`) entries) + filterM doesFileExist (fmap (directory ) named) diff --git a/src/Tilia/Cabal/Target.hs b/src/Tilia/Cabal/Target.hs --- a/src/Tilia/Cabal/Target.hs +++ b/src/Tilia/Cabal/Target.hs @@ -22,7 +22,6 @@ import Data.ByteString.Char8 qualified as BS8 import Data.Char (toLower) import Data.List (isPrefixOf, isSuffixOf, sort) -import Data.List.NonEmpty qualified as NE import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map import Data.Set (Set) @@ -31,7 +30,6 @@ import Data.Text qualified as T import Data.Text.Encoding qualified as T import Distribution.Fields.Field (Field (..), FieldLine (..), Name (..)) -import Distribution.Fields.ParseResult (runParseResult) import Distribution.Fields.Parser (readFields) import Distribution.PackageDescription ( GenericPackageDescription (..), @@ -39,33 +37,32 @@ unPackageName, unUnqualComponentName, ) -import Distribution.PackageDescription.Parsec (parseGenericPackageDescription) -import Distribution.Parsec (showPError) import Distribution.Types.PackageId (PackageIdentifier (..)) import System.Directory (doesFileExist, listDirectory) import System.FilePath - ( dropExtension, - dropTrailingPathSeparator, + ( dropTrailingPathSeparator, normalise, takeDirectory, - takeExtension, (), ) import Tilia.Cabal.Package ( ComponentSection (..), + PackageProblem, addedSources, benchmarkBranches, + describePackageProblem, executableBranches, + isDeclaredModule, joined, libraryBranches, + readPackageDescription, setupScript, - sourceExtensions, suiteBranches, ) -import Tilia.Cabal.Project (Marker (..), ProjectRoot (..), markerFile) -import Tilia.Fixity.Plan (PlanComponent (..)) +import Tilia.Cabal.Plan (PlanComponent (..)) +import Tilia.Cabal.Project (Marker (..), ProjectRoot (..), cabalFilesIn, markerFile) import Tilia.Ignore (belowRoot, ignoreFilesAbove, isIgnored) -import Tilia.Utils (attempted, quietly) +import Tilia.Utils (fieldWords, quietly) -- | Which components a run was asked for. data Target @@ -147,18 +144,14 @@ -- | Is a directory entry one of the files wanted there? admits :: Wanted -> FilePath -> Bool -admits Wanted{..} entry = - takeExtension entry `elem` sourceExtensions - && ( Set.member entry wantedEntries - || Set.member (dropExtension entry) wantedModules - ) +admits Wanted{..} = isDeclaredModule wantedModules wantedEntries -- | Why a run could not work out what to format. data TargetProblem = -- | A @cabal.project@ naming packages, none of which could be found. NoPackages FilePath - | -- | A @.cabal@ file that would not parse, and what the parser said. - Unparseable FilePath [Text] + | -- | A @.cabal@ file that could not be read or parsed, and why. + UnreadablePackage PackageProblem | -- | A target naming no component the project holds. NoSuchTarget Text [Text] deriving (Eq, Show) @@ -168,8 +161,7 @@ describeTargetProblem = \case NoPackages file -> T.pack file <> " names no packages that exist" - Unparseable file complaints -> - T.pack file <> " does not parse:" <> foldMap ("\n " <>) complaints + UnreadablePackage problem -> describePackageProblem problem NoSuchTarget asked available -> "no component matches " <> asked @@ -261,7 +253,7 @@ directories = Map.unionsWith (<>) - [ Map.mapKeys (joined (directoryOf (componentRoot c))) (componentSources c) + [ Map.mapKeys (joined (asDirectory (componentRoot c))) (componentSources c) | c <- components ] present (directory, wanted) = do @@ -272,8 +264,8 @@ -- | A directory spelled so that a path can be appended to it without -- further normalisation. -directoryOf :: FilePath -> FilePath -directoryOf = dropTrailingPathSeparator . normalise +asDirectory :: FilePath -> FilePath +asDirectory = dropTrailingPathSeparator . normalise -- | The @.cabal@ files the project is made of. -- @@ -303,11 +295,7 @@ [T.unwords [T.decodeUtf8Lenient value | FieldLine _ value <- ls]] | otherwise -> [] Section _ _ inner -> packagesIn inner - entries = - filter (not . T.null) - . fmap T.strip - . concatMap (T.split (== ',')) - . T.words + entries = fieldWords -- | Turn one entry of a @packages@ field into the @.cabal@ files it names. packageToCabalFile :: FilePath -> Text -> IO [FilePath] @@ -348,40 +336,27 @@ before `isPrefixOf` name && after `isSuffixOf` drop (length before) name --- | The @.cabal@ files sitting directly in a directory. -cabalFilesIn :: FilePath -> IO [FilePath] -cabalFilesIn directory = quietly [] $ do - entries <- listDirectory directory - let named = sort (filter (".cabal" `isSuffixOf`) entries) - filterM doesFileExist (fmap (directory ) named) - -- | Every component one @.cabal@ file declares. componentsInCabalFile :: FilePath -> IO (Either TargetProblem [Component]) componentsInCabalFile cabalFile = - attempted (BS.readFile cabalFile) >>= \case - Left why -> pure (Left (Unparseable cabalFile [why])) - Right bytes -> - case snd (runParseResult (parseGenericPackageDescription bytes)) of - Left (_, complaints) -> - pure (Left (Unparseable cabalFile (fmap said (NE.toList complaints)))) - where - said = T.pack . showPError cabalFile - Right described -> do - let root = takeDirectory cabalFile - declared = declaredComponents root described - hasSetup <- quietly False (doesFileExist (root setupScript)) - pure . Right $ - declared - <> [ Component - { componentPackage = packageOf described, - componentKind = Setup, - componentName = "setup", - componentRoot = root, - componentSources = - Map.singleton "." (Wanted Set.empty (Set.singleton setupScript)) - } - | hasSetup - ] + readPackageDescription cabalFile >>= \case + Left problem -> pure (Left (UnreadablePackage problem)) + Right described -> do + let root = takeDirectory cabalFile + declared = declaredComponents root described + hasSetup <- quietly False (doesFileExist (root setupScript)) + pure . Right $ + declared + <> [ Component + { componentPackage = packageOf described, + componentKind = Setup, + componentName = "setup", + componentRoot = root, + componentSources = + Map.singleton "." (Wanted Set.empty (Set.singleton setupScript)) + } + | hasSetup + ] -- | The name of a package. packageOf :: GenericPackageDescription -> Text @@ -422,7 +397,7 @@ componentSources = Map.unionsWith (<>) - [ sourcesIn (directoryOf d) declared + [ sourcesIn (asDirectory d) declared | branch <- branches, (d, declared) <- addedSources branch ] diff --git a/src/Tilia/Comments.hs b/src/Tilia/Comments.hs --- a/src/Tilia/Comments.hs +++ b/src/Tilia/Comments.hs @@ -16,11 +16,14 @@ holdsOff, continuesHaddock, carriedOnFrom, + carriesOn, widenTrigger, asOrdinary, triggerEscaped, opensHaddock, opensSectionHeading, + afterOpener, + triggerOn, commentsWithin, Pragma (..), commentPragma, @@ -34,10 +37,10 @@ import Data.Maybe (isJust, listToMaybe, mapMaybe) import Data.Text (Text) import Data.Text qualified as T -import GHC.Parser.Annotation qualified as GHC +import GHC.Parser.Lexer qualified as GHC import GHC.Types.SrcLoc qualified as GHC import Tilia.Source.Lines (Lines, blankAt, directiveOnLine, lineAt, lineTexts) -import Tilia.Span (Span (..), endPoint, startPoint) +import Tilia.Span (Span (..), covers) import Tilia.Span.Ghc (spanOfReal) -- | One comment. @@ -95,22 +98,21 @@ commentsOf :: -- | The module's lines, which every comment is read against. Lines -> - -- | The module's comments, in source order. - [GHC.LEpaComment] -> + -- | The module's comment tokens, in source order, each where the lexer + -- found it. + [(GHC.RealSrcSpan, GHC.Token)] -> [Comment] -commentsOf ls = fmap (uncurry (mkComment ls)) . mapMaybe located - where - located (GHC.L anchor (GHC.EpaComment tok _)) = case anchor of - GHC.EpaSpan (GHC.RealSrcSpan s _) -> Just (s, tok) - _ -> Nothing +commentsOf ls = mapMaybe (uncurry (mkComment ls)) --- | Build a comment from a token and the span it occupied. -mkComment :: Lines -> GHC.RealSrcSpan -> GHC.EpaCommentTok -> Comment -mkComment ls spn tok = case tok of - GHC.EpaLineComment t -> commentAt ls s LineComment (T.pack t) - GHC.EpaBlockComment t -> commentAt ls s BlockComment (T.pack t) - GHC.EpaDocComment _ -> commentAt ls s DocComment (sliceSpan (lineTexts ls) s) - GHC.EpaDocOptions t -> commentAt ls s LineComment (T.pack t) +-- | Build a comment from a token and the span it occupied, where the token +-- is a comment. +mkComment :: Lines -> GHC.RealSrcSpan -> GHC.Token -> Maybe Comment +mkComment ls spn = \case + GHC.ITlineComment t _ -> Just (commentAt ls s LineComment (T.pack t)) + GHC.ITblockComment t _ -> Just (commentAt ls s BlockComment (T.pack t)) + GHC.ITdocComment _ _ -> Just (commentAt ls s DocComment (sliceSpan (lineTexts ls) s)) + GHC.ITdocOptions t _ -> Just (commentAt ls s LineComment (T.pack t)) + _ -> Nothing where s = spanOfReal spn @@ -255,12 +257,27 @@ (_ :| []) -> True _ -> False +-- | Does a comment under a remark carry it on, rather than go with the code +-- after it: is it no further left than the remark, or does that code begin +-- further left than the comment? +carriesOn :: + -- | The column the remark begins at. + Int -> + -- | The comment. + Span -> + -- | Where the code after it begins, if any follows. + Maybe Span -> + Bool +carriesOn remark comment after = + remark <= spanStartColumn comment + || all (\r -> spanStartColumn r < spanStartColumn comment) after + -- | The line whose trailing comment a comment with the line to itself -- carries on, by being lined up under that line or that comment, or under -- comments that carry it on in turn, and the column that comment begins at. carriedOnFrom :: [Comment] -> Comment -> Maybe (Int, Int) carriedOnFrom cs = \c -> - if commentTrailing c + if commentTrailing c || commentFollowed c then Nothing else go @@ -286,7 +303,7 @@ ] go column line above | Just remark <- IntMap.lookup line remarks, - above == ContentAt column || remark == column = + above == ContentAt column || remark <= column = Just (line, remark) | Just (col, above') <- IntMap.lookup line ownLineComments, col == column, @@ -372,13 +389,9 @@ -- the point of escaping—so anything wanting to know whether a comment -- started life as a Haddock has to ask this. triggerEscaped :: Comment -> Bool -triggerEscaped c = case openerWidth headLine of - Nothing -> False - Just n -> case T.uncons (T.dropWhile (== ' ') (T.drop n headLine)) of - Just ('\\', rest) -> triggered rest - _ -> False - where - headLine = NE.head (commentBody c) +triggerEscaped c = case T.uncons =<< afterOpener (NE.head (commentBody c)) of + Just ('\\', rest) -> triggered rest + _ -> False -- | Does this text begin with one of the characters that opens a Haddock? triggered :: Text -> Bool @@ -399,15 +412,17 @@ splitTrigger :: Text -> Maybe (Text, Text) splitTrigger l = do n <- openerWidth l - let (opener, afterOpener) = T.splitAt n l - (gap, rest) = T.span (== ' ') afterOpener - (trigger, body) <- case T.uncons rest of - Just ('|', b) -> Just ("|", b) - Just ('^', b) -> Just ("^", b) - Just ('*', _) -> Just (T.span (== '*') rest) - _ -> Nothing - pure (opener <> gap <> trigger, body) + let (opener, rest) = T.splitAt n l + (gap, inside) = T.span (== ' ') rest + trigger <- triggerOn inside + pure (opener <> gap <> trigger, T.drop (T.length trigger) inside) +-- | What follows the @--@ or @{-@ that opens a comment, and the spaces after +-- it, if the line opens one. +afterOpener :: Text -> Maybe Text +afterOpener l = (\n -> T.dropWhile (== ' ') (T.drop n l)) <$> openerWidth l +{-# INLINE afterOpener #-} + -- | How many characters open a comment, if it opens one. openerWidth :: Text -> Maybe Int openerWidth l @@ -415,11 +430,18 @@ | "{-" `T.isPrefixOf` l = Just 2 | otherwise = Nothing +-- | The trigger at the start of what follows a comment's opener: @|@, @^@, +-- or a run of @*@. +triggerOn :: Text -> Maybe Text +triggerOn inside = case T.uncons inside of + Just ('|', _) -> Just "|" + Just ('^', _) -> Just "^" + Just ('*', _) -> Just (T.takeWhile (== '*') inside) + _ -> Nothing + -- | The comments written inside a region. commentsWithin :: Span -> [Comment] -> [Comment] -commentsWithin s = filter (within . commentSpan) - where - within c = startPoint s <= startPoint c && endPoint c <= endPoint s +commentsWithin s = filter (covers s . commentSpan) -- | A compiler pragma, which is written as a block comment but is not one. -- diff --git a/src/Tilia/Comments/Attach.hs b/src/Tilia/Comments/Attach.hs --- a/src/Tilia/Comments/Attach.hs +++ b/src/Tilia/Comments/Attach.hs @@ -162,7 +162,7 @@ DLocated s d -> let (mine, p') = claimPlaced s p (d', p'') = go p' d - write = foldMap (uncurry (writtenAs margin (isEmptyAnchor s))) + write = foldMap (uncurry (writtenAs margin (zeroWidth s))) before' = (Before,) <$> heldOffFrom d [c | (Before, c) <- mine] after' = @@ -190,11 +190,8 @@ in (DVariant a' b', p') d -> (d, p) --- | Hold the last comment off a Haddock about to be written under it. --- --- Only a comment written as @--@ lines needs holding off: the lexer would --- read it and the Haddock under it as one comment. A @{- … -}@ ends at its --- own bracket and may sit against whatever follows. +-- | Hold the last comment, if written as @--@ lines, off a Haddock about to +-- be written under it. heldOffFrom :: Doc -> [Comment] -> [Comment] heldOffFrom d cs = case unsnoc cs of Just (earlier, c) @@ -227,11 +224,6 @@ DBreak -> ([], layout == Broken) DSoftBreak -> ([], layout == Broken) _ -> ([], False) - --- | Is this region an 'emptyAnchor' rather than one covering something --- written? -isEmptyAnchor :: Span -> Bool -isEmptyAnchor s = startPoint s == endPoint s -- | Render one 'Comment' where it was placed. writtenAs :: diff --git a/src/Tilia/Comments/Place.hs b/src/Tilia/Comments/Place.hs --- a/src/Tilia/Comments/Place.hs +++ b/src/Tilia/Comments/Place.hs @@ -27,6 +27,7 @@ ( Above (..), Comment (..), carriedOnFrom, + carriesOn, closesItself, commentTrailing, singleLine, @@ -158,7 +159,7 @@ onThatLine = IntMap.findWithDefault [] line regionsByEndLine candidate r = endPoint r <= startPoint here - && startPoint r /= endPoint r + && not (zeroWidth r) && not (fencedOff r) writtenAgainst = maybe False (`Set.member` regionEndPoints) stopsAt @@ -175,18 +176,15 @@ next = snd <$> Map.lookupGE (endPoint here) regionsByStartPoint continues - | nothingBelowItLinesUp, - Just (anchor, remark) <- carriedOn c = + | Just (anchor, remark) <- carriedOn c, + carriesOn remark here next = (,linedUpWith remark) <$> endingOn anchor | otherwise = Nothing linedUpWith remark - | remark == spanStartColumn here = After SpillUnderPrevious + | remark <= spanStartColumn here = After SpillUnderPrevious | otherwise = After SpillAtIndentation - nothingBelowItLinesUp = - all (\r -> spanStartColumn r < spanStartColumn here) next - under | Just (top, bottom) <- IntMap.lookup (spanStartLine here) runs, Just (line, column) <- commentNextLine bottom, @@ -204,7 +202,7 @@ onThatLine = IntMap.findWithDefault [] line regionsByEndLine lineEnd = maximum (fmap endPoint onThatLine) linedUp r = - startPoint r /= endPoint r + not (zeroWidth r) && endPoint r == lineEnd && (startsUnderIt r || holdsTheLine r) && not (fencedOff r) diff --git a/src/Tilia/Cpp.hs b/src/Tilia/Cpp.hs --- a/src/Tilia/Cpp.hs +++ b/src/Tilia/Cpp.hs @@ -19,17 +19,8 @@ -- * Splitting Guard (..), Configurations (..), - configurations, - leaves, branchLeaves, correspondingBranches, - linearLeaves, - countLeaves, - answeredLeaves, - answeredLinearLeaves, - - -- * Diagnostics - regions, ) where @@ -42,7 +33,6 @@ import Data.IntMap.Strict qualified as IntMap import Data.List (sort) import Data.List.NonEmpty (NonEmpty, nonEmpty) -import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map import Data.Maybe (catMaybes, fromMaybe, isNothing, listToMaybe, mapMaybe, maybeToList) import Data.Monoid (Any (..)) @@ -55,7 +45,7 @@ import Tilia.Cpp.Fragment (bodyOf, fragmentText, fragmentsOf, linesHeld, reassembled) import Tilia.Cpp.Merge (Settled (..), combine, merge) import Tilia.Cpp.Place (CommentSummary, restoreUnprinted, summarizeComments) -import Tilia.Doc (defaultRenderOptions, printDoc) +import Tilia.Doc (printDoc) import Tilia.Doc.Internal ( Doc (..), Layout (..), @@ -82,11 +72,7 @@ dropping, linesOf, ) -import Tilia.Span - ( Span, - spanEndLine, - spanStartLine, - ) +import Tilia.Span (spanEndLine, spanStartLine) ---------------------------------------------------------------------------- -- Formatting @@ -113,18 +99,22 @@ evalState ( runExceptT ( formatAllConfigs - parser - known - path - (reading parser known path (noAnswers source) source) + formatter + (reading formatter (noAnswers source) source) ) ) (configurationBudget * linesHeld source) formatted <- - printDoc defaultRenderOptions + printDoc <$> restoreUnprinted source found document formatted <$ traverse_ (Left . RuledOutBranch) (ruledOutBranch formatted) where + formatter = + Formatter + { formatterParser = parser, + formatterRender = known, + formatterPath = path + } known = render { rcImportBarriers = maybe [] (importBarriers parser source) groups, @@ -198,6 +188,16 @@ TooManyConfigurations -> refuse TooManyConfigurations _ -> pure Nothing +-- | What every configuration of a module is parsed and printed with. +data Formatter = Formatter + { -- | What to parse a configuration with. + formatterParser :: ParserConfig, + -- | What to print it with. + formatterRender :: RenderConfig, + -- | The file this is, for the positions in a parse error. + formatterPath :: FilePath + } + -- | A configuration, with what its conditionals come to worked out once -- for everything that asks. data Reading = Reading @@ -219,18 +219,14 @@ -- | Read a configuration. reading :: - -- | What to parse a configuration with. - ParserConfig -> - -- | What to print it with. - RenderConfig -> - -- | The file this is, for the positions in a parse error. - FilePath -> + -- | What to parse and print each configuration with. + Formatter -> -- | How this configuration was reached. Reached -> -- | Input text. Text -> Reading -reading parser render path reached source = +reading formatter reached source = Reading { readingReached = reached, readingSource = source, @@ -238,10 +234,11 @@ readingApart = do apart <- withForest (`variations` source) let baseline = without (vaBaselineDropped apart) reached - pure (apart, reading parser render path baseline (vaBaseline apart)), - readingPragma = withForest (\f -> splitOnPragma parser f source), + pure (apart, reading formatter baseline (vaBaseline apart)), + readingPragma = + withForest (\f -> splitOnPragma (formatterParser formatter) f source), readingFormatted = - formatSingleConfig parser render path reached (withoutOpaque source) + formatSingleConfig formatter reached (withoutOpaque source) } where forest = readConditionals source @@ -266,16 +263,12 @@ -- | Format every configuration of a module, and merge them into one -- document, with what they found besides their code. formatAllConfigs :: - -- | What to parse a configuration with. - ParserConfig -> - -- | What to print it with. - RenderConfig -> - -- | The file this is, for the positions in a parse error. - FilePath -> + -- | What to parse and print each configuration with. + Formatter -> -- | The configuration. Reading -> Spending (Doc, CommentSummary) -formatAllConfigs parser render path r = do +formatAllConfigs formatter r = do forest <- except (readingForest r) case readingApart r of Nothing -> do @@ -289,10 +282,10 @@ base <- if isNothing pragma || affordable then - attempt (formatAllConfigs parser render path baseline) + attempt (formatAllConfigs formatter baseline) else pure Nothing fragmented <- case (pragma, base) of - (Nothing, Just b) -> join <$> attempt (inFragments parser render path reached forest source b) + (Nothing, Just b) -> join <$> attempt (inFragments formatter reached forest source b) _ -> pure Nothing linear <- case (fragmented, base) of (Nothing, Just b) | affordable -> oneAtATime apart b @@ -300,13 +293,13 @@ case fragmented <|> linear of Just found -> pure found Nothing -> case maybeToList pragma <> forest of - g : _ -> together parser render path reached (configurationsOn g forest source) + g : _ -> together formatter reached (configurationsOn g forest source) [] -> error "Tilia: a module that varies has a conditional to split on" where reached = readingReached r source = readingSource r oneAtATime apart base = do - varied <- attempt (separately parser render path reached apart base) + varied <- attempt (separately formatter reached apart base) pure $ do (merged, found) <- varied d <- combine Broken (fst base) (zip (fmap cfgWholes (vaGroups apart)) merged) @@ -383,12 +376,8 @@ -- | Vary each conditional on its own, holding the others at their first -- branch. separately :: - -- | What to parse a configuration with. - ParserConfig -> - -- | What to print it with. - RenderConfig -> - -- | The file this is, for the positions in a parse error. - FilePath -> + -- | What to parse and print each configuration with. + Formatter -> -- | How this configuration was reached. Reached -> -- | The conditionals to vary, and the baseline to hold them against. @@ -396,10 +385,10 @@ -- | What the baseline was formatted to. (Doc, CommentSummary) -> Spending ([Doc], CommentSummary) -separately parser render path reached v (baseDoc, baseFound) = do +separately formatter reached v (baseDoc, baseFound) = do groups <- aheadOf (catMaybes (concat readings)) . for readings . traverse $ - maybe (pure (baseDoc, mempty)) (formatAllConfigs parser render path) + maybe (pure (baseDoc, mempty)) (formatAllConfigs formatter) let merged = zipWith (mergeOf (reachedLines reached)) @@ -410,7 +399,7 @@ readings = [ [ if t == vaBaseline v then Nothing - else Just (reading parser render path (answering c i reached) t) + else Just (reading formatter (answering c i reached) t) | (i, t) <- zip [0 ..] (cfgTexts c) ] | c <- vaGroups v @@ -421,12 +410,8 @@ -- -- 'Nothing' where the module cannot be taken apart like that. inFragments :: - -- | What to parse a configuration with. - ParserConfig -> - -- | What to print it with. - RenderConfig -> - -- | The file this is, for the positions in a parse error. - FilePath -> + -- | What to parse and print each configuration with. + Formatter -> -- | How this configuration was reached. Reached -> -- | The outermost conditionals. @@ -436,17 +421,17 @@ -- | What the baseline was formatted to. (Doc, CommentSummary) -> Spending (Maybe (Doc, CommentSummary)) -inFragments parser render path reached forest source (baseDoc, baseFound) = +inFragments formatter reached forest source (baseDoc, baseFound) = case parts of Nothing -> pure Nothing Just (body, ps) -> do let readings = - [ reading parser render path (without gone reached) t + [ reading formatter (without gone reached) t | (_, (t, gone)) <- ps ] formatted <- aheadOf readings $ - traverse (formatAllConfigs parser render path) readings + traverse (formatAllConfigs formatter) readings pure $ do doc <- reassembled body (zip (fmap fst ps) (fmap fst formatted)) pure (doc, baseFound <> foldMap snd formatted) @@ -459,8 +444,8 @@ (fragmentsOf body forest) pure (body, ps) --- | The outermost conditional around a @LANGUAGE@ or @OPTIONS@ pragma that --- changes how the rest of the module is parsed, if there is one. +-- | The outermost conditional around a @LANGUAGE@ pragma that changes how +-- the rest of the module is parsed, if there is one. -- -- Formatting a fragment on its own takes the rest of the module to be -- parsed alike in every configuration. @@ -488,35 +473,32 @@ in any pragma (take (to - from + 1) (drop (from - 1) written)) pragma l = let u = T.toUpper l - in "{-#" `T.isInfixOf` u - && ("LANGUAGE" `T.isInfixOf` u || "OPTIONS" `T.isInfixOf` u) + in "{-#" `T.isInfixOf` u && "LANGUAGE" `T.isInfixOf` u -- | Vary the conditionals together, one group at a time. together :: - -- | What to parse a configuration with. - ParserConfig -> - -- | What to print it with. - RenderConfig -> - -- | The file this is, for the positions in a parse error. - FilePath -> + -- | What to parse and print each configuration with. + Formatter -> -- | How this configuration was reached. Reached -> -- | The group to split on, and the branch texts to split it into. Configurations -> Spending (Doc, CommentSummary) -together parser render path reached c = do - (found, blind) <- - formatted differentlyRead `catchE` \case - ConfigurationNotParsed answers _ - | not differentlyRead, - isNothing (implied answers) -> - formatted True - e -> refuse e - if blind then fst <$> formatted False else pure found +together formatter reached c + | differentlyRead = settledOr (fst <$> formatted False) + | otherwise = + (fst <$> formatted False) `catchE` \case + e@(ConfigurationNotParsed answers _) + | isNothing (implied answers) -> settledOr (refuse e) + e -> refuse e where - readingOf = reading parser render path + settledOr unsettled = do + (found, blind) <- formatted True + if blind then unsettled else pure found + readingOf = reading formatter differentlyRead = or (zipWith (\a b -> not (readAlike parser a b)) texts (drop 1 texts)) + parser = formatterParser formatter texts = cfgTexts c formatted settle = do let (settledBy, answers) = @@ -526,7 +508,7 @@ if null (unconditionalErrors t) then Just . (,) i - <$> formatAllConfigs parser render path (readingOf r t) + <$> formatAllConfigs formatter (readingOf r t) else pure Nothing docs <- except (traverse (complete (fmap (fmap fst) found)) (zip [0 ..] texts)) @@ -597,22 +579,23 @@ -- | Format one configuration's code with the ordinary printer, and gather -- what else it holds. formatSingleConfig :: - -- | What to parse it with. - ParserConfig -> - -- | What to print it with. - RenderConfig -> - -- | The file this is, for the positions in a parse error. - FilePath -> + -- | What to parse and print it with. + Formatter -> -- | How this configuration was reached. Reached -> -- | The configuration itself, with no directives left in it. Text -> Either CppError (Doc, CommentSummary) -formatSingleConfig parser render path reached text = - case parseConfiguration parser path (reachedLines reached) text of +formatSingleConfig formatter reached text = + case parseConfiguration + (formatterParser formatter) + (formatterPath formatter) + (reachedLines reached) + text of Left e -> Left (ConfigurationNotParsed (reachedAnswers reached) e) Right parsed -> - let (document, loose) = renderConfiguration render parsed + let (document, loose) = + renderConfiguration (formatterRender formatter) parsed in Right (document, summarizeComments loose (comments (pmSource parsed))) -- | How a configuration was reached, and what to call it. @@ -715,19 +698,3 @@ (cfgGuards c) (cfgWholes c) [] - ----------------------------------------------------------------------------- --- Diagnostics - --- | Every region a document records provenance for, with what was printed --- there. --- --- The outermost wins where a span appears twice, which is the one 'walk' --- would have given a comment to. -regions :: Doc -> Map Span Doc -regions = Map.fromListWith (\_ outer -> outer) . go - where - go = \case - DLocated s d -> (s, d) : go d - DVariant a _ -> go a - d -> foldChildren go d diff --git a/src/Tilia/Cpp/Directives.hs b/src/Tilia/Cpp/Directives.hs --- a/src/Tilia/Cpp/Directives.hs +++ b/src/Tilia/Cpp/Directives.hs @@ -15,21 +15,16 @@ -- * Splitting Guard (..), Configurations (..), - configurations, configurationsOn, Varied (..), untouched, - leaves, branchLeaves, implied, settledBranch, correspondingBranches, ruledOutBranch, unconditionalErrors, - linearLeaves, - countLeaves, - answeredLeaves, - answeredLinearLeaves, + Assignment, resolved, -- * The directives themselves @@ -63,7 +58,13 @@ import Tilia.Cpp.Macros (Macros, guardHolds, impliedBy) import Tilia.Doc.Internal (Conditional (..)) import Tilia.Parser (ParseError, describeParseError) -import Tilia.Source (directiveOnLine) +import Tilia.Source.Lines + ( conditionalKeywords, + continuesGroup, + directiveOnLine, + opaqueKeywords, + opensGroup, + ) import Tilia.Span ( Span, mkSpan, @@ -81,10 +82,7 @@ -- | Blank out the directive lines, keeping every branch. blankCpp :: Text -> Text -blankCpp source = - blanking - ([(dLine d, dLastLine d) | d <- directives source] <> [(n, n) | (n, _) <- macroLines source]) - source +blankCpp = withoutDirectives directives -- | Blank out every branch the macros rule out, and the conditionals that -- ask about them. @@ -119,9 +117,16 @@ -- | A module with the opaque directives and the lines using its macros -- blanked out. withoutOpaque :: Text -> Text -withoutOpaque source = +withoutOpaque = withoutDirectives opaqueDirectives + +-- | A module with the directives a scan finds and the lines using its +-- macros blanked out. +withoutDirectives :: (Text -> [Directive]) -> Text -> Text +withoutDirectives scan source = blanking - ([(dLine d, dLastLine d) | d <- opaqueDirectives source] <> [(n, n) | (n, _) <- macroLines source]) + ( [(dLine d, dLastLine d) | d <- scan source] + <> [(n, n) | (n, _) <- macroLines source] + ) source -- | Why a module using the preprocessor could not be formatted. @@ -129,7 +134,8 @@ = -- | A conditional that does not make sense: the line and the keyword of -- the directive that gives it away, and what is wrong with it. MalformedConditional Int Text Malformation - | -- | More configurations than 'configurationBudget' allows. + | -- | Configurations that would format the module's lines more times over + -- than 'Tilia.Cpp.configurationBudget' allows. TooManyConfigurations | -- | A configuration the parser rejected, and which one it was. ConfigurationNotParsed [([Guard], Int)] ParseError @@ -212,14 +218,6 @@ } deriving (Eq, Show) --- | Split a module on its first outermost conditional, and on every other --- one written behind the same directives, wherever in the module it sits. -configurations :: Text -> Maybe Configurations -configurations source = do - forest <- scanConditionals source - gs <- listToMaybe forest - pure (configurationsOn gs forest source) - -- | Split a module on one of its conditionals, and on every other one -- written behind the same directives. configurationsOn :: @@ -259,10 +257,6 @@ where reaches (from, to) = spanStartLine s <= to && from <= spanEndLine s --- | Every configuration of a module, with every conditional resolved. -leaves :: Text -> Either CppError [Text] -leaves = fmap (fmap snd) . answeredLeaves - -- | One configuration for every branch of every conditional, and no more. branchLeaves :: Text -> Either CppError [Text] branchLeaves source = do @@ -436,90 +430,9 @@ groups = [gsWhole g | forest <- maybeToList (scanConditionals source), g <- allGroups forest] encloses n (from, to) = from < n && n < to --- | The configurations reached by varying one conditional at a time. -linearLeaves :: Text -> Either CppError [Text] -linearLeaves = fmap (fmap snd) . answeredLinearLeaves - --- | How many configurations a module has, without building any of them, --- and so counting those no definition of the macros gives. -countLeaves :: Text -> Either CppError Integer -countLeaves source = do - forest <- readConditionals source - pure (sum [across answers forest | answers <- combinations (afforded forest)]) - where - across answers = product . fmap (one answers) - one answers gs = case lookup (gsGuards gs) answers of - Just i -> across answers (nestedIn gs i) - Nothing -> sum [across answers (nestedIn gs i) | i <- [0 .. gsCount gs - 1]] - combinations = traverse (\(g, k) -> [(g, i) | i <- [0 .. k - 1]]) - afforded forest = go 1 (repeated forest) - where - go _ [] = [] - go n ((g, k) : rest) - | n * toInteger k <= guardsToTie = (g, k) : go (n * toInteger k) rest - | otherwise = [] - --- | The guards a module asks more than once, and how many answers each has. -repeated :: [GroupSpec] -> [([Guard], Int)] -repeated forest = distinct Map.empty [q | q@(g, _) <- asked forest, twice g] - where - asked gss = concat [(gsGuards gs, gsCount gs) : asked (concat (gsNested gs)) | gs <- gss] - times = Map.fromListWith (+) [(g, 1 :: Int) | (g, _) <- asked forest] - twice g = Map.findWithDefault 0 g times >= 2 - - distinct _ [] = [] - distinct seen (q@(g, _) : rest) - | Map.member g seen = distinct seen rest - | otherwise = q : distinct (Map.insert g () seen) rest - --- | How many combinations of answers 'countLeaves' will enumerate. -guardsToTie :: Integer -guardsToTie = 4096 - --- | Every configuration some definition of the macros gives, and the --- answers that reach it. -answeredLeaves :: Text -> Either CppError [(Assignment, Text)] -answeredLeaves = - fmap (filter (isJust . implied . Map.toList . fst)) . go Map.empty - where - go answers source = case configurations source of - Nothing | not (null (unconditionalErrors source)) -> Right [] - Nothing -> (\t -> [(answers, t)]) <$> resolved source - Just c -> - concat - <$> traverse - (\(i, t) -> go (Map.insert (cfgGuards c) i answers) t) - (zip [0 ..] (cfgTexts c)) - -- | Which branch every question was answered with to reach a configuration. type Assignment = Map [Guard] Int --- | The same, labelled by the answers that reach each one, and for the same --- reason as 'answeredLeaves'. -answeredLinearLeaves :: Text -> Either CppError [(Assignment, Text)] -answeredLinearLeaves = - fmap (filter (isJust . implied . Map.toList . fst)) . go Map.empty - where - go answers source = case configurations source of - Nothing -> (\t -> [(answers, t)]) <$> resolved source - Just c -> case zip [0 ..] (cfgTexts c) of - [] -> Right [] - (i, first) : rest -> - (<>) - <$> go (Map.insert (cfgGuards c) i answers) first - <*> traverse (held answers (cfgGuards c)) rest - where - held before gs (i, t) = answeredBaseline (Map.insert gs i before) t - --- | The configuration in which every question still to be asked takes its --- first branch, and the answers that gives. -answeredBaseline :: Assignment -> Text -> Either CppError (Assignment, Text) -answeredBaseline answers source = case configurations source of - Nothing -> (answers,) <$> resolved source - Just c -> case cfgTexts c of - [] -> Right (answers, source) - t : _ -> answeredBaseline (Map.insert (cfgGuards c) 0 answers) t - -- | A module with every conditional answered, and its other directives -- taken out, or why its conditionals do not make sense. resolved :: Text -> Either CppError Text @@ -551,8 +464,7 @@ go = \case [] -> [] (n, l) : ls - | Just (keyword, body) <- directiveOnLine l, - keyword `elem` directiveKeywords -> + | Just (keyword, body) <- directiveOnLine l -> let (continued, rest) = continuation l ls in Directive { dLine = n, @@ -616,30 +528,9 @@ scanConditionals :: Text -> Maybe [GroupSpec] scanConditionals = either (const Nothing) Just . readConditionals --- | The directives that ask a question, and so split a module in two. -conditionalKeywords :: [Text] -conditionalKeywords = opensGroup <> continuesGroup <> ["endif"] - --- | The keywords that open a group or continue one. -opensGroup, continuesGroup :: [Text] -opensGroup = ["if", "ifdef", "ifndef"] -continuesGroup = ["elif", "elifdef", "elifndef", "else"] - -- | Does this line begin with a preprocessor directive? isDirective :: Text -> Bool -isDirective l = case directiveOnLine l of - Just (keyword, _) -> keyword `elem` directiveKeywords - Nothing -> False - --- | Every directive the C preprocessor takes, whether or not this module --- can do anything with the ones it names. -directiveKeywords :: [Text] -directiveKeywords = conditionalKeywords <> opaqueKeywords - --- | The unconditional directives that do not split the source code. -opaqueKeywords :: [Text] -opaqueKeywords = - ["define", "undef", "include", "line", "error", "warning", "pragma"] +isDirective = isJust . directiveOnLine -- | One conditional group, read off the directives that make it up. data GroupSpec = GroupSpec diff --git a/src/Tilia/Cpp/Fragment.hs b/src/Tilia/Cpp/Fragment.hs --- a/src/Tilia/Cpp/Fragment.hs +++ b/src/Tilia/Cpp/Fragment.hs @@ -121,7 +121,7 @@ [ Fragment gs (any above gs) (runAt (lo - 1)) (runAt hi) | (gs, (lo, hi)) <- clustered . sortOn (fst . snd) $ - [(g, reach (bodyRuns body) (gsWhole g)) | g <- forest] + [(g, runsTouched (bodyRuns body) (gsWhole g)) | g <- forest] ] where above = (<= bodyHeadEnd body) . fst . gsWhole @@ -131,8 +131,8 @@ -- | The runs a conditional's lines touch, or where it falls between two of -- them. -reach :: [Run] -> (Int, Int) -> (Int, Int) -reach runs (a, b) = +runsTouched :: [Run] -> (Int, Int) -> (Int, Int) +runsTouched runs (a, b) = case [i | (i, r) <- zip [0 ..] runs, runFrom r <= b, a <= runTo r] of [] -> let p = length (takeWhile ((< a) . runTo) runs) in (p, p) is -> (minimum is, maximum is + 1) diff --git a/src/Tilia/Cpp/Macros.hs b/src/Tilia/Cpp/Macros.hs --- a/src/Tilia/Cpp/Macros.hs +++ b/src/Tilia/Cpp/Macros.hs @@ -226,10 +226,7 @@ firstThat f = foldr (\x acc -> maybe acc Just (f x)) Nothing readDigits = T.foldl' (\n c -> n * 10 + toInteger (fromEnum c - fromEnum '0')) 0 --- | An expression, and what is left of the tokens after it. -type Reading = Maybe (Expr, [Token]) - -orExpr :: [Token] -> Reading +orExpr :: [Token] -> Maybe (Expr, [Token]) orExpr ts = do (left, rest) <- andExpr ts more left rest @@ -240,7 +237,7 @@ more (Or left right) rest' rest -> Just (left, rest) -andExpr :: [Token] -> Reading +andExpr :: [Token] -> Maybe (Expr, [Token]) andExpr ts = do (left, rest) <- compared ts more left rest @@ -251,7 +248,7 @@ more (And left right) rest' rest -> Just (left, rest) -compared :: [Token] -> Reading +compared :: [Token] -> Maybe (Expr, [Token]) compared ts = do (left, rest) <- unary ts case rest of @@ -284,7 +281,7 @@ exactly = And (Reaches n [m]) (Not (Reaches n [m + 1])) reaching _ _ _ = Nothing -unary :: [Token] -> Reading +unary :: [Token] -> Maybe (Expr, [Token]) unary = \case Punct "!" : rest -> do (e, rest') <- unary rest diff --git a/src/Tilia/Cpp/Merge.hs b/src/Tilia/Cpp/Merge.hs --- a/src/Tilia/Cpp/Merge.hs +++ b/src/Tilia/Cpp/Merge.hs @@ -22,8 +22,8 @@ import Data.Text (Text) import Data.Text qualified as T import Tilia.Cpp.Directives (Guard (..), Varied (..), untouched) -import Tilia.Cpp.Place (regionOf) -import Tilia.Doc (defaultRenderOptions, printDoc) +import Tilia.Cpp.Place (foldRegions, regionOf) +import Tilia.Doc (printDoc) import Tilia.Doc.Combinators qualified as Doc import Tilia.Doc.Internal ( Conditional (..), @@ -44,7 +44,7 @@ wrap, ) import Tilia.Source (Lines, lineAt) -import Tilia.Span (Span (..), covers, endOf, endPoint, meets, startOf, startPoint) +import Tilia.Span (Span (..), covers, endOf, meets, startOf, zeroWidth) -- | A conditional other than the one asked about that answering a question -- settles, for some answers at least. @@ -132,9 +132,26 @@ Nothing -> case spineAt l d of parts@(_ : _ : _) -> Just . factored middle l $ - [if k == inside then parts else [e] | (k, e) <- zip [0 ..] xs] + [ if k == inside then tucked inside l parts else [e] + | (k, e) <- zip [0 ..] xs + ] _ -> Nothing + tucked inside l parts = case unsnoc parts of + Just (front, DNest _ y) + | e : _ <- + [ e + | e <- xs, + regionOf e == regionOf y, + fmap spanStartColumn (regionOf e) == column, + printDoc (DGroup l y) + == printDoc e + ] -> + front <> [e] + _ -> parts + where + column = spanStartColumn <$> listToMaybe (drop inside spans) + factored within layout ss = let same (x, _) (y, _) = agree varied layout x y common as bs = @@ -240,7 +257,7 @@ byLines | not (any continuing ss), not (null (foldr1 Set.intersection (foldMap writtenAt <$> ss))), - (ls, cuts) <- unzip (fmap (linesOf layout) ss), + (ls, cuts) <- unzip (fmap (printedLines layout) ss), or cuts = [factored whole layout ls] | otherwise = [] @@ -318,7 +335,7 @@ lineEnding h hs | all ((== printed h) . printed) hs = layout | otherwise = Flat - printed = printDoc defaultRenderOptions + printed = printDoc endingWith t d = fromMaybe (d <> t) (inAlternatives d) where @@ -447,9 +464,9 @@ agreeOn varied layout x y = case (x, y) of (DLocated s x', DLocated t y') -> s == t - && ( untouched varied (reach s x') - && untouched varied (reach t y') - && startPoint s /= endPoint s + && ( untouched varied (spanWithHaddock s x') + && untouched varied (spanWithHaddock t y') + && not (zeroWidth s) || inside x' y' ) (DCppChoice ws bs x', DCppChoice ws' cs y') -> @@ -480,8 +497,8 @@ -- | A region's span, stretched over the span it prints first, which the -- Haddock of a constructor, a field or an argument is, written above or -- below it. -reach :: Span -> Doc -> Span -reach s d = maybe s (<> s) (firstMarked d) +spanWithHaddock :: Span -> Doc -> Span +spanWithHaddock s d = maybe s (<> s) (firstMarked d) where firstMarked = \case DLocated h x -> firstMarked x <|> Just h @@ -759,8 +776,8 @@ -- | The lines a run of documents prints and the space between them, each in -- the wrappers it is printed in, and whether that cuts an element of the -- run. -linesOf :: Layout -> [Doc] -> ([Doc], Bool) -linesOf layout xs = (plain . mconcat <$> filter (not . null) ps, cut) +printedLines :: Layout -> [Doc] -> ([Doc], Bool) +printedLines layout xs = (plain . mconcat <$> filter (not . null) ps, cut) where (ps, _, cut) = partsOf layout Within xs @@ -805,7 +822,7 @@ d -> getAny (foldChildren (Any . bare) d) -- | Where a part of a run of documents begins. -data Place +data PartStart = -- | On a line, after what the line already holds. Within | -- | Between two lines. @@ -818,7 +835,7 @@ -- | The layout the run is printed in. Layout -> -- | Where the run begins. - Place -> + PartStart -> -- | The run. [Doc] -> -- | The parts in order, the first of them what the run adds to the part @@ -826,7 +843,7 @@ -- run ends, which is where what follows it begins; and whether an element -- of the run holds what is printed on more than one line, so that the cut -- went through it. - ([[Doc]], Place, Bool) + ([[Doc]], PartStart, Bool) partsOf layout = walk [[]] False where walk ls cut place = \case @@ -874,10 +891,7 @@ -- | Where the regions a document holds were written. writtenAt :: Doc -> Set Span -writtenAt = \case - DLocated s d -> Set.insert s (writtenAt d) - DFence s d -> Set.insert s (writtenAt d) - d -> foldChildren writtenAt d +writtenAt = foldRegions (\s _ -> Set.insert s) -- | Does this document print nothing but space and what ends a line? blank :: Doc -> Bool diff --git a/src/Tilia/Cpp/Place.hs b/src/Tilia/Cpp/Place.hs --- a/src/Tilia/Cpp/Place.hs +++ b/src/Tilia/Cpp/Place.hs @@ -8,6 +8,8 @@ summarizeComments, restoreUnprinted, regionOf, + regionsIn, + foldRegions, ) where @@ -108,8 +110,8 @@ summaryHaddocks = Set.fromList [commentSpan c | c <- every, holdsOff c] } --- | Place comments into a document is the result of merging different --- configurations. +-- | Put the conditionals, comments, opaque directives and macro lines back +-- into the document the configurations were merged into. restoreUnprinted :: -- | The module as written. Text -> @@ -378,12 +380,20 @@ -- | Every region a document records, and what it holds. regionsIn :: Doc -> [(Span, Doc)] -regionsIn = \case - DLocated s d -> (s, d) : regionsIn d - DFence s d -> (s, d) : regionsIn d - d -> foldChildren regionsIn d +regionsIn = foldRegions (\s d inside -> (s, d) : inside) --- | The smallest span covering every region a document records. +-- | Fold the regions a document records, giving each its span, what it +-- holds, and what the fold made of the regions inside it. +foldRegions :: (Monoid m) => (Span -> Doc -> m -> m) -> Doc -> m +foldRegions f = go + where + go = \case + DLocated s d -> f s d (go d) + DFence s d -> f s d (go d) + d -> foldChildren go d +{-# INLINE foldRegions #-} + +-- | The smallest span covering the outermost regions a document records. regionOf :: Doc -> Maybe Span regionOf = \case DLocated s _ -> Just s diff --git a/src/Tilia/Diff.hs b/src/Tilia/Diff.hs --- a/src/Tilia/Diff.hs +++ b/src/Tilia/Diff.hs @@ -34,7 +34,7 @@ -- | After. Text -> Text -diff palette = unified palette (Just roomFor) [] +diff palette = unified palette [] -- | The whole of a unified diff of one file against its formatted self, -- headed the way @git diff@ heads one. @@ -50,7 +50,6 @@ diffInFull palette path = unified palette - Nothing [paint palette Place ("diff --git " <> before <> " " <> after)] (before, after) where @@ -60,11 +59,9 @@ -- | One line of the comparison, with the number it has on each side. data Line = Line !Mark !Int !Int !Text --- | A unified diff, with whatever heading and limit the caller wants. +-- | A unified diff, with whatever heading the caller wants. unified :: Palette -> - -- | How many lines are worth printing, where there is a limit at all. - Maybe Int -> -- | Whatever goes above the two file names. [Text] -> -- | What to call the two sides. @@ -74,28 +71,20 @@ -- | After. Text -> Text -unified palette limit above (beforeName, afterName) before after +unified palette above (beforeName, afterName) before after | null hunks, before /= after = "(the two differ only in how they end their lines)" | null hunks = "(the two are identical as text, so the difference is in something\ \ the text does not show)" - | otherwise = T.intercalate "\n" (above <> heading <> shown) + | otherwise = T.intercalate "\n" (above <> heading <> body) where heading = [ paint palette (Header Gone) ("--- " <> beforeName), paint palette (Header New) ("+++ " <> afterName) ] - shown = case limit of - Just room | length body > room -> take room body <> [omitted room] - _ -> body - where - omitted room = - paint palette Meta $ - "… and " <> T.pack (show (length body - room)) <> " more lines" - body = concatMap render hunks render range = hunkHeading range : fmap line (slice range) @@ -113,7 +102,7 @@ [] -> "0,0" line (Line mark _ _ text) = case mark of - Context -> paint palette Unchanged (" " <> text) + Context -> paint palette Kept (" " <> text) Removed -> paint palette Gone ("-" <> text) Added -> paint palette New ("+" <> text) @@ -134,10 +123,6 @@ -- | How many unchanged lines to show either side of a change. margin :: Int margin = 3 - --- | How many lines of diff are worth printing before it stops being read. -roomFor :: Int -roomFor = 60 -- | Join hunks that have grown into one another. merge :: [(Int, Int)] -> [(Int, Int)] diff --git a/src/Tilia/Doc.hs b/src/Tilia/Doc.hs --- a/src/Tilia/Doc.hs +++ b/src/Tilia/Doc.hs @@ -1,8 +1,6 @@ -- | Turning a printed document into source text. module Tilia.Doc ( Doc, - RenderOptions (..), - defaultRenderOptions, printDoc, ) where @@ -10,11 +8,9 @@ import Data.Text (Text) import Tilia.Doc.Internal ( Doc, - RenderOptions (..), - defaultRenderOptions, render, ) -- | Render a document to source text. -printDoc :: RenderOptions -> Doc -> Text +printDoc :: Doc -> Text printDoc = render diff --git a/src/Tilia/Doc/Combinators.hs b/src/Tilia/Doc/Combinators.hs --- a/src/Tilia/Doc/Combinators.hs +++ b/src/Tilia/Doc/Combinators.hs @@ -224,8 +224,6 @@ attach Hanging body = space <> body attach Normal body = breakOrSpace <> indent body --- | 'Hanging' if the span was a single line in the input, 'Normal' - ---------------------------------------------------------------------------- -- Indentation diff --git a/src/Tilia/Doc/Internal.hs b/src/Tilia/Doc/Internal.hs --- a/src/Tilia/Doc/Internal.hs +++ b/src/Tilia/Doc/Internal.hs @@ -25,8 +25,6 @@ TrailingWhitespace (..), -- * Rendering - RenderOptions (..), - defaultRenderOptions, render, ) where @@ -295,16 +293,9 @@ ---------------------------------------------------------------------------- -- Rendering --- | Knobs for 'render'. -newtype RenderOptions = RenderOptions - { -- | Columns per indentation step. - roIndentStep :: Int - } - deriving (Eq, Show) - --- | Two columns per step. -defaultRenderOptions :: RenderOptions -defaultRenderOptions = RenderOptions{roIndentStep = 2} +-- | Columns per indentation step. +indentStep :: Int +indentStep = 2 -- | What the engine carries while walking a document. data Env = Env @@ -312,8 +303,6 @@ envIndent :: !Int, -- | The layout of the innermost group. envLayout :: !Layout, - -- | Columns per indentation step. - envIndentStep :: !Int, -- | Whether what is written now is a note, which goes to the margin -- right above a preprocessor directive. envNote :: !Bool @@ -414,14 +403,13 @@ } -- | Turn a document into text. -render :: RenderOptions -> Doc -> Text -render opts doc = finish (roIndentStep opts) (go env doc emptyOut) +render :: Doc -> Text +render doc = finish (go env doc emptyOut) where env = Env { envIndent = 0, envLayout = Broken, - envIndentStep = roIndentStep opts, envNote = False } @@ -450,7 +438,7 @@ DHardBreak -> breakLine (envIndent env) DVerbatimBreak lineStart trailing -> verbatimBreakLine (envNote env) lineStart trailing DCat a b -> go env b . go env a - DNest n d -> go env{envIndent = envIndent env + n * envIndentStep env} d + DNest n d -> go env{envIndent = envIndent env + n * indentStep} d DAlign d -> \out -> go env{envIndent = max (envIndent env) (outColumn out)} d out DCppMarginNote d -> \out -> @@ -698,24 +686,16 @@ -- | Assemble the final text: one trailing newline, no blank lines at the -- end, no trailing whitespace anywhere. -finish :: - -- | Columns per indentation step. - Int -> - Out -> - Text -finish step out = +finish :: Out -> Text +finish out = case dropWhile (T.null . lineBody) (outLines (breakLine 0 out)) of [] -> "" - ls -> T.unlines (lineText <$> notesToMargin (continued step (reverse ls))) + ls -> T.unlines (lineText <$> notesToMargin (continued (reverse ls))) -- | Indent each alternative of a conditional that continues the line before -- the conditional further than that line. -continued :: - -- | Columns per indentation step. - Int -> - [Line] -> - [Line] -continued step = walk [] 0 False +continued :: [Line] -> [Line] +continued = walk [] 0 False where walk frames previous pending = \case [] -> [] @@ -736,7 +716,7 @@ | lineContinues l, not (linePinned l), at <= before -> - (before, before - at + step) : rest + (before, before - at + indentStep) : rest where at = lineIndent l + sum (fmap snd rest) _ -> frames diff --git a/src/Tilia/Editor.hs b/src/Tilia/Editor.hs --- a/src/Tilia/Editor.hs +++ b/src/Tilia/Editor.hs @@ -4,6 +4,8 @@ -- | Definitions to support editor integrations. module Tilia.Editor ( editorSession, + Compiled (..), + compiledSession, formatBuffer, ) where @@ -18,9 +20,11 @@ componentsOfTarget, ) import Tilia.Format - ( FormatError, + ( Compiled (..), + FormatError (NoProject), PlanSource (..), Session, + compiledSession, newSession, sessionRoot, ) @@ -53,25 +57,23 @@ downloading checkAst checkIdempotence - debugFixity = do - planSource <- case givenPlan of - Just plan -> pure (GivenPlan plan) - Nothing -> PlanFromCabal <$> components - newSession - file - planSource - caching - downloading - checkAst - checkIdempotence - debugFixity - where - components = - findProjectRoot file >>= \case - Nothing -> pure [] - Just root -> - either (const []) (mapMaybe componentInPlan) + debugFixity = + findProjectRoot file >>= \case + Nothing -> pure (Left (NoProject file)) + Just root -> do + planSource <- case givenPlan of + Just plan -> pure (GivenPlan plan) + Nothing -> + PlanFromCabal . either (const []) (mapMaybe componentInPlan) <$> componentsOfTarget root Everything + newSession + root + planSource + caching + downloading + checkAst + checkIdempotence + debugFixity -- | Format given text on the assumption it comes from the specified -- 'FilePath'. diff --git a/src/Tilia/Equivalence.hs b/src/Tilia/Equivalence.hs --- a/src/Tilia/Equivalence.hs +++ b/src/Tilia/Equivalence.hs @@ -68,6 +68,7 @@ ) import Tilia.Imports (normalizeImports) import Tilia.Parser (ParsedModule (..)) +import Tilia.Pragma (languageNames) import Tilia.Source (comments, sourceLines) import Tilia.Span (Span (..)) import Tilia.Span.Ghc (spanOf, spansOf) @@ -561,9 +562,5 @@ where entries p | pragmaName p == "LANGUAGE" = - [ ("LANGUAGE", extension) - | e <- T.splitOn "," (pragmaBody p), - let extension = T.strip e, - not (T.null extension) - ] + [("LANGUAGE", extension) | extension <- languageNames (pragmaBody p)] | otherwise = [(pragmaName p, pragmaBody p)] diff --git a/src/Tilia/Fixity.hs b/src/Tilia/Fixity.hs --- a/src/Tilia/Fixity.hs +++ b/src/Tilia/Fixity.hs @@ -11,6 +11,7 @@ Fixity (..), defaultFixity, spellFixity, + readPrecedence, -- * Module declarations declaredFixities, @@ -83,6 +84,7 @@ import Data.Set qualified as Set import Data.Text (Text) import Data.Text qualified as T +import Data.Text.Read qualified as T import GHC.Generics (Generic) import GHC.Hs hiding (Fixity, OpName) import GHC.Types.Fixity qualified as GHC @@ -123,6 +125,13 @@ -- | What an operator with no declaration in scope means: @infixl 9@. defaultFixity :: Fixity defaultFixity = Fixity LeftAssoc 9 + +-- | Read a precedence, which can be -1: GHC gives @->@ one, below anything +-- the report allows anyone to write. +readPrecedence :: Text -> Maybe Int +readPrecedence t = case T.signed T.decimal t of + Right (p, rest) | T.null rest -> Just p + _ -> Nothing -- | A fixity, written the way it would be declared. spellFixity :: Fixity -> Text diff --git a/src/Tilia/Fixity/Archive.hs b/src/Tilia/Fixity/Archive.hs new file mode 100644 --- /dev/null +++ b/src/Tilia/Fixity/Archive.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | What a package's source tarball holds that a module could be read out +-- of. +module Tilia.Fixity.Archive + ( Archive (..), + readArchive, + InArchive (..), + moduleIn, + pathOfModule, + moduleEndings, + writtenForHsc, + ) +where + +import Codec.Archive.Tar qualified as Tar +import Codec.Compression.GZip qualified as GZip +import Control.DeepSeq (NFData, force) +import Control.Exception (evaluate) +import Data.ByteString qualified as BS +import Data.ByteString.Lazy qualified as BL +import Data.List (isSuffixOf) +import Data.Maybe (listToMaybe, mapMaybe) +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.Encoding qualified as T +import GHC.Generics (Generic) +import Tilia.Fixity.Cabal (cabalFileAtTop, entryPosixPath, sourceDirs) +import Tilia.Utils (quietly) + +-- | What a tarball holds that a module could be read out of. +data Archive = Archive + { -- | The package's @.cabal@ file, the first one at the top. + archiveCabal :: Maybe Text, + -- | Every file that could hold a module, by where it sits, in the order + -- the tarball has them. + archiveFiles :: [(FilePath, BS.ByteString)] + } + deriving (Generic) + +instance NFData Archive + +-- | Read a tarball, keeping what a module could be read out of. +readArchive :: FilePath -> IO (Maybe Archive) +readArchive tarball = quietly Nothing $ do + bytes <- BL.readFile tarball + Just <$> evaluate (force (sweep Nothing [] (Tar.read (GZip.decompress bytes)))) + where + sweep cabal found = \case + Tar.Next entry rest + | Tar.NormalFile content _ <- Tar.entryContent entry, + cabalFileAtTop (entryPosixPath entry), + Nothing <- cabal -> + sweep (Just (T.decodeUtf8Lenient (BL.toStrict content))) found rest + | Tar.NormalFile content _ <- Tar.entryContent entry, + any (`isSuffixOf` entryPosixPath entry) moduleEndings -> + sweep cabal ((entryPosixPath entry, BL.toStrict content) : found) rest + | otherwise -> sweep cabal found rest + _ -> Archive cabal (reverse found) + +-- | Find a module in what a tarball holds and say what was found. +moduleIn :: Text -> Archive -> Maybe InArchive +moduleIn modName archive = listToMaybe (mapMaybe pick moduleEndings) + where + dirs = maybe [] sourceDirs (archiveCabal archive) + pick ending = + inArchive ending . T.decodeUtf8Lenient . snd + <$> listToMaybe (under sfx matching <> matching) + where + sfx = "/" <> pathOfModule modName <> ending + matching = [f | f <- archiveFiles archive, sfx `isSuffixOf` fst f] + under sfx matching = [f | d <- dirs, f <- matching, inDir sfx d (fst f)] + inDir sfx d path + | d == "." = takeWhile (/= '/') path <> sfx == path + | otherwise = ("/" <> T.unpack d <> sfx) `isSuffixOf` path + +-- | Where a module's file is under the directory that holds it, without an +-- extension. +pathOfModule :: Text -> FilePath +pathOfModule = T.unpack . T.replace "." "/" + +-- | The endings a package may write a module under, in the order they are +-- tried. +moduleEndings :: [String] +moduleEndings = [".hs", ".hsc"] + +-- | What an archive holds for a module. +data InArchive + = -- | Haskell, as the package wrote it. + Haskell Text + | -- | A module written for @hsc2hs@. Its text is not kept: there is + -- nothing to be done with it, and it is taken to declare nothing. + ForHsc + +-- | What was found under one ending amounts to. +inArchive :: String -> Text -> InArchive +inArchive ending text + | writtenForHsc ending = ForHsc + | otherwise = Haskell text + +-- | Is this a module @hsc2hs@ writes rather than one anybody compiles? +writtenForHsc :: FilePath -> Bool +writtenForHsc = isSuffixOf ".hsc" diff --git a/src/Tilia/Fixity/ByHand.hs b/src/Tilia/Fixity/ByHand.hs deleted file mode 100644 --- a/src/Tilia/Fixity/ByHand.hs +++ /dev/null @@ -1,33 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | Fixities for the modules written for @hsc2hs@, which are not read. -module Tilia.Fixity.ByHand - ( hscFixities, - ) -where - -import Data.Map.Strict (Map) -import Data.Map.Strict qualified as Map -import Data.Text (Text) -import Tilia.Fixity - --- | What the modules written for @hsc2hs@ declare. --- --- This is the whole answer for an @.hsc@, given instead of reading it, and --- a module absent from here declares nothing rather than being unreadable. -hscFixities :: Map Text (Map OpName Fixity) -hscFixities = - Map.fromList - [ -- @addSignal@ and @deleteSignal@ take a signal on the left and a set - -- on the right, so a chain of them only typechecks to the right, and - -- the module says so with a bare @infixr@—precedence 9, as the Report - -- has it when none is written. - entry - "System.Posix.Signals" - [ ("addSignal", RightAssoc, 9), - ("deleteSignal", RightAssoc, 9) - ] - ] - where - entry name ops = - (name, Map.fromList [(OpName o, Fixity d p) | (o, d, p) <- ops]) diff --git a/src/Tilia/Fixity/Cabal.hs b/src/Tilia/Fixity/Cabal.hs --- a/src/Tilia/Fixity/Cabal.hs +++ b/src/Tilia/Fixity/Cabal.hs @@ -1,7 +1,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} --- | Reading a package's exposed modules out of its @.cabal@ file. +-- | Reading a package's modules out of its @.cabal@ file. module Tilia.Fixity.Cabal ( packageModules, cabalFileInArchive, @@ -26,10 +26,10 @@ import Data.Text.Encoding qualified as T import GHC.Driver.Session qualified as GHC import GHC.LanguageExtensions.Type (Extension) -import Tilia.Pragma (lookupExtension) -import Tilia.Utils (quietly) +import Tilia.Pragma (applyExtensionName, lookupEdition) +import Tilia.Utils (fieldWords, quietly) --- | The modules a package exposes, read from the @.cabal@ file in its +-- | The modules a package holds, read from the @.cabal@ file in its -- source tarball. -- -- 'Nothing' if the tarball cannot be read or holds no @.cabal@ file. @@ -71,10 +71,7 @@ modulesUnder field = concatMap moduleNames . fieldsNamed field . T.lines where - moduleNames = - filter looksLikeModule - . concatMap (T.split (== ',')) - . T.words + moduleNames = filter looksLikeModule . fieldWords looksLikeModule m = case T.uncons m of Just (c, _) -> c `elem` ['A' .. 'Z'] Nothing -> False @@ -83,38 +80,22 @@ sourceDirs :: Text -> [Text] sourceDirs contents = Data.List.nub (named <> ["."]) where - named = - filter (not . T.null) - . fmap T.strip - . concatMap (T.split (== ',')) - . concatMap T.words - . fieldsNamed "hs-source-dirs" - $ T.lines contents + named = concatMap fieldWords (fieldsNamed "hs-source-dirs" (T.lines contents)) -- | The extensions a package puts in force, read from its @.cabal@ file. declaredExtensions :: Text -> [Extension] declaredExtensions contents = - foldl apply baseline named + foldl applyExtensionName baseline named where ls = T.lines contents - baseline = case mapMaybe languageNamed (fieldsNamed "default-language" ls) of - [] -> GHC.languageExtensions (Just GHC.Haskell98) - editions -> - Data.List.nub (concatMap (GHC.languageExtensions . Just) editions) + baseline = + case mapMaybe lookupEdition (fieldsNamed "default-language" ls) of + [] -> GHC.languageExtensions (Just GHC.Haskell98) + editions -> + Data.List.nub (concatMap (GHC.languageExtensions . Just) editions) named = - concatMap (T.split (== ',')) . concatMap T.words $ + concatMap fieldWords $ fieldsNamed "extensions" ls <> fieldsNamed "default-extensions" ls - apply acc written = case T.strip written of - name - | Just off <- T.stripPrefix "No" name, - Just extension <- lookupExtension off -> - filter (/= extension) acc - | Just extension <- lookupExtension name, - extension `notElem` acc -> - acc <> [extension] - | otherwise -> acc - languageNamed written = - lookup (T.unpack (T.strip written)) [(show e, e) | e <- [minBound .. maxBound]] -- | The values of every field with the given name, wherever it appears and -- however deeply it is nested. diff --git a/src/Tilia/Fixity/Cache.hs b/src/Tilia/Fixity/Cache.hs --- a/src/Tilia/Fixity/Cache.hs +++ b/src/Tilia/Fixity/Cache.hs @@ -3,7 +3,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} --- | Package-level cache. +-- | Answers remembered on disk between runs. module Tilia.Fixity.Cache ( Cache, PlanToken (..), @@ -40,7 +40,6 @@ import Data.Text (Text) import Data.Text qualified as T import Data.Text.IO qualified as T -import Data.Text.Read qualified as T import Data.Time (UTCTime) import Data.Time.Format (defaultTimeLocale, formatTime) import Data.Time.Format.ISO8601 (iso8601ParseM, iso8601Show) @@ -107,16 +106,16 @@ traverse_ remember found pure found --- | The modules a package exposes, if that was worked out before. +-- | The modules a package holds, if that was worked out before. cachedModules :: Cache -> Text -> IO (Maybe [Text]) cachedModules cache package = - readIfPresent (at cache ["modules", package]) $ + readIfPresent (at cache (modulesFile package)) $ filter (not . T.null) . T.lines --- | Remember what a package exposes. +-- | Remember which modules a package holds. storeModules :: Cache -> Text -> [Text] -> IO () storeModules cache package = - writeAtomically (at cache ["modules", package]) . T.unlines + writeAtomically (at cache (modulesFile package)) . T.unlines -- | What was established about a module before, if anything. cachedEstablished :: @@ -130,7 +129,7 @@ -- left unsettled was left so under another plan. IO (Maybe Established) cachedEstablished cache package modName = - fmap join . readIfPresent (at cache ["established", package, modName]) $ + fmap join . readIfPresent (at cache (establishedFile package modName)) $ assembled . fmap T.words . T.lines where assembled entries = do @@ -179,7 +178,7 @@ Established -> IO () storeEstablished cache package modName established = - writeAtomically path . renderLines $ + writeAtomically (at cache (establishedFile package modName)) . renderLines $ fmap (("fixity" :) . renderFixity) (Map.toList fixities) <> [ ["unsettled", tokenOf cache] <> chain <> renderNamespaced names | (chain, names) <- Map.toList (establishedUnsettled established) @@ -201,7 +200,6 @@ Just kids /= Map.lookup (OpName parent) written ] where - path = at cache ["established", package, modName] fixities = establishedFixities established certain = establishedCertain established written = Map.map (Set.map snd) (certainMembers certain) @@ -218,7 +216,7 @@ -- | What it said, or 'Nothing' if nothing is remembered for that stamp. IO (Maybe (Maybe (NonEmpty ModuleSummary))) cachedSummaries cache key stamp = - fmap join . readIfPresent (at cache ["summaries", key]) $ \contents -> + fmap join . readIfPresent (at cache (summariesFile key)) $ \contents -> case T.lines contents of (header : rest) | header == readFrom stamp -> parseSummaries rest _ -> Nothing @@ -236,7 +234,7 @@ Maybe (NonEmpty ModuleSummary) -> IO () storeSummaries cache key stamp summaries = - writeAtomically (at cache ["summaries", key]) . T.unlines $ + writeAtomically (at cache (summariesFile key)) . T.unlines $ readFrom stamp : renderSummaries summaries -- | The first line of a remembered summary: what it was read from, and the @@ -370,7 +368,7 @@ -- see it. cachedInstalled :: Cache -> IO (Maybe [InstalledPackage]) cachedInstalled cache = quietly Nothing $ do - readIfPresent (at cache ["installed", tokenOf cache]) T.lines >>= \case + readIfPresent (at cache (installedFile cache)) T.lines >>= \case Nothing -> pure Nothing Just ls -> do let (databases, packages) = span (T.isPrefixOf "db ") ls @@ -404,7 +402,7 @@ | null databases = pure () | otherwise = quietly () $ do stamps <- traverse stampOf databases - writeAtomically (at cache ["installed", tokenOf cache]) . renderLines $ + writeAtomically (at cache (installedFile cache)) . renderLines $ [["db", stamp, T.pack path] | (path, stamp) <- zip databases stamps] <> concatMap packageLines (installedPackages found) where @@ -423,12 +421,12 @@ -- and left the plan exactly as before. cachedFutileSolve :: Cache -> IO Bool cachedFutileSolve cache = - isJust <$> readIfPresent (at cache ["solves", tokenOf cache]) (const ()) + isJust <$> readIfPresent (at cache (solvesFile cache)) (const ()) -- | Remember that solving again did not widen the plan. storeFutileSolve :: Cache -> IO () storeFutileSolve cache = - writeAtomically (at cache ["solves", tokenOf cache]) "" + writeAtomically (at cache (solvesFile cache)) "" -- | The packages an earlier run was still short of after asking @cabal@ to -- fetch them. @@ -436,38 +434,36 @@ cachedFutileFetch cache = fromMaybe [] <$> readIfPresent - (at cache ["fetches", tokenOf cache]) + (at cache (fetchesFile cache)) (filter (not . T.null) . T.lines) -- | Remember what fetching left missing. storeFutileFetch :: Cache -> [Text] -> IO () storeFutileFetch cache = - writeAtomically (at cache ["fetches", tokenOf cache]) . T.unlines + writeAtomically (at cache (fetchesFile cache)) . T.unlines -- | When the project was last solved under this plan. cachedSolveTime :: Cache -> IO (Maybe UTCTime) cachedSolveTime cache = join <$> readIfPresent - (at cache ["solve-times", tokenOf cache]) + (at cache (solveTimeFile cache)) (iso8601ParseM . T.unpack . T.strip) -- | Remember when the project was solved under this plan. storeSolveTime :: Cache -> UTCTime -> IO () storeSolveTime cache = - writeAtomically (at cache ["solve-times", tokenOf cache]) - . T.pack - . iso8601Show + writeAtomically (at cache (solveTimeFile cache)) . T.pack . iso8601Show -- | Where @cabal@ last said it keeps the sources it downloads. cachedPackageCache :: Cache -> IO (Maybe FilePath) cachedPackageCache cache = - readIfPresent (at cache ["package-cache", tokenOf cache]) (T.unpack . T.strip) + readIfPresent (at cache (packageCacheFile cache)) (T.unpack . T.strip) -- | Remember where @cabal@ keeps the sources it downloads. storePackageCache :: Cache -> FilePath -> IO () storePackageCache cache = - writeAtomically (at cache ["package-cache", tokenOf cache]) . T.pack + writeAtomically (at cache (packageCacheFile cache)) . T.pack -- | Render a fixity declaration as fields. renderFixity :: ((Namespace, OpName), Fixity) -> [Text] @@ -498,9 +494,6 @@ "r" -> Just RightAssoc "n" -> Just NoAssoc _ -> Nothing - readPrecedence t = case T.signed T.decimal t of - Right (p, rest) | T.null rest -> Just p - _ -> Nothing -- | Render a namespace as 'Text'. renderNamespace :: Namespace -> Text @@ -551,6 +544,38 @@ at cache path = case cache of Cache root _ -> Just (foldl () root (fmap T.unpack path)) NoCache -> Nothing + +-- | The path of the modules a package exposes. +modulesFile :: Text -> [Text] +modulesFile package = ["modules", package] + +-- | The path of what reading a module established. +establishedFile :: Text -> Text -> [Text] +establishedFile package modName = ["established", package, modName] + +-- | The path of what each configuration of a project module says. +summariesFile :: Text -> [Text] +summariesFile key = ["summaries", key] + +-- | The path of the packages the compiler can see. +installedFile :: Cache -> [Text] +installedFile cache = ["installed", tokenOf cache] + +-- | The path of the mark that solving again did not widen the plan. +solvesFile :: Cache -> [Text] +solvesFile cache = ["solves", tokenOf cache] + +-- | The path of what fetching left missing. +fetchesFile :: Cache -> [Text] +fetchesFile cache = ["fetches", tokenOf cache] + +-- | The path of when the project was last solved. +solveTimeFile :: Cache -> [Text] +solveTimeFile cache = ["solve-times", tokenOf cache] + +-- | The path of the directory @cabal@ downloads sources into. +packageCacheFile :: Cache -> [Text] +packageCacheFile cache = ["package-cache", tokenOf cache] -- | The token a cache is kept under. tokenOf :: Cache -> Text diff --git a/src/Tilia/Fixity/Debug.hs b/src/Tilia/Fixity/Debug.hs --- a/src/Tilia/Fixity/Debug.hs +++ b/src/Tilia/Fixity/Debug.hs @@ -13,9 +13,10 @@ where import Data.Choice (Choice) -import Data.List.NonEmpty (NonEmpty) +import Data.List.NonEmpty (NonEmpty, nonEmpty) import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map +import Data.Maybe (mapMaybe) import Data.Set qualified as Set import Data.Text (Text) import Data.Text qualified as T @@ -24,6 +25,7 @@ Established (..), Fixity (..), Import (..), + ModuleChain (..), OpName (..), Provenance (..), Resolution (..), @@ -37,6 +39,7 @@ reachUnqualified, spellDisagreement, spellFixity, + spellModuleChain, spellUnreadIn, ) import Tilia.Palette (Color (Operator, Place), Palette, paint) @@ -191,9 +194,13 @@ | null (noteUnsettled i) -> operators n | otherwise -> operators n <> ", not settling every name" <> through (noteUnsettled i) - through ways = case filter (not . null) ways of + through ways = case mapMaybe nonEmpty ways of [] -> "" - below -> ", through " <> T.intercalate " or " (fmap (T.intercalate " → " . fmap named) below) + below -> + ", through " + <> T.intercalate + " or " + (fmap (spellModuleChain palette . ModuleChain) below) qualification i = case (noteQualified i, noteAlias i) of (True, Just alias) -> " qualified as " <> named alias diff --git a/src/Tilia/Fixity/HiFile.hs b/src/Tilia/Fixity/HiFile.hs --- a/src/Tilia/Fixity/HiFile.hs +++ b/src/Tilia/Fixity/HiFile.hs @@ -12,7 +12,8 @@ ) where -import Data.Array (Array, bounds, listArray, (!)) +import Control.Monad (unless) +import Data.Array (Array, bounds, inRange, listArray, (!)) import Data.Bits (shiftL, testBit, (.&.), (.|.)) import Data.ByteString (ByteString) import Data.ByteString qualified as BS @@ -87,7 +88,7 @@ hiFile :: Get HiFile hiFile = do magic <- word32be - unless' (magic == 0x1face64) (failure ("not a 64-bit interface file: " <> T.pack (show magic))) + unless (magic == 0x1face64) (failure ("not a 64-bit interface file: " <> T.pack (show magic))) version <- string series <- case take 3 version of "910" -> pure Series910 @@ -95,11 +96,11 @@ "914" -> pure Series914 _ -> failure ("unsupported interface version " <> T.pack version) _way <- string - unless' (series == Series914) fingerprint + unless (series == Series914) fingerprint _extFields <- pointer series stringsAt <- pointer series namesAt <- pointer series - unless' (series == Series910) (() <$ pointer series) + unless (series == Series910) (() <$ pointer series) strings <- lookingAt stringsAt dictionary names <- lookingAt namesAt symbolTable let tables = Tables strings names (keyedNames series) @@ -181,10 +182,6 @@ | inRange (bounds strings) i = pure (T.decodeUtf8Lenient (strings ! i)) | otherwise = failure "string index out of range" --- | Whether an index is within bounds. -inRange :: (Int, Int) -> Int -> Bool -inRange (lo, hi) i = lo <= i && i <= hi - -- | A unit, which must be a real one: instantiated units come of Backpack. unit :: Get () unit = @@ -302,10 +299,6 @@ listOf get = do n <- sleb mapM (const get) [1 .. n] - --- | Run an action unless the condition holds. -unless' :: Bool -> Get () -> Get () -unless' condition action = if condition then pure () else action -- | Reading from a position in a byte string. newtype Get a = Get{runGet :: ByteString -> Int -> Either Text (a, Int)} diff --git a/src/Tilia/Fixity/Interface.hs b/src/Tilia/Fixity/Interface.hs --- a/src/Tilia/Fixity/Interface.hs +++ b/src/Tilia/Fixity/Interface.hs @@ -22,7 +22,6 @@ import Data.Set qualified as Set import Data.Text (Text) import Data.Text qualified as T -import Data.Text.Read qualified as T import GHC.Generics (Generic) import Tilia.Fixity import Tilia.Fixity.HiFile (HiExport (..), HiFile (..), HiName (..), decodeHiFile) @@ -81,8 +80,7 @@ ], interfaceReexports = [ (m, op) - | names <- exports, - (Just m, _, op) <- names, + | (Just m, _, op) <- concatMap mentioned hiExports, m /= hiModule ], interfaceMembers = Map.map (Set.map snd) members, @@ -94,7 +92,6 @@ } } where - exports = concatMap resolved hiExports exported = concatMap exportedNames hiExports exportedHere = Set.fromList [(namespace, op) | (_, namespace, op) <- exported] @@ -109,11 +106,9 @@ exportedNames = \case Avail n -> maybeToList (known n) AvailTC _ ns -> mapMaybe known ns - resolved = \case - Avail n -> maybe [] (pure . pure) (known n) - AvailTC p ns -> - let kids = mapMaybe known ns - in maybe (fmap pure kids) (\named -> [named : kids]) (known p) + mentioned = \case + Avail n -> maybeToList (known n) + AvailTC p ns -> maybeToList (known p) <> mapMaybe known ns known = \case HiName m namespace op -> Just (Just m, namespace, op) BuiltInSyntax namespace op -> Just (Nothing, namespace, op) @@ -213,13 +208,6 @@ p <- readPrecedence precedence pure (OpName op, Fixity d p) _ -> Nothing - where - -- Not one digit: GHC gives @->@ a precedence of -1, below anything the - -- report allows anyone to write, and drops it into a fixities line like - -- any other. - readPrecedence t = case T.signed T.decimal t of - Right (p, rest) | T.null rest -> Just p - _ -> Nothing -- | Split an exports section into its entries, keeping the members an entry -- wears in braces with the name they belong to. diff --git a/src/Tilia/Fixity/PackageDb.hs b/src/Tilia/Fixity/PackageDb.hs --- a/src/Tilia/Fixity/PackageDb.hs +++ b/src/Tilia/Fixity/PackageDb.hs @@ -1,7 +1,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} --- | Querying the compiler on which package exposes a module and where its +-- | Querying the compiler on which package holds a module and where its -- compiled interfaces are. module Tilia.Fixity.PackageDb ( InstalledPackage (..), @@ -22,7 +22,7 @@ import System.Directory (doesDirectoryExist, findExecutable) import System.FilePath (()) import Tilia.Process (readProgramOutput) -import Tilia.Utils (quietly) +import Tilia.Utils (fieldWords, quietly) -- | An installed package. data InstalledPackage = InstalledPackage @@ -130,7 +130,7 @@ -- | The modules an @exposed-modules@ field names that the package holds. moduleNames :: Text -> [Text] -moduleNames = go . moduleTokens +moduleNames = go . fieldWords where go = \case (_ : "from" : _ : rest) -> go rest @@ -144,17 +144,13 @@ -- | The modules an @exposed-modules@ field names that another package -- holds, each with its name there. reexportedModules :: Text -> [(Text, Text)] -reexportedModules = go . moduleTokens +reexportedModules = go . fieldWords where go = \case (m : "from" : original : rest) -> (m, T.takeWhileEnd (/= ':') original) : go rest (_ : rest) -> go rest [] -> [] - --- | The words of a field that lists modules. -moduleTokens :: Text -> [Text] -moduleTokens = filter (not . T.null) . concatMap (T.split (== ',')) . T.words -- | Split a record into its fields. parseFields :: Text -> Map.Map Text Text diff --git a/src/Tilia/Fixity/Plan.hs b/src/Tilia/Fixity/Plan.hs --- a/src/Tilia/Fixity/Plan.hs +++ b/src/Tilia/Fixity/Plan.hs @@ -8,1898 +8,935 @@ -- that says what each imported module exports. This is that function, built -- from what the project itself is compiled against. module Tilia.Fixity.Plan - ( -- * Build plans - PlanPackage (..), - PackageSource (..), - isFetchable, - sourceHashOf, - BuildPlan (..), - readBuildPlan, - readGivenPlan, - fetchUninstalled, - tokenForEnvAndBuildPlan, - tokenForBuildPlan, - macrosOf, - plannedCompiler, - - -- * Readiness - Readiness (..), - PlanComponent (..), - spellComponent, - plannedComponents, - planPathFor, - checkReadiness, - plannedTarballs, - packageCacheRoot, - guessedPackageCacheRoot, - Futility (..), - undiscoveredFutility, - futilityFor, - prepareWith, - loadPlan, - - -- * Resolving - Route (..), - Resolver (..), - newResolver, - newResolverVia, - newResolverWith, - withReexports, - scopeFor, - ) -where - -import Codec.Archive.Tar qualified as Tar -import Codec.Compression.GZip qualified as GZip -import Control.Applicative ((<|>)) -import Control.Concurrent - ( MVar, - ThreadId, - getNumCapabilities, - modifyMVar, - modifyMVar_, - myThreadId, - newEmptyMVar, - newMVar, - readMVar, - tryPutMVar, - tryReadMVar, - ) -import Control.Concurrent.QSem (newQSem, signalQSem, waitQSem) -import Control.DeepSeq (NFData, force) -import Control.Exception (bracket_, evaluate, onException) -import Control.Monad (filterM, join, void) -import Crypto.Hash.SHA256 qualified as SHA256 -import Data.Aeson - ( FromJSON (..), - Value, - decodeStrict, - eitherDecodeFileStrict, - withObject, - (.:), - (.:?), - ) -import Data.Aeson.Types (parseMaybe) -import Data.ByteString qualified as BS -import Data.ByteString.Base16 qualified as B16 -import Data.ByteString.Lazy qualified as BL -import Data.Choice (Choice, fromBool, isTrue, pattern Do) -import Data.Foldable (toList, traverse_) -import Data.IORef -import Data.List (isSuffixOf) -import Data.List qualified -import Data.List.NonEmpty (NonEmpty ((:|))) -import Data.List.NonEmpty qualified as NE -import Data.Map.Strict (Map) -import Data.Map.Strict qualified as Map -import Data.Maybe (catMaybes, fromMaybe, isNothing, listToMaybe, mapMaybe) -import Data.Set (Set) -import Data.Set qualified as Set -import Data.Text (Text) -import Data.Text qualified as T -import Data.Text.Encoding qualified as T -import Data.Text.Read qualified as T -import Data.Time (UTCTime, getCurrentTime) -import Data.Unique (Unique, newUnique) -import Distribution.Version (Version, mkVersion) -import GHC.Generics (Generic) -import GHC.Hs (HsModule) -import GHC.Hs.Extension (GhcPs) -import GHC.IO.Handle (hDuplicate) -import GHC.LanguageExtensions.Type (Extension (ImplicitPrelude)) -import System.Directory - ( XdgDirectory (XdgCache), - doesFileExist, - getAppUserDataDirectory, - getModificationTime, - getXdgDirectory, - listDirectory, - ) -import System.Environment (lookupEnv) -import System.Exit (ExitCode (..)) -import System.FilePath (isRelative, takeDirectory, ()) -import System.IO (hClose, hFlush, stderr) -import System.Info qualified -import System.Process - ( StdStream (CreatePipe, Inherit, UseHandle), - createProcess, - cwd, - proc, - std_err, - std_in, - std_out, - waitForProcess, - ) -import Tilia.Cabal.Package (newPackageReader) -import Tilia.Cpp.Directives (branchLeaves, withoutRuledOut) -import Tilia.Cpp.Macros (Macros (..)) -import Tilia.Fixity -import Tilia.Fixity.ByHand (hscFixities) -import Tilia.Fixity.Cabal - ( cabalFileAtTop, - containedModules, - declaredExtensions, - entryPosixPath, - packageModules, - sourceDirs, - ) -import Tilia.Fixity.Cache -import Tilia.Fixity.HiFile (primopFixities) -import Tilia.Fixity.Interface -import Tilia.Fixity.PackageDb -import Tilia.Parser -import Tilia.Pragma (effectiveExtensions) -import Tilia.Process (readProgramOutput) -import Tilia.Utils (inParallel, quietly) - ----------------------------------------------------------------------------- --- The plan - --- | One package of a build plan. -data PlanPackage = PlanPackage - { -- | Package name - ppName :: Text, - -- | Package version - ppVersion :: Text, - -- | Package source - ppSource :: PackageSource, - -- | Which components of the package the entry is about. - -- - -- Usually one, because @cabal@ configures a package one component at a - -- time and gives each its own entry. A package it cannot take apart—one - -- with a @Custom@ build type, whose @Setup.hs@ is entitled to do as it - -- pleases—is planned whole instead, and its entry is about every - -- component at once. - ppComponents :: [Text] - } - deriving (Eq, Show) - --- | Where a package's source is. -data PackageSource - = -- | Already installed, so @cabal@ will not build it. - -- - -- Not the same as "ships with the compiler", though it includes those. - PreExisting - | -- | A directory on this machine—the project being formatted, or a - -- sibling of it in the same repository. - LocalPackage FilePath - | -- | Fetched from a repository as a tarball, with the SHA-256 the plan - -- expects it to have and where it was fetched from. - RepoPackage (Maybe Text) RepoProvenance - | -- | A @source-repository-package@ we have not found the sources of. - SourceRepo - | -- | The same, found unpacked under the project's own @dist-newstyle@. - CheckedOut FilePath - deriving (Eq, Show) - --- | Which repository a package was fetched from, as far as it bears on --- finding the tarball afterwards. -data RepoProvenance - = -- | One @cabal@ downloads from, named by its URI. The tarball goes into - -- the package cache, in a directory named after the repository as the - -- configuration spells it. - RepoDownloaded Text - | -- | A directory of tarballs, named by @file+noindex@. Nothing is - -- downloaded and nothing is cached: the tarball is already sitting - -- there, beside the index @cabal@ wrote for it. - RepoFromDirectory FilePath - | -- | A plan that does not say. Older @cabal@ wrote nothing here, and - -- Hackage is the only guess worth making. - RepoNoProvenance - deriving (Eq, Show) - --- | Is there a tarball to go and read? -isFetchable :: PlanPackage -> Bool -isFetchable p = case ppSource p of - RepoPackage _ _ -> True - _ -> False - --- | Every package the compiler can see. -getInstalledPackages :: Cache -> IO [InstalledPackage] -getInstalledPackages cache = - cachedInstalled cache >>= \case - Just packages -> pure packages - Nothing -> do - found <- readInstalledPackages - storeInstalled cache found - pure (installedPackages found) - --- | Summarize a 'BuildPlan', and the environment it will be read in, by --- hashing over both. -tokenForBuildPlan :: BuildPlan -> IO PlanToken -tokenForBuildPlan plan = do - environment <- compilerIdentity - pure (tokenForEnvAndBuildPlan environment plan) - --- | Similar to 'tokenForBuildPlan', but allows passing a compiler identity --- as an argument. -tokenForEnvAndBuildPlan :: Text -> BuildPlan -> PlanToken -tokenForEnvAndBuildPlan environment plan = - PlanToken - . T.take 16 - . T.decodeUtf8Lenient - . B16.encode - . SHA256.hash - . T.encodeUtf8 - $ T.intercalate - "\n" - ( environment - : bpCompiler plan - : Data.List.sort (fmap cacheKey (bpPackages plan)) - ) - --- | The SHA-256 the plan expects this package's tarball to have. -sourceHashOf :: PlanPackage -> Maybe Text -sourceHashOf p = case ppSource p of - RepoPackage hash _ -> hash - _ -> Nothing - --- | A resolved build plan. -data BuildPlan = BuildPlan - { bpCompiler :: Text, - bpPackages :: [PlanPackage] - } - deriving (Eq, Show) - -instance FromJSON BuildPlan where - parseJSON = withObject "BuildPlan" $ \o -> - BuildPlan - <$> o .: "compiler-id" - <*> o .: "install-plan" - -instance FromJSON PlanPackage where - parseJSON = withObject "PlanPackage" $ \o -> do - name <- o .: "pkg-name" - version <- o .: "pkg-version" - kind <- o .:? "type" - sourceKind <- o .:? "pkg-src" >>= traverse (.: "type") - sourcePath <- o .:? "pkg-src" >>= traverse (.:? "path") - sourceHash <- o .:? "pkg-src-sha256" - repo <- o .:? "pkg-src" >>= traverse (.:? "repo") - repoKind <- traverse (traverse (.:? "type")) repo - repoUri <- traverse (traverse (.:? "uri")) repo - repoPath <- traverse (traverse (.:? "path")) repo - named <- o .:? "component-name" - whole <- o .:? "components" - pure - PlanPackage - { ppName = name, - ppVersion = version, - ppComponents = componentsOf named whole, - ppSource = case (kind :: Maybe Text, sourceKind :: Maybe Text) of - (Just "pre-existing", _) -> PreExisting - (_, Just "repo-tar") -> - RepoPackage - sourceHash - ( case ( join (join repoKind) :: Maybe Text, - join (join repoPath), - join (join repoUri) - ) of - (Just "local-repo-no-index", Just dir, _) -> - RepoFromDirectory (T.unpack dir) - (_, _, Just uri) -> RepoDownloaded uri - _ -> RepoNoProvenance - ) - (_, Just "local") -> LocalPackage (maybe "" T.unpack (join sourcePath)) - (_, Just "source-repo") -> SourceRepo - -- Anything else is treated as already present. - _ -> PreExisting - } - --- | The components one plan entry is about. --- --- @cabal@ writes this two ways. An entry for a single component names it in --- @component-name@; an entry for a package planned whole carries a --- @components@ object instead, keyed by the very same spellings. Reading --- only the first would leave every @Custom@ package looking like one the --- plan says nothing about, and a run would keep asking @cabal@ to solve --- again for components a fresh solve would file exactly where this one did. --- --- @setup@ is dropped. It is the @Setup.hs@ program @cabal@ builds in order --- to build the package, not a component of the package, and nothing in the --- project will ever be formatted as part of it. -componentsOf :: Maybe Text -> Maybe (Map Text Value) -> [Text] -componentsOf named whole = case named of - Just component -> [component] - Nothing -> filter (/= "setup") (Map.keys (fromMaybe Map.empty whole)) - --- | Read @plan.json@. -readBuildPlan :: FilePath -> IO (Either Text BuildPlan) -readBuildPlan path = - decodePlan path >>= traverse (checkedOutIn (takeDirectory (takeDirectory path))) - --- | Read a plan that is to be trusted as up to date. -readGivenPlan :: - -- | The project root. - FilePath -> - -- | The plan. - FilePath -> - IO (Either Text BuildPlan) -readGivenPlan root path = - fmap (\plan -> plan{bpPackages = fmap rooted (bpPackages plan)}) - <$> decodePlan path - where - rooted p = case ppSource p of - LocalPackage dir - | isRelative dir -> - p{ppSource = LocalPackage (root dir)} - _ -> p - --- | Decode a plan, or say why it cannot be. -decodePlan :: FilePath -> IO (Either Text BuildPlan) -decodePlan path = - doesFileExist path >>= \case - False -> pure (Left ("no build plan at " <> T.pack path)) - True -> either (Left . T.pack) Right <$> eitherDecodeFileStrict path - --- | Find where @cabal@ unpacked each @source-repository-package@. -checkedOutIn :: FilePath -> BuildPlan -> IO BuildPlan -checkedOutIn distDir plan = do - packages <- traverse locate (bpPackages plan) - pure plan{bpPackages = packages} - where - locate p = case ppSource p of - SourceRepo -> - clonesOf p >>= \case - (dir : _) -> pure p{ppSource = CheckedOut dir} - [] -> pure p - _ -> pure p - clonesOf p = quietly [] $ do - entries <- listDirectory (distDir "src") - filterM - (isThePackage p) - [ distDir "src" e - | e <- Data.List.sort entries, - (ppName p <> "-") `T.isPrefixOf` T.pack e - ] - isThePackage p dir = quietly False $ do - contents <- readFileText (dir T.unpack (ppName p) <> ".cabal") - pure (maybe False (describes p) contents) - describes p text = - any (names "name:" (ppName p)) (T.lines text) - && any (names "version:" (ppVersion p)) (T.lines text) - names field value line = case T.stripPrefix field (T.toLower (T.strip line)) of - Just rest -> T.strip rest == T.toLower value - Nothing -> False - --- | The version macros a plan settles. -macrosOf :: BuildPlan -> Macros -macrosOf plan = - mempty - { macroExactVersions = - Map.fromList - ( [ ("MIN_VERSION_" <> underscored name, version) - | (name, [version]) <- Map.toList (Map.map Set.toList versions) - ] - <> [("MIN_VERSION_GLASGOW_HASKELL", v) | v <- toList compiler] - ), - macroExactNumbers = - Map.fromList - [ entry - | (major : minor : patches) <- toList compiler, - entry <- - [ ("__GLASGOW_HASKELL__", major * 100 + minor), - ("__GLASGOW_HASKELL_PATCHLEVEL1__", nth 0 patches), - ("__GLASGOW_HASKELL_PATCHLEVEL2__", nth 1 patches) - ] - ], - macroUndefined = - if null compiler - then Set.empty - else Set.fromList ["__MHS__", "__HUGS__"], - macroPlannedPackages = - Just (Set.fromList [underscored (ppName p) | p <- bpPackages plan]) - } - where - versions = - Map.fromListWith - Set.union - [ (ppName p, Set.singleton v) - | p <- bpPackages plan, - Just v <- [numberedVersion (ppVersion p)] - ] - compiler = do - version <- T.stripPrefix "ghc-" (bpCompiler plan) - parts <- numberedVersion version - case parts of - _ : _ : _ -> Just (take 4 (parts <> repeat 0)) - _ -> Nothing - nth i xs = if i < length xs then xs !! i else 0 - --- | The version of GHC a plan is for, where it is for GHC. -plannedCompiler :: BuildPlan -> Maybe Version -plannedCompiler plan = - mkVersion . fmap fromInteger - <$> (numberedVersion =<< T.stripPrefix "ghc-" (bpCompiler plan)) - --- | The modules @cabal@ writes itself for a plan's packages. -generatedModules :: BuildPlan -> Set Text -generatedModules plan = - Set.fromList - [ prefix <> underscored (ppName p) - | p <- bpPackages plan, - prefix <- ["Paths_", "PackageInfo_"] - ] - --- | A package's name as a module name spells it, which is with the hyphens --- turned into underscores. @cabal@ does this for the version macros and for --- the modules it generates alike. -underscored :: Text -> Text -underscored = T.map (\c -> if c == '-' then '_' else c) - --- | A version as its numbers, or 'Nothing' where any of them is not one. -numberedVersion :: Text -> Maybe [Integer] -numberedVersion = traverse number . T.splitOn "." - where - number part = case T.decimal part of - Right (n, rest) | T.null rest -> Just n - _ -> Nothing - ----------------------------------------------------------------------------- --- Readiness - --- | A component of the project. -data PlanComponent = PlanComponent - { -- | The package it belongs to. - pcPackage :: Text, - -- | @lib@, @exe:name@, @test:name@, @bench:name@. - pcName :: Text - } - deriving (Eq, Ord, Show) - --- | A component as it would be written on the command line. -spellComponent :: PlanComponent -> Text -spellComponent c = pcPackage c <> ":" <> pcName c - --- | The components of the project's own packages that a plan covers. -plannedComponents :: BuildPlan -> [PlanComponent] -plannedComponents plan = - [ PlanComponent (ppName p) component - | p <- bpPackages plan, - LocalPackage _ <- [ppSource p], - component <- ppComponents p - ] - --- | Whether everything the resolver needs is on disk. -data Readiness - = -- | Nothing to do. - Ready - | -- | No build plan; @cabal@ has not solved this project yet. - PlanMissing - | -- | The plan is older than the files that determine it. - PlanStale [FilePath] - | -- | The plan says nothing about components the run is about to format. - PlanNarrow [Text] - | -- | The plan is there, and some packages have neither been downloaded - -- nor built. The names are listed so that a caller can say what it is - -- waiting for. - -- - -- Built counts as having them: their interfaces provide everything the - -- source tarball would. - SourcesMissing [Text] - deriving (Eq, Show) - --- | Where @cabal@ writes the plan for a project. -planPathFor :: FilePath -> FilePath -planPathFor projectDir = projectDir "dist-newstyle" "cache" "plan.json" - --- | Check what is missing. --- --- One read of the plan and one @stat@ per package, so this is fast enough --- to run before every format. -checkReadiness :: Choice "useCache" -> [PlanComponent] -> FilePath -> IO Readiness -checkReadiness caching wanted projectDir = - readBuildPlan (planPathFor projectDir) >>= \case - Left _ -> pure PlanMissing - Right plan -> do - solved <- cachedSolveTime =<< openCache caching =<< tokenForBuildPlan plan - newer <- filesNewerThanPlan plan projectDir solved - let covered = plannedComponents plan - missing = [spellComponent c | c <- wanted, c `notElem` covered] - case (newer, missing) of - (_ : _, _) -> pure (PlanStale newer) - ([], _ : _) -> pure (PlanNarrow missing) - ([], []) -> - sourcesShortOf caching plan >>= \case - [] -> pure Ready - ps -> pure (SourcesMissing (fmap ppName ps)) - --- | The packages the plan expects to fetch whose sources are not here. -sourcesShortOf :: Choice "useCache" -> BuildPlan -> IO [PlanPackage] -sourcesShortOf caching plan = do - cache <- openCache caching =<< tokenForBuildPlan plan - tarballs <- filter (isFetchable . fst) <$> plannedTarballs cache plan - absent <- fmap fst <$> filterM (fmap not . doesFileExist . snd) tarballs - if null absent - then pure [] - else do - installed <- getInstalledPackages cache - pure (filter (not . builtAlready installed) absent) - --- | Has the compiler got this package already? -builtAlready :: [InstalledPackage] -> PlanPackage -> Bool -builtAlready installed p = any matches installed - where - matches i = ipName i == ppName p && ipVersion i == ppVersion p - --- | The project files that have changed since the plan was written, and --- since the last solve, which leaves a plan it would not change as it was. -filesNewerThanPlan :: BuildPlan -> FilePath -> Maybe UTCTime -> IO [FilePath] -filesNewerThanPlan plan projectDir solved = quietly [] $ do - written <- getModificationTime (planPathFor projectDir) - let planTime = maybe written (max written) solved - atRoot <- quietly [] (listDirectory projectDir) - inPackages <- concat <$> traverse cabalFilesIn (localDirs plan) - let candidates = - [projectDir f | f <- atRoot, f `elem` projectFiles] - <> [projectDir f | f <- atRoot, ".cabal" `isSuffixOf` f] - <> inPackages - newer <- traverse (isNewerThan planTime) candidates - pure [f | Just f <- newer] - where - projectFiles = - ["cabal.project", "cabal.project.local", "cabal.project.freeze"] - localDirs p = - Data.List.nub [dir | LocalPackage dir <- fmap ppSource (bpPackages p)] - cabalFilesIn dir = quietly [] $ do - entries <- listDirectory dir - pure [dir f | f <- entries, ".cabal" `isSuffixOf` f] - isNewerThan planTime path = quietly Nothing $ do - t <- getModificationTime path - pure (if t > planTime then Just path else Nothing) - --- | An account of actions we know are not worth attempting. -data Futility = Futility - { -- | Has solving this plan already been tried and left it as narrow? - solveWasFutile :: IO Bool, - -- | Record that a solve has been run and left it narrow, which is what - -- 'solveWasFutile' answers from afterwards. - rememberFutileSolve :: IO (), - -- | The packages an earlier fetch was still short of afterwards. - fetchWasFutileFor :: IO [Text], - -- | Remember what a fetch left missing. - rememberFutileFetch :: [Text] -> IO (), - -- | Remember when a solve started, so that no change made before it - -- makes the plan stale. - rememberSolveTime :: UTCTime -> IO () - } - --- | The state when we know nothing about futile actions yet. -undiscoveredFutility :: Futility -undiscoveredFutility = - Futility - { solveWasFutile = pure False, - rememberFutileSolve = pure (), - fetchWasFutileFor = pure [], - rememberFutileFetch = const (pure ()), - rememberSolveTime = const (pure ()) - } - --- | A memory kept in the cache, under the plan the project has now. -futilityFor :: Choice "useCache" -> FilePath -> Futility -futilityFor caching projectDir = - Futility - { solveWasFutile = withCache False cachedFutileSolve, - rememberFutileSolve = withCache () storeFutileSolve, - fetchWasFutileFor = withCache [] cachedFutileFetch, - rememberFutileFetch = \packages -> - withCache () (`storeFutileFetch` packages), - rememberSolveTime = \started -> withCache () (`storeSolveTime` started) - } - where - withCache fallback use = - readBuildPlan (planPathFor projectDir) >>= \case - Left _ -> pure fallback - Right plan -> use =<< openCache caching =<< tokenForBuildPlan plan - --- | Do whatever is missing, given a way to run @cabal@ and a memory of what --- earlier attempts came to. -prepareWith :: - -- | Whether to use the cache. - Choice "useCache" -> - -- | Whether to download what is missing. - Choice "download" -> - -- | Run @cabal@ with these arguments. - ([String] -> IO (Either Text ())) -> - -- | What earlier attempts came to. - Futility -> - -- | The components the run is about to format. - [PlanComponent] -> - -- | The project being prepared. - FilePath -> - -- | What it was found to be short of. - Readiness -> - IO (Either Text ()) -prepareWith caching downloading cabal futility wanted projectDir = \case - Ready -> pure (Right ()) - SourcesMissing _ -> fetch - PlanMissing -> solveThenFetch - PlanStale _ -> solveThenFetch - PlanNarrow _ -> - solveWasFutile futility >>= \case - True -> fetchWhatIsShort - False -> solveThenFetch - where - wholeProject = ["--enable-tests", "--enable-benchmarks"] - tryWholeProject args = - cabal (args <> wholeProject) >>= \case - Right () -> pure (Right ()) - Left _ -> cabal args - fetch - | isTrue downloading = tryWholeProject ["build", ":all", "--only-download"] - | otherwise = pure (Right ()) - fetchWhatIsShort = - readBuildPlan (planPathFor projectDir) >>= \case - Left _ -> pure (Right ()) - Right plan -> do - short <- fmap ppName <$> sourcesShortOf caching plan - refused <- fetchWasFutileFor futility - if null short || all (`elem` refused) short - then pure (Right ()) - else - fetch >>= \case - Left err -> pure (Left err) - Right () -> do - left <- sourcesShortOf caching plan - rememberFutileFetch futility (fmap ppName left) - pure (Right ()) - solveThenFetch = do - started <- getCurrentTime - tryWholeProject ["build", ":all", "--dry-run"] >>= \case - Left err -> pure (Left err) - Right () -> do - rememberSolveTime futility started - checkReadiness caching wanted projectDir >>= \case - SourcesMissing _ -> fetch - PlanNarrow _ -> rememberFutileSolve futility >> fetchWhatIsShort - _ -> pure (Right ()) - --- | Run @cabal@ in a project directory, letting it speak for itself. -runCabal :: FilePath -> [String] -> IO (Either Text ()) -runCabal projectDir args = quietly (Left "could not run cabal") $ do - hFlush stderr - -- A duplicate because 'createProcess' closes the handle it is given once - -- the child has it, and closing the real standard error would leave - -- nothing to report the failure on. - passed <- hDuplicate stderr - -- A pipe closed at once rather than our standard input, which in an - -- editor's process carries what the editor says to it. - (toChild, _, _, running) <- - createProcess - (proc "cabal" args) - { cwd = Just projectDir, - std_in = CreatePipe, - std_out = UseHandle passed, - std_err = Inherit - } - traverse_ hClose toChild - code <- waitForProcess running - pure $ case code of - ExitSuccess -> Right () - _ -> Left ("cabal " <> T.unwords (fmap T.pack args) <> " failed; see above") - --- | Fetch the sources of a trusted plan's dependencies that are neither --- installed nor fetched already, at the versions the plan names. -fetchUninstalled :: - -- | Whether to use the cache. - Choice "useCache" -> - -- | The project the plan is for. - FilePath -> - -- | The build plan to use. - BuildPlan -> - IO () -fetchUninstalled caching projectDir plan = - sourcesShortOf caching plan >>= \case - [] -> pure () - short -> - void . runCabal projectDir $ - "fetch" - : "--no-dependencies" - : [T.unpack (ppName p <> "-" <> ppVersion p) | p <- short] - --- | Get a plan that is safe to use, doing whatever @cabal@ work is needed. -loadPlan :: - -- | Whether to use the cache. - Choice "useCache" -> - -- | Whether to download what is missing. - Choice "download" -> - -- | The components the run is about to format, so that a plan which says - -- nothing about them is solved again rather than trusted. - [PlanComponent] -> - -- | The project whose plan it is. - FilePath -> - IO (Either Text BuildPlan) -loadPlan caching downloading wanted projectDir = do - readiness <- checkReadiness caching wanted projectDir - prepareWith - caching - downloading - (runCabal projectDir) - (futilityFor caching projectDir) - wanted - projectDir - readiness - >>= \case - Left err -> pure (Left err) - _ -> readBuildPlan (planPathFor projectDir) - --- | Every planned package whose source could be in the package cache, with --- where that would be: under the package cache @cabal@ last named, unless --- a tarball it downloads is not there, when @cabal@ is asked again. -plannedTarballs :: Cache -> BuildPlan -> IO [(PlanPackage, FilePath)] -plannedTarballs cache plan = - cachedPackageCache cache >>= \case - Just remembered -> do - tarballs <- under remembered - absent <- - filterM - (fmap not . doesFileExist . snd) - (filter (isFetchable . fst) tarballs) - if null absent then pure tarballs else asked - Nothing -> asked - where - asked = do - cacheRoot <- packageCacheRoot - storePackageCache cache cacheRoot - under cacheRoot - under cacheRoot = do - repos <- quietly [] (Data.List.sort <$> listDirectory cacheRoot) - traverse - (\p -> (,) p <$> tarballFor cacheRoot repos p) - [p | p <- bpPackages plan, not (isLocal p)] - isLocal p = case ppSource p of - LocalPackage _ -> True - CheckedOut _ -> True - _ -> False - --- | Where @cabal@ keeps downloaded package sources, one directory per --- repository it downloads from. -packageCacheRoot :: IO FilePath -packageCacheRoot = - readProgramOutput - "cabal" - ["path", "--remote-repo-cache", "--output-format=json"] - >>= \case - Just said | Just dir <- remoteRepoCacheIn said -> pure dir - _ -> guessedPackageCacheRoot - --- | The package cache directory, out of what @cabal path@ printed. -remoteRepoCacheIn :: Text -> Maybe FilePath -remoteRepoCacheIn said = do - spoken <- - listToMaybe $ - reverse (filter (not . T.null) (fmap T.strip (T.lines said))) - value <- decodeStrict (T.encodeUtf8 spoken) - parseMaybe (withObject "cabal path" (.: "remote-repo-cache")) value - --- | Where @cabal@ probably keeps its downloaded packages. -guessedPackageCacheRoot :: IO FilePath -guessedPackageCacheRoot = - lookupEnv "CABAL_DIR" >>= \case - Just dir -> pure (dir "packages") - Nothing -> do - places <- cabalDirs - found <- filterM holdsAnIndex (toList places) - pure (fromMaybe (NE.head places) (listToMaybe found)) - where - holdsAnIndex dir = - quietly False (doesFileExist (dir hackage "01-index.tar")) - hackage = "hackage.haskell.org" - --- | Every directory @cabal@ could be keeping a package cache in, the --- platform's own default first. -cabalDirs :: IO (NonEmpty FilePath) -cabalDirs = do - appData <- getAppUserDataDirectory "cabal" - xdg <- quietly Nothing (Just <$> getXdgDirectory XdgCache "cabal") - pure . fmap ( "packages") $ case xdg of - Just dir | not onWindows -> dir :| [appData] - Just dir -> appData :| [dir] - Nothing -> appData :| [] - --- | Whether this is a Windows build, for the places that differ there. -onWindows :: Bool -onWindows = System.Info.os == "mingw32" - --- | The repository @cabal@ would have kept a package's sources under. -hackageByDefault :: FilePath -hackageByDefault = "hackage.haskell.org" - --- | Where a package's source tarball is, or where fetching would put it. -tarballFor :: FilePath -> [FilePath] -> PlanPackage -> IO FilePath -tarballFor cacheRoot repos p = case provenanceOf p of - RepoFromDirectory dir -> pure (dir flat) - RepoDownloaded uri -> searched (hostOf uri) - RepoNoProvenance -> searched Nothing - where - flat = T.unpack (ppName p <> "-" <> ppVersion p <> ".tar.gz") - under repo = - cacheRoot - repo - T.unpack (ppName p) - T.unpack (ppVersion p) - flat - searched preferred = do - let first' = fromMaybe hackageByDefault preferred - rest = filter (/= first') repos - found <- filterM doesFileExist (fmap under (first' : rest)) - pure (fromMaybe (under first') (listToMaybe found)) - --- | Which repository a package came from, where it came from one. -provenanceOf :: PlanPackage -> RepoProvenance -provenanceOf p = case ppSource p of - RepoPackage _ repo -> repo - _ -> RepoNoProvenance - --- | The host a URI names, which is what @cabal@ conventionally calls the --- repository that lives there. -hostOf :: Text -> Maybe FilePath -hostOf uri = case T.breakOn "//" uri of - (_, rest) - | not (T.null rest), - host <- T.takeWhile (/= '/') (T.drop 2 rest), - not (T.null host) -> - Just (T.unpack host) - _ -> Nothing - ----------------------------------------------------------------------------- --- Resolving - --- | Where a module's fixities can be read from. -data Route - = -- | The compiled interface the package database points at. Cheap, and - -- authoritative where it exists, since it is the compiler's own account - -- of what it settled on. - FromInterface - | -- | The module's source, out of the package's tarball in Cabal's - -- package cache. Slower, and the only route for a package that is - -- planned but not built. - FromSource - deriving (Eq, Show) - --- | What can be asked about a module, once a plan says where to look. -newtype Resolver = Resolver - { -- | What reading a module established about the names it exports. - askModule :: Text -> IO Established - } - --- | Build a new 'Resolver'. --- --- Answers are remembered on disk between runs by "Tilia.Fixity.Cache", so a --- package is decompressed and parsed once per machine rather than once per --- file. -newResolver :: - -- | The build plan to use. - BuildPlan -> - IO Resolver -newResolver = newResolverVia (Do #useCache) [FromInterface, FromSource] - --- | 'newResolver', restricted to the routes given. -newResolverVia :: - -- | Whether to use the cache. - Choice "useCache" -> - -- | Which readings to try, in order. - [Route] -> - -- | The build plan to use. - BuildPlan -> - IO Resolver -newResolverVia caching routes plan = do - cache <- openCache caching =<< tokenForBuildPlan plan - tarballs <- - if FromSource `elem` routes - then plannedTarballs cache plan - else pure [] - installed <- getInstalledPackages cache - newResolverWith routes cache installed tarballs plan - --- | 'newResolverVia', given what it would find out from the machine. -newResolverWith :: - -- | Which readings to try, in order. - [Route] -> - -- | Where to remember answers between runs. - Cache -> - -- | Every package the compiler can see. - [InstalledPackage] -> - -- | Every planned package that might have a tarball, and where it would - -- be. - [(PlanPackage, FilePath)] -> - -- | The build plan to use. - BuildPlan -> - IO Resolver -newResolverWith routes cache installed tarballs plan = do - index <- buildModuleIndex cache installed tarballs - let interfaces = interfaceIndex installed - local <- localModules plan - flights <- newMVar (Flights Map.empty Map.empty) - answersRead <- newMemo - askPackage <- newPackageReader (plannedCompiler plan) - extensionsRead <- newMemo - summariesRead <- newMemo - archivesRead <- newMemo - interfacesRead <- newMemo - reading <- newQSem =<< getNumCapabilities - let interfaceOf modName = - memoized flights interfacesRead Nothing modName $ - case Map.lookup modName primopFixities of - Just declared -> pure (Just (asInterface declared)) - Nothing -> case Map.lookup modName interfaces of - Nothing -> pure Nothing - Just (_, path) -> - bracket_ (waitQSem reading) (signalQSem reading) $ - readInterface modName path - let workings = - Workings - { wkRoutes = routes, - wkCache = cache, - wkLocal = local, - wkIndex = index, - wkInterfaces = interfaces, - wkInterfaceOf = interfaceOf, - wkReach = reach, - wkSummariesOf = summariesOf, - wkModuleInArchive = moduleInArchive, - wkGenerated = generatedModules plan, - wkReexported = - Map.fromList [pair | i <- installed, pair <- ipReexports i] - } - -- The stand-in is what 'withReexports' makes of a module it is in the - -- middle of reading. - reach visiting modName - | modName `Set.member` visiting = pure mempty - | otherwise = - memoized flights answersRead mempty modName $ - resolveModule workings visiting modName - summariesOf modName text = - memoized flights summariesRead Nothing modName $ do - extensions <- extensionsOf modName - let summarized = - evaluate . force $ - configurationsOf - (macrosOf plan) - (Just extensions) - modName - text - stamp = - digestOf $ - T.intercalate "\n" [T.pack (show extensions), macrosRead, text] - case digestOf . T.pack <$> Map.lookup modName local of - Nothing -> summarized - Just key -> - join - <$> recalled - (cachedSummaries cache key stamp) - (storeSummaries cache key stamp) - (Just <$> summarized) - macrosRead = T.pack (show (macrosOf plan)) - extensionsOf modName - | Just path <- Map.lookup modName local = - either (const []) id <$> askPackage path - | Just (package, tarball) <- Map.lookup modName index = - memoized flights extensionsRead [] package $ - foldMap declaredExtensions . (archiveCabal =<<) <$> archiveOf tarball - | otherwise = pure [] - archiveOf tarball = - memoized flights archivesRead Nothing (T.pack tarball) (readArchive tarball) - moduleInArchive tarball modName = (moduleIn modName =<<) <$> archiveOf tarball - pure Resolver{askModule = reach Set.empty} - --- | Answers filed under the names they are about, each worked out once. -data Memo v = Memo Unique (IORef (Map Text (MVar v))) - --- | An empty 'Memo'. -newMemo :: IO (Memo v) -newMemo = Memo <$> newUnique <*> newIORef Map.empty - --- | Which thread is working out which answer, and which answer each waiting --- thread waits for, across all of a resolver's tables. -data Flights = Flights - { flightOwners :: Map (Unique, Text) ThreadId, - flightWaits :: Map ThreadId (Unique, Text) - } - --- | Look an answer up in a table, working it out and filing it the first --- time. -memoized :: - -- | Who is working out what. - MVar Flights -> - -- | Where the answers are filed. - Memo v -> - -- | The answer for a thread that cannot wait. - v -> - -- | What the answer is about. - Text -> - -- | Work that is being memoized. - IO v -> - IO v -memoized flights (Memo table answers) standIn key work = - Map.lookup key <$> readIORef answers >>= \case - Just slot -> tryReadMVar slot >>= maybe (waitFor slot) pure - Nothing -> do - me <- myThreadId - claimed <- modifyMVar flights $ \fl -> do - filed <- readIORef answers - case Map.lookup key filed of - Just slot -> pure (fl, Left slot) - Nothing -> do - slot <- newEmptyMVar - writeIORef answers (Map.insert key slot filed) - pure - ( fl{flightOwners = Map.insert (table, key) me (flightOwners fl)}, - Right slot - ) - case claimed of - Left slot -> waitFor slot - Right slot -> do - answer <- work `onException` file slot standIn - answer <$ file slot answer - where - file slot answer = modifyMVar_ flights $ \fl -> do - _ <- tryPutMVar slot answer - pure fl{flightOwners = Map.delete (table, key) (flightOwners fl)} - waitFor slot = do - me <- myThreadId - settled <- modifyMVar flights $ \fl -> - tryReadMVar slot >>= \case - Just answer -> pure (fl, Just answer) - Nothing - | waitedOnBy fl me (table, key) -> pure (fl, Just standIn) - | otherwise -> - pure - ( fl{flightWaits = Map.insert me (table, key) (flightWaits fl)}, - Nothing - ) - case settled of - Just answer -> pure answer - Nothing -> do - answer <- readMVar slot - modifyMVar_ flights $ \fl -> - pure fl{flightWaits = Map.delete me (flightWaits fl)} - pure answer - --- | Is this answer being worked out by the given thread, or by one that --- waits for it, directly or through others? -waitedOnBy :: Flights -> ThreadId -> (Unique, Text) -> Bool -waitedOnBy fl me = go - where - go key = case Map.lookup key (flightOwners fl) of - Nothing -> False - Just owner - | owner == me -> True - | otherwise -> maybe False go (Map.lookup owner (flightWaits fl)) - --- | Work out what a module can see, using a resolver to reach its imports. --- --- This is the join between the pure half of "Tilia.Fixity" and the half --- that touches the disk: the imports are resolved first, and the scope is --- then computed from the answers. Note that a name an import leaves --- unsettled stays unsettled, which is what lets 'Tilia.Fixity.lookupFixity' --- distinguish a conclusion from a guess. -scopeFor :: - -- | What can be asked about the modules it imports. - Resolver -> - -- | Whether @ImplicitPrelude@ is on, which the module's own pragmas - -- and its package's @default-extensions@ decide between them. - Choice "implicitPrelude" -> - -- | The configurations of the module whose scope is wanted, already - -- parsed. - NonEmpty (HsModule GhcPs) -> - -- | Everything that module can see, and what it could not find out. - IO Scope -scopeFor resolver implicitPrelude configurations = do - let imports = moduleImports implicitPrelude configurations - answers <- - inParallel - (\m -> (m,) <$> askModule resolver m) - (fmap importModule imports) - let table = Map.fromList answers - pure $ - resolveScope - implicitPrelude - (\m -> Map.findWithDefault unreadable m table) - configurations - --- | Everything a resolver consults, and the way back into it. --- --- None of it changes from one module to the next, which is why --- 'newResolverVia' builds it once and hands it over whole. What comes back --- out of that is the 'Resolver'; this is what is behind it. -data Workings = Workings - { -- | Which readings to try, in the order given. - wkRoutes :: [Route], - -- | Where to remember answers between runs. - wkCache :: Cache, - -- | The modules of the project's own packages, which are read straight - -- from disk rather than out of an archive. - wkLocal :: Map Text FilePath, - -- | Which package holds each module, and the tarball to find it in; the - -- package is the cache key, which carries the hash the tarball was - -- verified against. - wkIndex :: Map Text (Text, FilePath), - -- | What to file an answer read out of each module's interface under. - wkInterfaces :: Map Text (Text, FilePath), - -- | A module's interface, read at most once a run. - wkInterfaceOf :: Text -> IO (Maybe Interface), - -- | How to reach another module. Tied back on itself by - -- 'newResolverVia', so that the memo it keeps covers the recursive - -- calls too. - wkReach :: Set Text -> Text -> IO Established, - -- | What each configuration of a module says, given its text, worked - -- out once a run. - wkSummariesOf :: Text -> Text -> IO (Maybe (NonEmpty ModuleSummary)), - -- | What a tarball holds for a module, each tarball read once a run. - wkModuleInArchive :: FilePath -> Text -> IO (Maybe InArchive), - -- | The modules @cabal@ writes itself, which are therefore in no - -- package's sources. See 'generatedModules'. - wkGenerated :: Set Text, - -- | The modules an installed package exposes that another one holds, - -- each with its name there. - wkReexported :: Map Text Text - } - --- | What reading a module establishes, by the cheapest route that settles --- it. -resolveModule :: - -- | Where to look, and how to get back to the resolver. - Workings -> - -- | Modules currently being resolved further up the call chain. - Set Text -> - -- | The module to resolve. - Text -> - IO Established -resolveModule - Workings - { wkRoutes, - wkCache, - wkLocal, - wkIndex, - wkInterfaces, - wkInterfaceOf, - wkReach, - wkSummariesOf, - wkModuleInArchive, - wkGenerated, - wkReexported - } - visiting - modName - | Just path <- Map.lookup modName wkLocal, - writtenForHsc path = - pure (hscDeclares modName) - | Just path <- Map.lookup modName wkLocal = - readFileText path >>= \case - Nothing -> pure unreadable - Just source -> - fromSummaries (wkReach visiting') modName =<< wkSummariesOf modName source - | Just original <- Map.lookup modName wkReexported, - Map.notMember modName wkInterfaces = - wkReach visiting' original - | otherwise = answered <$> firstAnswer (fmap taking wkRoutes) - where - visiting' = Set.insert modName visiting - - taking = \case - FromInterface -> viaInterface - FromSource -> viaArchive - - -- A route that read some of the module is kept in case no later one - -- reads all of it. - firstAnswer = go Nothing - where - go partial [] = pure (fromMaybe unreadable partial) - go partial (route : rest) = - route >>= \case - Just established - | settlesEverything established -> pure established - | established /= unreadable -> go (partial <|> Just established) rest - _ -> go partial rest - - viaInterface = case Map.lookup modName wkInterfaces of - Nothing -> pure Nothing - Just (key, _) -> - throughCache key (Just <$> fromInterface wkInterfaceOf modName) - - viaArchive = case Map.lookup modName wkIndex of - Nothing -> pure Nothing - Just (package, tarball) -> - throughCache package $ - fromSource - wkModuleInArchive - wkSummariesOf - (wkReach visiting') - tarball - modName - - answered established - | settlesEverything established = established - | Set.member modName wkGenerated = settledAs Map.empty established - | otherwise = established - throughCache key = - recalled - (cachedEstablished wkCache key modName) - (storeEstablished wkCache key modName) - --- | Which package and tarball holds each module. -buildModuleIndex :: - -- | Where to remember each package's module list. - Cache -> - -- | What the compiler says is installed. Empty if @ghc-pkg@ could not be - -- run, in which case every package falls back to its @.cabal@ file. - [InstalledPackage] -> - -- | Every package that might have a tarball, and where it would be. - [(PlanPackage, FilePath)] -> - -- | For each module, the package that exposes it (as a cache key) and - -- the tarball holding its source. - IO (Map Text (Text, FilePath)) -buildModuleIndex cache installed tarballs = - Map.fromListWith (\_ first' -> first') . concat <$> traverse one tarballs - where - byNameVersion = - Map.fromList [((ipName i, ipVersion i), ipModules i) | i <- installed] - one (p, tarball) = do - let key = cacheKey p - let exposed = Map.lookup (ppName p, ppVersion p) byNameVersion - held <- fromCabalFile cache key tarball p - let modules = case (exposed, held) of - (Nothing, Nothing) -> [] - (a, b) -> concat (catMaybes [a, b]) - pure [(m, (key, tarball)) | m <- modules] - --- | Where each installed module's compiled interface is. -interfaceIndex :: [InstalledPackage] -> Map Text (Text, FilePath) -interfaceIndex installed = - Map.fromListWith - (\_ first' -> first') - [ (m, (key, dir T.unpack (T.replace "." "/" m) <> ".hi")) - | i <- installed, - dir <- ipImportDirs i, - -- Bound out here so that the directory is hashed once rather than - -- once for each of the modules found in it. - let key = keyFor dir, - m <- ipModules i - ] - where - keyFor dir = "interface-" <> digestOf (T.pack dir) - --- | A name for some text, short enough to file something under. -digestOf :: Text -> Text -digestOf = - T.take 24 . T.decodeUtf8Lenient . B16.encode . SHA256.hash . T.encodeUtf8 - --- | Present a fixity map as an 'Interface'. -asInterface :: Fixities -> Interface -asInterface fixities = - Interface - { interfaceDeclares = fixities, - interfaceReexports = [], - interfaceMembers = Map.empty, - interfaceExports = Nothing - } - --- | What a compiled interface says a module exports, with the fixities of --- what it passes on read from where each is declared. -fromInterface :: - -- | A module's interface, if it has one. - (Text -> IO (Maybe Interface)) -> - -- | The module to read. - Text -> - IO Established -fromInterface interfaceOf modName = - interfaceOf modName >>= \case - Nothing -> pure unreadable - Just iface -> do - declarers <- - inParallel - asked - (distinct (fmap fst (interfaceReexports iface))) - let declarer m = join (lookup m declarers) - pure - Established - { establishedFixities = - Map.union (interfaceDeclares iface) . Map.unions $ - [ Map.filterWithKey - (\(_, o) _ -> o == op) - (interfaceDeclares declared) - | (m, op) <- interfaceReexports iface, - Just declared <- [declarer m] - ], - establishedUnsettled = - Map.fromListWith - Set.union - [ ([m], Set.fromList [(InTypes, op), (InTerms, op)]) - | (m, op) <- interfaceReexports iface, - Nothing <- [declarer m] - ], - establishedUntold = Set.empty, - establishedCertain = fromMaybe mempty (interfaceExports iface), - establishedMembers = interfaceMembers iface - } - where - asked m = do - interface <- interfaceOf m - pure (m, interface) - distinct = Map.keys . Map.fromList . fmap (,()) - --- | A package's module list from the @.cabal@ file in its tarball. -fromCabalFile :: - -- | Where to remember the answer. - Cache -> - -- | What to file it under. Carries the hash the tarball was verified - -- against, so a changed tarball misses rather than matching stale data. - Text -> - -- | The tarball to read the @.cabal@ file out of. - FilePath -> - -- | The package it belongs to, consulted for the hash to verify against. - PlanPackage -> - -- | The modules it exposes, or 'Nothing' if the tarball is absent, fails - -- verification, or holds no @.cabal@ file. - IO (Maybe [Text]) -fromCabalFile cache key tarball p = - recalled (cachedModules cache key) (storeModules cache key) $ - verified p tarball >>= \case - False -> pure Nothing - True -> packageModules tarball - --- | How a package's cached answers are filed. -cacheKey :: PlanPackage -> Text -cacheKey p = - ppName p <> "-" <> ppVersion p <> maybe "" (("-" <>) . T.take 16) (sourceHashOf p) - --- | Does the tarball hash to what the plan says it should? -verified :: PlanPackage -> FilePath -> IO Bool -verified p tarball = case sourceHashOf p of - Nothing -> pure True - Just expected -> - quietly False $ do - actual <- sha256OfFile tarball - pure (actual == T.toLower expected) - --- | The SHA-256 of a file, as lower-case hex. -sha256OfFile :: FilePath -> IO Text -sha256OfFile path = do - bytes <- BL.readFile path - pure (T.decodeUtf8Lenient (B16.encode (SHA256.hashlazy bytes))) - --- | Read what a module exports out of a tarball, following re-exports. -fromSource :: - -- | What a tarball holds for a module. - (FilePath -> Text -> IO (Maybe InArchive)) -> - -- | What each configuration of a module says, given its text. - (Text -> Text -> IO (Maybe (NonEmpty ModuleSummary))) -> - -- | How to reach another module, for chasing re-exports. This is - -- 'resolveModule' tied back on itself, with the visiting set already - -- extended. - (Text -> IO Established) -> - -- | The tarball holding this module's source. - FilePath -> - -- | The module to read. - Text -> - -- | What reading it established, or 'Nothing' if there is no archive to - -- read it from. - IO (Maybe Established) -fromSource moduleInArchive summariesOf reach tarball modName = - doesFileExist tarball >>= \case - False -> pure Nothing - True -> - fmap Just $ - moduleInArchive tarball modName >>= \case - Nothing -> pure unreadable - Just ForHsc -> pure (hscDeclares modName) - Just (Haskell source) -> - fromSummaries reach modName =<< summariesOf modName source - --- | What a module exports, out of what each of its configurations says. -fromSummaries :: - -- | How to reach another module, for chasing re-exports. This is - -- 'resolveModule' tied back on itself, with the visiting set already - -- extended. - (Text -> IO Established) -> - -- | The name the module was looked up under. - Text -> - -- | What each configuration of it says, or 'Nothing' where none of them - -- parses. - Maybe (NonEmpty ModuleSummary) -> - IO Established -fromSummaries reach modName = \case - Nothing -> pure unreadable - Just summaries -> - agreeing <$> traverse (withReexports reach modName) summaries - --- | One answer from every configuration of a module that counts. --- --- A module may declare a fixity in one configuration and a different one in --- another. Which of them holds depends on how the module is compiled, which --- is not ours to decide, so disagreement leaves the name unsettled. --- Agreement across the ones that count is an answer, and a stronger one --- than the blanked text could give. --- --- A configuration that leaves names unsettled is passed over where another --- settles every name, because almost every one of those is a branch meant --- for a different platform. Where none does, every configuration counts, --- and a name any of them leaves unsettled stays unsettled. -agreeing :: NonEmpty Established -> Established -agreeing answers = - settledOnly - Established - { establishedFixities = Map.mapMaybe sole declared, - establishedUnsettled = - Map.unionsWith - Set.union - ( maybe - Map.empty - (Map.singleton []) - disagreed - : fmap establishedUnsettled (toList counted) - ), - establishedUntold = foldMap establishedUntold counted, - establishedCertain = foldr1 inEvery (fmap establishedCertain counted), - establishedMembers = - Map.unionsWith Set.union (fmap establishedMembers counted) - } - where - counted = - fromMaybe answers $ - NE.nonEmpty (NE.filter settlesEverything answers) - declared = - Map.unionsWith - (<>) - [Map.map pure (establishedFixities a) | a <- toList counted] - sole (fixity :| rest) = - if all (== fixity) rest then Just fixity else Nothing - disagreed = inhabited (Map.keysSet (Map.filter (isNothing . sole) declared)) - inEvery a b = - Certain - { certainNames = Set.intersection (certainNames a) (certainNames b), - certainMembers = - Map.intersectionWith - Set.intersection - (certainMembers a) - (certainMembers b) - } - --- | Where each module that lives in a directory rather than an archive is. -localModules :: BuildPlan -> IO (Map Text FilePath) -localModules plan = - Map.unions <$> traverse forPackage (concatMap directoryOf (bpPackages plan)) - where - directoryOf p = case ppSource p of - LocalPackage dir -> [dir] - CheckedOut dir -> [dir] - _ -> [] - forPackage dir = quietly Map.empty $ do - entries <- listDirectory dir - case filter (".cabal" `isSuffixOf`) entries of - [] -> pure Map.empty - (cabalFile : _) -> do - contents <- readFileText (dir cabalFile) - case contents of - Nothing -> pure Map.empty - Just text -> - Map.fromList . concat - <$> traverse (locate dir (sourceDirs text)) (containedModules text) - locate dir dirs m = do - found <- - filterM - doesFileExist - [ dir T.unpack d modulePath m ending - | d <- dirs, - ending <- moduleEndings - ] - pure [(m, path) | path <- take 1 found] - - modulePath m ending = T.unpack (T.replace "." "/" m) <> ending - --- | Read a file, if it is there and is text. -readFileText :: FilePath -> IO (Maybe Text) -readFileText path = quietly Nothing $ do - there <- doesFileExist path - if there - then Just . T.decodeUtf8Lenient <$> BS.readFile path - else pure Nothing - --- | What a module exports, out of what it declares and what its imports --- bring in. -withReexports :: - -- | How to reach another module, for names this one only passes on. - (Text -> IO Established) -> - -- | The name this module was looked up under. - Text -> - -- | The module. - ModuleSummary -> - IO Established -withReexports reach modName summary = - case summaryExports summary of - Nothing -> pure own - Just items -> do - listed <- - reached $ \i -> - any (suppliedBy i) (concatMap named items) - || ( not (importQualified i) - && importAlias i - `elem` [m | ExportModule m <- items] - ) - let reexported = - Map.fromList - [ ((qualifier, parent), membersFrom listed qualifier parent) - | ExportAll qualifier parent <- items, - Map.notMember parent declared - ] - members = - [ (qualifier, kid) - | ((qualifier, _), Just kids) <- Map.toList reexported, - kid <- Set.toList kids, - Set.notMember kid defined - ] - more <- reached $ \i -> - Map.notMember (importModule i) listed && any (suppliedBy i) members - let answers = Map.union listed more - parts = fmap (exported answers reexported) items - pure . together $ - mempty - { establishedFixities = - Map.restrictKeys - (summaryFixities summary) - (foldMap (certainNames . establishedCertain) parts), - establishedMembers = summaryListedMembers summary - } - : parts - where - imports = summaryImports summary - declared = summaryDeclaredMembers summary - defined = - Set.map snd (summaryNames summary) - <> Set.map snd (Map.keysSet (summaryFixities summary)) - own = - mempty - { establishedFixities = summaryFixities summary, - establishedCertain = Certain (summaryNames summary) declared, - establishedMembers = Map.map (Set.map snd) declared - } - reached wanted = - Map.fromList - <$> traverse - (\m -> (m,) <$> reach m) - (Set.toList (Set.fromList [importModule i | i <- imports, wanted i])) - suppliedBy i (qualifier, op) = maySupply Map.empty qualifier op i - named = \case - ExportName _ qualifier op -> - [(qualifier, op) | Set.notMember op defined] - ExportAll qualifier parent -> - [(qualifier, parent) | Set.notMember parent defined] - ExportSome qualifier parent kids -> - [(qualifier, op) | op <- parent : kids, Set.notMember op defined] - ExportModule _ -> [] - - exported answers reexported = \case - ExportName namespace qualifier op -> - settled answers True qualifier (namespace, op) - <> certainly (Set.singleton (namespace, op)) Map.empty - ExportAll qualifier parent - | Just kids <- Map.lookup parent declared -> withMembers parent kids - | otherwise -> - let found = settled answers True qualifier (InTypes, parent) - kids = - Map.findWithDefault Nothing (qualifier, parent) reexported - in found - <> mempty{establishedUntold = Map.keysSet (establishedUnsettled found)} - <> foldMap (member answers qualifier parent) (foldMap Set.toList kids) - <> case kids of - Nothing -> certainly (Set.singleton (InTypes, parent)) Map.empty - Just known -> - withMembers parent (certainMembersOf answers qualifier parent) - <> mempty{establishedMembers = Map.singleton parent known} - ExportSome qualifier parent kids -> - settled answers True qualifier (InTypes, parent) - <> foldMap (member answers qualifier parent) kids - <> withMembers - parent - ( Set.filter - ((`elem` kids) . snd) - ( fromMaybe - (certainMembersOf answers qualifier parent) - (Map.lookup parent declared) - ) - ) - ExportModule m -> - (if Just m == summaryName summary || m == modName then own else mempty) - <> foldMap - (whole answers) - [i | i <- imports, not (importQualified i), importAlias i == m] - - certainly names members = mempty{establishedCertain = Certain names members} - withMembers parent kids = - certainly (Set.insert (InTypes, parent) kids) (Map.singleton parent kids) - member answers qualifier parent kid - | Set.member kid defined = mempty - | otherwise = - case [ (i, established, certainKids) - | (i, established) <- candidates answers qualifier parent, - decides established (InTypes, parent) i, - let certainKids = - Set.filter - ((== kid) . snd) - ( Map.findWithDefault - Set.empty - parent - (certainMembers (establishedCertain established)) - ), - not (Set.null certainKids) - ] of - (i, established, certainKids) : _ -> - foldMap (from [(i, established)]) certainKids - [] -> - foldMap - ( \namespace -> - settled answers False qualifier (namespace, kid) - ) - [InTypes, InTerms] - - candidates answers qualifier op = - [ (i, established) - | i <- imports, - Just established <- [Map.lookup (importModule i) answers], - maySupply (establishedMembers established) qualifier op i - ] - - settled answers certain qualifier name@(_, op) - | Set.member op defined = mempty - | otherwise = case [ (i, established) - | certain, - (i, established) <- found, - decides established name i - ] of - decider : _ -> from [decider] name - [] -> from found name - where - found = candidates answers qualifier op - - from imported name = - case [ importModule i : chain - | (i, established) <- imported, - chain <- unsettledThrough established name - ] of - [] -> - mempty - { establishedFixities = - Map.fromList - ( take - 1 - [ (name, fixity) - | (_, a) <- imported, - Just fixity <- [Map.lookup name (establishedFixities a)] - ] - ) - } - chains -> - mempty - { establishedUnsettled = - Map.fromList [(chain, Set.singleton name) | chain <- chains] - } - - membersFrom answers qualifier parent = - case mapMaybe - (Map.lookup parent . establishedMembers . snd) - (candidates answers qualifier parent) of - [] -> Nothing - kids -> Just (Set.unions kids) - - certainMembersOf answers qualifier parent = - Set.unions - [ Set.filter (\kid -> certainlyBrings (establishedMembers established) kid i) kids - | (i, established) <- candidates answers qualifier parent, - let certain = establishedCertain established, - Set.member (InTypes, parent) (certainNames certain), - Just kids <- [Map.lookup parent (certainMembers certain)] - ] - - whole answers i = - Established - { establishedFixities = - Map.filterWithKey - (\(_, op) _ -> admitted op) - (establishedFixities established), - establishedUnsettled = - Map.mapKeys - (importModule i :) - ( Map.mapMaybe - (inhabited . Set.filter (admitted . snd)) - (establishedUnsettled established) - ), - establishedUntold = - Set.map - (importModule i :) - (establishedUntold established), - establishedCertain = - Certain - { certainNames = Set.filter included (certainNames certain), - certainMembers = - Map.map - (Set.filter included) - ( Map.filterWithKey - (\parent _ -> included (InTypes, parent)) - (certainMembers certain) - ) - }, - establishedMembers = establishedMembers established - } - where - established = Map.findWithDefault mempty (importModule i) answers - certain = establishedCertain established - admitted op = maySupply (establishedMembers established) Nothing op i - included name = certainlyBrings (establishedMembers established) name i - --- | The parts of what a module exports, together. --- --- A name one part certainly exports with a settled fixity is the one every --- other part exports under that name too, or the module would not compile, --- so no part leaves it unsettled. -together :: [Established] -> Established -together parts = - settledOnly - combined - { establishedUnsettled = - Map.mapMaybe - (inhabited . (`Set.difference` certain)) - (establishedUnsettled combined) - } - where - combined = mconcat parts - certain = - Set.unions - [ Set.filter - (null . unsettledThrough part) - (certainNames (establishedCertain part)) - | part <- parts - ] - --- | An answer without the fixities of the names it leaves unsettled. -settledOnly :: Established -> Established -settledOnly established - | settlesEverything established = established - | otherwise = - established - { establishedFixities = - Map.filterWithKey - (\name _ -> null (unsettledThrough established name)) - (establishedFixities established) - } - --- | An answer whose fixities come from elsewhere, and settle every name. -settledAs :: Fixities -> Established -> Established -settledAs fixities established = - established - { establishedFixities = fixities, - establishedUnsettled = Map.empty, - establishedUntold = Set.empty - } - --- | A set, unless it is empty. -inhabited :: Set a -> Maybe (Set a) -inhabited names - | Set.null names = Nothing - | otherwise = Just names - --- | Every configuration the preprocessor allows of a module's text that is --- Haskell, parsed and summarized. -configurationsOf :: - -- | What the plan settles about the questions its conditionals ask. - Macros -> - -- | What extensions the module's package puts in force. - Maybe [Extension] -> - -- | The module's name, for the parser to put in its errors. - Text -> - -- | Its text. - Text -> - Maybe (NonEmpty ModuleSummary) -configurationsOf macros extensions modName text = - NE.nonEmpty . mapMaybe parsed - =<< whatParsed (branchLeaves (withoutRuledOut macros text)) - where - parsed leaf = - summarize (hasImplicitPrelude (fromMaybe [] extensions) leaf) . pmModule - <$> whatParsed (parseModule (configOf leaf) named leaf) - whatParsed = either (const Nothing) Just - configOf leaf = maybe defaultParserConfig (configFor leaf) extensions - configFor leaf exts = parserConfigFor (effectiveExtensions exts leaf) - named = T.unpack modName - --- | Does this module see the Prelude without importing it? -hasImplicitPrelude :: [Extension] -> Text -> Choice "implicitPrelude" -hasImplicitPrelude extensions source = - fromBool (ImplicitPrelude `elem` effectiveExtensions extensions source) - --- | What a tarball holds that a module could be read out of. -data Archive = Archive - { -- | The package's @.cabal@ file, the first one at the top. - archiveCabal :: Maybe Text, - -- | Every file that could hold a module, by where it sits, in the order - -- the tarball has them. - archiveFiles :: [(FilePath, BS.ByteString)] - } - deriving (Generic) - -instance NFData Archive - --- | Read a tarball, keeping what a module could be read out of. -readArchive :: FilePath -> IO (Maybe Archive) -readArchive tarball = quietly Nothing $ do - bytes <- BL.readFile tarball - Just <$> evaluate (force (sweep Nothing [] (Tar.read (GZip.decompress bytes)))) - where - sweep cabal found = \case - Tar.Next entry rest - | Tar.NormalFile content _ <- Tar.entryContent entry, - cabalFileAtTop (entryPosixPath entry), - Nothing <- cabal -> - sweep (Just (T.decodeUtf8Lenient (BL.toStrict content))) found rest - | Tar.NormalFile content _ <- Tar.entryContent entry, - any (`isSuffixOf` entryPosixPath entry) moduleEndings -> - sweep cabal ((entryPosixPath entry, BL.toStrict content) : found) rest - | otherwise -> sweep cabal found rest - _ -> Archive cabal (reverse found) - --- | Find a module in what a tarball holds and say what was found. -moduleIn :: Text -> Archive -> Maybe InArchive -moduleIn modName archive = listToMaybe (mapMaybe pick moduleEndings) - where - dirs = maybe [] sourceDirs (archiveCabal archive) - pick ending = - inArchive ending . T.decodeUtf8Lenient . snd - <$> listToMaybe (under sfx matching <> matching) - where - sfx = "/" <> T.unpack (T.replace "." "/" modName) <> ending - matching = [f | f <- archiveFiles archive, sfx `isSuffixOf` fst f] - under sfx matching = [f | d <- dirs, f <- matching, inDir sfx d (fst f)] - inDir sfx d path - | d == "." = takeWhile (/= '/') path <> sfx == path - | otherwise = ("/" <> T.unpack d <> sfx) `isSuffixOf` path - --- | The endings a package may write a module under, in the order they are --- tried. -moduleEndings :: [String] -moduleEndings = [".hs", ".hsc"] - --- | What an archive holds for a module. -data InArchive - = -- | Haskell, as the package wrote it. - Haskell Text - | -- | A module written for @hsc2hs@. Its text is not kept: there is - -- nothing to be done with it, and 'hscFixities' answers for it. - ForHsc - --- | What was found under one ending amounts to. -inArchive :: String -> Text -> InArchive -inArchive ending text - | writtenForHsc ending = ForHsc - | otherwise = Haskell text - --- | Is this a module @hsc2hs@ writes rather than one anybody compiles? -writtenForHsc :: FilePath -> Bool -writtenForHsc = isSuffixOf ".hsc" - --- | What an @.hsc@ module declares, which is nothing unless it is named. -hscDeclares :: Text -> Established -hscDeclares modName = - mempty - { establishedFixities = - maybe Map.empty inBothNamespaces (Map.lookup modName hscFixities) - } + ( Route (..), + Resolver (..), + newResolver, + newResolverVia, + newResolverWith, + newResolverFrom, + withReexports, + scopeFor, + ) +where + +import Control.Applicative ((<|>)) +import Control.Concurrent (getNumCapabilities) +import Control.Concurrent.QSem (newQSem, signalQSem, waitQSem) +import Control.DeepSeq (force) +import Control.Exception (bracket_, evaluate) +import Control.Monad (filterM, join) +import Crypto.Hash.SHA256 qualified as SHA256 +import Data.ByteString.Base16 qualified as B16 +import Data.ByteString.Lazy qualified as BL +import Data.Choice (Choice, fromBool, pattern Do) +import Data.Foldable (toList) +import Data.List.NonEmpty (NonEmpty ((:|))) +import Data.List.NonEmpty qualified as NE +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Maybe (catMaybes, fromMaybe, isNothing, mapMaybe) +import Data.Set (Set) +import Data.Set qualified as Set +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.Encoding qualified as T +import GHC.Hs (HsModule) +import GHC.Hs.Extension (GhcPs) +import GHC.LanguageExtensions.Type (Extension (ImplicitPrelude)) +import System.Directory (doesFileExist) +import System.FilePath (()) +import Tilia.Cabal.Package (PackageReader, declaredModules, newPackageReader, readPackageDescription) +import Tilia.Cabal.Plan +import Tilia.Cabal.Project (cabalFilesIn) +import Tilia.Cpp.Directives (branchLeaves, withoutRuledOut) +import Tilia.Cpp.Macros (Macros (..)) +import Tilia.Fixity +import Tilia.Fixity.Archive (Archive (..), InArchive (..), moduleEndings, moduleIn, pathOfModule, readArchive, writtenForHsc) +import Tilia.Fixity.Cabal (declaredExtensions, packageModules) +import Tilia.Fixity.Cache +import Tilia.Fixity.HiFile (HiFile, primopFixities) +import Tilia.Fixity.Interface +import Tilia.Fixity.PackageDb +import Tilia.Memo (memoized, newFlights, newMemo) +import Tilia.Parser +import Tilia.Pragma (effectiveExtensions) +import Tilia.Utils (byteOrderMark, inParallel, quietly, readFileText, sha256Of) + +---------------------------------------------------------------------------- +-- Resolving + +-- | Where a module's fixities can be read from. +data Route + = -- | The compiled interface the package database points at. Cheap, and + -- authoritative where it exists, since it is the compiler's own account + -- of what it settled on. + FromInterface + | -- | The module's source, out of the package's tarball in Cabal's + -- package cache. Slower, and the only route for a package that is + -- planned but not built. + FromSource + deriving (Eq, Show) + +-- | What can be asked about a module, once a plan says where to look. +newtype Resolver = Resolver + { -- | What reading a module established about the names it exports. + askModule :: Text -> IO Established + } + +-- | Build a new 'Resolver'. +-- +-- Answers are remembered on disk between runs by "Tilia.Fixity.Cache", so a +-- package is decompressed and parsed once per machine rather than once per +-- file. +newResolver :: + -- | The build plan to use. + BuildPlan -> + IO Resolver +newResolver plan = do + packageReader <- newPackageReader (plannedCompiler plan) + newResolverVia (Do #useCache) [FromInterface, FromSource] packageReader plan + +-- | 'newResolver', restricted to the routes given. +newResolverVia :: + -- | Whether to use the cache. + Choice "useCache" -> + -- | Which readings to try, in order. + [Route] -> + -- | What the package of each of the project's own modules puts in force. + PackageReader -> + -- | The build plan to use. + BuildPlan -> + IO Resolver +newResolverVia caching routes packageReader plan = do + cache <- openCache caching =<< tokenForBuildPlan plan + tarballs <- + if FromSource `elem` routes + then plannedTarballs cache plan + else pure [] + installed <- getInstalledPackages cache + newResolverWith routes cache installed tarballs packageReader plan + +-- | 'newResolverVia', given what it would find out from the machine. +newResolverWith :: + -- | Which readings to try, in order. + [Route] -> + -- | Where to remember answers between runs. + Cache -> + -- | Every package the compiler can see. + [InstalledPackage] -> + -- | Every planned package that might have a tarball, and where it would + -- be. + [(PlanPackage, FilePath)] -> + -- | What the package of each of the project's own modules puts in force. + PackageReader -> + -- | The build plan to use. + BuildPlan -> + IO Resolver +newResolverWith routes cache installed tarballs packageReader plan = do + index <- buildModuleIndex cache installed tarballs + let interfaces = interfaceIndex installed + local <- localModules plan + flights <- newFlights + answersRead <- newMemo + extensionsRead <- newMemo + archivesRead <- newMemo + interfacesRead <- newMemo + reading <- newQSem =<< getNumCapabilities + let interfaceOf modName = + memoized flights interfacesRead Nothing modName $ + case Map.lookup modName primopFixities of + Just declared -> pure (Just (asInterface declared)) + Nothing -> case Map.lookup modName interfaces of + Nothing -> pure Nothing + Just (_, path) -> + bracket_ (waitQSem reading) (signalQSem reading) $ + readInterface modName path + let workings = + Workings + { wkRoutes = routes, + wkCache = cache, + wkLocal = local, + wkIndex = index, + wkInterfaces = interfaces, + wkInterfaceOf = interfaceOf, + wkReach = reach, + wkSummariesOf = summariesOf, + wkModuleInArchive = moduleInArchive, + wkGenerated = generatedModules plan, + wkReexported = + Map.fromListWith + (\_ first' -> first') + [pair | i <- installed, pair <- ipReexports i] + } + -- The stand-in is what 'withReexports' makes of a module it is in the + -- middle of reading. + reach visiting modName + | modName `Set.member` visiting = pure mempty + | otherwise = + memoized flights answersRead mempty modName $ + resolveModule workings visiting modName + summariesOf modName text = + extensionsOf modName >>= \case + Nothing -> pure Nothing + Just extensions -> do + let summarized = + evaluate . force $ + configurationsOf (macrosOf plan) extensions modName text + stamp = + digestOf . T.intercalate "\n" $ + [T.pack (show extensions), macrosRead, text] + case digestOf . T.pack <$> Map.lookup modName local of + Nothing -> summarized + Just key -> + join + <$> recalled + (cachedSummaries cache key stamp) + (storeSummaries cache key stamp) + (Just <$> summarized) + macrosRead = T.pack (show (macrosOf plan)) + extensionsOf modName + | Just path <- Map.lookup modName local = + either (const Nothing) Just <$> packageReader path + | Just (package, tarball) <- Map.lookup modName index = + memoized flights extensionsRead Nothing package $ + fmap declaredExtensions . (archiveCabal =<<) <$> archiveOf tarball + | otherwise = pure Nothing + archiveOf tarball = + memoized flights archivesRead Nothing (T.pack tarball) (readArchive tarball) + moduleInArchive tarball modName = (moduleIn modName =<<) <$> archiveOf tarball + pure Resolver{askModule = reach Set.empty} + +-- | A 'Resolver' that reads every module out of the interface given for it, +-- for a program that has compiled the project and holds its interfaces. +newResolverFrom :: + -- | The interface of a module, by name. + (Text -> IO (Maybe HiFile)) -> + IO Resolver +newResolverFrom given = do + flights <- newFlights + interfacesRead <- newMemo + answersRead <- newMemo + let interfaceOf modName = + memoized flights interfacesRead Nothing modName $ + case Map.lookup modName primopFixities of + Just declared -> pure (Just (asInterface declared)) + Nothing -> + (either (const Nothing) Just . fromHiFile modName =<<) + <$> given modName + pure + Resolver + { askModule = \modName -> + memoized flights answersRead unreadable modName $ + fromInterface interfaceOf modName + } + +-- | Work out what a module can see, using a resolver to reach its imports. +-- +-- This is the join between the pure half of "Tilia.Fixity" and the half +-- that touches the disk: the imports are resolved first, and the scope is +-- then computed from the answers. Note that a name an import leaves +-- unsettled stays unsettled, which is what lets 'Tilia.Fixity.lookupFixity' +-- distinguish a conclusion from a guess. +scopeFor :: + -- | What can be asked about the modules it imports. + Resolver -> + -- | Whether @ImplicitPrelude@ is on, which the module's own pragmas + -- and its package's @default-extensions@ decide between them. + Choice "implicitPrelude" -> + -- | The configurations of the module whose scope is wanted, already + -- parsed. + NonEmpty (HsModule GhcPs) -> + -- | Everything that module can see, and what it could not find out. + IO Scope +scopeFor resolver implicitPrelude configurations = do + let imports = moduleImports implicitPrelude configurations + answers <- + inParallel + (\m -> (m,) <$> askModule resolver m) + (fmap importModule imports) + let table = Map.fromList answers + pure $ + resolveScope + implicitPrelude + (\m -> Map.findWithDefault unreadable m table) + configurations + +-- | Everything a resolver consults, and the way back into it. +-- +-- None of it changes from one module to the next, which is why +-- 'newResolverWith' builds it once and hands it over whole. What comes back +-- out of that is the 'Resolver'; this is what is behind it. +data Workings = Workings + { -- | Which readings to try, in the order given. + wkRoutes :: [Route], + -- | Where to remember answers between runs. + wkCache :: Cache, + -- | The modules of the project's own packages, which are read straight + -- from disk rather than out of an archive. + wkLocal :: Map Text FilePath, + -- | Which package holds each module, and the tarball to find it in; the + -- package is the cache key, which carries the hash the tarball was + -- verified against. + wkIndex :: Map Text (Text, FilePath), + -- | What to file an answer read out of each module's interface under. + wkInterfaces :: Map Text (Text, FilePath), + -- | A module's interface, read at most once a run. + wkInterfaceOf :: Text -> IO (Maybe Interface), + -- | How to reach another module. Tied back on itself by + -- 'newResolverWith', so that the memo it keeps covers the recursive + -- calls too. + wkReach :: Set Text -> Text -> IO Established, + -- | What each configuration of a module says, given its text, worked + -- out once a run. + wkSummariesOf :: Text -> Text -> IO (Maybe (NonEmpty ModuleSummary)), + -- | What a tarball holds for a module, each tarball read once a run. + wkModuleInArchive :: FilePath -> Text -> IO (Maybe InArchive), + -- | The modules @cabal@ writes itself, which are therefore in no + -- package's sources. See 'generatedModules'. + wkGenerated :: Set Text, + -- | The modules an installed package exposes that another one holds, + -- each with its name there. + wkReexported :: Map Text Text + } + +-- | What reading a module establishes, by the cheapest route that settles +-- it. +resolveModule :: + -- | Where to look, and how to get back to the resolver. + Workings -> + -- | Modules currently being resolved further up the call chain. + Set Text -> + -- | The module to resolve. + Text -> + IO Established +resolveModule + Workings + { wkRoutes, + wkCache, + wkLocal, + wkIndex, + wkInterfaces, + wkInterfaceOf, + wkReach, + wkSummariesOf, + wkModuleInArchive, + wkGenerated, + wkReexported + } + visiting + modName + | Just path <- Map.lookup modName wkLocal, + writtenForHsc path = + pure mempty + | Just path <- Map.lookup modName wkLocal = + readFileText path >>= \case + Nothing -> pure unreadable + Just source -> + fromSummaries (wkReach visiting') modName + =<< wkSummariesOf modName (snd (byteOrderMark source)) + | Just original <- Map.lookup modName wkReexported, + Map.notMember modName wkInterfaces = + wkReach visiting' original + | otherwise = answered <$> firstAnswer (fmap taking wkRoutes) + where + visiting' = Set.insert modName visiting + + taking = \case + FromInterface -> viaInterface + FromSource -> viaArchive + + -- A route that read some of the module is kept in case no later one + -- reads all of it. + firstAnswer = go Nothing + where + go partial [] = pure (fromMaybe unreadable partial) + go partial (route : rest) = + route >>= \case + Just established + | settlesEverything established -> pure established + | established /= unreadable -> go (partial <|> Just established) rest + _ -> go partial rest + + viaInterface = case Map.lookup modName wkInterfaces of + Nothing -> pure Nothing + Just (key, _) -> + throughCache key (Just <$> fromInterface wkInterfaceOf modName) + + viaArchive = case Map.lookup modName wkIndex of + Nothing -> pure Nothing + Just (package, tarball) -> + throughCache package $ + fromSource + wkModuleInArchive + wkSummariesOf + (wkReach visiting') + tarball + modName + + answered established + | settlesEverything established = established + | Set.member modName wkGenerated = + established + { establishedFixities = Map.empty, + establishedUnsettled = Map.empty, + establishedUntold = Set.empty + } + | otherwise = established + throughCache key = + recalled + (cachedEstablished wkCache key modName) + (storeEstablished wkCache key modName) + +-- | Which package and tarball holds each module. +buildModuleIndex :: + -- | Where to remember each package's module list. + Cache -> + -- | What the compiler says is installed. Empty if @ghc-pkg@ could not be + -- run, in which case every package falls back to its @.cabal@ file. + [InstalledPackage] -> + -- | Every package that might have a tarball, and where it would be. + [(PlanPackage, FilePath)] -> + -- | For each module, the package that holds it (as a cache key) and + -- the tarball holding its source. + IO (Map Text (Text, FilePath)) +buildModuleIndex cache installed tarballs = + Map.fromListWith (\_ first' -> first') . concat <$> traverse one tarballs + where + byNameVersion = + Map.fromList [((ipName i, ipVersion i), ipModules i) | i <- installed] + one (p, tarball) = do + let key = cacheKey p + let exposed = Map.lookup (ppName p, ppVersion p) byNameVersion + held <- fromCabalFile cache key tarball p + let modules = case (exposed, held) of + (Nothing, Nothing) -> [] + (a, b) -> concat (catMaybes [a, b]) + pure [(m, (key, tarball)) | m <- modules] + +-- | Where each installed module's compiled interface is. +interfaceIndex :: [InstalledPackage] -> Map Text (Text, FilePath) +interfaceIndex installed = + Map.fromListWith + (\_ first' -> first') + [ (m, (key, dir pathOfModule m <> ".hi")) + | i <- installed, + dir <- ipImportDirs i, + -- Bound out here so that the directory is hashed once rather than + -- once for each of the modules found in it. + let key = keyFor dir, + m <- ipModules i + ] + where + keyFor dir = "interface-" <> digestOf (T.pack dir) + +-- | A name for some text, short enough to file something under. +digestOf :: Text -> Text +digestOf = T.take 24 . sha256Of + +-- | Present a fixity map as an 'Interface'. +asInterface :: Fixities -> Interface +asInterface fixities = + Interface + { interfaceDeclares = fixities, + interfaceReexports = [], + interfaceMembers = Map.empty, + interfaceExports = Nothing + } + +-- | What a compiled interface says a module exports, with the fixities of +-- what it passes on read from where each is declared. +fromInterface :: + -- | A module's interface, if it has one. + (Text -> IO (Maybe Interface)) -> + -- | The module to read. + Text -> + IO Established +fromInterface interfaceOf modName = + interfaceOf modName >>= \case + Nothing -> pure unreadable + Just iface -> do + declarers <- + inParallel + asked + (distinct (fmap fst (interfaceReexports iface))) + let declarer m = join (lookup m declarers) + pure + Established + { establishedFixities = + Map.union (interfaceDeclares iface) . Map.unions $ + [ Map.filterWithKey + (\(_, o) _ -> o == op) + (interfaceDeclares declared) + | (m, op) <- interfaceReexports iface, + Just declared <- [declarer m] + ], + establishedUnsettled = + Map.fromListWith + Set.union + [ ([m], Set.fromList [(InTypes, op), (InTerms, op)]) + | (m, op) <- interfaceReexports iface, + Nothing <- [declarer m] + ], + establishedUntold = Set.empty, + establishedCertain = fromMaybe mempty (interfaceExports iface), + establishedMembers = interfaceMembers iface + } + where + asked m = do + interface <- interfaceOf m + pure (m, interface) + distinct = Map.keys . Map.fromList . fmap (,()) + +-- | A package's module list from the @.cabal@ file in its tarball. +fromCabalFile :: + -- | Where to remember the answer. + Cache -> + -- | What to file it under. Carries the hash the tarball was verified + -- against, so a changed tarball misses rather than matching stale data. + Text -> + -- | The tarball to read the @.cabal@ file out of. + FilePath -> + -- | The package it belongs to, consulted for the hash to verify against. + PlanPackage -> + -- | The modules it holds, or 'Nothing' if the tarball is absent, fails + -- verification, or holds no @.cabal@ file. + IO (Maybe [Text]) +fromCabalFile cache key tarball p = + recalled (cachedModules cache key) (storeModules cache key) $ + verified p tarball >>= \case + False -> pure Nothing + True -> packageModules tarball + +-- | Does the tarball hash to what the plan says it should? +verified :: PlanPackage -> FilePath -> IO Bool +verified p tarball = case sourceHashOf p of + Nothing -> pure True + Just expected -> + quietly False $ do + actual <- sha256OfFile tarball + pure (actual == T.toLower expected) + +-- | The SHA-256 of a file, as lower-case hex. +sha256OfFile :: FilePath -> IO Text +sha256OfFile path = do + bytes <- BL.readFile path + pure (T.decodeUtf8Lenient (B16.encode (SHA256.hashlazy bytes))) + +-- | Read what a module exports out of a tarball, following re-exports. +fromSource :: + -- | What a tarball holds for a module. + (FilePath -> Text -> IO (Maybe InArchive)) -> + -- | What each configuration of a module says, given its text. + (Text -> Text -> IO (Maybe (NonEmpty ModuleSummary))) -> + -- | How to reach another module, for chasing re-exports. This is + -- 'resolveModule' tied back on itself, with the visiting set already + -- extended. + (Text -> IO Established) -> + -- | The tarball holding this module's source. + FilePath -> + -- | The module to read. + Text -> + -- | What reading it established, or 'Nothing' if there is no archive to + -- read it from. + IO (Maybe Established) +fromSource moduleInArchive summariesOf reach tarball modName = + doesFileExist tarball >>= \case + False -> pure Nothing + True -> + fmap Just $ + moduleInArchive tarball modName >>= \case + Nothing -> pure unreadable + Just ForHsc -> pure mempty + Just (Haskell source) -> + fromSummaries reach modName =<< summariesOf modName source + +-- | What a module exports, out of what each of its configurations says. +fromSummaries :: + -- | How to reach another module, for chasing re-exports. This is + -- 'resolveModule' tied back on itself, with the visiting set already + -- extended. + (Text -> IO Established) -> + -- | The name the module was looked up under. + Text -> + -- | What each configuration of it says, or 'Nothing' where none of them + -- parses. + Maybe (NonEmpty ModuleSummary) -> + IO Established +fromSummaries reach modName = \case + Nothing -> pure unreadable + Just summaries -> + agreeing <$> traverse (withReexports reach modName) summaries + +-- | One answer from every configuration of a module that counts. +-- +-- A module may declare a fixity in one configuration and a different one in +-- another. Which of them holds depends on how the module is compiled, which +-- is not ours to decide, so disagreement leaves the name unsettled. +-- Agreement across the ones that count is an answer, and a stronger one +-- than the blanked text could give. +-- +-- A configuration that leaves names unsettled is passed over where another +-- settles every name, because almost every one of those is a branch meant +-- for a different platform. Where none does, every configuration counts, +-- and a name any of them leaves unsettled stays unsettled. +agreeing :: NonEmpty Established -> Established +agreeing answers = + settledOnly + Established + { establishedFixities = Map.mapMaybe sole declared, + establishedUnsettled = + Map.unionsWith + Set.union + ( maybe + Map.empty + (Map.singleton []) + disagreed + : fmap establishedUnsettled (toList counted) + ), + establishedUntold = foldMap establishedUntold counted, + establishedCertain = foldr1 inEvery (fmap establishedCertain counted), + establishedMembers = + Map.unionsWith Set.union (fmap establishedMembers counted) + } + where + counted = + fromMaybe answers $ + NE.nonEmpty (NE.filter settlesEverything answers) + declared = + Map.unionsWith + (<>) + [Map.map pure (establishedFixities a) | a <- toList counted] + sole (fixity :| rest) = + if all (== fixity) rest then Just fixity else Nothing + disagreed = inhabited (Map.keysSet (Map.filter (isNothing . sole) declared)) + inEvery a b = + Certain + { certainNames = Set.intersection (certainNames a) (certainNames b), + certainMembers = + Map.intersectionWith + Set.intersection + (certainMembers a) + (certainMembers b) + } + +-- | Where each module that lives in a directory rather than an archive is. +localModules :: BuildPlan -> IO (Map Text FilePath) +localModules plan = + Map.unions <$> traverse forPackage (concatMap directoryOf (bpPackages plan)) + where + directoryOf p = case ppSource p of + LocalPackage dir -> [dir] + CheckedOut dir -> [dir] + _ -> [] + forPackage dir = quietly Map.empty $ do + cabalFilesIn dir >>= \case + [] -> pure Map.empty + (cabalFile : _) -> + readPackageDescription cabalFile >>= \case + Left _ -> pure Map.empty + Right described -> + Map.fromListWith (\_ first' -> first') . concat + <$> traverse (locate dir) (declaredModules described) + locate dir (m, unwritten) = do + found <- filterM doesFileExist [dir unwritten <> e | e <- moduleEndings] + pure [(m, path) | path <- take 1 found] + +-- | What a module exports, out of what it declares and what its imports +-- bring in. +withReexports :: + -- | How to reach another module, for names this one only passes on. + (Text -> IO Established) -> + -- | The name this module was looked up under. + Text -> + -- | The module. + ModuleSummary -> + IO Established +withReexports reach modName summary = + case summaryExports summary of + Nothing -> pure own + Just items -> do + listed <- + reached $ \i -> + any (suppliedBy i) (concatMap named items) + || ( not (importQualified i) + && importAlias i + `elem` [m | ExportModule m <- items] + ) + let reexported = + Map.fromList + [ ((qualifier, parent), membersFrom listed qualifier parent) + | ExportAll qualifier parent <- items, + Map.notMember parent declared + ] + members = + [ (qualifier, kid) + | ((qualifier, _), Just kids) <- Map.toList reexported, + kid <- Set.toList kids, + Set.notMember kid defined + ] + more <- reached $ \i -> + Map.notMember (importModule i) listed && any (suppliedBy i) members + let answers = Map.union listed more + parts = fmap (exported answers reexported) items + pure . together $ + mempty + { establishedFixities = + Map.restrictKeys + (summaryFixities summary) + (foldMap (certainNames . establishedCertain) parts), + establishedMembers = summaryListedMembers summary + } + : parts + where + imports = summaryImports summary + declared = summaryDeclaredMembers summary + defined = + Set.map snd (summaryNames summary) + <> Set.map snd (Map.keysSet (summaryFixities summary)) + own = + mempty + { establishedFixities = summaryFixities summary, + establishedCertain = Certain (summaryNames summary) declared, + establishedMembers = Map.map (Set.map snd) declared + } + reached wanted = + Map.fromList + <$> traverse + (\m -> (m,) <$> reach m) + (Set.toList (Set.fromList [importModule i | i <- imports, wanted i])) + suppliedBy i (qualifier, op) = maySupply Map.empty qualifier op i + named = \case + ExportName _ qualifier op -> + [(qualifier, op) | Set.notMember op defined] + ExportAll qualifier parent -> + [(qualifier, parent) | Set.notMember parent defined] + ExportSome qualifier parent kids -> + [(qualifier, op) | op <- parent : kids, Set.notMember op defined] + ExportModule _ -> [] + + exported answers reexported = \case + ExportName namespace qualifier op -> + settled answers True qualifier (namespace, op) + <> certainly (Set.singleton (namespace, op)) Map.empty + ExportAll qualifier parent + | Just kids <- Map.lookup parent declared -> withMembers parent kids + | otherwise -> + let found = settled answers True qualifier (InTypes, parent) + kids = + Map.findWithDefault Nothing (qualifier, parent) reexported + in found + <> mempty{establishedUntold = Map.keysSet (establishedUnsettled found)} + <> foldMap (member answers qualifier parent) (foldMap Set.toList kids) + <> case kids of + Nothing -> certainly (Set.singleton (InTypes, parent)) Map.empty + Just known -> + withMembers parent (certainMembersOf answers qualifier parent) + <> mempty{establishedMembers = Map.singleton parent known} + ExportSome qualifier parent kids -> + settled answers True qualifier (InTypes, parent) + <> foldMap (member answers qualifier parent) kids + <> withMembers + parent + ( Set.filter + ((`elem` kids) . snd) + ( fromMaybe + (certainMembersOf answers qualifier parent) + (Map.lookup parent declared) + ) + ) + ExportModule m -> + (if Just m == summaryName summary || m == modName then own else mempty) + <> foldMap + (whole answers) + [i | i <- imports, not (importQualified i), importAlias i == m] + + certainly names members = mempty{establishedCertain = Certain names members} + withMembers parent kids = + certainly (Set.insert (InTypes, parent) kids) (Map.singleton parent kids) + member answers qualifier parent kid + | Set.member kid defined = mempty + | otherwise = + case [ (i, established, certainKids) + | (i, established) <- candidates answers qualifier parent, + decides established (InTypes, parent) i, + let certainKids = + Set.filter + ((== kid) . snd) + ( Map.findWithDefault + Set.empty + parent + (certainMembers (establishedCertain established)) + ), + not (Set.null certainKids) + ] of + (i, established, certainKids) : _ -> + foldMap (from [(i, established)]) certainKids + [] -> + foldMap + ( \namespace -> + settled answers False qualifier (namespace, kid) + ) + [InTypes, InTerms] + + candidates answers qualifier op = + [ (i, established) + | i <- imports, + Just established <- [Map.lookup (importModule i) answers], + maySupply (establishedMembers established) qualifier op i + ] + + settled answers certain qualifier name@(_, op) + | Set.member op defined = mempty + | otherwise = case [ (i, established) + | certain, + (i, established) <- found, + decides established name i + ] of + decider : _ -> from [decider] name + [] -> from found name + where + found = candidates answers qualifier op + + from imported name = + case [ importModule i : chain + | (i, established) <- imported, + chain <- unsettledThrough established name + ] of + [] -> + mempty + { establishedFixities = + Map.fromList + ( take + 1 + [ (name, fixity) + | (_, a) <- imported, + Just fixity <- [Map.lookup name (establishedFixities a)] + ] + ) + } + chains -> + mempty + { establishedUnsettled = + Map.fromList [(chain, Set.singleton name) | chain <- chains] + } + + membersFrom answers qualifier parent = + case mapMaybe + (Map.lookup parent . establishedMembers . snd) + (candidates answers qualifier parent) of + [] -> Nothing + kids -> Just (Set.unions kids) + + certainMembersOf answers qualifier parent = + Set.unions + [ Set.filter (\kid -> certainlyBrings (establishedMembers established) kid i) kids + | (i, established) <- candidates answers qualifier parent, + let certain = establishedCertain established, + Set.member (InTypes, parent) (certainNames certain), + Just kids <- [Map.lookup parent (certainMembers certain)] + ] + + whole answers i = + Established + { establishedFixities = + Map.filterWithKey + (\(_, op) _ -> admitted op) + (establishedFixities established), + establishedUnsettled = + Map.mapKeys + (importModule i :) + ( Map.mapMaybe + (inhabited . Set.filter (admitted . snd)) + (establishedUnsettled established) + ), + establishedUntold = + Set.map + (importModule i :) + (establishedUntold established), + establishedCertain = + Certain + { certainNames = Set.filter included (certainNames certain), + certainMembers = + Map.map + (Set.filter included) + ( Map.filterWithKey + (\parent _ -> included (InTypes, parent)) + (certainMembers certain) + ) + }, + establishedMembers = establishedMembers established + } + where + established = Map.findWithDefault mempty (importModule i) answers + certain = establishedCertain established + admitted op = maySupply (establishedMembers established) Nothing op i + included name = certainlyBrings (establishedMembers established) name i + +-- | The parts of what a module exports, together. +-- +-- A name one part certainly exports with a settled fixity is the one every +-- other part exports under that name too, or the module would not compile, +-- so no part leaves it unsettled. +together :: [Established] -> Established +together parts = + settledOnly + combined + { establishedUnsettled = + Map.mapMaybe + (inhabited . (`Set.difference` certain)) + (establishedUnsettled combined) + } + where + combined = mconcat parts + certain = + Set.unions + [ Set.filter + (null . unsettledThrough part) + (certainNames (establishedCertain part)) + | part <- parts + ] + +-- | An answer without the fixities of the names it leaves unsettled. +settledOnly :: Established -> Established +settledOnly established + | settlesEverything established = established + | otherwise = + established + { establishedFixities = + Map.filterWithKey + (\name _ -> null (unsettledThrough established name)) + (establishedFixities established) + } + +-- | A set, unless it is empty. +inhabited :: Set a -> Maybe (Set a) +inhabited names + | Set.null names = Nothing + | otherwise = Just names + +-- | Every configuration the preprocessor allows of a module's text that is +-- Haskell, parsed and summarized. +configurationsOf :: + -- | What the plan settles about the questions its conditionals ask. + Macros -> + -- | What extensions the module's package puts in force. + [Extension] -> + -- | The module's name, for the parser to put in its errors. + Text -> + -- | Its text. + Text -> + Maybe (NonEmpty ModuleSummary) +configurationsOf macros extensions modName text = + NE.nonEmpty . mapMaybe parsed + =<< whatParsed (branchLeaves (withoutRuledOut macros text)) + where + parsed leaf = + summarize (hasImplicitPrelude extensions leaf) . pmModule + <$> whatParsed (parseModule (ParserConfig extensions) named leaf) + whatParsed = either (const Nothing) Just + named = T.unpack modName + +-- | Does this module see the Prelude without importing it? +hasImplicitPrelude :: [Extension] -> Text -> Choice "implicitPrelude" +hasImplicitPrelude extensions source = + fromBool (ImplicitPrelude `elem` effectiveExtensions extensions source) diff --git a/src/Tilia/Format.hs b/src/Tilia/Format.hs --- a/src/Tilia/Format.hs +++ b/src/Tilia/Format.hs @@ -1,6 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} -- | Formatting a file, with everything the project can tell us about it. module Tilia.Format @@ -12,6 +13,8 @@ sessionRoot, PlanSource (..), newSession, + Compiled (..), + compiledSession, fixityNotesOf, formatSource, rewritten, @@ -30,6 +33,7 @@ import Data.Set qualified as Set import Data.Text (Text) import Data.Text qualified as T +import Data.Version (Version, versionBranch) import GHC.LanguageExtensions.Type (Extension (ImplicitPrelude)) import Tilia.Cabal.Package ( PackageProblem (..), @@ -37,6 +41,15 @@ describePackageProblem, newPackageReader, ) +import Tilia.Cabal.Plan + ( PlanComponent, + fetchUninstalled, + loadPlan, + macrosOf, + plannedCompiler, + readGivenPlan, + versionMacros, + ) import Tilia.Cabal.Project (ProjectRoot (..), findProjectRoot) import Tilia.Cpp ( CppError (..), @@ -48,7 +61,7 @@ withoutRuledOut, ) import Tilia.Cpp.Macros (Macros) -import Tilia.Doc (defaultRenderOptions, printDoc) +import Tilia.Doc (printDoc) import Tilia.Equivalence (commentDifference, syntaxDifference) import Tilia.Fixity ( OpName, @@ -59,26 +72,21 @@ unknownOperators, ) import Tilia.Fixity.Debug (FixityNotes, fixityNotes) +import Tilia.Fixity.HiFile (HiFile) import Tilia.Fixity.Plan - ( PlanComponent, - Resolver (..), + ( Resolver (..), Route (FromInterface, FromSource), - fetchUninstalled, - loadPlan, - macrosOf, + newResolverFrom, newResolverVia, - plannedCompiler, - readGivenPlan, scopeFor, ) import Tilia.Palette (Color (Operator, Place), Palette, paint) import Tilia.Parser ( ParseError, ParsedModule, - ParserConfig, + ParserConfig (..), describeParseError, parseModule, - parserConfigFor, pmGathered, pmModule, ) @@ -92,7 +100,7 @@ NoProject FilePath | -- | A project, but no build plan we could read or produce, and why. NoBuildPlan FilePath Text - | -- | We failed to read .cabal file. + | -- | The extensions in force in the file could not be settled, and why. NoPackage FilePath PackageProblem | -- | The file is not Haskell we can parse. NotParsed ParseError @@ -230,8 +238,8 @@ -- | Settle everything that does not depend on the file being formatted. newSession :: - -- | Where to start looking for the project. - FilePath -> + -- | The project. + ProjectRoot -> -- | Where the build plan comes from. PlanSource -> -- | Whether to read from and write to the cache. @@ -246,21 +254,21 @@ -- with 'fixityNotesOf'. Choice "debugFixity" -> IO (Either FormatError Session) -newSession start planSource caching downloading checkAst checkIdempotence debugFixity = runExceptT $ do - project <- need (NoProject start) =<< liftIO (findProjectRoot start) +newSession project planSource caching downloading checkAst checkIdempotence debugFixity = runExceptT $ do let root = prPath project - (plan, resolver) <- case planSource of + (plan, routes) <- case planSource of PlanFromCabal components -> do plan <- orElse (NoBuildPlan root) =<< liftIO (loadPlan caching downloading components root) - (,) plan <$> liftIO (newResolverVia caching [FromInterface, FromSource] plan) + pure (plan, [FromInterface, FromSource]) GivenPlan path -> do plan <- orElse (NoBuildPlan root) =<< liftIO (readGivenPlan root path) routes <- if isTrue downloading then [FromInterface, FromSource] <$ liftIO (fetchUninstalled caching root plan) else pure [FromInterface] - (,) plan <$> liftIO (newResolverVia caching routes plan) - askPackage <- liftIO (newPackageReader (plannedCompiler plan)) + pure (plan, routes) + packageReader <- liftIO (newPackageReader (plannedCompiler plan)) + resolver <- liftIO (newResolverVia caching routes packageReader plan) notes <- if isTrue debugFixity then Just <$> liftIO (newIORef Map.empty) @@ -270,14 +278,57 @@ { sessionRoot = project, sessionResolver = resolver, sessionMacros = macrosOf plan, - sessionPackage = askPackage, + sessionPackage = packageReader, sessionCheckAst = checkAst, sessionCheckIdempotence = checkIdempotence, sessionFixityNotes = notes } + +-- | What compiling a file's component establishes, which a session +-- otherwise works out with Cabal, the package database, and the sources of +-- dependencies. +data Compiled = Compiled + { -- | The extensions the component puts in force. + compiledExtensions :: [Extension], + -- | The version of the compiler. + compiledWith :: Version, + -- | The version of each package the component depends on, by name. + compiledPackages :: Map Text Version, + -- | The interface of a module the component can import, by name. + compiledInterface :: Text -> IO (Maybe HiFile) + } + +-- | Settle everything that does not depend on the file being formatted from +-- what compiling its component establishes. +compiledSession :: + -- | The file. + FilePath -> + -- | What compiling its component establishes. + Compiled -> + -- | Check AST equivalence. + Choice "checkAst" -> + -- | Check idempotence. + Choice "checkIdempotence" -> + IO (Either FormatError Session) +compiledSession file Compiled{..} checkAst checkIdempotence = runExceptT $ do + project <- + maybe (throwE (NoProject file)) pure =<< liftIO (findProjectRoot file) + resolver <- liftIO (newResolverFrom compiledInterface) + pure + Session + { sessionRoot = project, + sessionResolver = resolver, + sessionMacros = + versionMacros + (Just (numbers compiledWith)) + (fmap numbers compiledPackages), + sessionPackage = \_ -> pure (Right compiledExtensions), + sessionCheckAst = checkAst, + sessionCheckIdempotence = checkIdempotence, + sessionFixityNotes = Nothing + } where - need :: FormatError -> Maybe a -> ExceptT FormatError IO a - need e = maybe (throwE e) pure + numbers = fmap toInteger . versionBranch -- | What the run made of every file's operators, by file. -- @@ -303,7 +354,7 @@ throwE (PositionPragmas path) package <- orElse (NoPackage path) =<< liftIO (sessionPackage session path) let resolver = sessionResolver session - config = parserConfigFor package + config = ParserConfig package extensionsAndCpp text = let declared = effectiveExtensions package text in (Set.fromList declared, usesCpp declared text) @@ -344,7 +395,7 @@ maybe (orElse NotParsed (parseModule config path text)) pure already render <- renderConfigFor extensions (pure parsed) pure - ( printDoc defaultRenderOptions (renderModule render parsed), + ( printDoc (renderModule render parsed), Just parsed ) let inForce@(_, cpp) = extensionsAndCpp source diff --git a/src/Tilia/Imports.hs b/src/Tilia/Imports.hs --- a/src/Tilia/Imports.hs +++ b/src/Tilia/Imports.hs @@ -23,8 +23,8 @@ import GHC.Types.SourceText (StringLiteral (..)) import GHC.Types.SrcLoc import Tilia.Comments (Comment (..), commentTrailing, commentsWithin) -import Tilia.Span (endPoint, isSingleLine, startPoint) -import Tilia.Span.Ghc (bracketsSpan, spanOf, spanOfSrcSpan, tokenSpan) +import Tilia.Span (Span (..), endPoint, isSingleLine, startPoint) +import Tilia.Span.Ghc (bracketsSpan, spanOf, spanOfSrcSpan) -- | Sort and fold together a module's imports. normalizeImports :: @@ -49,7 +49,7 @@ (combineImports directives written) [((importIdentity implicitPrelude i, hiddenNames i, alone i), i) | i <- is] alone i - | any strands (spanOf i) = startLineOf i + | any strands (spanOf i) = lineOf i | otherwise = 0 where strands s = @@ -58,9 +58,6 @@ (filter loose (commentsWithin s written)) loose = not . commentTrailing unanchored starts c = not (any (> endPoint (commentSpan c)) starts) - startLineOf i = case srcSpanStart (getLocA i) of - RealSrcLoc l _ -> srcLocLine l - _ -> 0 -- | The names an import hides, where it hides any, so that only imports -- hiding the same names are folded together. @@ -111,10 +108,11 @@ groupBy ((==) `on` fst) [(between i, i) | i <- xs] & fmap (fmap snd) where between i = length (takeWhile (< lineOf i) barriers) - lineOf i = case srcSpanStart (getLocA i) of - RealSrcLoc l _ -> srcLocLine l - _ -> 0 +-- | The line an item begins on, or 0 for one without a place in the input. +lineOf :: GenLocated SrcSpanAnnA a -> Int +lineOf = maybe 0 spanStartLine . spanOf + -- | Sort by the keys, then replace each run of equal keys by one value -- folded out of it. foldRuns :: @@ -323,7 +321,7 @@ | onOneLine open close && not (onOneLine open' close') = (warning, (open', dots, comma, close')) | otherwise = (warning, (open, dots, comma, close)) - onOneLine open close = all isSingleLine (tokenSpan open <> tokenSpan close) + onOneLine open close = all isSingleLine (spanOf open <> spanOf close) -- | An entry with the names in its own brackets sorted and deduplicated. sortSubnames :: IE GhcPs -> IE GhcPs diff --git a/src/Tilia/Memo.hs b/src/Tilia/Memo.hs new file mode 100644 --- /dev/null +++ b/src/Tilia/Memo.hs @@ -0,0 +1,118 @@ +{-# LANGUAGE LambdaCase #-} + +-- | Tables of answers, each worked out once however many threads ask for it. +module Tilia.Memo + ( Memo, + newMemo, + Flights, + newFlights, + memoized, + ) +where + +import Control.Concurrent + ( MVar, + ThreadId, + modifyMVar, + modifyMVar_, + myThreadId, + newEmptyMVar, + newMVar, + readMVar, + tryPutMVar, + tryReadMVar, + ) +import Control.Exception (onException) +import Data.IORef (IORef, newIORef, readIORef, writeIORef) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Text (Text) +import Data.Unique (Unique, newUnique) + +-- | Answers filed under the names they are about, each worked out once. +data Memo v = Memo Unique (IORef (Map Text (MVar v))) + +-- | An empty 'Memo'. +newMemo :: IO (Memo v) +newMemo = Memo <$> newUnique <*> newIORef Map.empty + +-- | Which thread is working out which answer, and which answer each waiting +-- thread waits for, across all of a resolver's tables. +data Flights = Flights + { flightOwners :: Map (Unique, Text) ThreadId, + flightWaits :: Map ThreadId (Unique, Text) + } + +-- | Nobody working out anything, and nobody waiting. +newFlights :: IO (MVar Flights) +newFlights = newMVar (Flights Map.empty Map.empty) + +-- | Look an answer up in a table, working it out and filing it the first +-- time. +memoized :: + -- | Who is working out what. + MVar Flights -> + -- | Where the answers are filed. + Memo v -> + -- | The answer for a thread that cannot wait. + v -> + -- | What the answer is about. + Text -> + -- | Work that is being memoized. + IO v -> + IO v +memoized flights (Memo table answers) standIn key work = + Map.lookup key <$> readIORef answers >>= \case + Just slot -> tryReadMVar slot >>= maybe (waitFor slot) pure + Nothing -> do + me <- myThreadId + claimed <- modifyMVar flights $ \fl -> do + filed <- readIORef answers + case Map.lookup key filed of + Just slot -> pure (fl, Left slot) + Nothing -> do + slot <- newEmptyMVar + writeIORef answers (Map.insert key slot filed) + pure + ( fl{flightOwners = Map.insert (table, key) me (flightOwners fl)}, + Right slot + ) + case claimed of + Left slot -> waitFor slot + Right slot -> do + answer <- work `onException` file slot standIn + answer <$ file slot answer + where + file slot answer = modifyMVar_ flights $ \fl -> do + _ <- tryPutMVar slot answer + pure fl{flightOwners = Map.delete (table, key) (flightOwners fl)} + waitFor slot = do + me <- myThreadId + settled <- modifyMVar flights $ \fl -> + tryReadMVar slot >>= \case + Just answer -> pure (fl, Just answer) + Nothing + | waitedOnBy fl me (table, key) -> pure (fl, Just standIn) + | otherwise -> + pure + ( fl{flightWaits = Map.insert me (table, key) (flightWaits fl)}, + Nothing + ) + case settled of + Just answer -> pure answer + Nothing -> do + answer <- readMVar slot + modifyMVar_ flights $ \fl -> + pure fl{flightWaits = Map.delete me (flightWaits fl)} + pure answer + +-- | Is this answer being worked out by the given thread, or by one that +-- waits for it, directly or through others? +waitedOnBy :: Flights -> ThreadId -> (Unique, Text) -> Bool +waitedOnBy fl me = go + where + go key = case Map.lookup key (flightOwners fl) of + Nothing -> False + Just owner + | owner == me -> True + | otherwise -> maybe False go (Map.lookup owner (flightWaits fl)) diff --git a/src/Tilia/Palette.hs b/src/Tilia/Palette.hs --- a/src/Tilia/Palette.hs +++ b/src/Tilia/Palette.hs @@ -39,7 +39,7 @@ | -- | A line a change adds. New | -- | A line a change leaves alone. - Unchanged + Kept | -- | Something that went well. Good | -- | Something that did not, without being wrong. @@ -64,7 +64,7 @@ Meta -> "\ESC[36m" Gone -> "\ESC[31m" New -> "\ESC[32m" - Unchanged -> "\ESC[39m" + Kept -> "\ESC[39m" Good -> "\ESC[32m" Middling -> "\ESC[33m" Bad -> "\ESC[31m" diff --git a/src/Tilia/Parser.hs b/src/Tilia/Parser.hs --- a/src/Tilia/Parser.hs +++ b/src/Tilia/Parser.hs @@ -12,8 +12,6 @@ ParseError (..), describeParseError, ParserConfig (..), - defaultParserConfig, - parserConfigFor, ghcLibParserVersion, ) where @@ -22,6 +20,7 @@ import Data.IntMap.Strict (IntMap) import Data.IntMap.Strict qualified as IntMap import Data.List (isSuffixOf, nub, sortOn) +import Data.Maybe (listToMaybe, mapMaybe) import Data.Text (Text) import Data.Text qualified as T import Data.Text.Encoding qualified as T @@ -33,7 +32,6 @@ import GHC.Hs.Extension (GhcPs) import GHC.LanguageExtensions.Type (Extension) import GHC.Parser qualified as GHC -import GHC.Parser.Annotation (LEpaComment, getLocA) import GHC.Parser.Lexer qualified as GHC import GHC.Types.Error qualified as GHC import GHC.Types.SrcLoc qualified as GHC @@ -43,8 +41,8 @@ import Tilia.Gathered (Gathered (..), gathered) import Tilia.Pragma (effectiveExtensions) import Tilia.Source (Lines, Source, SourceType (..), Written (..), lineTexts, linesOf, sourceOf) -import Tilia.Span (Span (..)) -import Tilia.Span.Ghc (spanOfReal) +import Tilia.Span (Span (..), startPoint) +import Tilia.Span.Ghc (spanOf) -- | A parsed module, together with the comments found in it. data ParsedModule = ParsedModule @@ -185,12 +183,12 @@ -- | Lex every comment, in source order, and the line each quasi-quotation -- written over several lines ends on, by the line it begins on, from the -- state a parse starts in. -lexed :: GHC.PState -> ([LEpaComment], IntMap Int) +lexed :: GHC.PState -> ([(GHC.RealSrcSpan, GHC.Token)], IntMap Int) lexed s = case GHC.lexTokenStream (GHC.options s) (GHC.buffer s) loc of GHC.PFailed _ -> error "Tilia: a module that parses cannot fail to lex" GHC.POk _ tokens -> - ( [ GHC.commentToAnnotation (GHC.L l t) + ( [ (l, t) | GHC.L (GHC.RealSrcSpan l _) t <- tokens, isComment t ], @@ -292,18 +290,8 @@ -- | The start of the first thing that is not part of the header. headerEndOf :: HsModule GhcPs -> Maybe Span headerEndOf hsModule = - foldl' earliest Nothing $ - fmap getLocA (hsmodImports hsModule) - <> fmap getLocA (hsmodDecls hsModule) - where - earliest acc l = case GHC.srcSpanToRealSrcSpan l of - Nothing -> acc - Just s -> - let this = spanOfReal s - in Just (maybe this (keepEarlier this) acc) - keepEarlier a b - | (spanStartLine a, spanStartColumn a) <= (spanStartLine b, spanStartColumn b) = a - | otherwise = b + listToMaybe . sortOn startPoint $ + mapMaybe spanOf (hsmodImports hsModule) <> mapMaybe spanOf (hsmodDecls hsModule) -- | Why a module did not parse. data ParseError = ParseError @@ -323,24 +311,6 @@ { -- | Extensions to enable before parsing. pcExtensions :: [Extension] } - --- | What to parse with when there is no package to ask. -defaultParserConfig :: ParserConfig -defaultParserConfig = parserConfigFor [] - --- | What to parse with, given whatever the package had to say. -parserConfigFor :: - -- | What the package puts in force, or nothing if there is no package. - [Extension] -> - -- | The resulting parser config. - ParserConfig -parserConfigFor package = - ParserConfig - { pcExtensions = - if null package - then GHC.languageExtensions (Just GHC.GHC2021) - else package - } -- | What a file's name says it holds. sourceTypeOf :: FilePath -> SourceType diff --git a/src/Tilia/Pragma.hs b/src/Tilia/Pragma.hs --- a/src/Tilia/Pragma.hs +++ b/src/Tilia/Pragma.hs @@ -5,6 +5,9 @@ ( movesPositions, effectiveExtensions, lookupExtension, + lookupEdition, + applyExtensionName, + languageNames, ) where @@ -31,28 +34,33 @@ -- | The module's source, read here for its @LANGUAGE@ pragmas alone. Text -> [Extension] -effectiveExtensions package - | null package = pragmasOver onUnlessRefused - | otherwise = pragmasOver package - --- | The extensions that are on until something says otherwise. -onUnlessRefused :: [Extension] -onUnlessRefused = [ImplicitPrelude] - --- | Apply a module's @LANGUAGE@ pragmas to a starting set. -pragmasOver :: [Extension] -> Text -> [Extension] -pragmasOver initial = foldl' apply initial . concatMap pragmaNames . pragmaBodies +effectiveExtensions package = + foldl' applyExtensionName package . concatMap pragmaNames . pragmaBodies where - apply acc name = case T.stripPrefix "No" name >>= lookupExtension of - Just off -> filter (/= off) acc - Nothing -> case lookupExtension name of - Just on | on `notElem` acc -> acc <> [on] - _ -> acc pragmaNames body = let (keyword, names) = T.break (== ' ') body in if T.toUpper keyword == "LANGUAGE" - then filter (not . T.null) (fmap T.strip (T.splitOn "," names)) + then languageNames names else [] + +-- | Turn on the extension a name spells, or off where the name puts @No@ in +-- front of one, leaving the set as it is for a name that spells neither. +applyExtensionName :: [Extension] -> Text -> [Extension] +applyExtensionName acc name = + case T.stripPrefix "No" name >>= lookupExtension of + Just off -> filter (/= off) acc + Nothing -> case lookupExtension name of + Just on | on `notElem` acc -> acc <> [on] + _ -> acc + +-- | The extensions a @LANGUAGE@ pragma names, as written. +languageNames :: Text -> [Text] +languageNames = filter (not . T.null) . fmap T.strip . T.splitOn "," + +-- | Parse the name of an edition of the language, such as @GHC2021@. +lookupEdition :: Text -> Maybe GHC.Language +lookupEdition name = + lookup name [(T.pack (show e), e) | e <- [minBound .. maxBound]] -- | Parse an extension name. lookupExtension :: Text -> Maybe Extension diff --git a/src/Tilia/Render.hs b/src/Tilia/Render.hs --- a/src/Tilia/Render.hs +++ b/src/Tilia/Render.hs @@ -11,7 +11,7 @@ import Data.IntMap.Strict qualified as IntMap import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map -import Data.Maybe (isJust, listToMaybe) +import Data.Maybe (listToMaybe) import Data.Set (Set) import Data.Set qualified as Set import Data.Text (Text) @@ -38,7 +38,7 @@ import Tilia.Parser (ParsedModule (..)) import Tilia.Render.Context import Tilia.Render.Declaration (decls, declsKeepingGroups) -import Tilia.Render.Expression (hsCmd, hsExprIn, untypedSplice) +import Tilia.Render.Expression (hsExprIn, untypedSplice) import Tilia.Render.Haddock (haddockSpans) import Tilia.Render.Header (HeaderPragma (..), hsModule, takeHeaderPragmas, takeStackHeader) import Tilia.Render.Signature (sigDecl) @@ -109,6 +109,7 @@ (comments (pmSource parsed)) (hsmodImports m) } + carryingOn = carriedOnFrom loose ctx = Ctx { ctxExtensions = rcExtensions settings, @@ -118,8 +119,11 @@ ctxSource = pmSource parsed, ctxLineComments = indexOn (filter (not . closesItself) loose), ctxCarryingOn = - Set.fromList - (startPoint . commentSpan <$> filter (isJust . carriedOnFrom loose) loose), + Map.fromList + [ (startPoint (commentSpan c), remark) + | c <- loose, + Just (_, remark) <- [carryingOn c] + ], ctxHaddocks = indexOn haddocks, ctxKnot = knot } @@ -221,7 +225,6 @@ knot = Knot { knotExpr = hsExprIn, - knotCmd = hsCmd, knotSplice = untypedSplice, knotSig = sigDecl, knotDecls = decls, diff --git a/src/Tilia/Render/Body.hs b/src/Tilia/Render/Body.hs deleted file mode 100644 --- a/src/Tilia/Render/Body.hs +++ /dev/null @@ -1,85 +0,0 @@ -{-# LANGUAGE LambdaCase #-} - --- | Hanging vs non-hanging constructs. -module Tilia.Render.Body - ( ExprBody (..), - CmdBody (..), - CmdTopBody (..), - exprHangs, - operatorName, - cmdTopHangs, - ) -where - -import GHC.Hs -import GHC.Types.Name.Occurrence (occNameString) -import GHC.Types.Name.Reader (RdrName, rdrNameOcc) -import GHC.Types.SrcLoc (GenLocated (..), unLoc) -import Tilia.Doc.Body -import Tilia.Doc.Combinators -import Tilia.Render.Context -import Tilia.Span -import Tilia.Span.Ghc - --- | An expression standing as the body of an enclosing construct. -data ExprBody = ExprBody Ctx Site (LHsExpr GhcPs) - -instance Body ExprBody where - printBody (ExprBody ctx site e) = knotExpr (ctxKnot ctx) ctx site e - bodyPlacement (ExprBody _ _ e) = exprHangs (unLoc e) - --- | A command standing as the body of an enclosing construct. -data CmdBody = CmdBody Ctx Site (LHsCmd GhcPs) - -instance Body CmdBody where - printBody (CmdBody ctx site c) = knotCmd (ctxKnot ctx) ctx site c - bodyPlacement (CmdBody _ _ c) = cmdHangs (unLoc c) - --- | A command at the top of an arrow form. -data CmdTopBody = CmdTopBody Ctx Site (LHsCmdTop GhcPs) - -instance Body CmdTopBody where - printBody (CmdTopBody ctx site l) = - at ctx l (\(HsCmdTop _ cmd) -> knotCmd (ctxKnot ctx) ctx site cmd) - bodyPlacement (CmdTopBody _ _ l) = cmdTopHangs (unLoc l) - --- | Does this expression absorb the line break that introduces it? -exprHangs :: HsExpr GhcPs -> Placement -exprHangs = \case - HsDo _ (DoExpr _) _ -> Hanging - HsDo _ (MDoExpr _) _ -> Hanging - HsCase{} -> Hanging - HsLam _ lamVariant mg -> case lamVariant of - LamCase -> Hanging - LamCases -> Hanging - LamSingle -> case mg of - MG _ (L _ [L _ (Match _ _ (L _ ps@(_ : _)) _)]) - | maybe False isSingleLine (spansOf ps) -> Hanging - _ -> Normal - HsProc _ p _ - | maybe False isSingleLine (spanOf p) -> Hanging - | otherwise -> Normal - HsApp _ _ y -> exprHangs (unLoc y) - OpApp _ x op y - | Just n <- operatorName op, - occNameString (rdrNameOcc n) == "$" -> - exprHangs (unLoc y) - | otherwise -> exprHangs (unLoc x) - _ -> Normal - --- | Does this command absorb the line break that introduces it? -cmdHangs :: HsCmd GhcPs -> Placement -cmdHangs = \case - HsCmdDo{} -> Hanging - HsCmdCase{} -> Hanging - HsCmdLam{} -> Hanging - _ -> Normal - -cmdTopHangs :: HsCmdTop GhcPs -> Placement -cmdTopHangs (HsCmdTop _ c) = cmdHangs (unLoc c) - --- | The name of an operator, when the expression standing as one is a name. -operatorName :: LHsExpr GhcPs -> Maybe RdrName -operatorName e = case unLoc e of - HsVar _ (L _ n) -> Just n - _ -> Nothing diff --git a/src/Tilia/Render/Class.hs b/src/Tilia/Render/Class.hs --- a/src/Tilia/Render/Class.hs +++ b/src/Tilia/Render/Class.hs @@ -18,6 +18,7 @@ where import Data.Choice (fromBool, pattern Do) +import Data.Foldable (fold) import Data.Function (on) import Data.List (sortBy) import Data.Maybe (isNothing) @@ -54,13 +55,13 @@ txt "class" <> layoutFrom ctx wholeHeadSpan head' <> body where headSpan = spanOf tyCon <> spansOf hsq_explicit - whereSpan = tokenSpan (acd_where anns) + whereSpan = spanOf (acd_where anns) wholeHeadSpan = foldMap spanOf ctxt <> headSpan <> spansOf fdeps head' = breakOrSpace <> indent - ( foldMap (classContext ctx) ctxt + ( foldMap (leftContext ctx) ctxt <> layoutFrom ctx headSpan classHead <> indent (funDeps ctx fdeps) <> includeUnless @@ -102,12 +103,6 @@ isCTuple (Exact n) arity = isCTupleTyConName n && n == cTupleTyConName arity isCTuple _ _ = False --- | A context on a class head, with the @=>@ that follows it. -classContext :: Ctx -> LHsContext GhcPs -> Doc -classContext ctx ctxt - | null (unLoc ctxt) = mempty - | otherwise = context ctx ctxt <> joinedBy "=>" - -- | The functional dependencies of a class. funDeps :: Ctx -> [LHsFunDep GhcPs] -> Doc funDeps _ [] = mempty @@ -131,7 +126,7 @@ txt "instance" <> layoutFrom ctx headSpan head' <> body where headSpan = foldMap spanOf warning <> spanOf cid_poly_ty - whereSpan = tokenSpan (acid_where anns) + whereSpan = spanOf (acid_where anns) head' = foldMap (\w -> breakOrSpace <> at ctx w warningTxt) warning @@ -201,7 +196,7 @@ dataFamInstDecl ctx style (DataFamInstDecl FamEqn{..}) = dataDecl ctx - style + (fromBool (style == Free)) feqn_tycon feqn_pats typeArgSpan @@ -212,10 +207,7 @@ where -- @data instance forall k (a :: k). D a = …@ binds its variables ahead -- of the head, exactly as a type family instance does. - outerBinders = case feqn_bndrs of - HsOuterImplicit NoExtField -> mempty - HsOuterExplicit _ bndrs -> - forallBndrs ctx Invisible (tyVarBndr ctx) bndrs <> breakOrSpace + outerBinders = outerBndrs ctx breakOrSpace feqn_bndrs -- | A @data family@ or @type family@ declaration. famDecl :: Ctx -> FamilyStyle -> FamilyDecl GhcPs -> Doc @@ -249,12 +241,11 @@ (isNothing resultSig && isNothing fdInjectivityAnn) space <> indent - ( sequence_' resultSig + ( fold resultSig <> space <> foldMap (at_ ctx (injectivityAnn ctx)) fdInjectivityAnn ) - sequence_' = maybe mempty id resultSig = familyResultSig ctx fdResultSig equations = case closedEqns of @@ -290,12 +281,10 @@ tyFamInstEqn ctx FamEqn{..} = binders <> nest (if hasBinders then 1 else 0) (lhs <> rhs) where - (binders, hasBinders) = case feqn_bndrs of - HsOuterImplicit NoExtField -> (mempty, False) - HsOuterExplicit _ bndrs -> - ( forallBndrs ctx Invisible (tyVarBndr ctx) bndrs <> breakOrSpace, - not (null bndrs) - ) + binders = outerBndrs ctx breakOrSpace feqn_bndrs + hasBinders = case feqn_bndrs of + HsOuterExplicit _ (_ : _) -> True + _ -> False lhs = layoutFrom ctx (spanOf feqn_tycon <> foldMap typeArgSpan feqn_pats) $ diff --git a/src/Tilia/Render/Context.hs b/src/Tilia/Render/Context.hs --- a/src/Tilia/Render/Context.hs +++ b/src/Tilia/Render/Context.hs @@ -14,6 +14,7 @@ -- * Extensions extensionOn, + negativeLiteralGap, -- * Fixities operatorFixity, @@ -50,12 +51,12 @@ import Data.Text (Text) import Data.Text qualified as T import GHC.Hs hiding (Fixity) -import GHC.LanguageExtensions.Type (Extension) +import GHC.LanguageExtensions.Type (Extension (NegativeLiterals)) import GHC.Types.Name.Occurrence (occNameString) import GHC.Types.Name.Reader (RdrName (..), rdrNameOcc) import GHC.Types.SrcLoc (GenLocated (..)) import GHC.Types.SrcLoc qualified as GHC -import Tilia.Comments (Comment (..), CommentStyle (..), commentTrailing) +import Tilia.Comments (Comment (..), CommentStyle (..), carriesOn, commentTrailing) import Tilia.Doc.Combinators import Tilia.Fixity ( Fixity, @@ -93,8 +94,9 @@ ctxCaptured :: Map Span Fixity, -- | The comments that take whole lines, by starting position. ctxLineComments :: Map (Int, Int) Comment, - -- | Where each comment that carries on a trailing comment begins. - ctxCarryingOn :: Set (Int, Int), + -- | The column of the trailing comment each comment that carries one on + -- begins at, by where that comment begins. + ctxCarryingOn :: Map (Int, Int) Int, -- | The module as its author wrote it. ctxSource :: Source, -- | The author's own text for each Haddock, by starting position. @@ -105,10 +107,8 @@ -- | The backward edges of the rendering knot. data Knot = Knot - { -- | Expressions, needed by types, patterns and bodies. + { -- | Expressions, needed by patterns. knotExpr :: Ctx -> Site -> LHsExpr GhcPs -> Doc, - -- | Commands, needed by bodies. - knotCmd :: Ctx -> Site -> LHsCmd GhcPs -> Doc, -- | Splices, needed by types and patterns, defined with expressions. knotSplice :: Ctx -> SpliceDecoration -> HsUntypedSplice GhcPs -> Doc, -- | Signature declarations, needed by @let@ and @where@ bodies. @@ -174,6 +174,11 @@ extensionOn :: Ctx -> Extension -> Bool extensionOn ctx e = Set.member e (ctxExtensions ctx) +-- | With @NegativeLiterals@ on, @- 1@ and @-1@ are different, so the minus +-- in front of a literal has to keep its distance. +negativeLiteralGap :: Ctx -> Doc +negativeLiteralGap ctx = includeWhen (extensionOn ctx NegativeLiterals) space + ---------------------------------------------------------------------------- -- Fixities @@ -218,11 +223,10 @@ Map.dropWhileAntitone (< endPoint a) (ctxLineComments ctx) printedAfter c = commentTrailing c - || ( Set.member (startPoint s) (ctxCarryingOn ctx) - && spanStartColumn b < spanStartColumn s - ) - where - s = commentSpan c + || maybe + False + (\remark -> carriesOn remark (commentSpan c) (Just b)) + (Map.lookup (startPoint (commentSpan c)) (ctxCarryingOn ctx)) -- | Is a comment going to be printed between the two spans? commentPrintedBetween :: Ctx -> Maybe Span -> Maybe Span -> Bool diff --git a/src/Tilia/Render/Data.hs b/src/Tilia/Render/Data.hs --- a/src/Tilia/Render/Data.hs +++ b/src/Tilia/Render/Data.hs @@ -38,8 +38,9 @@ dataDecl :: -- | The context. Ctx -> - -- | The family style. - FamilyStyle -> + -- | Whether @instance@ follows the keyword, as it does in a family + -- instance that stands on its own. + Choice "instanceWord" -> -- | The type constructor. LocatedN RdrName -> -- | What it is applied to. @@ -55,18 +56,17 @@ Doc -> HsDataDefn GhcPs -> Doc -dataDecl ctx style tyCon tyVars tyVarSpan renderTyVar fixity outerBinders HsDataDefn{..} = - txt (keyword <> instanceWord) <> header <> constructors <> derivings +dataDecl ctx instanceWord tyCon tyVars tyVarSpan renderTyVar fixity outerBinders HsDataDefn{..} = + txt (keyword <> if isTrue instanceWord then " instance" else "") + <> header + <> constructors + <> derivings where keyword = case dd_cons of NewTypeCon _ -> "newtype" DataTypeCons False _ -> "data" DataTypeCons True _ -> "type data" - instanceWord = case style of - Associated -> "" - Free -> " instance" - headSpan = spanOf tyCon <> foldMap tyVarSpan tyVars wholeHeadSpan = headSpan @@ -195,11 +195,7 @@ <> indent (layoutFrom ctx sigSpan (brokenIfDocumented ctx documented signature)) signature = - outerBndrs ctx (unLoc con_outer_bndrs) - <> ( case unLoc con_outer_bndrs of - HsOuterImplicit{} -> mempty - HsOuterExplicit{} -> breakOrSpace - ) + outerBndrs ctx breakOrSpace (unLoc con_outer_bndrs) <> foldMap (\tele -> forallTelescope ctx tele <> breakOrSpace) con_inner_bndrs <> foldMap (\qs -> context ctx qs <> joinedBy "=>") @@ -310,13 +306,6 @@ PrefixCon xs -> spansOf (fmap cdf_type xs) RecCon l -> spanOf l InfixCon x y -> spansOf (fmap cdf_type [x, y]) - --- | A context standing to the left of a @=>@, with the arrow and the break --- after it. -leftContext :: Ctx -> LHsContext GhcPs -> Doc -leftContext ctx = \case - L _ [] -> mempty - ctxt -> context ctx ctxt <> joinedBy "=>" -- | One @deriving@ clause, with the strategy it was written with. derivingClause :: Ctx -> HsDerivingClause GhcPs -> Doc diff --git a/src/Tilia/Render/Declaration.hs b/src/Tilia/Render/Declaration.hs --- a/src/Tilia/Render/Declaration.hs +++ b/src/Tilia/Render/Declaration.hs @@ -1,5 +1,8 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} -- | Declarations: dispatching to the right printer, and grouping. @@ -9,6 +12,7 @@ ) where +import Data.Choice (pattern Don't) import Data.List (sort) import Data.List.NonEmpty (NonEmpty (..), (<|)) import Data.List.NonEmpty qualified as NE @@ -277,7 +281,7 @@ DataDecl{..} -> dataDecl ctx - Associated + (Don't #instanceWord) tcdLName (hsq_explicit tcdTyVars) spanOf diff --git a/src/Tilia/Render/Expression.hs b/src/Tilia/Render/Expression.hs --- a/src/Tilia/Render/Expression.hs +++ b/src/Tilia/Render/Expression.hs @@ -12,7 +12,6 @@ module Tilia.Render.Expression ( hsExpr, hsExprIn, - hsCmd, valDecl, untypedSplice, ) @@ -33,8 +32,8 @@ import GHC.LanguageExtensions.Type (Extension (..)) import GHC.Types.Basic (Boxity (..)) import GHC.Types.Fixity (LexicalFixity (..)) -import GHC.Types.Name.Occurrence (isVarOcc) -import GHC.Types.Name.Reader (RdrName, mkVarUnqual, rdrNameOcc) +import GHC.Types.Name.Occurrence (isVarOcc, occNameString) +import GHC.Types.Name.Reader (RdrName (..), mkVarUnqual, rdrNameOcc) import GHC.Types.SourceText import GHC.Types.SrcLoc ( GenLocated (..), @@ -50,7 +49,6 @@ ( Fixity, Namespace (..), ) -import Tilia.Render.Body import Tilia.Render.Context import Tilia.Render.Layout import Tilia.Render.Literal (stringLiteral) @@ -89,14 +87,26 @@ <> indent ( atSpan ctx - (tokenSpan at' <> spanOf (hswc_body a)) + (spanOf at' <> spanOf (hswc_body a)) (txt "@" <> hsTypeBody ctx (spanOf (hswc_body a)) (unLoc (hswc_body a))) ) OpApp _ x op y -> exprChain ctx site x op y - NegApp _ e _ -> txt "-" <> negationGap ctx e <> hsExpr ctx e + NegApp _ e _ -> + txt "-" + <> includeWhen (isLiteral e) (negativeLiteralGap ctx) + <> hsExpr ctx e HsPar _ e -> layoutWithin ctx here (spanOf e) $ - parensWith (closingFor site) (insideBrackets here (hsExpr ctx e)) + parensWith (closingFor site) (insideBrackets here (apart (hsExpr ctx e))) + where + apart d = case unLoc e of + SectionR _ (L _ (HsVar _ (L _ (Unqual o)))) _ + | unboxedParens, take 1 (occNameString o) == "#" -> space <> d + SectionL _ _ (L _ (HsVar _ (L _ (Unqual o)))) + | unboxedParens, occNameString o == "#" -> d <> space + _ -> d + unboxedParens = + extensionOn ctx UnboxedTuples || extensionOn ctx UnboxedSums SectionL _ x op -> hsExpr ctx x <> breakOrSpace <> indent (hsExpr ctx op) SectionR _ op x -> hsExpr ctx op <> breakOrSpace <> indent (hsExpr ctx x) ExplicitTuple _ args boxity -> tuple ctx here (closingFor site) boxity args @@ -210,16 +220,12 @@ bodyIn :: BodyOf body b -> Bracing -> LocatedA body -> b bodyIn mkBody bracing = mkBody (withBracing bracing plainSite) --- | @-@ in front of a literal needs a space when @NegativeLiterals@ is on, --- since @- 1@ and @-1@ then parse differently. -negationGap :: Ctx -> LHsExpr GhcPs -> Doc -negationGap ctx e = - includeWhen (extensionOn ctx NegativeLiterals && isLiteral) space - where - isLiteral = case unLoc e of - HsLit{} -> True - HsOverLit{} -> True - _ -> False +-- | Is this expression a literal? +isLiteral :: LHsExpr GhcPs -> Bool +isLiteral e = case unLoc e of + HsLit{} -> True + HsOverLit{} -> True + _ -> False -- | A function applied to arguments. application :: Ctx -> Site -> LHsExpr GhcPs -> LHsExpr GhcPs -> Doc @@ -263,9 +269,7 @@ | any isMissing args = flat (brackets' (sepBy comma (fmap arg args))) | otherwise = brackets' (insideBrackets here (commaSep (fmap arg args))) where - brackets' = case boxity of - Boxed -> parensWith closing - Unboxed -> unboxedWith closing + brackets' = boxityBrackets boxity closing isMissing = \case Missing _ -> True _ -> False @@ -304,7 +308,7 @@ <> includeUnless hfbPun ( space - <> maybe id located (tokenSpan =<< hfbAnn) (txt "=") + <> keywordAt ctx (spanOf =<< hfbAnn) "=" <> attach placement (hsExpr ctx hfbRHS) ) where @@ -351,7 +355,7 @@ renderExprChain :: Ctx -> Site -> OpChain (LHsExpr GhcPs) (LHsExpr GhcPs) -> Doc renderExprChain ctx site = \case Operand e -> hsExprIn ctx site e - chain@(Chain operands@(firstOne :| rest) operators) -> + chain@(Chain operands@(firstOne :| _) operators) -> layoutFrom ctx (chainSpan spanOf chain) $ if trailing then laidOut MayBrace @@ -364,13 +368,11 @@ chainPlacement exprHangs (chainSpan spanOf firstOne) (NE.last operands) laidOut bracing = renderExprChain ctx (withBracing bracing site) firstOne - <> pieces bracing firstOne operators rest - pieces bracing previous (o : os) (operand : more) = - let isLast = null more - operandSite = + <> foldr (piece bracing) mempty (links operands operators) + piece bracing (previous, o, operand, isLast) rest' = + let operandSite = withBracing (if isLast then siteBracing site else bracing) plainSite rendered = renderExprChain ctx operandSite operand - rest' = pieces bracing operand os more in if trailing then space @@ -387,7 +389,6 @@ (hsExpr ctx o) rendered <> rest' - pieces _ _ _ _ = mempty tailPlacement isLast before o operand | isLast, not (maybe True isSingleLine (chainSpan spanOf operand)), @@ -467,7 +468,7 @@ BodyStmt _ body _ _ -> printBody (mkBody site body) BindStmt arrow p f -> hsPatClosing ctx (closingFor site) p - <> nest 1 (space <> maybe id located (uniTokenSpan arrow) (txt "<-")) + <> nest 1 (space <> keywordAt ctx (spanOf arrow) "<-") <> layoutFrom ctx (fmap endOf (spanOf p) <> spanOf f) @@ -537,14 +538,12 @@ items (siteBracing site) $ keepBlanks (separatedByBlank ctx) - [(spanOf stmt, item place stmt) | (place, stmt) <- places xs] - item place stmt = case place of - Last -> rendered (siteBracing site) - Only -> rendered (siteBracing site) - _ -> mayBraceWhenFlat (siteBracing site) rendered - where - rendered bracing = - at_ ctx (stmtBody ctx (blockSite bracing) mkBody) stmt + [ (spanOf stmt, item position stmt) + | (position, stmt) <- positioned xs + ] + item position stmt = + blockItem position (siteBracing site) $ \bracing -> + at_ ctx (stmtBody ctx (blockSite bracing) mkBody) stmt blockSite bracing = plainSite{siteInBlock = True, siteBracing = bracing} @@ -595,11 +594,11 @@ MatchGroup GhcPs (LocatedA body) -> Doc caseOf ctx site mkBody EpAnnHsCase{..} scrutinee mg = - maybe id located (tokenSpan hsCaseAnnCase) (txt "case") + keywordAt ctx (spanOf hsCaseAnnCase) "case" <> space <> hsExpr ctx scrutinee <> space - <> indent (maybe id located (tokenSpan hsCaseAnnOf) (txt "of")) + <> indent (keywordAt ctx (spanOf hsCaseAnnOf) "of") <> breakOrSpace <> bracedForSite site alternatives where @@ -675,17 +674,17 @@ Doc letIn ctx bodyOf nested (letToken, inToken) binds body = align $ - written (tokenSpan letToken) (txt "let") + written (spanOf letToken) (txt "let") <> space <> align ( localBinds ctx NoBrace binds - <> foldMap (emptyAnchor . startOf) (tokenSpan inToken) + <> foldMap (emptyAnchor . startOf) (spanOf inToken) ) - <> written (tokenSpan inToken) (separator <> txt "in") + <> written (spanOf inToken) (separator <> txt "in") <> (if chained then breakOrSpace else space) <> align (printBody (bodyOf body)) where - chained = nested && not (sameLine (tokenSpan inToken) (spanOf body)) + chained = nested && not (sameLine (spanOf inToken) (spanOf body)) separator = if chained then space else variant space (hardBreak <> txt " ") written s d = if chained then fenceWithin ctx s d else d @@ -696,19 +695,17 @@ anchored ann . align . items bracing $ keepBlanks (separatedByBlank ctx) - [(spanOf item, rendered place item) | (place, item) <- places sorted] + [ (spanOf item, rendered position item) + | (position, item) <- positioned sorted + ] where sorted = sortBy (leftmost_smallest `on` getLocA) (fmap (fmap Left) binds <> fmap (fmap Right) sigs) - rendered place item = case place of - Last -> render NoBrace - Only -> render NoBrace - _ -> mayBraceWhenFlat NoBrace render - where - render b = - at_ ctx (either (valDecl ctx b) (knotSig (ctxKnot ctx) ctx)) item + rendered position item = + blockItem position NoBrace $ \b -> + at_ ctx (either (valDecl ctx b) (knotSig (ctxKnot ctx) ctx)) item HsValBinds _ _ -> error "Tilia: renamer-only local bindings" HsIPBinds ann (IPBinds _ xs) -> anchored ann (items bracing (fmap (at_ ctx implicitBind) xs)) @@ -821,7 +818,7 @@ _ -> Nothing render = \case Operand c -> at ctx c (cmdTop ctx site) - chain@(Chain operands@(firstOne :| rest) operators) -> + chain@(Chain operands@(firstOne :| _) operators) -> layoutFrom ctx (chainSpan spanOf chain) $ mayBraceWhenFlat (if placement == Hanging then MayBrace else NoBrace) laidOut where @@ -831,23 +828,16 @@ (chainSpan spanOf firstOne) (NE.last operands) laidOut bracing = - renderIn bracing firstOne <> pieces bracing firstOne operators rest - pieces bracing previous (o : os) (operand : more) = + renderIn bracing firstOne + <> foldMap (piece bracing) (links operands operators) + piece bracing (previous, o, operand, isLast) = attachOperator placement (chainSpan spanOf previous) (spanOf o) (chainSpan spanOf operand) (hsExpr ctx o) - ( renderIn - ( if null more - then siteBracing site - else bracing - ) - operand - ) - <> pieces bracing operand os more - pieces _ _ _ _ = mempty + (renderIn (if isLast then siteBracing site else bracing) operand) renderIn bracing = \case Operand c -> at ctx c (cmdTop ctx (withBracing bracing site)) inner -> render inner @@ -897,19 +887,15 @@ Doc matchGroup ctx bracing mkBody style MG{..} | isCaseStyle style, null (unLoc mg_alts) = txt "{}" - | otherwise = items blockBracing (fmap rendered (places (unLoc mg_alts))) + | otherwise = items blockBracing (fmap rendered (positioned (unLoc mg_alts))) where blockBracing = case style of CaseStyle -> ifEmpty LambdaCaseStyle -> ifEmpty _ -> NoBrace ifEmpty = if null (unLoc mg_alts) then MayBrace else bracing - rendered (place, m) = case place of - Last -> written bracing - Only -> written bracing - _ -> mayBraceWhenFlat bracing written - where - written b = at_ ctx (renderMatch b) m + rendered (position, m) = + blockItem position bracing (\b -> at_ ctx (renderMatch b) m) renderMatch b m@Match{..} = match ctx @@ -1100,7 +1086,7 @@ [] -> atSpan ctx (grhsSpan grhs) (printBody bound) _ -> maybe id located (spanOf lgrhs) . layoutFrom ctx (grhsSpan grhs) $ - maybe id fence headSpan guardHead + fenceWithin ctx headSpan guardHead <> nest (if parentPlacement == Normal then 1 else 0) (attach placement (printBody bound)) @@ -1112,7 +1098,7 @@ <> align (commaSep (fmap (align . hsStmt ctx) guards)) <> space <> indent (txt separator) - headSpan = (<>) <$> (tokenSpan =<< ga_vbar) <*> separatorSpan + headSpan = (<>) <$> (spanOf =<< ga_vbar) <*> separatorSpan bound = bodyIn mkBody bracing body separator = case style of EqualsSign -> "=" @@ -1123,7 +1109,7 @@ not (remarkBefore && remarkAfter) = bodyPlacement bound | otherwise = Normal - separatorSpan = either annSpan annSpan ga_sep + separatorSpan = either spanOf spanOf ga_sep remarkBefore = lineCommentWrittenBetween ctx (spansOf guards) separatorSpan remarkAfter = lineCommentWrittenBetween ctx separatorSpan (nextLine <$> separatorSpan) @@ -1196,7 +1182,7 @@ txt "[" <> name ctx quoter <> txt "|" - <> at ctx str (verbatim . T.pack . unpackFS) + <> verbatim (T.pack (unpackFS (unLoc str))) <> txt "|]" -- | A Template Haskell splice, typed or not. @@ -1242,6 +1228,14 @@ ClosedTypeFamily Nothing -> True _ -> False +-- | An item of a block: the last one keeps the block's bracing, and any +-- other may brace itself when the block is flat. +blockItem :: Position -> Bracing -> (Bracing -> Doc) -> Doc +blockItem position bracing render = case position of + Last -> render bracing + Only -> render bracing + _ -> mayBraceWhenFlat bracing render + -- | Let a block brace itself when the surrounding layout is flat. mayBraceWhenFlat :: Bracing -> (Bracing -> Doc) -> Doc mayBraceWhenFlat whenBroken render = @@ -1255,3 +1249,68 @@ | siteInBlock site && not (siteApplicand site) = mayBraceWhenFlat (siteBracing site) render | otherwise = render (siteBracing site) + +---------------------------------------------------------------------------- +-- Bodies + +-- | An expression standing as the body of an enclosing construct. +data ExprBody = ExprBody Ctx Site (LHsExpr GhcPs) + +instance Body ExprBody where + printBody (ExprBody ctx site e) = hsExprIn ctx site e + bodyPlacement (ExprBody _ _ e) = exprHangs (unLoc e) + +-- | A command standing as the body of an enclosing construct. +data CmdBody = CmdBody Ctx Site (LHsCmd GhcPs) + +instance Body CmdBody where + printBody (CmdBody ctx site c) = hsCmd ctx site c + bodyPlacement (CmdBody _ _ c) = cmdHangs (unLoc c) + +-- | A command at the top of an arrow form. +data CmdTopBody = CmdTopBody Ctx Site (LHsCmdTop GhcPs) + +instance Body CmdTopBody where + printBody (CmdTopBody ctx site l) = at ctx l (cmdTop ctx site) + bodyPlacement (CmdTopBody _ _ l) = cmdTopHangs (unLoc l) + +-- | Does this expression absorb the line break that introduces it? +exprHangs :: HsExpr GhcPs -> Placement +exprHangs = \case + HsDo _ (DoExpr _) _ -> Hanging + HsDo _ (MDoExpr _) _ -> Hanging + HsCase{} -> Hanging + HsLam _ lamVariant mg -> case lamVariant of + LamCase -> Hanging + LamCases -> Hanging + LamSingle -> case mg of + MG _ (L _ [L _ (Match _ _ (L _ ps@(_ : _)) _)]) + | maybe False isSingleLine (spansOf ps) -> Hanging + _ -> Normal + HsProc _ p _ + | maybe False isSingleLine (spanOf p) -> Hanging + | otherwise -> Normal + HsApp _ _ y -> exprHangs (unLoc y) + OpApp _ x op y + | Just n <- operatorName op, + occNameString (rdrNameOcc n) == "$" -> + exprHangs (unLoc y) + | otherwise -> exprHangs (unLoc x) + _ -> Normal + +-- | Does this command absorb the line break that introduces it? +cmdHangs :: HsCmd GhcPs -> Placement +cmdHangs = \case + HsCmdDo{} -> Hanging + HsCmdCase{} -> Hanging + HsCmdLam{} -> Hanging + _ -> Normal + +cmdTopHangs :: HsCmdTop GhcPs -> Placement +cmdTopHangs (HsCmdTop _ c) = cmdHangs (unLoc c) + +-- | The name of an operator, when the expression standing as one is a name. +operatorName :: LHsExpr GhcPs -> Maybe RdrName +operatorName e = case unLoc e of + HsVar _ (L _ n) -> Just n + _ -> Nothing diff --git a/src/Tilia/Render/Haddock.hs b/src/Tilia/Render/Haddock.hs --- a/src/Tilia/Render/Haddock.hs +++ b/src/Tilia/Render/Haddock.hs @@ -14,7 +14,6 @@ ) where -import Control.Applicative ((<|>)) import Data.Char (isSpace) import Data.Data (Data) import Data.Generics.Schemes (listify) @@ -26,6 +25,7 @@ import Data.Text qualified as T import GHC.Hs import GHC.Types.SrcLoc (GenLocated (..), getLoc, unLoc) +import Tilia.Comments (afterOpener, triggerOn) import Tilia.Doc.Combinators import Tilia.Gathered (Gathered (..)) import Tilia.Render.Context @@ -88,7 +88,7 @@ | blockForm -> (writtenAt rebuiltBlock, False) | otherwise -> (writtenAt rebuilt, False) where - writtenAt = maybe id fence (spanOfSrcSpan l) + writtenAt = fenceWithin ctx (spanOfSrcSpan l) emptyBlock = txt (blockOpener style) <> space <> txt "-}" rebuilt = sepBy hardBreak (zipWith line' (True : repeat False) written') @@ -134,9 +134,6 @@ maybe False isBlockForm (writtenHaddock ctx (spanOfSrcSpan (getLoc doc))) -- | The anchor of a named documentation chunk. --- --- Unlike a Haddock this carries no text of its own, so there is nothing to --- reuse and nothing to report a position for. docSectionName :: String -> Text docSectionName n = "-- $" <> T.pack n @@ -171,24 +168,6 @@ Caret -> "^" Section n -> T.replicate n "*" Chunk n -> "$" <> T.pack n - --- | What follows the @--@ or @{-@ that opens a comment, with the spaces --- after it removed. -afterOpener :: Text -> Maybe Text -afterOpener firstLine = T.stripStart <$> opened (T.stripStart firstLine) - where - opened t = T.stripPrefix "--" t <|> T.stripPrefix "{-" t - --- | The trigger an opened comment carries, for the triggers that are a run --- of one character. -triggerOn :: Text -> Maybe Text -triggerOn inside = do - (c, rest) <- T.uncons inside - case c of - '|' -> Just "|" - '^' -> Just "^" - '*' -> Just (T.cons c (T.takeWhile (== '*') rest)) - _ -> Nothing -- | Was the reused text a block comment? isBlockForm :: NonEmpty Text -> Bool diff --git a/src/Tilia/Render/Header.hs b/src/Tilia/Render/Header.hs --- a/src/Tilia/Render/Header.hs +++ b/src/Tilia/Render/Header.hs @@ -15,16 +15,17 @@ import Data.Function (on) import Data.List (sortOn) import Data.List.NonEmpty qualified as NE +import Data.Maybe (isJust) import Data.Set qualified as Set import Data.Text (Text) import Data.Text qualified as T -import GHC.Driver.Flags (Language) import GHC.Hs import GHC.LanguageExtensions.Type (Extension (..)) import GHC.Types.PkgQual (RawPkgQual (..)) import GHC.Types.SrcLoc (GenLocated (..), unLoc) import Tilia.Comments (Comment (..), Pragma (..), commentPragma) import Tilia.Doc.Combinators +import Tilia.Pragma (languageNames, lookupEdition) import Tilia.Render.Context import Tilia.Render.Declaration (decls) import Tilia.Render.Haddock @@ -41,8 +42,6 @@ hpSpan :: Span, -- | How many preprocessor directives the header has above it. hpRun :: Int, - -- | Where it sorts. - hpOrder :: PragmaOrder, -- | @LANGUAGE@, @OPTIONS_GHC@ or @OPTIONS_HADDOCK@. hpName :: Text, -- | One extension, or the whole of an options string. @@ -108,23 +107,23 @@ HeaderPragma { hpSpan = commentSpan c, hpRun = directivesAbove (spanStartLine (commentSpan c)), - hpOrder = orderOf p, hpName = pragmaName p, hpBody = pragmaBody p } headerPragma c = do p <- commentPragma c - _ <- lookupOrder (pragmaName p) + _ <- pragmaOrder (pragmaName p) (pragmaBody p) if inHeader headerEnd (commentSpan c) then Just p else Nothing - orderOf p = case pragmaName p of - "LANGUAGE" -> LanguageOrder (classifyExtension (pragmaBody p)) - other -> maybe OptionsGhcOrder id (lookupOrder other) - lookupOrder = \case - "LANGUAGE" -> Just (LanguageOrder Enabling) - "OPTIONS_GHC" -> Just OptionsGhcOrder - "OPTIONS_HADDOCK" -> Just OptionsHaddockOrder - _ -> Nothing +-- | Where a pragma sorts, given its name and its body, or 'Nothing' for one +-- the header does not hoist. +pragmaOrder :: Text -> Text -> Maybe PragmaOrder +pragmaOrder named body = case named of + "LANGUAGE" -> Just (LanguageOrder (classifyExtension body)) + "OPTIONS_GHC" -> Just OptionsGhcOrder + "OPTIONS_HADDOCK" -> Just OptionsHaddockOrder + _ -> Nothing + -- | Was this written above everything the compiler reads as code? inHeader :: Maybe Span -> Span -> Bool inHeader headerEnd s = case headerEnd of @@ -153,14 +152,15 @@ pragmaBlock :: [HeaderPragma] -> Doc pragmaBlock = foldMap render . dedupe . sortOn order . concatMap split where - order p = (hpRun p, hpOrder p, extension p) + order p = (hpRun p, orderOf p, extension p) extension p = if hpName p == "LANGUAGE" then hpBody p else "" - key p = (hpRun p, hpOrder p, hpBody p) + key p = (hpRun p, orderOf p, hpBody p) + orderOf p = pragmaOrder (hpName p) (hpBody p) dedupe = fmap NE.head . NE.groupBy ((==) `on` key) split p | hpName p == "LANGUAGE" = - [ p{hpBody = body, hpOrder = LanguageOrder (classifyExtension body)} - | body <- fmap T.strip (T.splitOn "," (hpBody p)) + [ p{hpBody = body} + | body <- languageNames (hpBody p) ] | otherwise = [p] @@ -185,9 +185,7 @@ -- | Does this name a whole edition of the language rather than one -- extension of it? namesAnEdition :: Text -> Bool -namesAnEdition t = any spelledTheSame [minBound .. maxBound] - where - spelledTheSame edition = t == T.pack (show (edition :: Language)) +namesAnEdition = isJust . lookupEdition -- | A whole module. hsModule :: @@ -235,8 +233,8 @@ ( breakOrSpace <> foldMap warning hsmodDeprecMessage <> foldMap exports' hsmodExports - <> txt "where" ) + <> keywordAt ctx (spanOf (am_where (anns hsmodAnn))) "where" <> hardBreak documentation = foldMap (haddock ctx Pipe Closed) hsmodHaddockModHeader warning w = at ctx w warningTxt <> breakOrSpace @@ -258,12 +256,16 @@ importExportItems ctx xs = variant (laidOut False) (laidOut True) where laidOut broken' = - sepBy breakOrSpace (zipWith (item broken') (Nothing : fmap Just xs) (places xs)) - item broken' previous (place, x) = - gapAbove place (unLoc <$> previous) (unLoc x) - <> align (at ctx (widenToDoc x) (ieItem ctx (spanOf x) (comma' broken' place))) - gapAbove place previous here - | place == First || place == Only = mempty + sepBy + breakOrSpace + (zipWith (item broken') (Nothing : fmap Just xs) (positioned xs)) + item broken' previous (position, x) = + gapAbove position (unLoc <$> previous) (unLoc x) + <> align (at ctx (widenToDoc x) (ieItem ctx (spanOf x) withComma)) + where + withComma = comma' broken' position + gapAbove position previous here + | position == First || position == Only = mempty | isSection here = hardBreak | isPipe here, maybe False runsOn previous = hardBreak | otherwise = mempty @@ -277,9 +279,9 @@ IEDoc{} -> True IEDocNamed{} -> True _ -> False - comma' broken' place + comma' broken' position | broken' = True - | otherwise = place == First || place == Middle + | otherwise = position == First || position == Middle -- | Widen an item's span to take in the documentation printed with it, so -- that a documented item is laid out as one thing. @@ -291,31 +293,25 @@ -- | One item of an import or export list. ieItem :: Ctx -> Maybe Span -> Bool -> IE GhcPs -> Doc ieItem ctx here withComma = \case - IEVar warning n doc -> - exportWarning warning - <> at ctx n (wrappedName ctx) - <> comma' - <> itemDocumentation doc - IEThingAbs warning n doc -> - exportWarning warning - <> at ctx n (wrappedName ctx) - <> comma' - <> itemDocumentation doc - IEThingAll (warning, _) n doc -> + IEVar warning n doc -> plain warning n doc + IEThingAbs warning n doc -> plain warning n doc + IEThingAll (warning, (_, dots, _)) n doc -> exportWarning warning <> at ctx n (wrappedName ctx) <> space - <> txt "(..)" + <> txt "(" + <> keywordAt ctx (spanOf dots) ".." + <> txt ")" <> comma' <> itemDocumentation doc - IEThingWith (warning, (open, _, _, close)) n wildcard members doc -> + IEThingWith (warning, (open, dots, _, close)) n wildcard members doc -> align ( exportWarning warning <> at ctx n (wrappedName ctx) <> layoutWithin ctx here - (tokenSpan open <> tokenSpan close <|> here) + (spanOf open <> spanOf close <|> here) ( breakOrSpace <> indent (parens (insideBrackets here (commaSep (align <$> withWildcard)))) ) @@ -328,7 +324,7 @@ NoIEWildcard -> rendered IEWildcard n' -> let (before, after) = splitAt n' rendered - in before <> [txt ".."] <> after + in before <> [keywordAt ctx (spanOf dots) ".."] <> after IEModuleContents (warning, _) m -> exportWarning warning <> at ctx m (moduleHeadName ctx) <> comma' IEGroup NoExtField n str -> haddock ctx (Section n) Open str @@ -337,6 +333,11 @@ Just written -> sepBy (verbatimBreak AtIndent TrimWhitespace) (fmap txt (NE.toList written)) Nothing -> txt (docSectionName n) where + plain warning n doc = + exportWarning warning + <> at ctx n (wrappedName ctx) + <> comma' + <> itemDocumentation doc comma' = includeWhen withComma comma exportWarning = foldMap (\w -> at ctx w warningTxt <> breakOrSpace) @@ -364,12 +365,12 @@ -- and its import list, each a node of its own past the keyword's column. importDecl :: Ctx -> ImportDecl GhcPs -> Doc importDecl ctx ImportDecl{..} = - keywordAt ctx (tokenSpan (importDeclAnnImport annotation)) "import" + keywordAt ctx (spanOf (importDeclAnnImport annotation)) "import" <> indent ( space <> includeWhen (ideclSource == IsBoot) (txt "{-# SOURCE #-}") <> space - <> includeWhen ideclSafe (keywordAt ctx (tokenSpan =<< importDeclAnnSafe annotation) "safe") + <> includeWhen ideclSafe (keywordAt ctx (spanOf =<< importDeclAnnSafe annotation) "safe") <> space <> levelBefore <> space @@ -386,7 +387,7 @@ ( \a -> indent ( space - <> keywordAt ctx (tokenSpan =<< importDeclAnnAs annotation) "as" + <> keywordAt ctx (spanOf =<< importDeclAnnAs annotation) "as" <> space <> at ctx a outputable ) @@ -395,7 +396,7 @@ <> foldMap (indent . (space <>)) importList where annotation = anns (ideclAnn ideclExt) - qualified = keywordAt ctx (tokenSpan =<< importDeclAnnQualified annotation) "qualified" + qualified = keywordAt ctx (spanOf =<< importDeclAnnQualified annotation) "qualified" qualifiedLast = extensionOn ctx ImportQualifiedPost isQualified = isImportDeclQualified ideclQualified packageQualifier = case ideclPkgQual of @@ -410,7 +411,7 @@ importList = flip fmap ideclImportList $ \(interpretation, L listLoc xs) -> let hidden = case interpretation of Exactly -> mempty - EverythingBut -> keywordAt ctx (tokenSpan (fst (al_rest (anns listLoc)))) "hiding" + EverythingBut -> keywordAt ctx (spanOf (fst (al_rest (anns listLoc)))) "hiding" listSpan = spanOfSrcSpan (locA listLoc) parensSpan = bracketsSpan (al_brackets (anns listLoc)) <|> listSpan in layoutWithin ctx listSpan parensSpan $ diff --git a/src/Tilia/Render/Layout.hs b/src/Tilia/Render/Layout.hs --- a/src/Tilia/Render/Layout.hs +++ b/src/Tilia/Render/Layout.hs @@ -9,8 +9,8 @@ items, itemsSepBy, keepBlanks, - Place (..), - places, + Position (..), + positioned, ) where @@ -59,7 +59,7 @@ gap previous (here, d) = includeWhen (blank previous here) hardBreak <> d -- | Where an item sits among its siblings. -data Place +data Position = Only | First | Middle @@ -67,10 +67,10 @@ deriving (Eq, Show) -- | Label each item of a list with its position. -places :: [a] -> [(Place, a)] -places [] = [] -places [x] = [(Only, x)] -places (x : xs) = (First, x) : go xs +positioned :: [a] -> [(Position, a)] +positioned [] = [] +positioned [x] = [(Only, x)] +positioned (x : xs) = (First, x) : go xs where go [] = [] go [y] = [(Last, y)] diff --git a/src/Tilia/Render/Literal.hs b/src/Tilia/Render/Literal.hs --- a/src/Tilia/Render/Literal.hs +++ b/src/Tilia/Render/Literal.hs @@ -18,7 +18,7 @@ import GHC.Data.FastString (FastString, unpackFS) import GHC.Parser.CharClass (is_space) import Tilia.Doc.Combinators -import Tilia.Render.Layout (Place (..), places) +import Tilia.Render.Layout (Position (..), positioned) -- | A string literal, from the text the author wrote. stringLiteral :: FastString -> Doc @@ -39,8 +39,8 @@ (fmap txt (litParts literal)) onOneLine = txt (joinParts (litParts literal)) acrossLines = - sepBy breakOrSpace (fmap continued (places (litParts literal))) - continued (place, s) = case place of + sepBy breakOrSpace (fmap continued (positioned (litParts literal))) + continued (position, s) = case position of Only -> txt s First -> txt s <> txt "\\" Middle -> txt "\\" <> txt s <> txt "\\" diff --git a/src/Tilia/Render/Name.hs b/src/Tilia/Render/Name.hs --- a/src/Tilia/Render/Name.hs +++ b/src/Tilia/Render/Name.hs @@ -78,10 +78,10 @@ NameBackquotes{} -> backticks . itsOwn nann_name _ -> itsOwn nann_name _ -> id - itsOwn = atSpan ctx . annSpan + itsOwn = atSpan ctx . spanOf inParens d = txt "(" <> d <> txt ")" spaceOutHash d - | extensionOn ctx UnboxedSums, + | extensionOn ctx UnboxedTuples || extensionOn ctx UnboxedSums, Unqual (occNameString -> '#' : _) <- x = space <> d <> space | otherwise = d diff --git a/src/Tilia/Render/Operator.hs b/src/Tilia/Render/Operator.hs --- a/src/Tilia/Render/Operator.hs +++ b/src/Tilia/Render/Operator.hs @@ -7,11 +7,13 @@ flattenAround, associate, chainSpan, + links, lastOperand, isSeparator, ) where +import Data.List (tails, zip4) import Data.List.NonEmpty (NonEmpty (..)) import Data.List.NonEmpty qualified as NE import Data.Maybe (isNothing, mapMaybe) @@ -115,14 +117,17 @@ in (NE.cons (NE.reverse current, reverse currentOps) groups, op : splitters) | otherwise = go (NE.cons y current) (op : currentOps) rest +-- | Each operator of a chain level with the operands either side of it, +-- and whether the one after it is the last. +links :: NonEmpty (OpChain a op) -> [op] -> [(OpChain a op, op, OpChain a op, Bool)] +links (firstOne :| rest) operators = + zip4 (firstOne : rest) operators rest (fmap null (drop 1 (tails rest))) + -- | The region of the input a chain came from. chainSpan :: (a -> Maybe Span) -> OpChain a op -> Maybe Span chainSpan spanOfOperand = \case Operand x -> spanOfOperand x - Chain xs _ -> foldr1 join' (chainSpan spanOfOperand <$> xs) - where - join' (Just a) (Just b) = Just (a <> b) - join' a b = maybe b Just a + Chain xs _ -> foldMap (chainSpan spanOfOperand) xs -- | The rightmost operand of a chain. lastOperand :: OpChain a op -> a diff --git a/src/Tilia/Render/Pattern.hs b/src/Tilia/Render/Pattern.hs --- a/src/Tilia/Render/Pattern.hs +++ b/src/Tilia/Render/Pattern.hs @@ -12,6 +12,7 @@ hsPatClosing, fieldOcc, unboxedSum, + boxityBrackets, ) where @@ -19,7 +20,6 @@ import Data.List.NonEmpty qualified as NE import Data.Maybe (isJust) import GHC.Hs -import GHC.LanguageExtensions.Type (Extension (..)) import GHC.Types.Basic (Arity, Boxity (..), ConTag) import GHC.Types.Name.Reader (RdrName) import GHC.Types.SrcLoc (GenLocated (..)) @@ -81,7 +81,7 @@ ListPat _ ps -> bracketsWith closing (insideBrackets here (commaSep (fmap recur ps))) TuplePat _ ps boxity -> - tupleBrackets + boxityBrackets boxity closing (insideBrackets here (commaSep (fmap (align . recur) ps))) @@ -97,7 +97,7 @@ SplicePat _ splice -> knotSplice (ctxKnot ctx) ctx DollarSplice splice LitPat _ lit -> outputable lit NPat _ v (isJust -> negated) _ -> - includeWhen negated (txt "-" <> negativeGap ctx) + includeWhen negated (txt "-" <> negativeLiteralGap ctx) <> at ctx v (outputable . ol_val) NPlusKPat _ n k _ _ _ -> align $ @@ -170,13 +170,8 @@ before = replicate (tag - 1) space after = replicate (arity - tag) space --- | The brackets a tuple pattern is written with. -tupleBrackets :: Boxity -> ClosingIndent -> Doc -> Doc -tupleBrackets = \case +-- | The brackets a tuple is written with. +boxityBrackets :: Boxity -> ClosingIndent -> Doc -> Doc +boxityBrackets = \case Boxed -> parensWith Unboxed -> unboxedWith - --- | With @NegativeLiterals@ on, @- 1@ and @-1@ are different expressions, so --- the minus of a negated literal has to keep its distance. -negativeGap :: Ctx -> Doc -negativeGap ctx = includeWhen (extensionOn ctx NegativeLiterals) space diff --git a/src/Tilia/Render/Pragma.hs b/src/Tilia/Render/Pragma.hs --- a/src/Tilia/Render/Pragma.hs +++ b/src/Tilia/Render/Pragma.hs @@ -56,7 +56,7 @@ Opaque _ -> txt "OPAQUE" NoUserInlinePrag -> mempty --- | The overlap pragma of an instance, and the separator after it. +-- | The overlap pragma of an instance. overlapMode :: Ctx -> Maybe (LocatedP OverlapMode) -> Maybe Doc overlapMode ctx mode = do m <- mode diff --git a/src/Tilia/Render/Signature.hs b/src/Tilia/Render/Signature.hs --- a/src/Tilia/Render/Signature.hs +++ b/src/Tilia/Render/Signature.hs @@ -36,7 +36,7 @@ import Tilia.Render.Pragma import Tilia.Render.Type import Tilia.Span (startOf) -import Tilia.Span.Ghc (spanOf, spansOf, tokenSpan) +import Tilia.Span.Ghc (spanOf, spansOf) -- | A signature declaration. sigDecl :: Ctx -> Sig GhcPs -> Doc @@ -45,7 +45,7 @@ PatSynSig _ names sigType -> patSynSig ctx names sigType ClassOpSig _ isDefault names sigType -> includeWhen isDefault (txt "default" <> space) <> typeSig ctx (Do #indentTail) names sigType - FixSig _ sig -> fixitySig ctx sig + FixSig ((_, written), _) sig -> fixitySig ctx written sig InlineSig _ n prag -> inlineSig ctx n prag SpecSig _ n types prag -> specialiseSig ctx Nothing (noLocA (HsVar NoExtField n)) types prag @@ -104,13 +104,12 @@ where body = typeSig ctx (Don't #indentTail) names sigType --- | @infixl 5 <+>@. -fixitySig :: Ctx -> FixitySig GhcPs -> Doc -fixitySig ctx (FixitySig namespace names (Fixity precedence direction)) = +-- | @infixl 5 <+>@, with the precedence only where one is written. +fixitySig :: Ctx -> Maybe EpaLocation -> FixitySig GhcPs -> Doc +fixitySig ctx written (FixitySig namespace names (Fixity prec direction)) = txt keyword <> space - <> outputable precedence - <> space + <> foldMap (const (outputable prec <> space)) written <> namespaceSpec namespace <> align (commaSep (fmap (name ctx) names)) where @@ -247,7 +246,7 @@ ruleDecls ctx (HsRules ((_, close), _) rules) = pragma "RULES" $ sepBy breakOrSpace (fmap (align . at_ ctx (ruleDecl ctx)) rules) - <> foldMap (emptyAnchor . startOf) (tokenSpan close) + <> foldMap (emptyAnchor . startOf) (spanOf close) -- | One rule of a @RULES@ block. ruleDecl :: Ctx -> RuleDecl GhcPs -> Doc diff --git a/src/Tilia/Render/Type.hs b/src/Tilia/Render/Type.hs --- a/src/Tilia/Render/Type.hs +++ b/src/Tilia/Render/Type.hs @@ -13,6 +13,7 @@ hsSigTypeBody, typeAscription, context, + leftContext, contextOf, tyVarBndr, Visibility (..), @@ -158,12 +159,11 @@ renderChain :: Ctx -> OpChain (LHsType GhcPs) (LocatedN RdrName) -> Doc renderChain ctx = \case Operand t -> hsType ctx t - chain@(Chain (firstOne :| rest) operators) -> + chain@(Chain operands@(firstOne :| _) operators) -> layoutFrom ctx (chainSpan spanOf chain) $ - renderChain ctx firstOne - <> mconcat (zipWith3 piece (firstOne : rest) operators rest) + renderChain ctx firstOne <> foldMap piece (links operands operators) where - piece previous op operand = + piece (previous, op, operand, _) = attachOperator Normal (chainSpan spanOf previous) @@ -268,6 +268,13 @@ HsParTy _ inner -> unbracket inner _ -> t +-- | A context standing to the left of a @=>@, with the arrow and the break +-- after it, or nothing where the context is empty. +leftContext :: Ctx -> LHsContext GhcPs -> Doc +leftContext ctx ctxt + | null (unLoc ctxt) = mempty + | otherwise = context ctx ctxt <> joinedBy "=>" + -- | A context over anything that can stand as a constraint. contextOf :: -- | Is this constraint nothing but a variable? @@ -360,11 +367,19 @@ HsForAllInvis _ bndrs -> forallBndrs ctx Invisible (tyVarBndr ctx) bndrs HsForAllVis _ bndrs -> forallBndrs ctx Visible (tyVarBndr ctx) bndrs --- | The binders a signature quantifies over, when it names them. -outerBndrs :: Ctx -> HsOuterTyVarBndrs Specificity GhcPs -> Doc -outerBndrs ctx = \case +-- | The binders a signature or an equation quantifies over, where it names +-- them. +outerBndrs :: + (TyVarBndrFlag flag) => + Ctx -> + -- | What separates them from what follows. + Doc -> + HsOuterTyVarBndrs flag GhcPs -> + Doc +outerBndrs ctx separator = \case HsOuterImplicit _ -> mempty - HsOuterExplicit _ bndrs -> forallTelescope ctx (mkHsForAllInvisTele noAnn bndrs) + HsOuterExplicit _ bndrs -> + forallBndrs ctx Invisible (tyVarBndr ctx) bndrs <> separator -- | A type together with whatever it quantifies over. hsSigType :: Ctx -> LHsSigType GhcPs -> Doc @@ -373,12 +388,7 @@ -- | A signature type whose location the caller has already entered. hsSigTypeBody :: Ctx -> HsSigType GhcPs -> Doc hsSigTypeBody ctx HsSig{..} = - outerBndrs ctx sig_bndrs - <> ( case sig_bndrs of - HsOuterImplicit{} -> mempty - HsOuterExplicit{} -> afterBinders - ) - <> hsType ctx sig_body + outerBndrs ctx afterBinders sig_bndrs <> hsType ctx sig_body where afterBinders | typeIsDocumented (unLoc sig_body) = hardBreak diff --git a/src/Tilia/Run.hs b/src/Tilia/Run.hs --- a/src/Tilia/Run.hs +++ b/src/Tilia/Run.hs @@ -5,8 +5,6 @@ module Tilia.Run ( -- * Outcomes Outcome (..), - declined, - failed, differs, failIfDeclined, exitCodeOf, @@ -17,7 +15,6 @@ readAsUtf8, formattingOutcome, writeBack, - inParallel, -- * Report Report (..), @@ -46,7 +43,15 @@ ) import Tilia.Newline (NewlineStyle (Lf), getNewlineStyle, setNewlineStyle) import Tilia.Palette (Color (Bad, Good, Middling, Place), Palette, marker, paint) -import Tilia.Utils (asUtf8, attempted, inParallel, indent, lineWidth, wrapTo) +import Tilia.Utils + ( asUtf8, + attempted, + byteOrderMark, + inParallel, + indent, + lineWidth, + wrapTo, + ) ---------------------------------------------------------------------------- -- Outcomes @@ -118,9 +123,11 @@ Text -> IO Outcome outcomeOf session path before = - formatSource session path (setNewlineStyle Lf before) >>= \case + formatSource session path (setNewlineStyle Lf source) >>= \case Left e -> pure (if refused e then Declined e else Failed e) - Right formatted -> pure (formattingOutcome before formatted) + Right formatted -> pure (formattingOutcome before (mark <> formatted)) + where + (mark, source) = byteOrderMark before -- | Read a source file as UTF-8. readAsUtf8 :: FilePath -> IO (Either Text Text) diff --git a/src/Tilia/Source.hs b/src/Tilia/Source.hs --- a/src/Tilia/Source.hs +++ b/src/Tilia/Source.hs @@ -27,7 +27,8 @@ import Data.IntMap.Strict (IntMap) import Data.IntMap.Strict qualified as IntMap -import GHC.Parser.Annotation (LEpaComment) +import GHC.Parser.Lexer qualified as GHC +import GHC.Types.SrcLoc qualified as GHC import Tilia.Comments (Comment, commentsOf) import Tilia.Source.Lines @@ -56,8 +57,9 @@ sourceOf :: -- | The lines of the module, as this configuration has them. Lines -> - -- | Every comment of the module, in source order. - [LEpaComment] -> + -- | Every comment token of the module, in source order, each where the + -- lexer found it. + [(GHC.RealSrcSpan, GHC.Token)] -> -- | The line each quasi-quotation written over several lines ends on, by -- the line it begins on. IntMap Int -> diff --git a/src/Tilia/Source/Lines.hs b/src/Tilia/Source/Lines.hs --- a/src/Tilia/Source/Lines.hs +++ b/src/Tilia/Source/Lines.hs @@ -13,6 +13,10 @@ blankAt, directivePresentOnLine, directiveOnLine, + conditionalKeywords, + opensGroup, + continuesGroup, + opaqueKeywords, ) where @@ -82,8 +86,27 @@ directiveOnLine :: Text -> Maybe (Text, Text) directiveOnLine l = case T.uncons (T.stripStart l) of Just ('#', rest) - | not (T.null keyword) -> Just (keyword, body) + | keyword `elem` directiveKeywords -> Just (keyword, body) where body = T.stripStart rest keyword = T.takeWhile isAsciiLower body _ -> Nothing + +-- | Every directive the C preprocessor takes, whether or not this module +-- can do anything with the ones it names. +directiveKeywords :: [Text] +directiveKeywords = conditionalKeywords <> opaqueKeywords + +-- | The directives that ask a question, and so split a module in two. +conditionalKeywords :: [Text] +conditionalKeywords = opensGroup <> continuesGroup <> ["endif"] + +-- | The keywords that open a group or continue one. +opensGroup, continuesGroup :: [Text] +opensGroup = ["if", "ifdef", "ifndef"] +continuesGroup = ["elif", "elifdef", "elifndef", "else"] + +-- | The unconditional directives that do not split the source code. +opaqueKeywords :: [Text] +opaqueKeywords = + ["define", "undef", "include", "line", "error", "warning", "pragma"] diff --git a/src/Tilia/Span.hs b/src/Tilia/Span.hs --- a/src/Tilia/Span.hs +++ b/src/Tilia/Span.hs @@ -7,6 +7,7 @@ blankBetween, meets, covers, + zeroWidth, startOf, endOf, startPoint, @@ -68,6 +69,10 @@ -- | Does the first cover all of the second? covers :: Span -> Span -> Bool covers a b = startPoint a <= startPoint b && endPoint b <= endPoint a + +-- | Does a span cover nothing written, as an empty anchor's does? +zeroWidth :: Span -> Bool +zeroWidth s = startPoint s == endPoint s -- | A zero-width span at the start of the given one. startOf :: Span -> Span diff --git a/src/Tilia/Span/Ghc.hs b/src/Tilia/Span/Ghc.hs --- a/src/Tilia/Span/Ghc.hs +++ b/src/Tilia/Span/Ghc.hs @@ -6,22 +6,12 @@ spanOfSrcSpan, spanOf, spansOf, - tokenSpan, - uniTokenSpan, - annSpan, bracketsSpan, ) where import Data.Maybe (mapMaybe) -import GHC.Parser.Annotation - ( AnnListBrackets (..), - EpToken, - EpUniToken (..), - HasLoc, - getEpTokenSrcSpan, - getHasLoc, - ) +import GHC.Parser.Annotation (AnnListBrackets (..), HasLoc, getHasLoc) import GHC.Types.SrcLoc (GenLocated) import GHC.Types.SrcLoc qualified as GHC import Tilia.Span (Span, mkSpan) @@ -37,32 +27,18 @@ spanOfSrcSpan :: GHC.SrcSpan -> Maybe Span spanOfSrcSpan = fmap spanOfReal . GHC.srcSpanToRealSrcSpan --- | The span of a located thing. -spanOf :: (HasLoc l) => GenLocated l a -> Maybe Span +-- | Where something the compiler located was written: a node, a token or +-- an annotation. +spanOf :: (HasLoc l) => l -> Maybe Span spanOf = spanOfSrcSpan . getHasLoc --- | Where a keyword or a piece of punctuation was written. -tokenSpan :: EpToken sym -> Maybe Span -tokenSpan = spanOfSrcSpan . getEpTokenSrcSpan - --- | Where a keyword or a piece of punctuation that has a Unicode spelling --- was written. -uniTokenSpan :: EpUniToken tok utok -> Maybe Span -uniTokenSpan = \case - EpUniTok l _ -> annSpan l - NoEpUniTok -> Nothing - --- | Where an annotation says something was written. -annSpan :: (HasLoc l) => l -> Maybe Span -annSpan = spanOfSrcSpan . getHasLoc - -- | Where a list's brackets were written, from the opening one to the -- closing one. bracketsSpan :: AnnListBrackets -> Maybe Span bracketsSpan = \case - ListParens open close -> tokenSpan open <> tokenSpan close - ListBraces open close -> tokenSpan open <> tokenSpan close - ListSquare open close -> tokenSpan open <> tokenSpan close + ListParens open close -> spanOf open <> spanOf close + ListBraces open close -> spanOf open <> spanOf close + ListSquare open close -> spanOf open <> spanOf close _ -> Nothing -- | The span covering every located thing in the list. diff --git a/src/Tilia/Utils.hs b/src/Tilia/Utils.hs --- a/src/Tilia/Utils.hs +++ b/src/Tilia/Utils.hs @@ -6,7 +6,11 @@ module Tilia.Utils ( quietly, attempted, + readFileText, + fieldWords, asUtf8, + byteOrderMark, + sha256Of, lineWidth, indent, wrapTo, @@ -27,13 +31,16 @@ ) import Control.Exception (SomeException, displayException, try) import Control.Monad (replicateM) +import Crypto.Hash.SHA256 qualified as SHA256 import Data.ByteString qualified as BS +import Data.ByteString.Base16 qualified as B16 import Data.Foldable (for_, traverse_) import Data.IORef (atomicModifyIORef', newIORef, readIORef) import Data.Map.Strict qualified as Map import Data.Text (Text) import Data.Text qualified as T import Data.Text.Encoding qualified as T +import System.Directory (doesFileExist) -- | 'show' a value and take the result as 'Text'. tshow :: (Show a) => a -> Text @@ -46,6 +53,18 @@ Left (_ :: SomeException) -> pure fallback Right a -> pure a +-- | Read a file, if it is there and is text. +readFileText :: FilePath -> IO (Maybe Text) +readFileText path = quietly Nothing $ do + there <- doesFileExist path + if there + then Just . T.decodeUtf8Lenient <$> BS.readFile path + else pure Nothing + +-- | The words of a field's value, which whitespace and commas separate. +fieldWords :: Text -> [Text] +fieldWords = filter (not . T.null) . concatMap (T.split (== ',')) . T.words + -- | Run an action and return its result or the exception it threw rendered -- as 'Text'. attempted :: IO a -> IO (Either Text a) @@ -59,6 +78,15 @@ asUtf8 bytes = case T.decodeUtf8' bytes of Right text -> Right text Left _ -> Left "it is not valid UTF-8" + +-- | The byte order mark a text begins with, which GHC skips, if it has one, +-- and the rest of it. +byteOrderMark :: Text -> (Text, Text) +byteOrderMark t = T.splitAt (if "\xFEFF" `T.isPrefixOf` t then 1 else 0) t + +-- | The SHA-256 of a text's UTF-8 encoding, in hexadecimal. +sha256Of :: Text -> Text +sha256Of = T.decodeUtf8Lenient . B16.encode . SHA256.hash . T.encodeUtf8 -- | The line width for the terminal output of this program. lineWidth :: Int diff --git a/tests/Main.hs b/tests/Main.hs --- a/tests/Main.hs +++ b/tests/Main.hs @@ -11,14 +11,12 @@ -- everything. module Main (main) where -import Data.Bits (xor) -import Data.Char (ord) import Data.List (intercalate, isPrefixOf) -import Data.Word (Word64) import Spec qualified import System.Environment (lookupEnv) import Test.Hspec.Runner (Config (..), Path, defaultConfig, hspecWith) import Text.Read (readMaybe) +import Tilia.TestUtils (fingerprint) main :: IO () main = @@ -58,13 +56,6 @@ -- is rather than by where it happens to fall in the order. spell :: Path -> String spell (groups, requirement) = intercalate "/" (groups <> [requirement]) - --- | FNV-1a, so that a test lands in the same share on every machine and --- every run, and adding one test does not move the others. -fingerprint :: String -> Word64 -fingerprint = foldl' step 14695981039346656037 - where - step h c = (h `xor` fromIntegral (ord c)) * 1099511628211 -- | Is this test one whose answer the compiler can change? leansOnCompiler :: Path -> Bool diff --git a/tests/Tilia/Cabal/PackageSpec.hs b/tests/Tilia/Cabal/PackageSpec.hs --- a/tests/Tilia/Cabal/PackageSpec.hs +++ b/tests/Tilia/Cabal/PackageSpec.hs @@ -14,7 +14,7 @@ import System.IO.Temp (withSystemTempDirectory) import Test.Hspec import Tilia.Cabal.Package (PackageProblem (..), newPackageReader) -import Tilia.Fixity.Plan (BuildPlan (..), plannedCompiler) +import Tilia.Cabal.Plan (BuildPlan (..), plannedCompiler) spec :: Spec spec = do diff --git a/tests/Tilia/Comments/PlaceSpec.hs b/tests/Tilia/Comments/PlaceSpec.hs --- a/tests/Tilia/Comments/PlaceSpec.hs +++ b/tests/Tilia/Comments/PlaceSpec.hs @@ -8,9 +8,8 @@ import Tilia.Comments (Comment (..), renderComment) import Tilia.Comments.Place import Tilia.Doc.Internal (Spill (..)) -import Tilia.Parser -import Tilia.Source (comments) import Tilia.Span +import Tilia.TestUtils (commentsIn) spec :: Spec spec = do @@ -330,8 +329,3 @@ firstComment src = case commentsIn src of (c : _) -> c [] -> error "the test input had no comments" - -commentsIn :: Text -> [Comment] -commentsIn src = case parseModule defaultParserConfig "test.hs" src of - Left _ -> error "the test input did not parse" - Right pm -> comments (pmSource pm) diff --git a/tests/Tilia/CommentsSpec.hs b/tests/Tilia/CommentsSpec.hs --- a/tests/Tilia/CommentsSpec.hs +++ b/tests/Tilia/CommentsSpec.hs @@ -13,8 +13,8 @@ import Tilia.Doc import Tilia.Doc.Combinators import Tilia.Parser -import Tilia.Source (comments) import Tilia.Span +import Tilia.TestUtils (commentsIn, parsed) spec :: Spec spec = do @@ -196,7 +196,7 @@ -- Helpers render :: Doc -> Text -render = printDoc defaultRenderOptions +render = printDoc one :: Text -> Comment one src = case commentsIn src of @@ -206,12 +206,6 @@ countOf :: Text -> Text -> Int countOf needle = length . T.breakOnAll needle -commentsIn :: Text -> [Comment] -commentsIn src = - case parseModule defaultParserConfig "test.hs" src of - Left _ -> error "the test input did not parse" - Right pm -> comments (pmSource pm) - bodies :: Text -> [[Text]] bodies = fmap (NE.toList . commentBody) . commentsIn @@ -226,6 +220,4 @@ followeds = fmap commentFollowed . commentsIn headerLine :: Text -> Maybe Int -headerLine src = case parseModule defaultParserConfig "test.hs" src of - Left _ -> error "the test input did not parse" - Right pm -> spanStartLine <$> pmHeaderEnd pm +headerLine = fmap spanStartLine . pmHeaderEnd . parsed diff --git a/tests/Tilia/Corpus.hs b/tests/Tilia/Corpus.hs --- a/tests/Tilia/Corpus.hs +++ b/tests/Tilia/Corpus.hs @@ -25,7 +25,7 @@ import Codec.Archive.Tar qualified as Tar import Codec.Compression.GZip qualified as GZip -import Control.Exception (SomeException, try) +import Control.Exception (try) import Control.Monad (forM) import Data.ByteString.Lazy qualified as BL import Data.List (isPrefixOf, isSuffixOf, sort, stripPrefix) @@ -49,7 +49,8 @@ ) import System.Environment (lookupEnv) import System.FilePath (splitDirectories, takeDirectory, ()) -import Tilia.Cabal.Package (newPackageReader) +import Tilia.Cabal.Package (newPackageReader, sourceExtensions) +import Tilia.Utils (quietly) ---------------------------------------------------------------------------- -- Corpora @@ -361,7 +362,8 @@ "declaration" "signature" "pattern" "multiline.hs", "declaration" "splice" "quasiquote.hs", "declaration" "value" "function" "quasi-quotes.hs", - "declaration" "value" "function" "operator-comments-0.hs" + "declaration" "value" "function" "operator-comments-0.hs", + "declaration" "signature" "fixity" "infix.hs" ] <> ormoluRecordBraces <> ormoluUnreadable @@ -887,9 +889,10 @@ -- for an example within one that happens to have none. exampleReference :: Maybe FilePath, -- | What the package around it puts in force, already resolved from its - -- @.cabal@ file. Empty for a corpus whose examples are not modules of a - -- package; see 'corpusInPackages'. - exampleExtensions :: [Extension] + -- @.cabal@ file. 'Nothing' for a corpus whose examples are not modules + -- of a package, see 'corpusInPackages', and for one whose package could + -- not be read. + exampleExtensions :: Maybe [Extension] } deriving (Eq, Show) @@ -898,20 +901,24 @@ -- -- Fetching happens once: an unpacked corpus is left in place and found -- again, and a download interrupted half way leaves nothing behind to be --- mistaken for a complete one. 'Left' is for the machine that cannot reach --- the network rather than for a defect, and callers are expected to say so --- and carry on rather than fail. A vendored corpus is already here and can --- never fail this way. +-- mistaken for a complete one. 'Left' says why a corpus that is not here +-- could not be fetched; a vendored corpus is always here. +-- +-- The archive of a 'Fetched' corpus is deleted once unpacked; Hackage +-- releases keep theirs, which the fixity benchmarks read. obtain :: Corpus -> IO (Either Text [Example]) obtain corpus = case corpusSource corpus of Vendored dir -> Right <$> examplesIn corpus dir Fetched url root -> do home <- corpusCache let unpacked = home corpusName corpus + archive = unpacked <> ".tar.gz" createDirectoryIfMissing True home - fetch url (home corpusName corpus <> ".tar.gz") unpacked >>= \case + fetch url archive unpacked >>= \case Left problem -> pure (Left problem) - Right () -> Right <$> examplesIn corpus (unpacked root) + Right () -> do + removePathForcibly archive + Right <$> examplesIn corpus (unpacked root) HackageReleases releases -> do home <- corpusCache let root = home corpusName corpus @@ -968,9 +975,8 @@ -- partial file under the real name would be taken for a complete download -- on the next run and never fetched again. -- --- 'Left' is for the machine that cannot reach the network rather than for a --- defect, and callers are expected to say so and carry on. Only the fetch --- is caught: a file that cannot be written is a fault worth hearing about. +-- 'Left' says why the fetch failed. Only the fetch is caught: a file that +-- cannot be written is a fault worth hearing about. download :: (Url 'Https, Option 'Https) -> FilePath -> IO (Either Text ()) download (url, query) dest = try get >>= \case @@ -1018,7 +1024,7 @@ case Tar.entryContent entry of Tar.NormalFile content _ | Just path <- beneathTop (Tar.entryPath entry), - any (`isSuffixOf` path) (".cabal" : haskellExtensions) -> do + any (`isSuffixOf` path) (".cabal" : sourceExtensions) -> do createDirectoryIfMissing True (takeDirectory (staging path)) BL.writeFile (staging path) content _ -> pure () @@ -1070,36 +1076,23 @@ | suffix `isSuffixOf` name = Just (take (length name - length suffix) name) | otherwise = Nothing stemOf f = - fromMaybe f (listToMaybe (mapMaybe (`withoutSuffix` f) haskellExtensions)) + fromMaybe f (listToMaybe (mapMaybe (`withoutSuffix` f) sourceExtensions)) extensionOf f = - fromMaybe "" (listToMaybe (filter (`isSuffixOf` f) haskellExtensions)) + fromMaybe "" (listToMaybe (filter (`isSuffixOf` f) sourceExtensions)) -- | What each of a corpus's examples has in force before its own pragmas. -packageReaderFor :: Corpus -> IO (FilePath -> IO [Extension]) +packageReaderFor :: Corpus -> IO (FilePath -> IO (Maybe [Extension])) packageReaderFor corpus - | not (corpusInPackages corpus) = pure (const (pure [])) + | not (corpusInPackages corpus) = pure (const (pure Nothing)) | otherwise = do reader <- newPackageReader Nothing - pure (fmap (either (const []) id) . reader) - --- | The extensions an example may be written with. -haskellExtensions :: [String] -haskellExtensions = [".hs", ".hs-boot", ".hsig"] + pure (fmap (either (const Nothing) Just) . reader) haskellFilesIn :: FilePath -> IO [FilePath] haskellFilesIn dir = do isDir <- doesDirectoryExist dir if not isDir - then pure [dir | any (`isSuffixOf` dir) haskellExtensions] + then pure [dir | any (`isSuffixOf` dir) sourceExtensions] else do entries <- quietly [] (listDirectory dir) concat <$> traverse (haskellFilesIn . (dir )) entries - ----------------------------------------------------------------------------- --- Helpers - -quietly :: a -> IO a -> IO a -quietly fallback action = - try action >>= \case - Left (_ :: SomeException) -> pure fallback - Right a -> pure a diff --git a/tests/Tilia/CorpusSpec.hs b/tests/Tilia/CorpusSpec.hs --- a/tests/Tilia/CorpusSpec.hs +++ b/tests/Tilia/CorpusSpec.hs @@ -20,31 +20,26 @@ import Test.Hspec hiding (Example, after, before, example) import Tilia.Corpus import Tilia.Corpus.Manifest -import Tilia.Cpp - ( answeredLeaves, - answeredLinearLeaves, - countLeaves, - describeCppError, - everyBranch, - formatWithCpp, - usesCpp, - ) -import Tilia.Diff (diff) -import Tilia.Doc (defaultRenderOptions, printDoc) +import Tilia.Cpp (describeCppError, usesCpp) +import Tilia.Diff qualified as Diff import Tilia.Equivalence (commentDifference, syntaxDifference) -import Tilia.Palette (Palette (Plain), paletteFor) +import Tilia.Palette (Color (Meta), Palette (Plain), paint, paletteFor) import Tilia.Parser ( ParseError (..), ParsedModule (..), - ParserConfig, parseModule, - parserConfigFor, ) -import Tilia.Pragma (effectiveExtensions, movesPositions) -import Tilia.Render (RenderConfig, defaultRenderConfig, renderModule) +import Tilia.Pragma (movesPositions) import Tilia.Span (spanStartColumn, spanStartLine) import Tilia.Span.Ghc (spanOfSrcSpan) -import Tilia.TestConfig (exampleRenderConfig) +import Tilia.TestConfig (formatCppExample, printExample) +import Tilia.TestUtils + ( answeredLeaves, + answeredLinearLeaves, + countLeaves, + effectiveExtensionsFor, + parserConfigFor, + ) spec :: Spec spec = do @@ -274,6 +269,20 @@ readUtf8 :: FilePath -> IO (Maybe Text) readUtf8 path = either (const Nothing) Just . decodeUtf8' <$> BS.readFile path +-- | A unified diff, cut short after 60 lines, past which it stops being +-- read. +diff :: Palette -> (Text, Text) -> Text -> Text -> Text +diff palette names before after + | length body > room = T.intercalate "\n" (heading <> take room body <> [omitted]) + | otherwise = whole + where + whole = Diff.diff palette names before after + (heading, body) = splitAt 2 (T.lines whole) + room = 60 + omitted = + paint palette Meta $ + "… and " <> T.pack (show (length body - room)) <> " more lines" + -- | Run a check, turning a crash into a failure rather than into a dead test -- run. guarded :: Result -> IO Result @@ -292,7 +301,7 @@ -- | Everything that can be established about one example without doing any -- more input or output. -checkPure :: Palette -> FilePath -> [Extension] -> Text -> Maybe Text -> Result +checkPure :: Palette -> FilePath -> Maybe [Extension] -> Text -> Maybe Text -> Result checkPure palette path package source expected | movesPositions source = Result Declined "a pragma that moves positions, which we do not rewrite" noDigest @@ -349,20 +358,17 @@ where told formatted outcome why = Result outcome why (digestOf formatted) config = parserConfigFor package - inForce = effectiveExtensions package source + inForce = effectiveExtensionsFor package source parse = either (const Nothing) Just . parseModule config path - render parsed = - printDoc - defaultRenderOptions - (renderModule (exampleRenderConfig package source (pure parsed)) parsed) + render = printExample package source ---------------------------------------------------------------------------- -- Checking an example that involved the preprocessor -- | Everything that can be established about an example with conditionals in -- it. -checkCpp :: Palette -> FilePath -> [Extension] -> Text -> Maybe Text -> Result -checkCpp palette path package source expected = case formatWithCpp parser render path source of +checkCpp :: Palette -> FilePath -> Maybe [Extension] -> Text -> Maybe Text -> Result +checkCpp palette path package source expected = case formatCppExample package path source of Left why -> Result Declined (describeCppError why) noDigest Right formatted -> case (countLeaves source, countLeaves formatted) of (Left why, _) -> @@ -408,7 +414,7 @@ (Right went, Right came) | (why : _) <- alongside went came -> told formatted Broken (why <> "\n" <> against formatted) - | otherwise -> case formatWithCpp parser (renderConfigFor parser path package formatted) path formatted of + | otherwise -> case formatCppExample package path formatted of Left why -> told formatted Broken ("the output cannot be formatted again: " <> describeCppError why) Right settled @@ -463,7 +469,6 @@ parse = parseModule parser path parser = parserConfigFor package - render = renderConfigFor parser path package source -- | Why a parse failed, and where in the file, but not which file. -- @@ -494,8 +499,3 @@ -- | How many configurations one example gets compared over. configurationsToCheck :: Integer configurationsToCheck = 64 - --- | What to print an example's configurations with. -renderConfigFor :: ParserConfig -> FilePath -> [Extension] -> Text -> RenderConfig -renderConfigFor parser path package source = - maybe defaultRenderConfig (exampleRenderConfig package source) (everyBranch parser path source) diff --git a/tests/Tilia/Cpp/PropertiesSpec.hs b/tests/Tilia/Cpp/PropertiesSpec.hs --- a/tests/Tilia/Cpp/PropertiesSpec.hs +++ b/tests/Tilia/Cpp/PropertiesSpec.hs @@ -12,11 +12,12 @@ import Test.Hspec hiding (after, before) import Test.Hspec.QuickCheck (modifyMaxSuccess) import Test.QuickCheck -import Tilia.Cpp (answeredLeaves, formatWithCpp, withoutRuledOut) +import Tilia.Cpp (formatWithCpp, withoutRuledOut) import Tilia.Cpp.Macros (Macros (..)) import Tilia.Equivalence (syntaxDifference) -import Tilia.Parser (defaultParserConfig, parseModule, pmModule) +import Tilia.Parser (parseModule, pmModule) import Tilia.Render (defaultRenderConfig) +import Tilia.TestUtils (answeredLeaves, defaultParserConfig) import Tilia.Utils (tshow) spec :: Spec diff --git a/tests/Tilia/CppSpec.hs b/tests/Tilia/CppSpec.hs --- a/tests/Tilia/CppSpec.hs +++ b/tests/Tilia/CppSpec.hs @@ -1,8 +1,10 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -- | Whether documents printed from different configurations line up. module Tilia.CppSpec (spec) where +import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map import Data.Maybe (isJust, maybeToList) import Data.Text (Text) @@ -10,11 +12,20 @@ import Test.Hspec import Tilia.Cpp import Tilia.Cpp.Directives (implied) +import Tilia.Cpp.Place (regionsIn) import Tilia.Doc.Internal (Doc) import Tilia.Equivalence (syntaxDifference) -import Tilia.Parser (defaultParserConfig, parseModule, pmModule) +import Tilia.Parser (parseModule, pmModule) import Tilia.Render (defaultRenderConfig, renderModule) +import Tilia.Source (directiveOnLine) import Tilia.Span (Span) +import Tilia.TestUtils + ( configurations, + countLeaves, + defaultParserConfig, + leaves, + linearLeaves, + ) -- | Format a module which uses the C preprocessor, configured with nothing. formatCpp :: Text -> Either Text Text @@ -242,7 +253,7 @@ (said (linearLeaves atDeclarations), said (leaves atDeclarations)) `shouldSatisfy` uncurry (==) - describe "directives the prototype cannot read" $ do + describe "directives it cannot read" $ do it "refuses a module whose conditionals do not balance" $ formatCpp unbalanced `shouldBe` Left "the #ifdef at line 3 is never closed" @@ -265,6 +276,13 @@ formatCpp ruledOut `shouldBe` Left "the branch at line 6 is ruled out by a conditional around it that asks the same question" + describe "telling a directive line from code" $ do + it "reads the keyword and everything after the hash" $ + directiveOnLine " # if FOO" `shouldBe` Just ("if", "if FOO") + + it "does not take a label at the start of a line for a directive" $ + directiveOnLine " #field" `shouldBe` Nothing + ---------------------------------------------------------------------------- -- The modules the question is asked of @@ -730,3 +748,11 @@ documentOf source = case parseModule defaultParserConfig "" source of Left _ -> Left ("did not parse:\n" <> T.unpack source) Right parsed -> Right (renderModule defaultRenderConfig parsed) + +-- | Every region a document records provenance for, with what was printed +-- there. +-- +-- The outermost wins where a span appears twice, which is the one +-- 'Tilia.Comments.Attach.attachComments' gives a comment to. +regions :: Doc -> Map Span Doc +regions = Map.fromListWith (\_ outer -> outer) . regionsIn diff --git a/tests/Tilia/Doc/BodySpec.hs b/tests/Tilia/Doc/BodySpec.hs --- a/tests/Tilia/Doc/BodySpec.hs +++ b/tests/Tilia/Doc/BodySpec.hs @@ -58,4 +58,4 @@ `shouldBe` Hanging out :: Doc -> Text -out = printDoc defaultRenderOptions +out = printDoc diff --git a/tests/Tilia/Doc/CombinatorsSpec.hs b/tests/Tilia/Doc/CombinatorsSpec.hs --- a/tests/Tilia/Doc/CombinatorsSpec.hs +++ b/tests/Tilia/Doc/CombinatorsSpec.hs @@ -89,4 +89,4 @@ out (flat (includeUnless True (txt "a"))) `shouldBe` "" out :: Doc -> Text -out = printDoc defaultRenderOptions +out = printDoc diff --git a/tests/Tilia/Doc/InternalSpec.hs b/tests/Tilia/Doc/InternalSpec.hs --- a/tests/Tilia/Doc/InternalSpec.hs +++ b/tests/Tilia/Doc/InternalSpec.hs @@ -115,7 +115,7 @@ underPrevious = DHoldBack SpillUnderPrevious out :: Doc -> Text -out = printDoc defaultRenderOptions +out = printDoc directive :: Doc directive = DCppDirective (mkSpan (9, 1) (9, 6)) "if X" diff --git a/tests/Tilia/Doc/PropertiesSpec.hs b/tests/Tilia/Doc/PropertiesSpec.hs --- a/tests/Tilia/Doc/PropertiesSpec.hs +++ b/tests/Tilia/Doc/PropertiesSpec.hs @@ -87,4 +87,4 @@ squash = T.filter (not . isSpace) out :: Doc -> Text -out = printDoc defaultRenderOptions +out = printDoc diff --git a/tests/Tilia/EditorSpec.hs b/tests/Tilia/EditorSpec.hs --- a/tests/Tilia/EditorSpec.hs +++ b/tests/Tilia/EditorSpec.hs @@ -7,15 +7,26 @@ -- | Formatting what an editor holds of a module. module Tilia.EditorSpec (spec) where +import Data.ByteString qualified as BS import Data.Choice (pattern Don't) +import Data.Map.Strict qualified as Map import Data.Text (Text) import Data.Text qualified as T -import Data.Text.IO qualified as T +import Data.Text.Encoding qualified as T +import Data.Version (makeVersion) +import GHC.LanguageExtensions.Type (Extension (..)) import System.Directory (createDirectoryIfMissing) import System.FilePath (takeDirectory, ()) import System.IO.Temp (withSystemTempDirectory) import Test.Hspec -import Tilia.Editor (editorSession, formatBuffer) +import Tilia.Editor + ( Compiled (..), + compiledSession, + editorSession, + formatBuffer, + ) +import Tilia.Fixity (Direction (..), Fixity (..), Namespace (..), OpName (..)) +import Tilia.Fixity.HiFile (HiExport (..), HiFile (..), HiName (..)) import Tilia.Format (FormatError, formatErrorExitCode) import Tilia.Run (Outcome (..)) @@ -41,11 +52,21 @@ buffer ("src" "Ops.hs") "module Ops where\r\nx=1\r\n" `shouldReturn` CameTo "module Ops where\r\n\r\nx = 1\r\n" + it "keeps the byte order mark the buffer begins with" $ + withProject $ \buffer -> + buffer ("src" "Ops.hs") "\xFEFFmodule Ops where\nx=1\n" + `shouldReturn` CameTo "\xFEFFmodule Ops where\n\nx = 1\n" + it "takes fixities from the modules the buffer imports" $ withProject $ \buffer -> buffer ("src" "Uses.hs") "module Uses where\nimport Ops\nx=a <+> b\n" `shouldReturn` CameTo "module Uses where\n\nimport Ops\n\nx = a <+> b\n" + it "takes fixities from a module that begins with a byte order mark" $ + withProject $ \buffer -> + buffer ("src" "Uses.hs") "module Uses where\nimport Marked\nx=a <-> b\n" + `shouldReturn` CameTo "module Uses where\n\nimport Marked\n\nx = a <-> b\n" + it "declines an operator from a module it cannot read" $ withProject $ \buffer -> buffer ("src" "Uses.hs") "module Uses where\nimport Nowhere\nx=a b\n" @@ -83,6 +104,26 @@ (Don't #debugFixity) `shouldReturn` Just 2 + describe "given what compiling the project establishes" $ do + it "takes fixities from the interfaces it is given" $ + withCompiled $ \buffer -> + buffer ("src" "Uses.hs") "module Uses where\nimport Ops\nx=a <+> b\n" + `shouldReturn` CameTo "module Uses where\n\nimport Ops\n\nx = a <+> b\n" + + it "declines an operator from a module it is given no interface of" $ + withCompiled $ \buffer -> + buffer ("src" "Uses.hs") "module Uses where\nimport Nowhere\nx=a b\n" + `shouldReturn` CameDeclined 15 + + it "parses with the extensions it is given rather than the package's" $ + withCompiled $ \buffer -> + buffer ("src" "Uses.hs") "module Uses where\nf = \\case\n _ -> 1\n" + `shouldReturn` CameTo "module Uses where\n\nf = \\case\n _ -> 1\n" + + it "leaves out the branches the versions it is given rule out" $ + withCompiled $ \buffer -> + buffer ("src" "Uses.hs") versioned `shouldReturn` CameOut + -- | A formatted module with a conditional around two alternatives, which do -- not parse one after the other. alternatives :: Text @@ -127,6 +168,26 @@ "#endif" ] +-- | A module with a branch for a version of the package other than the one +-- built, which uses an operator from a module only that version has. +versioned :: Text +versioned = + T.unlines + [ "{-# LANGUAGE CPP #-}", + "", + "module Uses where", + "", + "#if MIN_VERSION_fake(1,0,0)", + "import Nowhere", + "", + "x = a b", + "#else", + "import Ops", + "", + "x = a <+> b", + "#endif" + ] + -- | What formatting a buffer came to, with errors told apart by the status -- they exit with. data Came @@ -152,24 +213,78 @@ failure :: FormatError -> Int failure = formatErrorExitCode --- | A project with a module declaring @infixl 6 <+>@, a @.tiliaignore@ +-- | A project with a module declaring @infixl 6 <+>@, one beginning with a +-- byte order mark declaring @infixr 0 <->@, a @.tiliaignore@ -- excluding @src/Generated.hs@, and a plan for it trusted as up to date, -- handed to the test as a way to format a buffer as one of its files. withProject :: ((FilePath -> Text -> IO Came) -> Expectation) -> Expectation withProject act = + inProject $ \dir project -> do + let planFile = dir "elsewhere" "plan.json" + write planFile $ + "{\"compiler-id\":\"ghc-0.0\",\"install-plan\":[\ + \{\"pkg-name\":\"fake\",\"pkg-version\":\"0.1.0.0\",\ + \\"pkg-src\":{\"type\":\"local\",\"path\":\"./.\"}}]}" + act $ \file text -> do + let path = project file + editorSession + path + (Just planFile) + (Don't #useCache) + (Don't #download) + (Don't #checkAst) + (Don't #checkIdempotence) + (Don't #debugFixity) + >>= \case + Left e -> pure (CameFailed (failure e)) + Right session -> came <$> formatBuffer session path text + +-- | The project of 'withProject', with what compiling it would establish +-- given instead of a plan: @LambdaCase@ in force, version 0.1.0.0 of the +-- package, and the interfaces of @Ops@ and of an empty @Prelude@. +withCompiled :: ((FilePath -> Text -> IO Came) -> Expectation) -> Expectation +withCompiled act = + inProject $ \_ project -> + act $ \file text -> do + let path = project file + compiledSession path compiled (Don't #checkAst) (Don't #checkIdempotence) + >>= \case + Left e -> pure (CameFailed (failure e)) + Right session -> came <$> formatBuffer session path text + where + compiled = + Compiled + { compiledExtensions = [ImplicitPrelude, LambdaCase], + compiledWith = makeVersion [9, 14, 1], + compiledPackages = Map.singleton "fake" (makeVersion [0, 1, 0, 0]), + compiledInterface = pure . (`Map.lookup` interfaces) + } + interfaces = + Map.fromList + [ ( "Ops", + HiFile + { hiModule = "Ops", + hiExports = [Avail (HiName "Ops" InTerms (OpName "<+>"))], + hiFixities = [(InTerms, OpName "<+>", Fixity LeftAssoc 6)] + } + ), + ("Prelude", HiFile{hiModule = "Prelude", hiExports = [], hiFixities = []}) + ] + +-- | A project with a module declaring @infixl 6 <+>@, one beginning with a +-- byte order mark declaring @infixr 0 <->@, and a @.tiliaignore@ excluding +-- @src/Generated.hs@, given to the test with the directory it is in. +inProject :: (FilePath -> FilePath -> Expectation) -> Expectation +inProject act = withSystemTempDirectory "tilia-editor" $ \dir -> do let project = dir "project" - planFile = dir "elsewhere" "plan.json" - write path text = do - createDirectoryIfMissing True (takeDirectory path) - T.writeFile path text write (project "fake.cabal") $ T.unlines [ "cabal-version: 2.4", "name: fake", "version: 0.1.0.0", "library", - " exposed-modules: Ops", + " exposed-modules: Ops, Marked", " hs-source-dirs: src", " default-language: Haskell2010" ] @@ -180,21 +295,18 @@ "(<+>) :: a -> a -> a", "(<+>) = const" ] + write (project "src" "Marked.hs") $ + T.unlines + [ "\xFEFFmodule Marked ((<->)) where", + "infixr 0 <->", + "(<->) :: a -> a -> a", + "(<->) = const" + ] write (project ".tiliaignore") "src/Generated.hs\n" - write planFile $ - "{\"compiler-id\":\"ghc-0.0\",\"install-plan\":[\ - \{\"pkg-name\":\"fake\",\"pkg-version\":\"0.1.0.0\",\ - \\"pkg-src\":{\"type\":\"local\",\"path\":\"./.\"}}]}" - act $ \file text -> do - let path = project file - editorSession - path - (Just planFile) - (Don't #useCache) - (Don't #download) - (Don't #checkAst) - (Don't #checkIdempotence) - (Don't #debugFixity) - >>= \case - Left e -> pure (CameFailed (failure e)) - Right session -> came <$> formatBuffer session path text + act dir project + +-- | Write a file, with the directories it is in. +write :: FilePath -> Text -> IO () +write path text = do + createDirectoryIfMissing True (takeDirectory path) + BS.writeFile path (T.encodeUtf8 text) diff --git a/tests/Tilia/EquivalenceSpec.hs b/tests/Tilia/EquivalenceSpec.hs --- a/tests/Tilia/EquivalenceSpec.hs +++ b/tests/Tilia/EquivalenceSpec.hs @@ -10,13 +10,8 @@ import GHC.Hs.Extension (GhcPs) import Test.Hspec import Tilia.Equivalence -import Tilia.Parser - ( ParsedModule, - defaultParserConfig, - describeParseError, - parseModule, - pmModule, - ) +import Tilia.Parser (pmModule) +import Tilia.TestUtils (parsed) spec :: Spec spec = do @@ -168,8 +163,3 @@ treeOf :: Text -> HsModule GhcPs treeOf = pmModule . parsed - -parsed :: Text -> ParsedModule -parsed source = case parseModule defaultParserConfig "Test.hs" source of - Left problem -> error (T.unpack (describeParseError problem)) - Right m -> m diff --git a/tests/Tilia/Fixity/CacheSpec.hs b/tests/Tilia/Fixity/CacheSpec.hs --- a/tests/Tilia/Fixity/CacheSpec.hs +++ b/tests/Tilia/Fixity/CacheSpec.hs @@ -11,13 +11,13 @@ import Data.Set qualified as Set import Data.Text (Text) import System.Directory (getModificationTime, listDirectory, setModificationTime) -import System.Environment (setEnv, unsetEnv) import System.FilePath (()) import System.IO.Temp (withSystemTempDirectory) import Test.Hspec import Tilia.Fixity import Tilia.Fixity.Cache import Tilia.Fixity.PackageDb (Installed (..), InstalledPackage (..)) +import Tilia.TestUtils (withEnvironment) spec :: Spec spec = do @@ -26,9 +26,9 @@ describe "a cache not to be used" $ it "remembers nothing, and nothing is made on disk for it" $ withIsolatedDirectory $ \dir -> do - setEnv "XDG_CACHE_HOME" dir - cache <- openCache (Don't #useCache) (PlanToken "plan") - unsetEnv "XDG_CACHE_HOME" + cache <- + withEnvironment [("XDG_CACHE_HOME", dir)] $ + openCache (Don't #useCache) (PlanToken "plan") storeModules cache "thing-1.0" ["A"] cachedModules cache "thing-1.0" `shouldReturn` Nothing listDirectory dir `shouldReturn` [] @@ -464,8 +464,5 @@ -- | Open a cache in a given directory, under a given token. open :: FilePath -> PlanToken -> IO Cache -open dir token = do - setEnv "XDG_CACHE_HOME" dir - cache <- openCache (Do #useCache) token - unsetEnv "XDG_CACHE_HOME" - pure cache +open dir token = + withEnvironment [("XDG_CACHE_HOME", dir)] (openCache (Do #useCache) token) diff --git a/tests/Tilia/Fixity/DebugSpec.hs b/tests/Tilia/Fixity/DebugSpec.hs --- a/tests/Tilia/Fixity/DebugSpec.hs +++ b/tests/Tilia/Fixity/DebugSpec.hs @@ -23,7 +23,8 @@ ) import Tilia.Fixity.Debug (fixityNotes, renderFixityNotes) import Tilia.Palette (Palette (Plain)) -import Tilia.Parser (defaultParserConfig, describeParseError, parseModule, pmModule) +import Tilia.Parser (pmModule) +import Tilia.TestUtils (parsed) import Tilia.Utils (lineWidth, visibleLength) spec :: Spec @@ -174,16 +175,14 @@ IO [Text] notesThrough chains world source = renderFixityNotes Plain . Map.singleton "M.hs" - <$> fixityNotes (Is #implicitPrelude) (pure . answerOf) scope (pure parsed) + <$> fixityNotes (Is #implicitPrelude) (pure . answerOf) scope (pure module') where scope = resolveScope (Is #implicitPrelude) answerOf (pure hsModule) answerOf m = case exportsOf m of Just fixities -> mempty{establishedFixities = fixities} Nothing -> mempty{establishedUntold = Set.singleton (fromMaybe [] (lookup m chains))} - hsModule = pmModule parsed - parsed = case parseModule defaultParserConfig "M.hs" ("module M where\n" <> source) of - Left problem -> error (T.unpack (describeParseError problem)) - Right m -> m + hsModule = pmModule module' + module' = parsed ("module M where\n" <> source) exportsOf m = do declared <- lookup m world inBothNamespaces . Map.fromList . fmap (\(op, fixity) -> (OpName op, fixity)) diff --git a/tests/Tilia/Fixity/DependenciesSpec.hs b/tests/Tilia/Fixity/DependenciesSpec.hs --- a/tests/Tilia/Fixity/DependenciesSpec.hs +++ b/tests/Tilia/Fixity/DependenciesSpec.hs @@ -17,7 +17,7 @@ import Control.Monad (filterM) import Data.ByteString qualified as BS -import Data.Choice (pattern Do, pattern Don't, pattern Is) +import Data.Choice (pattern Don't, pattern Is) import Data.Foldable (for_) import Data.List (isSuffixOf, sort) import Data.Map.Strict qualified as Map @@ -31,6 +31,7 @@ import System.FilePath (()) import Test.Hspec import Tilia.BootFixities (bootFixities) +import Tilia.Cabal.Plan import Tilia.Cpp (blankCpp) import Tilia.Fixity import Tilia.Fixity.Cache (PlanToken (..), openCache) @@ -39,6 +40,7 @@ import Tilia.Fixity.Plan import Tilia.Gathered (gathered) import Tilia.Parser +import Tilia.TestUtils (defaultParserConfig, routedResolver) import Tilia.WithProjectPlan ( Dependency (..), compilerShipped, @@ -53,8 +55,8 @@ withPlan :: BuildPlan -> Spec withPlan plan = do installed <- runIO readInstalledPackages - fromSource <- runIO (fixitiesThrough <$> newResolverVia (Do #useCache) [FromSource] plan) - fromInterface <- runIO (fixitiesThrough <$> newResolverVia (Do #useCache) [FromInterface] plan) + fromSource <- runIO (fixitiesThrough <$> routedResolver [FromSource] plan) + fromInterface <- runIO (fixitiesThrough <$> routedResolver [FromInterface] plan) resolver <- runIO (newResolver plan) let resolve = fixitiesThrough resolver own <- runIO ownModules diff --git a/tests/Tilia/Fixity/HiFileSpec.hs b/tests/Tilia/Fixity/HiFileSpec.hs --- a/tests/Tilia/Fixity/HiFileSpec.hs +++ b/tests/Tilia/Fixity/HiFileSpec.hs @@ -11,17 +11,15 @@ import Control.Applicative ((<|>)) import Control.Exception (evaluate) -import Data.Bits (xor) import Data.ByteString qualified as BS -import Data.Char (ord) import Data.Foldable (for_) import Data.Map.Strict qualified as Map import Data.Set (Set) import Data.Set qualified as Set import Data.Text (Text) import Data.Text qualified as T -import Data.Word (Word64) import Test.Hspec +import Tilia.Cabal.Plan (BuildPlan) import Tilia.Fixity (Fixities, Namespace (..), OpName (..)) import Tilia.Fixity.HiFile ( HiExport (..), @@ -32,8 +30,8 @@ ) import Tilia.Fixity.Interface (Interface (..), fromHiFile, parseInterface) import Tilia.Fixity.PackageDb (readInstalledPackages) -import Tilia.Fixity.Plan (BuildPlan) import Tilia.Process (readProgramOutput) +import Tilia.TestUtils (fingerprint) import Tilia.Utils (inParallel) import Tilia.WithProjectPlan ( Dependency (..), @@ -102,12 +100,10 @@ -- | Whether a module is in the fixed eighth of the rest, which are checked -- against @ghc@ all the same. -- --- Chosen by an FNV-1a hash of the name, so that it is the same modules on +-- Chosen by a 'fingerprint' of the name, so that it is the same modules on -- every run and machine. sampled :: Text -> Bool -sampled m = T.foldl' step 14695981039346656037 m `mod` 8 == (0 :: Word64) - where - step h c = (h `xor` fromIntegral (ord c)) * 1099511628211 +sampled m = fingerprint (T.unpack m) `mod` 8 == 0 -- | Where a direct reading and the text disagree about what fixities depend -- on, beyond what the text cannot tell. diff --git a/tests/Tilia/Fixity/PlanSpec.hs b/tests/Tilia/Fixity/PlanSpec.hs --- a/tests/Tilia/Fixity/PlanSpec.hs +++ b/tests/Tilia/Fixity/PlanSpec.hs @@ -48,19 +48,22 @@ import System.Info qualified import System.Timeout (timeout) import Test.Hspec +import Tilia.Cabal.Plan hiding (checkReadiness, prepareWith) +import Tilia.Cabal.Plan qualified as Plan import Tilia.Cpp.Macros (Macros (..)) import Tilia.Fixity import Tilia.Fixity.Cache (PlanToken (..), openCache, storePackageCache) +import Tilia.Fixity.HiFile (HiExport (..), HiFile (..), HiName (..)) import Tilia.Fixity.PackageDb ( Installed (..), InstalledPackage (..), compilerIdentity, readInstalledPackages, ) -import Tilia.Fixity.Plan hiding (checkReadiness, prepareWith) -import Tilia.Fixity.Plan qualified as Plan +import Tilia.Fixity.Plan import Tilia.Parser import Tilia.Process (readProgramOutput) +import Tilia.TestUtils (parsed, routedResolver, unreadOnly, withEnvironment) import Tilia.Utils (inParallel) import Tilia.WithProjectPlan (withProjectPlan) @@ -73,6 +76,7 @@ hscModules generatedModuleSpec askedAtOnce + givenInterfaces readBefore gitDependencies repositories @@ -524,11 +528,10 @@ -- | What a module written for @hsc2hs@ amounts to, by either route to one. -- --- Both fixtures below are what @hsc2hs@ takes and no compiler does, and --- both write a fixity that the answer is expected to ignore. That is the --- point: a module nothing can read is answered out of --- 'Tilia.Fixity.ByHand.hscFixities' or not at all, and were either answer --- arrived at by reading the file there would be no answer to give. +-- The fixture is what @hsc2hs@ takes and no compiler does, and it writes a +-- fixity that the answer is expected to ignore: a module nothing can read +-- declares nothing, and an answer arrived at by reading the file would +-- hold the fixity. hscModules :: Spec hscModules = describe "a module written for hsc2hs" $ do it "declares nothing, where it is one of the project's own" $ @@ -536,16 +539,9 @@ \rs -> do askModule rs "Cursed" `shouldReturn` mempty - it "declares what the table says, where it comes out of a tarball" - $ withFakeArchive - [ ("Cursed.hsc", cursed), - ("System/Posix/Signals.hsc", signals) - ] - $ \rs -> do - fixitiesOf rs "Cursed" `shouldReturn` Just Map.empty - signalled <- fixitiesOf rs "System.Posix.Signals" - fmap (Set.map snd . Map.keysSet) signalled - `shouldBe` Just (Set.fromList [OpName "addSignal", OpName "deleteSignal"]) + it "declares nothing, where it comes out of a tarball" $ + withFakeArchive [("Cursed.hsc", cursed)] $ + \rs -> fixitiesOf rs "Cursed" `shouldReturn` Just Map.empty -- | Where a package fetched from a repository is looked for. repositories :: Spec @@ -670,7 +666,7 @@ readGivenPlan project planFile >>= \case Left why -> expectationFailure (T.unpack why) Right plan -> do - resolver <- newResolverVia (Do #useCache) [FromInterface] plan + resolver <- routedResolver [FromInterface] plan fixities <- fixitiesOf resolver "Ops" (Map.lookup (InTerms, OpName "<+>") =<< fixities) `shouldBe` Just (Fixity LeftAssoc 6) @@ -696,7 +692,7 @@ ( readGivenPlan project planFile >>= \case Left why -> expectationFailure (T.unpack why) Right plan -> do - resolver <- newResolverVia (Do #useCache) [FromInterface] plan + resolver <- routedResolver [FromInterface] plan traverse_ (fixitiesOf resolver) ["Ops", "Nowhere.At.All"] ) `shouldReturn` [] @@ -975,7 +971,7 @@ it "answers for every module of a ring that hands itself on" $ withFakePlan [("src/" <> T.unpack (ringModule i) <> ".hs", ringSource i) | i <- [0 .. ringSize - 1]] $ \plan -> forM_ [1 :: Int .. 50] $ \_ -> do - resolver <- newResolverVia (Do #useCache) [FromInterface] plan + resolver <- routedResolver [FromInterface] plan answers <- timeout 30000000 $ inParallel (fixitiesOf resolver . ringModule) [0 .. ringSize - 1] @@ -986,6 +982,46 @@ (Map.lookup (InTerms, ringOperator i) =<< fixities) `shouldBe` Just (Fixity RightAssoc (i `mod` 10)) +-- | A resolver over interfaces handed to it, as an editor that has compiled +-- the project holds them. +givenInterfaces :: Spec +givenInterfaces = describe "a resolver over the interfaces it is given" $ do + it "reads a module's own fixities" $ do + resolver <- newResolverFrom given + fixitiesOf resolver "Ops" `shouldReturn` Just plus + + it "reads a fixity a module passes on where it is declared" $ do + resolver <- newResolverFrom given + fixitiesOf resolver "Facade" `shouldReturn` Just plus + + it "says nothing about a module it is not given" $ do + resolver <- newResolverFrom given + fixitiesOf resolver "Nowhere" `shouldReturn` Nothing + + it "says nothing about a module given an interface of another" $ do + resolver <- newResolverFrom (\_ -> given "Ops") + fixitiesOf resolver "Facade" `shouldReturn` Nothing + where + plus = Map.singleton (InTerms, OpName "<+>") (Fixity RightAssoc 5) + given m = pure (Map.lookup m interfaces) + interfaces = + Map.fromList + [ ( "Ops", + HiFile + { hiModule = "Ops", + hiExports = [Avail (HiName "Ops" InTerms (OpName "<+>"))], + hiFixities = [(InTerms, OpName "<+>", Fixity RightAssoc 5)] + } + ), + ( "Facade", + HiFile + { hiModule = "Facade", + hiExports = [Avail (HiName "Ops" InTerms (OpName "<+>"))], + hiFixities = [] + } + ) + ] + -- | A module of the project's own, which an earlier run has read. readBefore :: Spec readBefore = describe "a module of the project's own, read by an earlier run" $ do @@ -1070,18 +1106,6 @@ "interrupt = #const SIGINT" ] --- | What @unix@ writes, in miniature: a fixity declaration for a name used --- in backticks, in a file no reading of ours reaches. -signals :: Text -signals = - T.unlines - [ "#include ", - "module System.Posix.Signals (addSignal, deleteSignal) where", - "infixr `addSignal`, `deleteSignal`", - "addSignal :: Int -> Int -> Int", - "addSignal s m = m + #const SIGINT" - ] - -- | What the chase makes of one module's @<+>@, against a world of modules -- that disagree about it, where it settles it. chased :: Text -> IO (Maybe Fixity) @@ -1097,11 +1121,8 @@ -- | What the chase makes of one module against that world. chasedModule :: Text -> IO Established chasedModule source = - withReexports reach "M" (summarize (Is #implicitPrelude) (pmModule parsed)) + withReexports reach "M" (summarize (Is #implicitPrelude) (pmModule (parsed source))) where - parsed = case parseModule defaultParserConfig "M.hs" source of - Left _ -> error "the test input did not parse" - Right m -> m reach m = pure $ case m of "Control.Arrow" -> bringing (Fixity RightAssoc 5) @@ -1409,7 +1430,7 @@ ("src/Inner.hs", "module Inner (T (..)) where\ninfixr 5 :|\ndata T = A | Int :| Int\n") ] $ \rs -> do - let m = parse "module M where\nimport Facade (T (..))\n" + let m = parsed "module M where\nimport Facade (T (..))\n" scope <- scopeFor rs (Is #implicitPrelude) (pure (pmModule m)) lookupFixity scope InTerms Nothing (OpName ":|") `shouldBe` Resolved (Fixity RightAssoc 5) (DeclaredIn "Facade") @@ -1511,7 +1532,7 @@ it "settles an operator no unread module in scope could have declared" $ withFakeProject [("src/Opaque.hs", opaqueSource)] $ \rs -> do - let m = parse "module M where\nimport Opaque\n" + let m = parsed "module M where\nimport Opaque\n" scope <- scopeFor rs (Is #implicitPrelude) (pure (pmModule m)) lookupFixity scope InTerms Nothing (OpName "") `shouldBe` Resolved defaultFixity ReportDefault @@ -1519,7 +1540,7 @@ it "leaves one alone that the unread module's list does name" $ withFakeProject [("src/Opaque.hs", opaqueSource)] $ \rs -> do - let m = parse "module M where\nimport Opaque\n" + let m = parsed "module M where\nimport Opaque\n" scope <- scopeFor rs (Is #implicitPrelude) (pure (pmModule m)) lookupFixity scope InTerms Nothing (OpName "<+>") `shouldBe` Unresolved (ModuleChain ("Opaque" :| ["No.Such.Module"]) :| []) @@ -1647,7 +1668,7 @@ ("src/B.hs", "module B (clampTo) where\nclampTo :: Int -> Int -> Int\nclampTo = min\n") ] $ \rs -> do - let m = parse "module C (w) where\nimport A\nimport B\nw :: Int\nw = 1 `clampTo` 2\n" + let m = parsed "module C (w) where\nimport A\nimport B\nw :: Int\nw = 1 `clampTo` 2\n" scope <- scopeFor rs (Is #implicitPrelude) (pure (pmModule m)) lookupFixity scope InTerms Nothing (OpName "clampTo") `shouldBe` Resolved defaultFixity ReportDefault @@ -1658,7 +1679,7 @@ ("src/B.hs", "{-# LANGUAGE TypeOperators #-}\nmodule B ((:+:)) where\ndata a :+: b = a :+: b\n") ] $ \rs -> do - let m = parse "module C (w) where\nimport A\nimport B\nw = 1 :+: 2\n" + let m = parsed "module C (w) where\nimport A\nimport B\nw = 1 :+: 2\n" scope <- scopeFor rs (Is #implicitPrelude) (pure (pmModule m)) lookupFixity scope InTerms Nothing (OpName ":+:") `shouldBe` Unresolved (unreadOnly "A") @@ -1670,7 +1691,7 @@ ("src/Tree.hs", "module Tree (Tree (..)) where\ndata Tree = Leaf | Node Tree Tree\n") ] $ \rs -> do - let m = parse "module C (w) where\nimport Core\nimport Tree (Tree (..))\nw = Leaf `Node` Leaf `Node` Leaf\n" + let m = parsed "module C (w) where\nimport Core\nimport Tree (Tree (..))\nw = Leaf `Node` Leaf `Node` Leaf\n" scope <- scopeFor rs (Is #implicitPrelude) (pure (pmModule m)) lookupFixity scope InTerms Nothing (OpName "Node") `shouldBe` Resolved defaultFixity ReportDefault @@ -1682,7 +1703,7 @@ ("src/Tree.hs", "module Tree (Tree (..)) where\ndata Tree = Leaf | Node Tree Tree\n") ] $ \rs -> do - let m = parse "module C (w) where\nimport Core\nimport Tree (Tree)\nw = Leaf `Node` Leaf `Node` Leaf\n" + let m = parsed "module C (w) where\nimport Core\nimport Tree (Tree)\nw = Leaf `Node` Leaf `Node` Leaf\n" scope <- scopeFor rs (Is #implicitPrelude) (pure (pmModule m)) lookupFixity scope InTerms Nothing (OpName "Node") `shouldBe` Unresolved (ModuleChain ("Core" :| ["A"]) :| []) @@ -1693,7 +1714,7 @@ ("src/Other.hs", "module Other ((<+>)) where\ninfixl 6 <+>\n(<+>) :: Int -> Int -> Int\na <+> b = a - b\n") ] $ \rs -> do - let m = parse "module C (w) where\nimport Ops (T (..))\nimport Other\nw = 1 <+> 2\n" + let m = parsed "module C (w) where\nimport Ops (T (..))\nimport Other\nw = 1 <+> 2\n" scope <- scopeFor rs (Is #implicitPrelude) (pure (pmModule m)) lookupFixity scope InTerms Nothing (OpName "<+>") `shouldBe` Resolved (Fixity LeftAssoc 6) (DeclaredIn "Other") @@ -1957,11 +1978,8 @@ (Scope -> Expectation) -> Expectation endToEnd resolver source assertion = - case parseModule defaultParserConfig "test.hs" source of - Left _ -> expectationFailure "the test input did not parse" - Right pm -> do - scope <- scopeFor resolver (Is #implicitPrelude) (pure (pmModule pm)) - assertion scope + scopeFor resolver (Is #implicitPrelude) (pure (pmModule (parsed source))) + >>= assertion -- | Check one expected fixity, returning a description of any mismatch. check :: @@ -2022,11 +2040,6 @@ "f = 1" ] -parse :: Text -> ParsedModule -parse source = case parseModule defaultParserConfig "M.hs" source of - Left _ -> error "the test input did not parse" - Right pm -> pm - -- | A project of made-up modules, with a build plan written by hand. -- -- The plan names one local package and nothing else, which is enough for a @@ -2126,20 +2139,3 @@ entry (inside, text) = case Tar.toTarPath False inside of Left why -> error why Right tarPath -> pure (Tar.fileEntry tarPath (BL.fromStrict (T.encodeUtf8 text))) - --- | Run something with the given variables set, and the environment as it --- was afterwards however it turns out. -withEnvironment :: [(String, String)] -> IO a -> IO a -withEnvironment vars act = bracket set restore (const act) - where - set = traverse remember vars - remember (key, value) = do - was <- lookupEnv key - setEnv key value - pure (key, was) - restore = traverse_ (\(key, was) -> maybe (unsetEnv key) (setEnv key) was) - --- | The one import blamed for an operator, unread on its own account and so --- with nothing below it. -unreadOnly :: Text -> NonEmpty ModuleChain -unreadOnly m = ModuleChain (m :| []) :| [] diff --git a/tests/Tilia/FixitySpec.hs b/tests/Tilia/FixitySpec.hs --- a/tests/Tilia/FixitySpec.hs +++ b/tests/Tilia/FixitySpec.hs @@ -20,6 +20,7 @@ import Tilia.Fixity import Tilia.Parser import Tilia.Span (spanStartColumn, spanStartLine) +import Tilia.TestUtils (parsed, unreadOnly) spec :: Spec spec = do @@ -827,11 +828,6 @@ where whichever = Just . inBothNamespaces . Map.fromList -parsed :: Text -> ParsedModule -parsed src = case parseModule defaultParserConfig "test.hs" src of - Left _ -> error "the test input did not parse" - Right pm -> pm - -- | The fixities a module declares, by name alone. -- -- One entry per operator: a fixity that governs both namespaces is one @@ -886,12 +882,6 @@ -- | What is known in a world made of 'exportsOf' alone. knowingExports :: Text -> Established knowingExports = maybe unreadable (\fixities -> mempty{establishedFixities = fixities}) . exportsOf - --- | The one import blamed for an operator, unread on its own account and so --- with nothing below it. What every answer here was before a chain could be --- reported at all. -unreadOnly :: Text -> NonEmpty ModuleChain -unreadOnly m = ModuleChain (m :| []) :| [] -- | A module that uses an operator nothing in scope declares, alongside an -- import that could not be read. diff --git a/tests/Tilia/PragmaSpec.hs b/tests/Tilia/PragmaSpec.hs --- a/tests/Tilia/PragmaSpec.hs +++ b/tests/Tilia/PragmaSpec.hs @@ -34,30 +34,35 @@ ] (\source -> movesPositions source `shouldBe` False) describe "the extensions in force" $ do - it "starts from what is on by default" $ - effectiveExtensions [] "module M where\n" `shouldBe` [ImplicitPrelude] it "keeps what the package puts in force" $ effectiveExtensions [ImplicitPrelude, GADTs] "module M where\n" `shouldBe` [ImplicitPrelude, GADTs] - it "leaves the Prelude off where the package's own set does" $ - effectiveExtensions [GADTs] "module M where\n" `shouldBe` [GADTs] it "reads one extension" $ effectiveExtensions [] "{-# LANGUAGE BangPatterns #-}\nmodule M where\n" - `shouldBe` [ImplicitPrelude, BangPatterns] + `shouldBe` [BangPatterns] it "reads several from one pragma" $ - effectiveExtensions [] "{-# LANGUAGE GADTs, RankNTypes #-}\nmodule M where\n" - `shouldBe` [ImplicitPrelude, GADTs, RankNTypes] + effectiveExtensions + [] + "{-# LANGUAGE GADTs, RankNTypes #-}\nmodule M where\n" + `shouldBe` [GADTs, RankNTypes] it "reads several pragmas" $ - effectiveExtensions [] "{-# LANGUAGE GADTs #-}\n{-# LANGUAGE MagicHash #-}\n" - `shouldBe` [ImplicitPrelude, GADTs, MagicHash] + effectiveExtensions + [] + "{-# LANGUAGE GADTs #-}\n{-# LANGUAGE MagicHash #-}\n" + `shouldBe` [GADTs, MagicHash] it "ignores other pragmas" $ - effectiveExtensions [] "{-# OPTIONS_GHC -Wall #-}\n{-# LANGUAGE GADTs #-}\n" - `shouldBe` [ImplicitPrelude, GADTs] + effectiveExtensions + [] + "{-# OPTIONS_GHC -Wall #-}\n{-# LANGUAGE GADTs #-}\n" + `shouldBe` [GADTs] it "ignores an unknown extension rather than failing" $ effectiveExtensions [] "{-# LANGUAGE GADTs, NotARealExtension #-}\n" - `shouldBe` [ImplicitPrelude, GADTs] + `shouldBe` [GADTs] it "treats a No-prefix as turning one off" $ - effectiveExtensions [] "{-# LANGUAGE NoImplicitPrelude #-}\n" `shouldBe` [] + effectiveExtensions + [ImplicitPrelude] + "{-# LANGUAGE NoImplicitPrelude #-}\n" + `shouldBe` [] it "lets a module refuse what its package put in force" $ effectiveExtensions [ImplicitPrelude, GADTs] "{-# LANGUAGE NoGADTs #-}\n" `shouldBe` [ImplicitPrelude] @@ -65,8 +70,10 @@ effectiveExtensions [GADTs] "{-# LANGUAGE ImplicitPrelude #-}\n" `shouldBe` [GADTs, ImplicitPrelude] it "does not repeat an extension named twice" $ - effectiveExtensions [] "{-# LANGUAGE GADTs #-}\n{-# LANGUAGE GADTs #-}\n" - `shouldBe` [ImplicitPrelude, GADTs] + effectiveExtensions + [] + "{-# LANGUAGE GADTs #-}\n{-# LANGUAGE GADTs #-}\n" + `shouldBe` [GADTs] describe "lookupExtension" $ do it "knows an extension by the name one writes" $ diff --git a/tests/Tilia/RenderSpec.hs b/tests/Tilia/RenderSpec.hs --- a/tests/Tilia/RenderSpec.hs +++ b/tests/Tilia/RenderSpec.hs @@ -3,369 +3,41 @@ -- | Formatting whole modules. module Tilia.RenderSpec (spec) where -import Data.Map.Strict qualified as Map -import Data.Set qualified as Set import Data.Text (Text) import Data.Text qualified as T -import GHC.LanguageExtensions.Type (Extension (..)) import Test.Hspec -import Tilia.Doc (defaultRenderOptions, printDoc) -import Tilia.Fixity - ( Direction (..), - Fixity (..), - OpName (..), - Provenance (..), - Reach (..), - Scope (..), - ) -import Tilia.Parser (defaultParserConfig, parseModule) +import Tilia.Doc (printDoc) import Tilia.Render +import Tilia.TestUtils (parsed) spec :: Spec -spec = do - describe "the module header" $ do - it "puts the pragmas above the module and sorts them" $ - format - [ "{-# LANGUAGE OverloadedStrings, GADTs #-}", - "module M where" - ] - `shouldBe` [ "{-# LANGUAGE GADTs #-}", - "{-# LANGUAGE OverloadedStrings #-}", - "", - "module M where" - ] - - it "puts an extension pack before what it enables" $ - format - [ "{-# LANGUAGE ApplicativeDo #-}", - "{-# LANGUAGE GHC2021 #-}", - "module M where" - ] - `shouldBe` [ "{-# LANGUAGE GHC2021 #-}", - "{-# LANGUAGE ApplicativeDo #-}", - "", - "module M where" - ] - - it "puts qualified first throughout when the extension is off" $ - format - [ "module M where", - "import Data.Map qualified as M", - "import qualified Data.Set as S" - ] - `shouldBe` [ "module M where", - "", - "import qualified Data.Map as M", - "import qualified Data.Set as S" - ] - - it "puts qualified last throughout when the extension is on" $ - formatUnder - [ImportQualifiedPost] - [ "module M where", - "import Data.Map qualified as M", - "import qualified Data.Set as S" - ] - `shouldBe` [ "module M where", - "", - "import Data.Map qualified as M", - "import Data.Set qualified as S" - ] - - it "parses a module that takes back an extension the edition puts in force" $ - format - [ "{-# LANGUAGE NoStarIsType #-}", - "{-# LANGUAGE TypeOperators #-}", - "module M (type (*)) where", - "import GHC.TypeLits (type (*))" - ] - `shouldBe` [ "{-# LANGUAGE TypeOperators #-}", - "{-# LANGUAGE NoStarIsType #-}", - "", - "module M (type (*)) where", - "", - "import GHC.TypeLits (type (*))" - ] - - describe "comments" $ do - it "keeps one written between declarations" $ - format - [ "module M where", - "", - "-- a note", - "f = 1" - ] - `shouldBe` [ "module M where", - "", - "-- a note", - "f = 1" - ] - - it "keeps one written inside a binding" $ - format - [ "module M where", - "", - "f = g", - " where", - " -- about g", - " g = 1" - ] - `shouldBe` [ "module M where", - "", - "f = g", - " where", - " -- about g", - " g = 1" - ] - - it "keeps a self-delimiting one on the line it was written on" $ - format ["module M where", "", "f =", " {- here -} 1"] - `shouldBe` ["module M where", "", "f =", " {- here -} 1"] - - it "will not put a construct holding one on a single line" $ - format - [ "module M where", - "", - "f =", - " ( -- here", - " 1", - " )" - ] - `shouldBe` [ "module M where", - "", - "f =", - " ( -- here", - " 1", - " )" - ] - - describe "operator chains" $ do - -- With the fixities known, the chain is regrouped so that what binds - -- tightly stays together and the break falls where the reader expects. - it "breaks a chain at its loosest operator" $ - formatWith (Just arithmetic) spreadChain - `shouldBe` [ "module M where", - "", - "f =", - " a * b", - " + c * d" - ] - - -- Without them nothing is asserted about how the chain associates, so - -- nothing is rearranged and every operator is treated alike. - it "leaves a chain alone when the fixities are unknown" $ - formatWith Nothing spreadChain - `shouldBe` [ "module M where", - "", - "f =", - " a", - " * b", - " + c", - " * d" - ] - - it "takes an operator's fixity from the local binding that captures it" $ - formatWith - (Just arithmetic) - [ "module M where", - "", - "f =", - " a * b", - " + c * d", - " where", - " infixl 8 +", - " x + y = x" - ] - `shouldBe` [ "module M where", - "", - "f =", - " a", - " * b", - " + c", - " * d", - " where", - " infixl 8 +", - " x + y = x" - ] - - it "lets a separator hand a block to what precedes it" $ - formatWith - (Just arithmetic) - ["module M where", "", "f = g $ do", " h", " i"] - `shouldBe` [ "module M where", - "", - "f = g $ do", - " h", - " i" - ] - - describe "where a comment lands" $ do - -- A comment the author wrote after code ends a line here too, and the - -- printer has not finished with that line: the comma of a record field, - -- the arrow of an alternative and the closing bracket of a list all - -- still have to be emitted, and all of them belong before it. - it "keeps a comment at the end of the line it was written on" $ - format - [ "module M where", - "", - "f = case x of", - " a -> -- why", - " b" - ] - `shouldBe` [ "module M where", - "", - "f = case x of", - " a -> -- why", - " b" - ] - - it "leaves a comment written on its own line on one" $ - format - [ "module M where", - "", - "f = case x of", - " a ->", - " -- why", - " b" - ] - `shouldBe` [ "module M where", - "", - "f = case x of", - " a ->", - " -- why", - " b" - ] - - it "keeps one written before the closing bracket inside it" $ - format - [ "module M where", - "", - "xs =", - " [ a,", - " b", - " -- and that is all", - " ]" - ] - `shouldBe` [ "module M where", - "", - "xs =", - " [ a,", - " b", - " -- and that is all", - " ]" - ] - - -- Formatting an already formatted file must change nothing. The property - -- is easy to lose the moment comments move, since where a comment goes is - -- read off the input and moving it changes what the next pass reads. - describe "settling" - $ it "reaches its answer in one pass" - $ let once = format awkward - in formatWith Nothing once `shouldBe` once - - describe "layout follows the input" $ do - it "keeps a declaration that was on one line on one line" $ - format ["module M where", "", "f x = (x, x)"] - `shouldBe` ["module M where", "", "f x = (x, x)"] - - it "keeps one that was spread out spread out" $ - format ["module M where", "", "f x =", " ( x,", " x", " )"] - `shouldBe` [ "module M where", - "", - "f x =", - " ( x,", - " x", - " )" - ] - ----------------------------------------------------------------------------- --- Helpers +spec = + -- Without fixities nothing is asserted about how a chain associates, so + -- nothing is rearranged and every operator is treated alike. + describe "operator chains" + $ it "leaves a chain alone when the fixities are unknown" + $ format + [ "module M where", + "", + "f =", + " a * b", + " + c * d" + ] + `shouldBe` [ "module M where", + "", + "f =", + " a", + " * b", + " + c", + " * d" + ] --- | Format the given lines and give the result back as lines. +-- | Format the given lines with no fixities known and give the result back +-- as lines. format :: [Text] -> [Text] -format = formatWith Nothing - --- | Format with the given extensions in force, as a package would put them. -formatUnder :: [Extension] -> [Text] -> [Text] -formatUnder exts = withSettings defaultRenderConfig{rcExtensions = Set.fromList exts} - -formatWith :: Maybe Scope -> [Text] -> [Text] -formatWith scope = withSettings defaultRenderConfig{rcScope = scope} - -withSettings :: RenderConfig -> [Text] -> [Text] -withSettings settings input = - case parseModule defaultParserConfig "" source of - Left _ -> error ("did not parse:\n" <> T.unpack source) - Right parsed -> - T.lines (printDoc defaultRenderOptions (renderModule settings parsed)) - where - source = T.unlines input - --- | A module with comments in all the places that are hard to put them --- back. -awkward :: [Text] -awkward = - [ "module M where", - "", - "-- | A heading", - "", - "-- and a note under it", - "data T = T", - " { a :: Int, -- the first", - " -- the second", - " b :: Int", - " }", - "", - "f x -- what to do with this?", - " | x > 0 = g x", - " | otherwise = h x", - " where", - " g = id", - "", - " -- about h", - " h = negate", - "", - "xs =", - " [ one,", - " {- inline -} two", - " -- last", - " ]" - ] - --- | A chain the author already spread over more than one line, so that the --- question is where it breaks rather than whether it does. -spreadChain :: [Text] -spreadChain = - [ "module M where", - "", - "f =", - " a * b", - " + c * d" - ] - --- | A scope that knows the operators the tests use. -arithmetic :: Scope -arithmetic = - Scope - { scopeInTypes = nothingReaches, - scopeInTerms = - nothingReaches - { reachUnqualified = - Map.fromList - [ (OpName "$", (Fixity RightAssoc 0, DeclaredHere)), - (OpName "+", (Fixity LeftAssoc 6, DeclaredHere)), - (OpName "*", (Fixity LeftAssoc 7, DeclaredHere)) - ] - }, - scopeUnsettled = [] - } - --- | A namespace with nothing in it. -nothingReaches :: Reach -nothingReaches = - Reach - { reachUnqualified = Map.empty, - reachQualified = Map.empty, - reachAmbiguous = Map.empty, - reachDecided = Set.empty - } +format = + T.lines + . printDoc + . renderModule defaultRenderConfig + . parsed + . T.unlines diff --git a/tests/Tilia/RunSpec.hs b/tests/Tilia/RunSpec.hs --- a/tests/Tilia/RunSpec.hs +++ b/tests/Tilia/RunSpec.hs @@ -30,7 +30,7 @@ import Tilia.Format (FormatError (..), formatErrorExitCode, refused) import Tilia.Palette (Color (Bad), Palette (..)) import Tilia.Run -import Tilia.Utils (lineWidth, visibleLength, wrapTo) +import Tilia.Utils (inParallel, lineWidth, visibleLength, wrapTo) spec :: Spec spec = do @@ -60,10 +60,6 @@ it "counts a rewrite as a difference and nothing else" $ fmap differs [Changed "a" "b", Unchanged, decline, failure] `shouldBe` [True, False, False, False] - - it "keeps refusals and failures apart" $ do - fmap declined [decline, failure, Unchanged] `shouldBe` [True, False, False] - fmap failed [decline, failure, Unchanged] `shouldBe` [False, True, False] describe "the status a run leaves behind" $ do it "has none to give when nothing failed" $ diff --git a/tests/Tilia/TestConfig.hs b/tests/Tilia/TestConfig.hs --- a/tests/Tilia/TestConfig.hs +++ b/tests/Tilia/TestConfig.hs @@ -3,9 +3,10 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} --- | The settings every corpus example is formatted with. +-- | How every corpus example is formatted. module Tilia.TestConfig - ( exampleRenderConfig, + ( printExample, + formatCppExample, ) where @@ -17,6 +18,8 @@ import Data.Text (Text) import GHC.LanguageExtensions.Type (Extension) import Tilia.BootFixities (bootFixities) +import Tilia.Cpp (CppError, everyBranch, formatWithCpp) +import Tilia.Doc (printDoc) import Tilia.Fixity ( Direction (..), Established (..), @@ -33,13 +36,13 @@ unreadable, ) import Tilia.Parser (ParsedModule (..)) -import Tilia.Pragma (effectiveExtensions) -import Tilia.Render (RenderConfig (..), defaultRenderConfig) +import Tilia.Render (RenderConfig (..), defaultRenderConfig, renderModule) +import Tilia.TestUtils (effectiveExtensionsFor, parserConfigFor) -- | How to format one corpus example. exampleRenderConfig :: -- | What the package around it puts in force, if it is a module of one. - [Extension] -> + Maybe [Extension] -> Text -> -- | Its configurations, parsed. NonEmpty ParsedModule -> @@ -47,7 +50,7 @@ exampleRenderConfig package source parsed = defaultRenderConfig { rcExtensions = - Set.fromList (effectiveExtensions package source), + Set.fromList (effectiveExtensionsFor package source), rcScope = Just ( underEveryQualifier @@ -74,6 +77,35 @@ ] ) } + +-- | Print a corpus example that does not use the preprocessor. +printExample :: + -- | What the package around it puts in force, if it is a module of one. + Maybe [Extension] -> + Text -> + -- | It, parsed. + ParsedModule -> + Text +printExample package source parsed = + printDoc + (renderModule (exampleRenderConfig package source (pure parsed)) parsed) + +-- | Format a corpus example that uses the preprocessor. +formatCppExample :: + -- | What the package around it puts in force, if it is a module of one. + Maybe [Extension] -> + FilePath -> + Text -> + Either CppError Text +formatCppExample package path source = + formatWithCpp parser configured path source + where + parser = parserConfigFor package + configured = + maybe + defaultRenderConfig + (exampleRenderConfig package source) + (everyBranch parser path source) -- | What a module in scope exports, as far as the corpus is concerned. exportsOf :: Text -> Maybe Fixities diff --git a/tests/Tilia/TestUtils.hs b/tests/Tilia/TestUtils.hs new file mode 100644 --- /dev/null +++ b/tests/Tilia/TestUtils.hs @@ -0,0 +1,222 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE PatternSynonyms #-} + +-- | Helpers several specs share. +module Tilia.TestUtils + ( withEnvironment, + parserConfigFor, + defaultParserConfig, + effectiveExtensionsFor, + parsed, + commentsIn, + unreadOnly, + fingerprint, + routedResolver, + + -- * Configurations, enumerated + configurations, + leaves, + linearLeaves, + countLeaves, + answeredLeaves, + answeredLinearLeaves, + ) +where + +import Control.Exception (bracket) +import Data.Bits (xor) +import Data.Char (ord) +import Data.Choice (pattern Do) +import Data.Foldable (traverse_) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Map.Strict qualified as Map +import Data.Maybe (fromMaybe, isJust, listToMaybe) +import Data.Text (Text) +import Data.Text qualified as T +import Data.Word (Word64) +import GHC.Driver.Session qualified as GHC +import GHC.LanguageExtensions.Type (Extension (..)) +import System.Environment (lookupEnv, setEnv, unsetEnv) +import Tilia.Cabal.Package (newPackageReader) +import Tilia.Cabal.Plan (BuildPlan, plannedCompiler) +import Tilia.Comments (Comment) +import Tilia.Cpp.Directives + ( Assignment, + Configurations (..), + CppError, + GroupSpec (..), + Guard, + configurationsOn, + gsCount, + implied, + nestedIn, + readConditionals, + resolved, + scanConditionals, + unconditionalErrors, + ) +import Tilia.Fixity (ModuleChain (..)) +import Tilia.Fixity.Plan (Resolver, Route, newResolverVia) +import Tilia.Parser + ( ParsedModule (..), + ParserConfig (..), + describeParseError, + parseModule, + ) +import Tilia.Pragma (effectiveExtensions) +import Tilia.Source (comments) + +-- | Run something with the given variables set, and the environment as it +-- was afterwards however it turns out. +withEnvironment :: [(String, String)] -> IO a -> IO a +withEnvironment vars act = bracket set restore (const act) + where + set = traverse remember vars + remember (key, value) = do + was <- lookupEnv key + setEnv key value + pure (key, was) + restore = traverse_ (\(key, was) -> maybe (unsetEnv key) (setEnv key) was) + +-- | What to parse a module with, given what its package puts in force, or +-- 'Nothing' for a module of no package, which is read as GHC2021. +parserConfigFor :: Maybe [Extension] -> ParserConfig +parserConfigFor = + ParserConfig . fromMaybe (GHC.languageExtensions (Just GHC.GHC2021)) + +-- | What to parse a module of no package with. +defaultParserConfig :: ParserConfig +defaultParserConfig = parserConfigFor Nothing + +-- | The extensions in force in a module, given what its package puts in +-- force, or 'Nothing' for a module of no package, which starts from +-- @ImplicitPrelude@ alone. +-- +-- That is less than 'parserConfigFor' reads such a module with, so that +-- what is printed, @import qualified@ for one, reads the same under every +-- edition. +effectiveExtensionsFor :: Maybe [Extension] -> Text -> [Extension] +effectiveExtensionsFor = effectiveExtensions . fromMaybe [ImplicitPrelude] + +-- | Parse a module, or stop the test saying why it does not parse. +parsed :: Text -> ParsedModule +parsed source = case parseModule defaultParserConfig "M.hs" source of + Left problem -> error (T.unpack (describeParseError problem)) + Right m -> m + +-- | Every comment in a module. +commentsIn :: Text -> [Comment] +commentsIn = comments . pmSource . parsed + +-- | The one import blamed for an operator, unread on its own account and so +-- with nothing below it. +unreadOnly :: Text -> NonEmpty ModuleChain +unreadOnly m = ModuleChain (m :| []) :| [] + +-- | FNV-1a, a hash of a string that is the same on every machine and every +-- run. +fingerprint :: String -> Word64 +fingerprint = foldl' step 14695981039346656037 + where + step h c = (h `xor` fromIntegral (ord c)) * 1099511628211 + +-- | A 'Resolver' that reads modules by the routes given and remembers what +-- it reads. +routedResolver :: [Route] -> BuildPlan -> IO Resolver +routedResolver routes plan = do + packageReader <- newPackageReader (plannedCompiler plan) + newResolverVia (Do #useCache) routes packageReader plan + +-- | Split a module on its first outermost conditional, and on every other +-- one written behind the same directives, wherever in the module it sits. +configurations :: Text -> Maybe Configurations +configurations source = do + forest <- scanConditionals source + gs <- listToMaybe forest + pure (configurationsOn gs forest source) + +-- | Every configuration of a module, with every conditional resolved. +leaves :: Text -> Either CppError [Text] +leaves = fmap (fmap snd) . answeredLeaves + +-- | The configurations reached by varying one conditional at a time. +linearLeaves :: Text -> Either CppError [Text] +linearLeaves = fmap (fmap snd) . answeredLinearLeaves + +-- | How many configurations a module has, without building any of them, +-- and so counting those no definition of the macros gives. +countLeaves :: Text -> Either CppError Integer +countLeaves source = do + forest <- readConditionals source + pure (sum [across answers forest | answers <- combinations (afforded forest)]) + where + across answers = product . fmap (one answers) + one answers gs = case lookup (gsGuards gs) answers of + Just i -> across answers (nestedIn gs i) + Nothing -> sum [across answers (nestedIn gs i) | i <- [0 .. gsCount gs - 1]] + combinations = traverse (\(g, k) -> [(g, i) | i <- [0 .. k - 1]]) + afforded forest = go 1 (repeated forest) + where + go _ [] = [] + go n ((g, k) : rest) + | n * toInteger k <= guardsToTie = (g, k) : go (n * toInteger k) rest + | otherwise = [] + +-- | The guards a module asks more than once, and how many answers each has. +repeated :: [GroupSpec] -> [([Guard], Int)] +repeated forest = distinct Map.empty [q | q@(g, _) <- asked forest, twice g] + where + asked gss = concat [(gsGuards gs, gsCount gs) : asked (concat (gsNested gs)) | gs <- gss] + times = Map.fromListWith (+) [(g, 1 :: Int) | (g, _) <- asked forest] + twice g = Map.findWithDefault 0 g times >= 2 + + distinct _ [] = [] + distinct seen (q@(g, _) : rest) + | Map.member g seen = distinct seen rest + | otherwise = q : distinct (Map.insert g () seen) rest + +-- | How many combinations of answers 'countLeaves' will enumerate. +guardsToTie :: Integer +guardsToTie = 4096 + +-- | Every configuration some definition of the macros gives, and the +-- answers that reach it. +answeredLeaves :: Text -> Either CppError [(Assignment, Text)] +answeredLeaves = + fmap (filter (isJust . implied . Map.toList . fst)) . go Map.empty + where + go answers source = case configurations source of + Nothing | not (null (unconditionalErrors source)) -> Right [] + Nothing -> (\t -> [(answers, t)]) <$> resolved source + Just c -> + concat + <$> traverse + (\(i, t) -> go (Map.insert (cfgGuards c) i answers) t) + (zip [0 ..] (cfgTexts c)) + +-- | The same, labelled by the answers that reach each one, and for the same +-- reason as 'answeredLeaves'. +answeredLinearLeaves :: Text -> Either CppError [(Assignment, Text)] +answeredLinearLeaves = + fmap (filter (isJust . implied . Map.toList . fst)) . go Map.empty + where + go answers source = case configurations source of + Nothing -> (\t -> [(answers, t)]) <$> resolved source + Just c -> case zip [0 ..] (cfgTexts c) of + [] -> Right [] + (i, first) : rest -> + (<>) + <$> go (Map.insert (cfgGuards c) i answers) first + <*> traverse (held answers (cfgGuards c)) rest + where + held before gs (i, t) = answeredBaseline (Map.insert gs i before) t + +-- | The configuration in which every question still to be asked takes its +-- first branch, and the answers that gives. +answeredBaseline :: Assignment -> Text -> Either CppError (Assignment, Text) +answeredBaseline answers source = case configurations source of + Nothing -> (answers,) <$> resolved source + Just c -> case cfgTexts c of + [] -> Right (answers, source) + t : _ -> answeredBaseline (Map.insert (cfgGuards c) 0 answers) t diff --git a/tests/Tilia/WithProjectPlan.hs b/tests/Tilia/WithProjectPlan.hs --- a/tests/Tilia/WithProjectPlan.hs +++ b/tests/Tilia/WithProjectPlan.hs @@ -24,6 +24,13 @@ import System.FilePath (takeDirectory, ()) import System.IO.Unsafe (unsafePerformIO) import Test.Hspec (Spec) +import Tilia.Cabal.Plan + ( BuildPlan (..), + PackageSource (..), + PlanPackage (..), + loadPlan, + plannedTarballs, + ) import Tilia.Cabal.Project (findProjectRoot) import Tilia.Cabal.Target ( Target (..), @@ -36,13 +43,6 @@ ( Installed (..), InstalledPackage (..), readInstalledPackages, - ) -import Tilia.Fixity.Plan - ( BuildPlan (..), - PackageSource (..), - PlanPackage (..), - loadPlan, - plannedTarballs, ) import Tilia.Process (readProgramOutput) diff --git a/tilia.cabal b/tilia.cabal --- a/tilia.cabal +++ b/tilia.cabal @@ -1,8 +1,9 @@ cabal-version: 2.4 name: tilia -version: 0.1.1.0 +version: 0.1.2.0 license: BSD-3-Clause license-file: LICENSE.md +author: Mark Karpov maintainer: Mark Karpov tested-with: ghc ==9.10.3 @@ -20,6 +21,7 @@ corpora/hackage/hackage.manifest corpora/hackage/hackage.report corpora/vendored/**/*.hs + corpora/vendored/**/*.hsig extra-doc-files: CHANGELOG.md @@ -34,9 +36,25 @@ default: False manual: True +common common-ghc-options + ghc-options: + -O2 + -Wall + + if flag(dev) + ghc-options: + -Werror + -Wredundant-constraints + -Wpartial-fields + -Wunused-packages + -haddock + -Winvalid-haddock + library + import: common-ghc-options exposed-modules: Tilia.Cabal.Package + Tilia.Cabal.Plan Tilia.Cabal.Project Tilia.Cabal.Target Tilia.Comments @@ -56,7 +74,7 @@ Tilia.Editor Tilia.Equivalence Tilia.Fixity - Tilia.Fixity.ByHand + Tilia.Fixity.Archive Tilia.Fixity.Cabal Tilia.Fixity.Cache Tilia.Fixity.Debug @@ -71,13 +89,13 @@ Tilia.Gathered Tilia.Ignore Tilia.Imports + Tilia.Memo Tilia.Newline Tilia.Palette Tilia.Parser Tilia.Pragma Tilia.Process Tilia.Render - Tilia.Render.Body Tilia.Render.Class Tilia.Render.Context Tilia.Render.Data @@ -106,7 +124,7 @@ Cabal-syntax >=3.12 && <3.17, aeson >=2.1 && <3, array >=0.5 && <0.6, - base >=4.14 && <5, + base >=4.20 && <5, base16-bytestring >=1 && <2, bytestring >=0.11 && <0.13, choice >=0.2 && <0.3, @@ -124,29 +142,15 @@ transformers >=0.5 && <0.7, zlib >=0.6 && <0.8, - if flag(dev) - ghc-options: - -O2 - -Wall - -Werror - -Wredundant-constraints - -Wpartial-fields - -Wunused-packages - -haddock - -Winvalid-haddock - else - ghc-options: - -O2 - -Wall - executable tilia + import: common-ghc-options main-is: Main.hs hs-source-dirs: app other-modules: Paths_tilia autogen-modules: Paths_tilia default-language: GHC2021 build-depends: - base >=4.14 && <5, + base >=4.20 && <5, bytestring >=0.11 && <0.13, choice >=0.2 && <0.3, directory ^>=1.3, @@ -156,37 +160,23 @@ -- Twelve capabilities rather than -N, because formatting a project stops -- getting faster well before a machine runs out of cores and every - -- capability past that point costs about 40 MiB and 0.15s of CPU while - -- formatting nothing. Over this project's 43 files: 1.88s at -N1, 575ms - -- at -N8, 518ms at -N12, 499ms at -N16, and back to 509ms at -N24. Asking - -- for -N here instead is the same wall time as -N12 give or take noise, - -- for 50% more CPU and 940 MiB against 520 MiB. Twelve is no worse on a - -- smaller machine either: pinned to four cores it lands within 3% of -N4. + -- capability past that point costs about 35 MiB and 0.2s of CPU while + -- formatting nothing. Over this project's 109 files: 2.42s at -N1, 690ms + -- at -N8, 560ms at -N12, 590ms at -N16, and 600ms at -N24. Asking for -N + -- here instead is the same wall time as -N12 give or take noise, for 50% + -- more CPU and 1100 MiB against 680 MiB. Twelve is no worse on a smaller + -- machine either: pinned to four cores it is 4% faster than -N4. -- -- The nursery is the flag that pays for itself. At the default size the - -- same run takes 828ms rather than 522ms, which is what the extra 320 MiB + -- same run takes 810ms rather than 560ms, which is what the extra 270 MiB -- buys. ghc-options: -threaded -rtsopts "-with-rtsopts=-N12 -A32m" - if flag(dev) - ghc-options: - -O2 - -Wall - -Werror - -Wredundant-constraints - -Wpartial-fields - -Wunused-packages - -haddock - -Winvalid-haddock - else - ghc-options: - -O2 - -Wall - test-suite tests + import: common-ghc-options type: exitcode-stdio-1.0 main-is: Main.hs build-tool-depends: hspec-discover:hspec-discover >=2 && <3 @@ -230,13 +220,14 @@ Tilia.RenderSpec Tilia.RunSpec Tilia.TestConfig + Tilia.TestUtils Tilia.WithProjectPlan default-language: GHC2021 build-depends: QuickCheck >=2.14 && <3, array >=0.5 && <0.6, - base >=4.14 && <5, + base >=4.20 && <5, base16-bytestring >=1 && <2, bytestring >=0.11 && <0.13, choice >=0.2 && <0.3, @@ -260,22 +251,8 @@ -rtsopts "-with-rtsopts=-M8G -N" - if flag(dev) - ghc-options: - -O2 - -Wall - -Werror - -Wredundant-constraints - -Wpartial-fields - -Wunused-packages - -haddock - -Winvalid-haddock - else - ghc-options: - -O2 - -Wall - benchmark bench + import: common-ghc-options type: exitcode-stdio-1.0 main-is: Main.hs hs-source-dirs: @@ -290,11 +267,12 @@ Tilia.BootFixities Tilia.Corpus Tilia.TestConfig + Tilia.TestUtils c-sources: bench/cbits/counter.c default-language: GHC2021 build-depends: - base >=4.14 && <5, + base >=4.20 && <5, base16-bytestring >=1 && <2, bytestring >=0.11 && <0.13, choice >=0.2 && <0.3, @@ -317,18 +295,3 @@ -threaded -rtsopts "-with-rtsopts=-N1 -A1g -O1g -C1000 -T" - - if flag(dev) - ghc-options: - -O2 - -Wall - -Werror - -Wredundant-constraints - -Wpartial-fields - -Wunused-packages - -haddock - -Winvalid-haddock - else - ghc-options: - -O2 - -Wall