tilia 0.1.1.0 → 0.1.2.0

raw patch · 152 files changed

+4573/−3866 lines, 152 filesdep ~basePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• CHANGELOG.md +38/−0
• README.md +1/−0
• app/Main.hs +4/−5
• bench/Tilia/Bench/Cases.hs +18/−30
• bench/Tilia/Bench/Fixity.hs +9/−8
• bench/bench.record +56/−56
• corpora/hackage/hackage.manifest +40/−40
• corpora/vendored/declaration/value/fixity-local-to-a-binding-out.hs +29/−0
• corpora/vendored/declaration/value/fixity-local-to-a-binding.hs +29/−0
• corpora/vendored/declaration/value/fixity-without-a-precedence-out.hs +24/−0
• corpora/vendored/declaration/value/fixity-without-a-precedence.hs +21/−0
• corpora/vendored/declaration/value/layout-as-written-out.hs +8/−0
• corpora/vendored/declaration/value/layout-as-written.hs +8/−0
• corpora/vendored/declaration/value/operator-beginning-with-a-hash-out.hs +23/−0
• corpora/vendored/declaration/value/operator-beginning-with-a-hash.hs +23/−0
• corpora/vendored/declaration/value/operator-chains-out.hs +18/−0
• corpora/vendored/declaration/value/operator-chains.hs +16/−0
• corpora/vendored/import/qualified-after-the-module-name-out.hs +6/−0
• corpora/vendored/import/qualified-after-the-module-name.hs +4/−0
• corpora/vendored/import/qualified-before-the-module-name-out.hs +4/−0
• corpora/vendored/import/qualified-before-the-module-name.hs +3/−0
• corpora/vendored/other/comment-beside-a-wildcard-out.hs +19/−0
• corpora/vendored/other/comment-beside-a-wildcard.hs +18/−0
• corpora/vendored/other/comment-carried-on-under-a-remark-and-more-out.hs +20/−0
• corpora/vendored/other/comment-carried-on-under-a-remark-and-more.hs +20/−0
• corpora/vendored/other/comment-under-a-quasi-quotation-out.hs +19/−0
• corpora/vendored/other/comment-under-a-quasi-quotation.hs +19/−0
• corpora/vendored/other/comments-beside-an-alternative-and-a-bracket-out.hs +16/−0
• corpora/vendored/other/comments-beside-an-alternative-and-a-bracket.hs +16/−0
• corpora/vendored/other/comments-beside-the-where-of-the-header-out.hs +10/−0
• corpora/vendored/other/comments-beside-the-where-of-the-header.hs +10/−0
• corpora/vendored/other/comments-kept-where-written-out.hs +17/−0
• corpora/vendored/other/comments-kept-where-written.hs +17/−0
• corpora/vendored/other/comments-where-they-are-hard-to-put-back-out.hs +25/−0
• corpora/vendored/other/comments-where-they-are-hard-to-put-back.hs +25/−0
• corpora/vendored/other/cpp/code-after-an-optional-prefix-out.hs +32/−0
• corpora/vendored/other/cpp/code-after-an-optional-prefix.hs +32/−0
• corpora/vendored/other/cpp/where-after-an-export-list-in-a-conditional-out.hs +16/−0
• corpora/vendored/other/cpp/where-after-an-export-list-in-a-conditional.hs +15/−0
• corpora/vendored/other/extension-pack-before-what-it-enables-out.hs +4/−0
• corpora/vendored/other/extension-pack-before-what-it-enables.hs +3/−0
• corpora/vendored/other/extension-taken-back-from-the-edition-out.hs +6/−0
• corpora/vendored/other/extension-taken-back-from-the-edition.hs +4/−0
• corpora/vendored/other/language-pragmas-split-and-sorted-out.hs +4/−0
• corpora/vendored/other/language-pragmas-split-and-sorted.hs +2/−0
• corpora/vendored/signature/abstract-data-with-a-kind-out.hsig +7/−0
• corpora/vendored/signature/abstract-data-with-a-kind.hsig +6/−0
• corpora/vendored/signature/class-and-instances-out.hsig +10/−0
• corpora/vendored/signature/class-and-instances.hsig +10/−0
• corpora/vendored/signature/comments-after-the-last-declaration-out.hsig +10/−0
• corpora/vendored/signature/comments-after-the-last-declaration.hsig +10/−0
• corpora/vendored/signature/comments-in-a-signature-out.hsig +10/−0
• corpora/vendored/signature/comments-in-a-signature.hsig +10/−0
• corpora/vendored/signature/consecutive-type-signatures-out.hsig +7/−0
• corpora/vendored/signature/consecutive-type-signatures.hsig +5/−0
• corpora/vendored/signature/documented-declarations-out.hsig +7/−0
• corpora/vendored/signature/documented-declarations.hsig +7/−0
• corpora/vendored/signature/everything-above-the-keyword-out.hsig +8/−0
• corpora/vendored/signature/everything-above-the-keyword.hsig +8/−0
• corpora/vendored/signature/exports-listed-out.hsig +12/−0
• corpora/vendored/signature/exports-listed.hsig +12/−0
• corpora/vendored/signature/fixity-declaration-out.hsig +7/−0
• corpora/vendored/signature/fixity-declaration.hsig +7/−0
• corpora/vendored/signature/type-family-out.hsig +11/−0
• corpora/vendored/signature/type-family.hsig +11/−0
• corpora/vendored/signature/type-role-annotation-out.hsig +7/−0
• corpora/vendored/signature/type-role-annotation.hsig +7/−0
• src/Tilia/Cabal/Package.hs +72/−39
• src/Tilia/Cabal/Plan.hs +824/−0
• src/Tilia/Cabal/Project.hs +14/−5
• src/Tilia/Cabal/Target.hs +35/−60
• src/Tilia/Comments.hs +58/−36
• src/Tilia/Comments/Attach.hs +3/−11
• src/Tilia/Comments/Place.hs +6/−8
• src/Tilia/Cpp.hs +73/−106
• src/Tilia/Cpp/Directives.hs +22/−131
• src/Tilia/Cpp/Fragment.hs +3/−3
• src/Tilia/Cpp/Macros.hs +4/−7
• src/Tilia/Cpp/Merge.hs +34/−20
• src/Tilia/Cpp/Place.hs +17/−7
• src/Tilia/Diff.hs +5/−20
• src/Tilia/Doc.hs +1/−5
• src/Tilia/Doc/Combinators.hs +0/−2
• src/Tilia/Doc/Internal.hs +12/−32
• src/Tilia/Editor.hs +21/−19
• src/Tilia/Equivalence.hs +2/−5
• src/Tilia/Fixity.hs +9/−0
• src/Tilia/Fixity/Archive.hs +104/−0
• src/Tilia/Fixity/ByHand.hs +0/−33
• src/Tilia/Fixity/Cabal.hs +13/−32
• src/Tilia/Fixity/Cache.hs +51/−26
• src/Tilia/Fixity/Debug.hs +10/−3
• src/Tilia/Fixity/HiFile.hs +5/−12
• src/Tilia/Fixity/Interface.hs +4/−16
• src/Tilia/Fixity/PackageDb.hs +4/−8
• src/Tilia/Fixity/Plan.hs +932/−1895
• src/Tilia/Format.hs +75/−24
• src/Tilia/Imports.hs +8/−10
• src/Tilia/Memo.hs +118/−0
• src/Tilia/Palette.hs +2/−2
• src/Tilia/Parser.hs +7/−37
• src/Tilia/Pragma.hs +25/−17
• src/Tilia/Render.hs +8/−5
• src/Tilia/Render/Body.hs +0/−85
• src/Tilia/Render/Class.hs +11/−22
• src/Tilia/Render/Context.hs +16/−12
• src/Tilia/Render/Data.hs +9/−20
• src/Tilia/Render/Declaration.hs +5/−1
• src/Tilia/Render/Expression.hs +133/−74
• src/Tilia/Render/Haddock.hs +2/−23
• src/Tilia/Render/Header.hs +50/−49
• src/Tilia/Render/Layout.hs +7/−7
• src/Tilia/Render/Literal.hs +3/−3
• src/Tilia/Render/Name.hs +2/−2
• src/Tilia/Render/Operator.hs +9/−4
• src/Tilia/Render/Pattern.hs +6/−11
• src/Tilia/Render/Pragma.hs +1/−1
• src/Tilia/Render/Signature.hs +7/−8
• src/Tilia/Render/Type.hs +24/−14
• src/Tilia/Run.hs +13/−6
• src/Tilia/Source.hs +5/−3
• src/Tilia/Source/Lines.hs +24/−1
• src/Tilia/Span.hs +5/−0
• src/Tilia/Span/Ghc.hs +7/−31
• src/Tilia/Utils.hs +28/−0
• tests/Main.hs +1/−10
• tests/Tilia/Cabal/PackageSpec.hs +1/−1
• tests/Tilia/Comments/PlaceSpec.hs +1/−7
• tests/Tilia/CommentsSpec.hs +3/−11
• tests/Tilia/Corpus.hs +28/−35
• tests/Tilia/CorpusSpec.hs +32/−32
• tests/Tilia/Cpp/PropertiesSpec.hs +3/−2
• tests/Tilia/CppSpec.hs +28/−2
• tests/Tilia/Doc/BodySpec.hs +1/−1
• tests/Tilia/Doc/CombinatorsSpec.hs +1/−1
• tests/Tilia/Doc/InternalSpec.hs +1/−1
• tests/Tilia/Doc/PropertiesSpec.hs +1/−1
• tests/Tilia/EditorSpec.hs +137/−25
• tests/Tilia/EquivalenceSpec.hs +2/−12
• tests/Tilia/Fixity/CacheSpec.hs +6/−9
• tests/Tilia/Fixity/DebugSpec.hs +5/−6
• tests/Tilia/Fixity/DependenciesSpec.hs +5/−3
• tests/Tilia/Fixity/HiFileSpec.hs +4/−8
• tests/Tilia/Fixity/PlanSpec.hs +67/−71
• tests/Tilia/FixitySpec.hs +1/−11
• tests/Tilia/PragmaSpec.hs +22/−15
• tests/Tilia/RenderSpec.hs +30/−358
• tests/Tilia/RunSpec.hs +1/−5
• tests/Tilia/TestConfig.hs +38/−6
• tests/Tilia/TestUtils.hs +222/−0
• tests/Tilia/WithProjectPlan.hs +7/−7
• tilia.cabal +37/−74

@@ -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

@@ -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,

@@ -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 ->

@@ -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)

@@ -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.

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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 = (++)

@@ -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 = (++)

@@ -0,0 +1,8 @@+module M where++onOneLine x = (x, x)++spreadOut x =+  ( x,+    x+  )

@@ -0,0 +1,8 @@+module M where++onOneLine x = (x, x)++spreadOut x =+  ( x,+    x+  )

@@ -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) []

@@ -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) []

@@ -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

@@ -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

@@ -0,0 +1,6 @@+{-# LANGUAGE ImportQualifiedPost #-}++module M where++import Data.Map qualified as M+import Data.Set qualified as S

@@ -0,0 +1,4 @@+{-# LANGUAGE ImportQualifiedPost #-}+module M where+import Data.Map qualified as M+import qualified Data.Set as S

@@ -0,0 +1,4 @@+module M where++import qualified Data.Map as M+import qualified Data.Set as S

@@ -0,0 +1,3 @@+module M where+import Data.Map qualified as M+import qualified Data.Set as S

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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 ()

@@ -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 ()

@@ -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+  ]

@@ -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+  ]

@@ -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

@@ -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

@@ -0,0 +1,17 @@+module M where++-- a note+between = 1++inside = g+  where+    -- about g+    g = 1++selfDelimiting =+  {- here -} 1++notOnOneLine =+  ( -- here+    1+  )

@@ -0,0 +1,17 @@+module M where++-- a note+between = 1++inside = g+  where+    -- about g+    g = 1++selfDelimiting =+  {- here -} 1++notOnOneLine =+  ( -- here+    1+  )

@@ -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+  ]

@@ -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+  ]

@@ -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

@@ -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

@@ -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

@@ -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

@@ -0,0 +1,4 @@+{-# LANGUAGE GHC2021 #-}+{-# LANGUAGE ApplicativeDo #-}++module M where

@@ -0,0 +1,3 @@+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE GHC2021 #-}+module M where

@@ -0,0 +1,6 @@+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE NoStarIsType #-}++module M (type (*)) where++import GHC.TypeLits (type (*))

@@ -0,0 +1,4 @@+{-# LANGUAGE NoStarIsType #-}+{-# LANGUAGE TypeOperators #-}+module M (type (*)) where+import GHC.TypeLits (type (*))

@@ -0,0 +1,4 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}++module M where

@@ -0,0 +1,2 @@+{-# LANGUAGE OverloadedStrings, GADTs #-}+module M where

@@ -0,0 +1,7 @@+signature Shape where++import Data.Kind (Type)++data Shape :: Type++data Pair :: Type -> Type -> Type

@@ -0,0 +1,6 @@+signature Shape where++import Data.Kind (Type)++data Shape :: Type+data Pair :: Type -> Type -> Type

@@ -0,0 +1,10 @@+signature Ordered where++data Item++class Sized a where+  size :: a -> Int++instance Sized Item++instance Eq Item

@@ -0,0 +1,10 @@+signature Ordered where++data Item++class Sized a where+  size :: a -> Int++instance Sized Item++instance Eq Item

@@ -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

@@ -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

@@ -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 ()

@@ -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 ()

@@ -0,0 +1,7 @@+signature Store where++data Handle++open :: FilePath -> IO Handle++close :: Handle -> IO ()

@@ -0,0 +1,5 @@+signature Store where++data Handle+open :: FilePath -> IO Handle+close :: Handle -> IO ()

@@ -0,0 +1,7 @@+signature Clock where++-- | A reading of the wall clock.+data Instant++-- | The moment this was asked for.+now :: IO Instant

@@ -0,0 +1,7 @@+signature Clock where++-- | A reading of the wall clock.+data Instant++-- | The moment this was asked for.+now :: IO Instant

@@ -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

@@ -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

@@ -0,0 +1,12 @@+signature Codec+  ( Codec,+    encode,+    decode,+  )+where++data Codec++encode :: Codec -> String++decode :: String -> Maybe Codec

@@ -0,0 +1,12 @@+signature Codec+  ( Codec,+    encode,+    decode,+  )+where++data Codec++encode :: Codec -> String++decode :: String -> Maybe Codec

@@ -0,0 +1,7 @@+signature Combine where++data Chunk++infixr 5 <+>++(<+>) :: Chunk -> Chunk -> Chunk

@@ -0,0 +1,7 @@+signature Combine where++data Chunk++infixr 5 <+>++(<+>) :: Chunk -> Chunk -> Chunk

@@ -0,0 +1,11 @@+{-# LANGUAGE TypeFamilies #-}++signature Element where++data Container++type family Elem c++type Name = String++elems :: Container -> [Elem Container]

@@ -0,0 +1,11 @@+{-# LANGUAGE TypeFamilies #-}++signature Element where++data Container++type family Elem c++type Name = String++elems :: Container -> [Elem Container]

@@ -0,0 +1,7 @@+{-# LANGUAGE RoleAnnotations #-}++signature Cache where++type role Cache nominal representational++data Cache k v

@@ -0,0 +1,7 @@+{-# LANGUAGE RoleAnnotations #-}++signature Cache where++type role Cache nominal representational++data Cache k v

@@ -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

@@ -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

@@ -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)

@@ -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               ]

@@ -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. --

@@ -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 ::

@@ -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)

@@ -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

@@ -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

@@ -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)

@@ -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

@@ -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

@@ -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

@@ -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)]

@@ -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

@@ -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 

@@ -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

@@ -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'.

@@ -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)]

@@ -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

@@ -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"

@@ -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])

@@ -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.

@@ -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

@@ -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

@@ -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)}

@@ -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.

@@ -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

@@ -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)