diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,177 @@ +## Tilia 0.1.3.0 + +* An empty context comes out as written in a class or a data declaration, + as in `class () => C a`, and before a constructor, as in + `forall a. () => C a`, rather than being dropped, as it was already kept + in a signature and in a GADT constructor. + [Issue 299](https://github.com/mrkkrp/tilia/issues/299). +* Extensions turned on or off with flags in an `OPTIONS_GHC` pragma, or in + the older `OPTIONS` pragma, such as `-cpp`, `-XLambdaCase`, + `-fglasgow-exts` and `-fbang-patterns`, are taken into account, so a + module that needs them is parsed as GHC parses it. + [Issue 280](https://github.com/mrkkrp/tilia/issues/280). +* An `OPTIONS` pragma in the header is sorted with the `OPTIONS_GHC` + pragmas, keeping the order the two are written in among each other, rather + than being left where it was written. + [PR 319](https://github.com/mrkkrp/tilia/pull/319). +* An extension that turns another off, as `RebindableSyntax` turns off + `ImplicitPrelude`, does so where it is turned on, as with GHC, so under + `RebindableSyntax` the Prelude is not taken to be imported, and an import + of it sorts among the others, as under `NoImplicitPrelude`. + [PR 319](https://github.com/mrkkrp/tilia/pull/319). +* The pragmas of a header keep the order they are written in where sorting + them would leave other extensions in force, as with `NoMonoLocalBinds` + written above `TypeFamilies`, which turns `MonoLocalBinds` back on, or + with an option turning off an extension a later `LANGUAGE` pragma turns + on; and editions, of which GHC takes the last, keep their order among + each other. [PR 319](https://github.com/mrkkrp/tilia/pull/319). +* An options pragma written twice in a row is kept twice rather than + written once, since a flag such as `-fplugin-opt` counts each time it is + given. [PR 322](https://github.com/mrkkrp/tilia/pull/322). +* A pragma written below the `module` line, which GHC does not read, stays + where it is written rather than being moved above the line, where it + takes effect, and the module is parsed without what it names, as GHC + parses it. [Issue 288](https://github.com/mrkkrp/tilia/issues/288). +* `--check-ast` reads the pragmas of the header as GHC reads them, and + reports a module whose formatting would change the order of the flags of + its options, its `OPTIONS_HADDOCK` pragmas, or how GHC's own flag reader + takes them to switch extensions, the edition or the Safe Haskell mode. + [PR 322](https://github.com/mrkkrp/tilia/pull/322). +* An edition of the language a module names in its header, as in + `{-# LANGUAGE GHC2024 #-}` or with `-XGHC2024`, takes the place of the + `default-language` of its component, as with GHC, and what + `default-extensions` and the module's pragmas switch is switched on top + of it. [Issue 321](https://github.com/mrkkrp/tilia/issues/321). +* An extension turned off after one that implies it, as `NoExplicitForAll` + after `RankNTypes`, stays off when the module is parsed, as with GHC, + rather than being turned back on. + [PR 323](https://github.com/mrkkrp/tilia/pull/323). +* The `LANGUAGE` pragmas of a header are sorted by name after the + editions, rather than with the names that turn an extension off, and then + `ImplicitPrelude` and `CUSKs`, after the rest; where sorting them would + change what is in force, they keep the order they are written in, as + before. [PR 323](https://github.com/mrkkrp/tilia/pull/323). +* A `LANGUAGE` pragma holding a comment, as in `, PolyKinds -- for T` on + one of its lines, is read past the comment, as GHC reads it, and kept as + written, rather than taking the name and the comment together for a name + and putting the comment before the `#-}` of a pragma of its own, which GHC + could not read. [Issue 324](https://github.com/mrkkrp/tilia/issues/324). +* `--debug-fixity` says that the imports disagree about a constructor + written among types, as a promoted constructor is, where a run declines + the module over it, rather than showing its fixity settled. + [Issue 304](https://github.com/mrkkrp/tilia/issues/304). +* `.tiliaignore` files and the cache are read and written as UTF-8 whatever + the locale, so under `LANG=C` a `.tiliaignore` holding a character + outside ASCII no longer makes `check` and `inplace` crash, nor + `for-editor` format what it ignores, and what the cache holds about an + operator or a path with such a character is no longer worked out again on + every run. The cache starts anew, so the first run after upgrading works + everything out again. [Issue 290](https://github.com/mrkkrp/tilia/issues/290). +* Where the plan gives no hash to check a dependency's tarball against, a + tarball that is not gzip, or is cut short, leaves its package unread, so + that a module needing its fixities is declined, rather than ending the + run. [Issue 303](https://github.com/mrkkrp/tilia/issues/303). +* The body of a typed Template Haskell quote written over several lines, as + in `[|| … ||]`, is indented under its opening bracket together with its + closing one, as that of an untyped quote is, rather than coming out at + the column of the brackets. + [Issue 300](https://github.com/mrkkrp/tilia/issues/300). +* A name an as-pattern binds at the top level, as `plus` in + `plus@_ = (+)`, is taken for the module's own, rather than a module using + it being declined where an import could not be read; a name bound inside + the function of a view pattern, on the other hand, is not. + [Issue 301](https://github.com/mrkkrp/tilia/issues/301). +* A module that re-exports the members of a type without the type, such as + the methods of a class named by an operator, is no longer taken to declare + the type's fixity, and a name a decoded interface file re-exports takes + the fixity it has in the namespace it is exported in, as a type or as a + term, rather than in both. + [Issue 302](https://github.com/mrkkrp/tilia/issues/302). +* A conditional that begins among the bindings of a `where` clause and goes + on into the declarations after it stays whole where the bindings are + indented with a tab, as it already did where they are indented with + spaces, rather than coming out in two. + [Issue 297](https://github.com/mrkkrp/tilia/issues/297). +* A line that holds nothing but a use of a function-like macro and is + indented with a tab is taken to be at the column the tab moves it to, as + GHC takes it, rather than at the count of characters before it. One at the + column of the code under it is put back as written, rather than the module + being declined where the use does not read as code, and one further in is + read as code that carries on the line above, rather than put back at the + level of the code under it. + [PR 333](https://github.com/mrkkrp/tilia/pull/333). +* A sub-library is looked for in the build plan under `lib:` and its name, + as the plan writes it, rather than as the main library, so a package + whose only library is a named one no longer makes the first run under a + plan `cabal` solved ask it to solve again, and a sub-library the plan + leaves out no longer counts as planned where the main library is. + [Issue 296](https://github.com/mrkkrp/tilia/issues/296). +* A source directory that two packages name through different paths, as + `shared` in one and `../a/shared` in the other, is taken to be one + directory, so `check` and `inplace` format each module in it once, rather + than once under each path. + [Issue 295](https://github.com/mrkkrp/tilia/issues/295). +* A module that no `.cabal` file above it names, as one in a directory + outside every package that packages of the project share through `..`, + takes what a package of the project that names it puts in force, rather + than failing for want of a `.cabal` file, and the fixities it declares + are known to the modules importing it, rather than their being declined. + [Issue 295](https://github.com/mrkkrp/tilia/issues/295). +* A character literal holding a double quote, as in `'"'`, is read as one, + rather than as the start of a string, so a `{-# LINE #-}` written in a + string after it no longer has the module declined, and one written in the + code after it is no longer missed. + [Issue 292](https://github.com/mrkkrp/tilia/issues/292). +* A line that holds nothing but a use of a function-like macro is put back + at the indentation of the code under it, as it is written, rather than a + step further in wherever what is around it begins on a line above. One + among the statements of a `do` block, or between the equations of a + function, no longer comes out carrying on the line above it. + [Issue 279](https://github.com/mrkkrp/tilia/issues/279). +* A file whose formatting throws an exception is reported as failing, with + the exception, rather than the exception ending the run with "thread + blocked indefinitely in an MVar operation" and leaving every other file + unwritten and unreported. + [Issue 291](https://github.com/mrkkrp/tilia/issues/291). +* A dependency whose source is still missing after a download is no + longer downloaded again on every run, nor is `cabal` asked twice where it + keeps sources, which formatting on save paid for each time: what a + download does not bring in is remembered under the plan, as it already + was where the plan did not cover a component. + [Issue 289](https://github.com/mrkkrp/tilia/issues/289). +* An entry of the `packages` field of a `cabal.project` that begins with + dots or a slash, as `../lib`, `/abs/lib` or `.hidden`, is looked for where + it points, as `cabal` looks for it, rather than under the project with the + dots and the slash taken off, where it was usually not found and passed + over. [Issue 294](https://github.com/mrkkrp/tilia/issues/294). +* A string literal comes out as written wherever it is: its gaps line up + under its opening quote in a pattern and in a `WARNING` or `DEPRECATED` + message, as they already did in an expression, a rule's name is no longer + escaped again, as `"f/∘"` was into `"f/\8728"`, and an `SCC` label + written without quotes no longer gains them. + [PR 344](https://github.com/mrkkrp/tilia/pull/344). +* Top-level splices written one after another stay together across a + comment or a preprocessor line between them, as standalone `deriving` + declarations already did, rather than having blank lines put between + them. [PR 344](https://github.com/mrkkrp/tilia/pull/344). +* An interrupt arriving while a package or a file is read stops the run, + rather than being taken for that read failing. + [PR 344](https://github.com/mrkkrp/tilia/pull/344). +* A run reads the build plan once where nothing is missing, and the sources + of each dependency and the `.cabal` file of each package of the project + once rather than once per component. + [PR 344](https://github.com/mrkkrp/tilia/pull/344). +* A package declaring `cabal-version: 3.14`, `3.16` or `3.18` can be + formatted, as `.cabal` files are read with Cabal-syntax 3.18 whichever + compiler builds Tilia, where the release binaries, built with GHC 9.10.3 + and so Cabal-syntax 3.12, said its `.cabal` file did not parse. The + release binaries are now built with GHC 9.14.1. + [PR 345](https://github.com/mrkkrp/tilia/pull/345). +* The `.cabal` file of a dependency is read with Cabal-syntax, as the + project's own are, rather than line by line, so a line of its description + that begins with the name of a field is no longer taken for that field. + [PR 345](https://github.com/mrkkrp/tilia/pull/345). + ## Tilia 0.1.2.0 * A comment written beside the `..` of an item of an import or export list, diff --git a/HACKING.md b/HACKING.md new file mode 100644 --- /dev/null +++ b/HACKING.md @@ -0,0 +1,185 @@ +# Hacking + +Enter the development shell by either running `direnv allow` or `nix +develop`. Once in the shell, the development is ordinary Cabal: + +```console +$ cabal build +$ cabal test +``` + +All tests are in one test suite and there are a fair number of them. On my +machine the full test suite passes in 140 seconds, but it may be different +for you, so isolating a subset of the test suite may be helpful: + +```console +$ cabal test --test-options='--match "Tilia.Fixity"' +``` + +The test suite will perform downloads the first time you run it and so it +will be a bit slower on that run. It needs various corpora, such as Hackage +packages and GHC's own test suite, which are not checked into this +repository. + +The Hackage corpus is exercised in order to ensure that every module +formats, that its AST is preserved, and that formatting it is idempotent. +The results are recorded in `corpora/hackage/hackage.manifest`. Next to it, +`hackage.report` explains the failing cases. The manifest and the report can +be updated like this: + +```console +$ TILIA_CORPUS_ACCEPT=1 cabal test +``` + +Finally, Tilia formats itself, so make sure to run this command before you +open a PR: + +```console +$ nix run .#format +``` + +## Benchmarks + +The benchmarks format a fixed sample of the Hackage corpus, check what most +of its modules are printed as the way `--check-ast` does, and format a few +modules made to stress one part of the formatter each. They also work out +fixities the ways a run does: they read every module of a dozen packages of +the corpus out of their tarballs, as a run with a cold cache does, read the +same out of a cache, as a warm run does, and decode the interfaces of a few +packages the compiler ships with. They take about 45 seconds: + +```console +$ cabal bench +``` + +What each benchmark allocates and the instructions it retires are the same +from one run to the next to a hundredth of a percent, however busy the +machine is, so they are kept in `bench/bench.record` and checked like the +corpus is. The run fails where a benchmark allocates or retires 0.5% more +or less than the record says, or where all the benchmarks of a stage +together do 0.05% more or less. Update the record like this, and review the +change to it like any other: + +```console +$ TILIA_BENCH_ACCEPT=1 cabal bench +``` + +What is allocated depends on the compiler, so the record is made with the +base compiler, and CI checks it there. The instructions depend on the +processor as well, so they are checked only on the processor the record +names, where Linux lets a process count them; elsewhere the run says so and +checks the rest. What decoding the interfaces costs depends on what they +hold, which can differ between builds of one compiler, so the record keeps a +digest of their names and sizes, and decoding is checked only where it +matches; the bytes alone differ between two builds in fingerprints that cost +nothing to decode. The benchmarks run with `-A1g -O1g -C1000`, in about 1.2 +GiB, so that few collections fall inside one, and no major one or context +switch: the collector's own instructions depend on where in the work it +runs, which any change to what is allocated moves, and a major collection or +a context switch makes the counts depend on the rest of the heap and on the +clock. The benchmarks of one module or package run on their own with +`--match`, and updating the record then changes only their lines: + +```console +$ cabal bench --benchmark-options='--match QuickCheck' +``` + +To compare two versions on another processor, save what one measures and +compare the other with it, which shows the instructions and the time of +all the benchmarks together and the benchmarks that moved most: + +```console +$ cabal bench --benchmark-options='--save /tmp/before' +$ cabal bench --benchmark-options='--baseline /tmp/before' +``` + +Time is not recorded: on a quiet machine the time of all the benchmarks +together moves by about 1% from one run to the next, and the time of one of +them by up to 13%, even with `--runs 3`, which measures each three times and +takes the fastest. On a busy machine it moves by far more. + +## Adding a GHC version + +Tilia is built and tested with every compiler in the `compilers` list in +`flake.nix`. To add a major version of GHC: + +1. Add it to `compilers` in `flake.nix`, where the list goes from the oldest + version to the newest. If `haskell.nix` does not know the compiler yet, + update it first with `nix flake update haskellNix`. This also gives the + compiler a development shell, such as `nix develop .#ghc9161`. +2. Add it to the `build` matrix in `.github/workflows/ci.yaml` and number + the shards again, so that with `n` entries each takes its own `i/n`. The + test groups named in `compilerBound` in `tests/Main.hs` run on every + entry, and the rest of the suite is split between them. +3. Add it to `tested-with` in `tilia.cabal`, and widen the bounds for the + new versions of boot libraries. Bump `index-state` in `cabal.project` if + the plan needs newer releases from Hackage. +4. Generate the table of names that the series writes into interface files + as keys, with the new compiler: + + ```console + $ ./generate-known-keys.py --ghc /path/to/ghc-9.16.1/bin/ghc + ``` + + This writes `src/Tilia/Fixity/KnownKeys/GhcNNN.hs`, which goes into + `exposed-modules` in `tilia.cabal`. +5. Teach `Tilia.Fixity.HiFile` to read the interface files of the series: a + new `Series` constructor, its version in `hiFile`, its table in + `keyedNames`, its `primops` in `primopFixities`, and whatever the series + changed in the layout that `hiFile`, `payload`, `pointer`, and `fixity` + read. GHC's `GHC.Iface.Binary` and `GHC.Unit.Module.ModIface`, compared + between the two series, show what changed. Tilia passes interface it + cannot decode to `ghc --show-iface`, which works but costs a process per + interface. The tests fail until every interface of the project's + dependencies decodes and agrees with `ghc --show-iface` where the two are + compared: + + ```console + $ nix develop .#ghc9161 -c cabal test --test-options='--match "Tilia.Fixity"' + ``` + +6. Update `CHANGELOG.md`. + +`baseCompiler` in `flake.nix` names the base compiler, the newest of +`compilers`: it builds the release binaries, runs weeder, the self-format +checks and the benchmarks, and provides the default development shell. When +it changes, update `GHC_VERSION` in `.github/workflows/release.yaml` to +match, as well as the `restore-keys` of the `format` job and the compiler +of the `bench` job in `ci.yaml`, and record the benchmarks again with the +new base compiler. + +## Switching `ghc-lib-parser` + +To switch to another version of `ghc-lib-parser`: + +1. Change the bounds on `ghc-lib-parser` in the stanza of that name in + `tilia.cabal`, and bump `index-state` in `cabal.project` past its + release. If `haskell.nix`'s index of Hackage does not reach that + far, update the `haskellNix` input as well. +2. Fix what the new API breaks. Warnings are errors in this project, so a + constructor that the new syntax tree adds and the printer does not handle + shows up as an incomplete match. Add new syntax examples in + `corpora/vendored/`. +3. Point `ghcTestSuite` in `tests/Tilia/Corpus.hs` at the test suite of the + GHC release the parser comes from: its `corpusName` and the + `ghc-X.Y.Z-release` tag it is fetched from. Then revise `ghcUnreadable`, + the files GHC's own parser rejects, and `ghcDeclined`, the files Tilia is + right to refuse, against that test suite. +4. Regenerate `tests/Tilia/BootFixities.hs`, the fixities the tests take the + boot packages to export, with the compiler of the same release, after + checking that `PACKAGES` in the script still names its boot packages: + + ```console + $ ./generate-boot-fixities.py --ghc /path/to/ghc-9.16.1/bin/ghc + ``` + +5. Record the Hackage corpus again with `TILIA_CORPUS_ACCEPT=1 cabal test` + and review every change to `hackage.manifest` and `hackage.report`: a + module that changes its outcome or its digest is now parsed differently. +6. The cache keeps summaries of local modules by the version of + `ghc-lib-parser` that read them, but what it learned about dependencies + is kept regardless of it. If the new parser reads the sources of + dependencies differently, bump `formatVersion` in `Tilia.Fixity.Cache`. +7. Record the benchmarks again with `TILIA_BENCH_ACCEPT=1 cabal bench`, + since parsing takes a share of what they cost. +8. Update `CHANGELOG.md`. diff --git a/bench/Main.hs b/bench/Main.hs --- a/bench/Main.hs +++ b/bench/Main.hs @@ -1,6 +1,5 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -- | Measure what formatting a fixed sample of modules costs, and compare -- what it allocates and the instructions it retires with the record kept @@ -9,7 +8,8 @@ import Control.Applicative ((<|>)) import Control.Exception (SomeException, try) -import Control.Monad (join, mfilter, unless) +import Control.Monad (join, mfilter, unless, when) +import Data.ByteString qualified as BS import Data.Containers.ListUtils (nubOrd) import Data.Foldable (for_) import Data.Int (Int64) @@ -20,6 +20,7 @@ import Data.Ord (Down (..)) import Data.Text (Text) import Data.Text qualified as T +import Data.Text.Encoding qualified as T import Data.Text.IO qualified as T import Data.Traversable (for) import Data.Version (showVersion) @@ -42,7 +43,6 @@ strOption, value, ) -import System.Environment (lookupEnv) import System.Exit (die, exitFailure) import System.IO (BufferMode (..), hSetBuffering, stdout) import System.Info (fullCompilerVersion) @@ -53,6 +53,8 @@ import Tilia.Bench.Measure import Tilia.Bench.Record import Tilia.Corpus (hackagePackages, obtain) +import Tilia.TestUtils (switchedOn) +import Tilia.Utils (writeUtf8File) -- | How the benchmarks were asked to run. data Options = Options @@ -79,7 +81,7 @@ main = do hSetBuffering stdout LineBuffering options <- execParser optionsInfo - accepting <- (== Just "1") <$> lookupEnv "TILIA_BENCH_ACCEPT" + accepting <- switchedOn "TILIA_BENCH_ACCEPT" examples <- obtain hackagePackages >>= either (die . T.unpack) pure sampled <- corpusSubjects examples >>= either (die . T.unpack) pure let matching name = maybe True (`T.isInfixOf` name) (optMatch options) @@ -108,6 +110,10 @@ ended <- withFixityBenchmarks $ \(resolving, interfaces) -> do let record = comparable processor interfaces written decoding = recordInterfaces written == interfaces + reheaded = + recordCompiler written /= compiler + || recordProcessor written /= fromMaybe "none" processor + || not decoding checked (stage, _) = decoding || stage /= stageName Decode others <- for [b | b <- resolving, matching (benchmarkName b)] $ \b -> do (_, m) <- measureIO counter (optRuns options) (benchmarkRun b) id @@ -121,6 +127,10 @@ for_ baseline (summarize measured) if accepting then do + when (partial && reheaded) $ + die + "Only some benchmarks were run, on another compiler, processor\n\ + \or set of interfaces than the record's: accept them all at once." let entryOf k m = steadied (Map.lookup k (recordEntries record)) $ Entry @@ -428,7 +438,7 @@ -- | Save what was measured. writeBaseline :: FilePath -> [(Key, Measurement)] -> IO () writeBaseline path measured = - T.writeFile path . T.unlines $ + writeUtf8File path . T.unlines $ [ T.unwords [ stage, T.pack (show (measuredTime m)), @@ -441,7 +451,7 @@ -- | Read what 'writeBaseline' saved. readBaseline :: FilePath -> IO Baseline readBaseline path = do - text <- T.readFile path + text <- T.decodeUtf8Lenient <$> BS.readFile path pure $ Map.fromList [ ((stage, T.unwords rest), (t, readMaybe (T.unpack retired))) diff --git a/bench/Tilia/Bench/Cases.hs b/bench/Tilia/Bench/Cases.hs --- a/bench/Tilia/Bench/Cases.hs +++ b/bench/Tilia/Bench/Cases.hs @@ -20,11 +20,11 @@ import Data.Text qualified as T import Data.Text.Encoding (decodeUtf8') import Data.Traversable (for) -import GHC.LanguageExtensions.Type (Extension) import Tilia.Corpus (Example (..)) import Tilia.Cpp (usesCpp) import Tilia.Format (rewritten) import Tilia.Parser (parseModule) +import Tilia.Pragma (Defaults) import Tilia.TestConfig (formatCppExample, printExample) import Tilia.TestUtils (effectiveExtensionsFor, parserConfigFor) @@ -203,7 +203,7 @@ -- | A module to format, and to check what that printed where it is -- checked. -subjectOf :: Maybe [Extension] -> Bool -> Text -> Text -> Subject +subjectOf :: Maybe Defaults -> Bool -> Text -> Text -> Subject subjectOf package isChecked name source = Subject { subjectName = name, @@ -224,7 +224,7 @@ -- | What formatting a module prints, as the corpus does it, or 'Nothing' -- where it is declined. -formatted :: Maybe [Extension] -> FilePath -> Text -> Maybe Text +formatted :: Maybe Defaults -> FilePath -> Text -> Maybe Text formatted package path source | usesCpp (effectiveExtensionsFor package source) source = either (const Nothing) Just (formatCppExample package path source) diff --git a/bench/Tilia/Bench/Fixity.hs b/bench/Tilia/Bench/Fixity.hs --- a/bench/Tilia/Bench/Fixity.hs +++ b/bench/Tilia/Bench/Fixity.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} @@ -209,7 +208,7 @@ cache <- cacheUnder (dir "cache") interfaces <- interfacesOf decoded let reading kept modules = do - packageReader <- newPackageReader (plannedCompiler plan) + packageReader <- newPackageReader (plannedCompiler plan) [] resolver <- newResolverWith [FromSource] kept [] tarballs packageReader plan pure $ do answers <- traverse (askModule resolver) modules diff --git a/bench/Tilia/Bench/Record.hs b/bench/Tilia/Bench/Record.hs --- a/bench/Tilia/Bench/Record.hs +++ b/bench/Tilia/Bench/Record.hs @@ -1,6 +1,5 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -- | What the benchmarks cost when they were last recorded, kept in the -- repository so that a change to it shows in review like any other. @@ -12,15 +11,14 @@ ) where -import Control.Exception (SomeException, try) import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map import Data.Maybe (mapMaybe) import Data.Text (Text) import Data.Text qualified as T -import Data.Text.IO qualified as T import Data.Word (Word64) import Text.Read (readMaybe) +import Tilia.Utils (readUtf8File, writeUtf8File) -- | The bytes each benchmark allocated and the instructions it retired, by -- stage and module. @@ -50,9 +48,9 @@ -- before it is regenerated each say they are not in it. readRecord :: FilePath -> IO Record readRecord path = - try (T.readFile path) >>= \case - Left (_ :: SomeException) -> pure (Record "" "none" "" Map.empty) - Right text -> + readUtf8File path >>= \case + Nothing -> pure (Record "" "none" "" Map.empty) + Just text -> pure Record { recordCompiler = field "compiler " text, @@ -72,7 +70,7 @@ -- shows what changed rather than what moved. writeRecord :: FilePath -> Record -> IO () writeRecord path record = - T.writeFile path . T.unlines $ + writeUtf8File path . T.unlines $ [ "# What each benchmark costs, as far as that does not depend on how", "# busy the machine is. `cabal bench` checks it, and", "# `TILIA_BENCH_ACCEPT=1 cabal bench` writes it again.", diff --git a/bench/bench.record b/bench/bench.record --- a/bench/bench.record +++ b/bench/bench.record @@ -24,98 +24,98 @@ # they were not counted. # benchmark The module or the package it measures that on. -compiler ghc 9.10.3 +compiler ghc 9.14.1 processor AMD Ryzen AI 9 HX 370 w/ Radeon 890M -interfaces 1c28e35fa2432d89 +interfaces 78bbcc544104eadc # 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 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 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 -check 51558504 90521497 pandoc-3.10.2/src/Text/Pandoc/Class/PandocPure.hs -check 160564576 336134147 pandoc-3.10.2/src/Text/Pandoc/Readers/Markdown.hs -check 217005264 438646778 pandoc-3.10.2/src/Text/Pandoc/Writers/Powerpoint/Output.hs -check 177263168 360271324 purescript-0.15.15/src/Language/PureScript/Errors.hs -check 86199456 182395610 purescript-0.15.15/src/Language/PureScript/TypeChecker/Types.hs -check 76944368 174894002 recursion-schemes-5.2.3/src/Data/Functor/Foldable.hs -check 90285488 193297667 servant-server-0.20.3.0/src/Servant/Server/Internal.hs -check 99785848 200988911 swagger2-2.9.1/src/Data/Swagger/Internal.hs -check 104406992 193276384 text-2.1.4/tests/Tests/Properties/Folds.hs -check 62082528 128971807 time-1.16.0.1/test/main/Test/Format/ParseTime.hs -check 69973984 137412179 tls-2.4.3/Network/TLS/Extension.hs -check 322427128 758963691 unpacked-containers-0/src/Map/Internal.hs -check 438419048 846475201 vector-0.13.2.0/src/Data/Vector/Generic.hs -check 70657680 148642078 xmonad-0.18.1/src/XMonad/Operations.hs -decode 25613816 43571594 base-4.20.2.0 -decode 5830408 7145065 bytestring-0.12.2.0 -decode 9126328 11777525 containers-0.7 -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 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 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 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 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 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 +check 262394328 561065716 Agda-2.8.0/src/full/Agda/Syntax/Translation/ConcreteToAbstract.hs +check 397446832 830954176 ShellCheck-0.11.0/src/ShellCheck/Analytics.hs +check 241124648 438396589 aeson-2.3.1.0/src/Data/Aeson/KeyMap.hs +check 189604912 503938397 blaze-html-0.9.2.0/src/Text/Blaze/Html5/Attributes.hs +check 61103592 123879818 brittany-0.14.0.2/source/library/Language/Haskell/Brittany/Internal/Transformations/Alt.hs +check 80904096 166165901 distributed-process-0.7.8/src/Control/Distributed/Process/Node.hs +check 122830480 257529681 esqueleto-3.6.0.3/test/PostgreSQL/Test.hs +check 494049016 907759201 haxl-2.5.1.1/Haxl/Core/Monad.hs +check 208630016 437290005 idris-1.3.4/src/Idris/Elab/Term.hs +check 316305056 548835398 lifted-base-0.2.3.12/Control/Exception/Lifted.hs +check 58863640 126561712 megaparsec-9.8.1/Text/Megaparsec/Internal.hs +check 78865104 169281790 optparse-applicative-0.19.0.0/tests/test.hs +check 49898856 88299550 pandoc-3.10.2/src/Text/Pandoc/Class/PandocPure.hs +check 155279368 326828232 pandoc-3.10.2/src/Text/Pandoc/Readers/Markdown.hs +check 208221512 425543616 pandoc-3.10.2/src/Text/Pandoc/Writers/Powerpoint/Output.hs +check 171071104 351249427 purescript-0.15.15/src/Language/PureScript/Errors.hs +check 83717864 177741049 purescript-0.15.15/src/Language/PureScript/TypeChecker/Types.hs +check 75851168 173224739 recursion-schemes-5.2.3/src/Data/Functor/Foldable.hs +check 87866232 190347605 servant-server-0.20.3.0/src/Servant/Server/Internal.hs +check 96614904 199151954 swagger2-2.9.1/src/Data/Swagger/Internal.hs +check 100392680 186829756 text-2.1.4/tests/Tests/Properties/Folds.hs +check 59225512 125146433 time-1.16.0.1/test/main/Test/Format/ParseTime.hs +check 65691176 132601013 tls-2.4.3/Network/TLS/Extension.hs +check 316686328 745977417 unpacked-containers-0/src/Map/Internal.hs +check 429238096 834183400 vector-0.13.2.0/src/Data/Vector/Generic.hs +check 68487400 145286254 xmonad-0.18.1/src/XMonad/Operations.hs +decode 25986560 42986706 base-4.22.0.0 +decode 6162184 7405780 bytestring-0.12.2.0 +decode 9617160 11823599 containers-0.8 +decode 60341752 75721656 ghc-internal-9.1401.0 +decode 5048664 9492955 template-haskell-2.24.0.0 +decode 6427528 6910066 text-2.1.3 +format 556566968 1040003316 Agda-2.8.0/src/full/Agda/Syntax/Translation/ConcreteToAbstract.hs +format 3948115280 7939983547 QuickCheck-2.18.0.0/src/Test/QuickCheck/Arbitrary.hs +format 863564728 1573781326 ShellCheck-0.11.0/src/ShellCheck/Analytics.hs +format 303951416 534115111 aeson-2.3.1.0/src/Data/Aeson/KeyMap.hs +format 164705632 309258425 blaze-html-0.9.2.0/src/Text/Blaze/Html5/Attributes.hs +format 114058024 212152157 brittany-0.14.0.2/source/library/Language/Haskell/Brittany/Internal/Transformations/Alt.hs +format 170229520 316697956 distributed-process-0.7.8/src/Control/Distributed/Process/Node.hs +format 297570528 541006283 esqueleto-3.6.0.3/test/PostgreSQL/Test.hs +format 759077968 1520521231 haxl-2.5.1.1/Haxl/Core/Monad.hs +format 483356504 878928957 idris-1.3.4/src/Idris/Elab/Term.hs +format 1320092680 2678994116 lens-5.3.6/src/Control/Lens/Wrapped.hs +format 372668480 696092011 lifted-base-0.2.3.12/Control/Exception/Lifted.hs +format 110834768 209454593 megaparsec-9.8.1/Text/Megaparsec/Internal.hs +format 143959296 262866520 optparse-applicative-0.19.0.0/tests/test.hs +format 52995496 94413105 pandoc-3.10.2/src/Text/Pandoc/Class/PandocPure.hs +format 361638296 659596851 pandoc-3.10.2/src/Text/Pandoc/Readers/Markdown.hs +format 443949808 814179116 pandoc-3.10.2/src/Text/Pandoc/Writers/Powerpoint/Output.hs +format 357025320 656146525 purescript-0.15.15/src/Language/PureScript/Errors.hs +format 150005992 275935657 purescript-0.15.15/src/Language/PureScript/TypeChecker/Types.hs +format 122875928 216641468 recursion-schemes-5.2.3/src/Data/Functor/Foldable.hs +format 164938072 301655910 servant-server-0.20.3.0/src/Servant/Server/Internal.hs +format 167528512 311088065 swagger2-2.9.1/src/Data/Swagger/Internal.hs +format 648895256 1363324909 synthetic/comments +format 105358360 225585007 synthetic/conditionals +format 76791456 114759701 synthetic/imports +format 97076928 207279778 synthetic/nesting +format 793484632 1508895855 text-2.1.4/src/Data/Text/Internal/Fusion/CaseMapping.hs +format 216925176 379840605 text-2.1.4/tests/Tests/Properties/Folds.hs +format 125519664 227671534 time-1.16.0.1/test/main/Test/Format/ParseTime.hs +format 128974056 241642635 tls-2.4.3/Network/TLS/Extension.hs +format 985060280 1912068703 unordered-containers-0.2.21/Data/HashMap/Internal.hs +format 486293072 872473350 unpacked-containers-0/src/Map/Internal.hs +format 533965872 1009710097 vector-0.13.2.0/src/Data/Vector/Generic.hs +format 132689048 241971753 xmonad-0.18.1/src/XMonad/Operations.hs +recall 5011864 9048673 aeson-2.3.1.0 +recall 2205328 4115511 conduit-1.3.6.1 +recall 1748312 2942852 free-5.2 +recall 10404000 22672143 lens-5.3.6 +recall 1825680 3287510 megaparsec-9.8.1 +recall 2160552 3802105 mtl-2.3.2 +recall 1351496 2492548 optics-0.4.2.1 +recall 1559568 3026727 pandoc-types-1.23.1.2 +recall 2337880 4125023 semigroupoids-6.0.2 +recall 3239392 5595514 servant-0.20.3.0 +recall 5102944 8218446 text-2.1.4 +recall 3946288 7016254 vector-0.13.2.0 +resolve 1711586824 2939731779 aeson-2.3.1.0 +resolve 414482984 677964413 conduit-1.3.6.1 +resolve 453525440 735173130 free-5.2 +resolve 2764810360 4739854108 lens-5.3.6 +resolve 199884528 326934357 megaparsec-9.8.1 +resolve 209198760 338204339 mtl-2.3.2 +resolve 63227560 99404301 optics-0.4.2.1 +resolve 71461520 116712703 pandoc-types-1.23.1.2 +resolve 124101824 202496534 semigroupoids-6.0.2 +resolve 198377800 321014101 servant-0.20.3.0 +resolve 1090795072 1819001479 text-2.1.4 +resolve 2271139808 3767375431 vector-0.13.2.0 diff --git a/corpora/hackage/hackage.manifest b/corpora/hackage/hackage.manifest --- a/corpora/hackage/hackage.manifest +++ b/corpora/hackage/hackage.manifest @@ -482,7 +482,7 @@ formatted da3fb75adccf QuickCheck-2.18.0.0/tests/DiscardRatio.hs formatted 5408e5e13bd3 QuickCheck-2.18.0.0/tests/GCoArbitraryExample.hs formatted 8dd012261272 QuickCheck-2.18.0.0/tests/GShrinkExample.hs -formatted 3f82e6fd307d QuickCheck-2.18.0.0/tests/Generators.hs +formatted 5f4c2707cfc6 QuickCheck-2.18.0.0/tests/Generators.hs formatted 057887c409bc QuickCheck-2.18.0.0/tests/Misc.hs formatted 414efdc48918 QuickCheck-2.18.0.0/tests/MonadFix.hs formatted 85ad2d1decbe QuickCheck-2.18.0.0/tests/Monoids.hs @@ -516,7 +516,7 @@ formatted a381122da904 ShellCheck-0.11.0/src/ShellCheck/Formatter/Quiet.hs formatted ede5712d5ab7 ShellCheck-0.11.0/src/ShellCheck/Formatter/TTY.hs formatted a601aea10041 ShellCheck-0.11.0/src/ShellCheck/Interface.hs -formatted fd032d879733 ShellCheck-0.11.0/src/ShellCheck/Parser.hs +formatted 2cfa8339411e ShellCheck-0.11.0/src/ShellCheck/Parser.hs formatted 41e45f4ec82e ShellCheck-0.11.0/src/ShellCheck/Prelude.hs formatted 0b6a2ca650ea ShellCheck-0.11.0/src/ShellCheck/Regex.hs formatted d7f66e7f3a00 ShellCheck-0.11.0/test/shellcheck.hs @@ -561,30 +561,30 @@ formatted 8e47a331bfb8 aeson-2.3.1.0/src/Data/Aeson/TH.hs formatted 12a0132d4a2c aeson-2.3.1.0/src/Data/Aeson/Text.hs formatted d929af4e0687 aeson-2.3.1.0/src/Data/Aeson/Types.hs -formatted e11d9a90b593 aeson-2.3.1.0/src/Data/Aeson/Types/Class.hs +formatted 769fcc14bce2 aeson-2.3.1.0/src/Data/Aeson/Types/Class.hs formatted fc043ebfc291 aeson-2.3.1.0/src/Data/Aeson/Types/FromJSON.hs formatted af543197c845 aeson-2.3.1.0/src/Data/Aeson/Types/Generic.hs formatted a7b6903cad74 aeson-2.3.1.0/src/Data/Aeson/Types/Internal.hs formatted e372019c3433 aeson-2.3.1.0/src/Data/Aeson/Types/ToJSON.hs formatted 1916009e9352 aeson-2.3.1.0/tests/CastFloat.hs -formatted bad3a5065737 aeson-2.3.1.0/tests/DataFamilies/Encoders.hs -formatted 0d864147e795 aeson-2.3.1.0/tests/DataFamilies/Instances.hs +formatted 83937f2ef82e aeson-2.3.1.0/tests/DataFamilies/Encoders.hs +formatted 204116ceb7db aeson-2.3.1.0/tests/DataFamilies/Instances.hs formatted 91fe7aa4d3dc aeson-2.3.1.0/tests/DataFamilies/Properties.hs -formatted 4d002c77704c aeson-2.3.1.0/tests/DataFamilies/Types.hs +formatted 7f146994b15a aeson-2.3.1.0/tests/DataFamilies/Types.hs formatted 07fde92bf8d1 aeson-2.3.1.0/tests/DoubleToScientific.hs -formatted 659a9357b588 aeson-2.3.1.0/tests/Encoders.hs -formatted 30150da5a855 aeson-2.3.1.0/tests/ErrorMessages.hs +formatted 5377988ba287 aeson-2.3.1.0/tests/Encoders.hs +formatted 5ad9153a88b6 aeson-2.3.1.0/tests/ErrorMessages.hs formatted 72fb423455c1 aeson-2.3.1.0/tests/Functions.hs -formatted 45b065b98a94 aeson-2.3.1.0/tests/Instances.hs +formatted a9d868843992 aeson-2.3.1.0/tests/Instances.hs formatted 38b7096d53c4 aeson-2.3.1.0/tests/JSONTestSuite.hs formatted 82f27586e194 aeson-2.3.1.0/tests/Options.hs -formatted 269fd896fd74 aeson-2.3.1.0/tests/PropUtils.hs +formatted 44fab88974f6 aeson-2.3.1.0/tests/PropUtils.hs formatted 5c7e1bcf3dd6 aeson-2.3.1.0/tests/Properties.hs formatted 7d368ad15e82 aeson-2.3.1.0/tests/PropertyGeneric.hs -formatted 109d7fb52b5b aeson-2.3.1.0/tests/PropertyKeys.hs -formatted 0d9df9d04cba aeson-2.3.1.0/tests/PropertyQC.hs -formatted a2e378d49eb8 aeson-2.3.1.0/tests/PropertyRTFunctors.hs -formatted d54279308532 aeson-2.3.1.0/tests/PropertyRoundTrip.hs +formatted 6e8696681818 aeson-2.3.1.0/tests/PropertyKeys.hs +formatted fbd08dc6e050 aeson-2.3.1.0/tests/PropertyQC.hs +formatted 8225a2de1b48 aeson-2.3.1.0/tests/PropertyRTFunctors.hs +formatted ec45061f33d0 aeson-2.3.1.0/tests/PropertyRoundTrip.hs formatted 5c1372b7a444 aeson-2.3.1.0/tests/PropertyTH.hs formatted 5b4efaf27bc6 aeson-2.3.1.0/tests/RFC8785.hs formatted 378b97660503 aeson-2.3.1.0/tests/Regression/Issue1138.hs @@ -592,16 +592,16 @@ formatted f000e9c51f1a aeson-2.3.1.0/tests/Regression/Issue571.hs formatted 650ac09bee0a aeson-2.3.1.0/tests/Regression/Issue687.hs formatted e5c541d1465a aeson-2.3.1.0/tests/Regression/Issue967.hs -formatted f696f5d31388 aeson-2.3.1.0/tests/SerializationFormatSpec.hs +formatted dc258c7824a4 aeson-2.3.1.0/tests/SerializationFormatSpec.hs formatted 8eaa36c16021 aeson-2.3.1.0/tests/Tests.hs -formatted c88e88732cfd aeson-2.3.1.0/tests/Types.hs -formatted 7731424b43b3 aeson-2.3.1.0/tests/UnitTests.hs +formatted 67cf480b391c aeson-2.3.1.0/tests/Types.hs +formatted 27539a7f2ac7 aeson-2.3.1.0/tests/UnitTests.hs formatted f18689008d86 aeson-2.3.1.0/tests/UnitTests/FromJSONKey.hs formatted 8fa12a214cda aeson-2.3.1.0/tests/UnitTests/Hashable.hs formatted 2e6e13a2b307 aeson-2.3.1.0/tests/UnitTests/KeyMapInsertWith.hs formatted fc462ed61e50 aeson-2.3.1.0/tests/UnitTests/MonadFix.hs formatted 657449faeb93 aeson-2.3.1.0/tests/UnitTests/NoThunks.hs -formatted 31a111ec64d8 aeson-2.3.1.0/tests/UnitTests/NullaryConstructors.hs +formatted 860ac1653916 aeson-2.3.1.0/tests/UnitTests/NullaryConstructors.hs formatted 91f9a9590048 aeson-2.3.1.0/tests/UnitTests/OmitNothingFieldsNote.hs formatted 11d14533f820 aeson-2.3.1.0/tests/UnitTests/OptionalFields.hs formatted 699f022c0cb2 aeson-2.3.1.0/tests/UnitTests/OptionalFields/Common.hs @@ -617,7 +617,7 @@ 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 formatted 9e25d9947df5 async-2.2.6/Control/Concurrent/Async.hs -partly-checked 652d49b16c08 async-2.2.6/Control/Concurrent/Async/Internal.hs +partly-checked f088ecc2c2e1 async-2.2.6/Control/Concurrent/Async/Internal.hs formatted 68777666410b async-2.2.6/Control/Concurrent/Async/Warden.hs formatted a0f5a7bd29cb async-2.2.6/Control/Concurrent/Stream.hs formatted e865ae48f11b async-2.2.6/Setup.hs @@ -681,16 +681,16 @@ formatted 316b8d029dee aws-0.25.3/Aws/Core.hs formatted 526f7494fea1 aws-0.25.3/Aws/DynamoDb.hs formatted 11c5a36e6111 aws-0.25.3/Aws/DynamoDb/Commands.hs -formatted fdedda6a01bc aws-0.25.3/Aws/DynamoDb/Commands/BatchGetItem.hs -formatted 284a9d6d25fa aws-0.25.3/Aws/DynamoDb/Commands/BatchWriteItem.hs -formatted 37d0f09919b9 aws-0.25.3/Aws/DynamoDb/Commands/DeleteItem.hs +formatted f3cc0daec291 aws-0.25.3/Aws/DynamoDb/Commands/BatchGetItem.hs +formatted d547ef2d0b43 aws-0.25.3/Aws/DynamoDb/Commands/BatchWriteItem.hs +formatted 677a7cdf1061 aws-0.25.3/Aws/DynamoDb/Commands/DeleteItem.hs formatted 6e48f7806e5d aws-0.25.3/Aws/DynamoDb/Commands/GetItem.hs -formatted 413574967b43 aws-0.25.3/Aws/DynamoDb/Commands/PutItem.hs +formatted 27bb9f414054 aws-0.25.3/Aws/DynamoDb/Commands/PutItem.hs formatted 706f861f1b54 aws-0.25.3/Aws/DynamoDb/Commands/Query.hs formatted 76d3cbe6ea1b aws-0.25.3/Aws/DynamoDb/Commands/Scan.hs formatted c6547f406402 aws-0.25.3/Aws/DynamoDb/Commands/Table.hs -formatted 1159130413aa aws-0.25.3/Aws/DynamoDb/Commands/UpdateItem.hs -formatted 5527efbba0d1 aws-0.25.3/Aws/DynamoDb/Core.hs +formatted 66dd03e705d8 aws-0.25.3/Aws/DynamoDb/Commands/UpdateItem.hs +formatted 0779dd9e102b aws-0.25.3/Aws/DynamoDb/Core.hs formatted 7da30757579d aws-0.25.3/Aws/Ec2/InstanceMetadata.hs formatted 64524ea72e53 aws-0.25.3/Aws/Iam.hs formatted 749eee8b56a6 aws-0.25.3/Aws/Iam/Commands.hs @@ -1462,36 +1462,36 @@ formatted 52caf5793d73 brittany-0.14.0.2/data/Test99.hs formatted 7a5d0ee67b99 brittany-0.14.0.2/source/executable/Main.hs formatted f006bb65ddb6 brittany-0.14.0.2/source/library/Language/Haskell/Brittany.hs -formatted effc7ab14a00 brittany-0.14.0.2/source/library/Language/Haskell/Brittany/Internal.hs -formatted 62f91f308c2e brittany-0.14.0.2/source/library/Language/Haskell/Brittany/Internal/Backend.hs +formatted 7ddd24db972c brittany-0.14.0.2/source/library/Language/Haskell/Brittany/Internal.hs +formatted efd6c420ed12 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 47cac5b50849 brittany-0.14.0.2/source/library/Language/Haskell/Brittany/Internal/Config/Types.hs +formatted 442f38348553 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 0bd9379faeaf 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 4259510f3316 brittany-0.14.0.2/source/library/Language/Haskell/Brittany/Internal/Layouters/Decl.hs +formatted 35d642ea03c9 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 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 9219767aabaf 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 formatted 8d7327e29615 brittany-0.14.0.2/source/library/Language/Haskell/Brittany/Internal/Obfuscation.hs formatted 0dc2352f4480 brittany-0.14.0.2/source/library/Language/Haskell/Brittany/Internal/ParseModule.hs formatted 069a6d78e89a brittany-0.14.0.2/source/library/Language/Haskell/Brittany/Internal/Prelude.hs formatted 1a8db66fd521 brittany-0.14.0.2/source/library/Language/Haskell/Brittany/Internal/PreludeUtils.hs -formatted a12759ae906d brittany-0.14.0.2/source/library/Language/Haskell/Brittany/Internal/Transformations/Alt.hs +formatted a2109c56e3eb brittany-0.14.0.2/source/library/Language/Haskell/Brittany/Internal/Transformations/Alt.hs formatted c6217dd1471b brittany-0.14.0.2/source/library/Language/Haskell/Brittany/Internal/Transformations/Columns.hs formatted f558625f25b7 brittany-0.14.0.2/source/library/Language/Haskell/Brittany/Internal/Transformations/Floating.hs formatted 7d95cc82a77f brittany-0.14.0.2/source/library/Language/Haskell/Brittany/Internal/Transformations/Indent.hs formatted f6a84d0ce013 brittany-0.14.0.2/source/library/Language/Haskell/Brittany/Internal/Transformations/Par.hs -formatted 9bb018400ea8 brittany-0.14.0.2/source/library/Language/Haskell/Brittany/Internal/Types.hs -formatted 203fcf60dae6 brittany-0.14.0.2/source/library/Language/Haskell/Brittany/Internal/Utils.hs +formatted 5ea5611a32d7 brittany-0.14.0.2/source/library/Language/Haskell/Brittany/Internal/Types.hs +formatted ad92bdb716e5 brittany-0.14.0.2/source/library/Language/Haskell/Brittany/Internal/Utils.hs formatted 20badc0ca0c8 brittany-0.14.0.2/source/library/Language/Haskell/Brittany/Main.hs formatted e425ebfb8e97 brittany-0.14.0.2/source/test-suite/Main.hs formatted e865ae48f11b capability-0.5.0.1/Setup.hs @@ -1567,9 +1567,9 @@ formatted f70f6155e62a conduit-1.3.6.1/benchmarks/unfused.hs formatted 20fad0c5aecd conduit-1.3.6.1/src/Conduit.hs formatted bf88ceabad43 conduit-1.3.6.1/src/Data/Conduit.hs -formatted 1a953cd53139 conduit-1.3.6.1/src/Data/Conduit/Combinators.hs +formatted df07505ba4ab conduit-1.3.6.1/src/Data/Conduit/Combinators.hs formatted f520242138c3 conduit-1.3.6.1/src/Data/Conduit/Combinators/Stream.hs -formatted 7d754c7349cf conduit-1.3.6.1/src/Data/Conduit/Combinators/Unqualified.hs +formatted 438fcb6d4096 conduit-1.3.6.1/src/Data/Conduit/Combinators/Unqualified.hs formatted 8e861a915c2f conduit-1.3.6.1/src/Data/Conduit/Internal.hs formatted c35f5a66accc conduit-1.3.6.1/src/Data/Conduit/Internal/Conduit.hs formatted bbfd28e5b98b conduit-1.3.6.1/src/Data/Conduit/Internal/Fusion.hs @@ -1908,17 +1908,17 @@ formatted 95434fcb6957 exceptions-0.10.12/src/Control/Monad/Catch/Pure.hs formatted da6b7265725b exceptions-0.10.12/tests/Control/Monad/Catch/Tests.hs formatted bba664ba2b8b exceptions-0.10.12/tests/Tests.hs -formatted 421394df9111 fay-0.24.2.0/Setup.hs +formatted 9ecbe8994d9e fay-0.24.2.0/Setup.hs formatted ec9eeba0c6a1 fay-0.24.2.0/examples/CodeWorld.hs formatted 7cf91d63601f fay-0.24.2.0/examples/CodeWorldMain.hs -formatted d34203032896 fay-0.24.2.0/examples/Cont.hs +formatted 2791ee0a9bd2 fay-0.24.2.0/examples/Cont.hs formatted b5088332842e fay-0.24.2.0/examples/D3TreeSample.hs formatted 45fa087c720a fay-0.24.2.0/examples/FayFromJs.hs formatted d4be2511948d fay-0.24.2.0/examples/Separated.hs formatted 73cbc6340843 fay-0.24.2.0/examples/X.hs formatted 89a1e9058dc3 fay-0.24.2.0/examples/Y.hs formatted 55d7b8cf115f fay-0.24.2.0/examples/alert.hs -formatted 3563971c6bdb fay-0.24.2.0/examples/calc.hs +formatted e0b177e5a9f3 fay-0.24.2.0/examples/calc.hs formatted 2d60fb67f2de fay-0.24.2.0/examples/canvaswater.hs formatted 97df12f5dfa2 fay-0.24.2.0/examples/console.hs formatted 7608e18ca01c fay-0.24.2.0/examples/data.hs @@ -1934,38 +1934,38 @@ formatted 7085b02d6471 fay-0.24.2.0/examples/ref.hs formatted 55fe2b9f624f fay-0.24.2.0/examples/showExamples.hs formatted 884b6fbdaadc fay-0.24.2.0/examples/tailrecursive.hs -formatted c2d5e370d7e2 fay-0.24.2.0/src/Fay.hs -formatted 9a042d6a7ba9 fay-0.24.2.0/src/Fay/Compiler.hs -formatted 727b9da5eeda fay-0.24.2.0/src/Fay/Compiler/Decl.hs +formatted d57685ee2836 fay-0.24.2.0/src/Fay.hs +formatted 8e1eda45f5a1 fay-0.24.2.0/src/Fay/Compiler.hs +formatted 5c71e55e06ee fay-0.24.2.0/src/Fay/Compiler/Decl.hs formatted d4575500ee48 fay-0.24.2.0/src/Fay/Compiler/Defaults.hs 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 de04ffc1e73c fay-0.24.2.0/src/Fay/Compiler/Exp.hs -formatted cfc0f0f46b43 fay-0.24.2.0/src/Fay/Compiler/FFI.hs +formatted 85a69bad988d fay-0.24.2.0/src/Fay/Compiler/Exp.hs +formatted c6dd7b9e3183 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 -formatted 766c34ce53b0 fay-0.24.2.0/src/Fay/Compiler/InitialPass.hs -formatted d9d683411028 fay-0.24.2.0/src/Fay/Compiler/Misc.hs -formatted bce0992d570d fay-0.24.2.0/src/Fay/Compiler/ModuleT.hs -formatted 2fdd19da261b fay-0.24.2.0/src/Fay/Compiler/Optimizer.hs -formatted ac32749d90ec fay-0.24.2.0/src/Fay/Compiler/Packages.hs +formatted 7ffae636dbe4 fay-0.24.2.0/src/Fay/Compiler/Import.hs +formatted 95cf95ae99fe fay-0.24.2.0/src/Fay/Compiler/InitialPass.hs +formatted 9df7da80e8c4 fay-0.24.2.0/src/Fay/Compiler/Misc.hs +formatted e526d58c2637 fay-0.24.2.0/src/Fay/Compiler/ModuleT.hs +formatted 984b0a80a55e fay-0.24.2.0/src/Fay/Compiler/Optimizer.hs +formatted ce1e364e00bb fay-0.24.2.0/src/Fay/Compiler/Packages.hs formatted 1798f425b036 fay-0.24.2.0/src/Fay/Compiler/Parse.hs -formatted 46f343ccba7b fay-0.24.2.0/src/Fay/Compiler/Pattern.hs +formatted dba17f522647 fay-0.24.2.0/src/Fay/Compiler/Pattern.hs formatted 7cca783f3fcd fay-0.24.2.0/src/Fay/Compiler/Prelude.hs -formatted 0fe3943a05fb fay-0.24.2.0/src/Fay/Compiler/PrimOp.hs -formatted d7dcfe1aa9ca fay-0.24.2.0/src/Fay/Compiler/Print.hs +formatted 0705dae72c12 fay-0.24.2.0/src/Fay/Compiler/PrimOp.hs +formatted bec107e6f3d3 fay-0.24.2.0/src/Fay/Compiler/Print.hs formatted da23ccb55970 fay-0.24.2.0/src/Fay/Compiler/QName.hs formatted 9fe2fbd3e360 fay-0.24.2.0/src/Fay/Compiler/State.hs formatted fb1831a445cc fay-0.24.2.0/src/Fay/Compiler/Typecheck.hs formatted 631cbd5cb454 fay-0.24.2.0/src/Fay/Config.hs -formatted 15cd1e849d0e fay-0.24.2.0/src/Fay/Convert.hs +formatted 5e21cc38a1e1 fay-0.24.2.0/src/Fay/Convert.hs formatted 80d46083d774 fay-0.24.2.0/src/Fay/Exts.hs -formatted 7ec6f093e0ca fay-0.24.2.0/src/Fay/Exts/NoAnnotation.hs +formatted 23a0a09bf5e1 fay-0.24.2.0/src/Fay/Exts/NoAnnotation.hs formatted bd1f234d96c0 fay-0.24.2.0/src/Fay/Exts/Scoped.hs -formatted f7856f337bee fay-0.24.2.0/src/Fay/FFI.hs +formatted d29776a761a7 fay-0.24.2.0/src/Fay/FFI.hs formatted b21a6a7c7e2f fay-0.24.2.0/src/Fay/Runtime.hs -formatted 0ac5069cbf76 fay-0.24.2.0/src/Fay/Types.hs +formatted 21ff228b349a fay-0.24.2.0/src/Fay/Types.hs formatted 6654772d79a6 fay-0.24.2.0/src/Fay/Types/CompileError.hs formatted 4f7fdfee2a8f fay-0.24.2.0/src/Fay/Types/CompileResult.hs formatted cea8d04284a4 fay-0.24.2.0/src/Fay/Types/FFI.hs @@ -1973,33 +1973,33 @@ formatted 1165cbb859cc fay-0.24.2.0/src/Fay/Types/ModulePath.hs formatted ed80698a7cd1 fay-0.24.2.0/src/Fay/Types/Printer.hs formatted 6593766b1d2e fay-0.24.2.0/src/haskell-names/Language/Haskell/Names.hs -formatted 379279fca760 fay-0.24.2.0/src/haskell-names/Language/Haskell/Names/Annotated.hs -formatted effa30f29551 fay-0.24.2.0/src/haskell-names/Language/Haskell/Names/Exports.hs -formatted 633d0ead4b0e fay-0.24.2.0/src/haskell-names/Language/Haskell/Names/GetBound.hs -formatted 74e293075d13 fay-0.24.2.0/src/haskell-names/Language/Haskell/Names/GlobalSymbolTable.hs +formatted c40577bbbe78 fay-0.24.2.0/src/haskell-names/Language/Haskell/Names/Annotated.hs +formatted 2156e3053cf3 fay-0.24.2.0/src/haskell-names/Language/Haskell/Names/Exports.hs +formatted 2c712ca7ff92 fay-0.24.2.0/src/haskell-names/Language/Haskell/Names/GetBound.hs +formatted 6f5ea387dca8 fay-0.24.2.0/src/haskell-names/Language/Haskell/Names/GlobalSymbolTable.hs formatted 13662130820d fay-0.24.2.0/src/haskell-names/Language/Haskell/Names/GlobalSymbolTable.hs-boot -formatted 3346bfa56c31 fay-0.24.2.0/src/haskell-names/Language/Haskell/Names/Imports.hs +formatted ea2e30c7db82 fay-0.24.2.0/src/haskell-names/Language/Haskell/Names/Imports.hs formatted bda66c725ce4 fay-0.24.2.0/src/haskell-names/Language/Haskell/Names/LocalSymbolTable.hs -formatted c6c4acea37c3 fay-0.24.2.0/src/haskell-names/Language/Haskell/Names/ModuleSymbols.hs -formatted 76ce45f69410 fay-0.24.2.0/src/haskell-names/Language/Haskell/Names/Open/Base.hs +formatted 2dcb549aaa00 fay-0.24.2.0/src/haskell-names/Language/Haskell/Names/ModuleSymbols.hs +formatted 81d92815fef2 fay-0.24.2.0/src/haskell-names/Language/Haskell/Names/Open/Base.hs formatted b12db8ba5ce9 fay-0.24.2.0/src/haskell-names/Language/Haskell/Names/Open/Derived.hs -formatted 325536c28de7 fay-0.24.2.0/src/haskell-names/Language/Haskell/Names/Open/Instances.hs -formatted deb2b656a1ad fay-0.24.2.0/src/haskell-names/Language/Haskell/Names/RecordWildcards.hs -formatted 80dec7fda3fb fay-0.24.2.0/src/haskell-names/Language/Haskell/Names/Recursive.hs -formatted 006f3c334ab0 fay-0.24.2.0/src/haskell-names/Language/Haskell/Names/ScopeUtils.hs -formatted 3dd4a51f2cc5 fay-0.24.2.0/src/haskell-names/Language/Haskell/Names/SyntaxUtils.hs -formatted 954e31fc5bf8 fay-0.24.2.0/src/haskell-names/Language/Haskell/Names/Types.hs +formatted d7517cafa993 fay-0.24.2.0/src/haskell-names/Language/Haskell/Names/Open/Instances.hs +formatted 864c19ccab50 fay-0.24.2.0/src/haskell-names/Language/Haskell/Names/RecordWildcards.hs +formatted 36ca15cae788 fay-0.24.2.0/src/haskell-names/Language/Haskell/Names/Recursive.hs +formatted 35f308030af1 fay-0.24.2.0/src/haskell-names/Language/Haskell/Names/ScopeUtils.hs +formatted 7d8238517a1b fay-0.24.2.0/src/haskell-names/Language/Haskell/Names/SyntaxUtils.hs +formatted cd1075fe28e2 fay-0.24.2.0/src/haskell-names/Language/Haskell/Names/Types.hs formatted a185a50b6e6a fay-0.24.2.0/src/main/Main.hs formatted b9c869a29067 fay-0.24.2.0/src/tests/Test/CommandLine.hs formatted 68c640b352e9 fay-0.24.2.0/src/tests/Test/Compile.hs formatted 6fdbf9951c76 fay-0.24.2.0/src/tests/Test/Convert.hs formatted 89d594b07db0 fay-0.24.2.0/src/tests/Test/Desugar.hs formatted a3937c4d8bef fay-0.24.2.0/src/tests/Test/Util.hs -formatted 63cce78f9492 fay-0.24.2.0/src/tests/Tests.hs +formatted 198e7e859e4a fay-0.24.2.0/src/tests/Tests.hs formatted 8114602da4c3 fay-0.24.2.0/tests/AllBaseModules.hs formatted e78d25c5a73d fay-0.24.2.0/tests/AutomaticList.hs formatted 779c72fbdb74 fay-0.24.2.0/tests/Bool.hs -formatted ad89dd2cf37b fay-0.24.2.0/tests/CPP.hs +formatted d5c6ec08c4a5 fay-0.24.2.0/tests/CPP.hs formatted 61e542a01350 fay-0.24.2.0/tests/Char.hs formatted 7badee2f20a7 fay-0.24.2.0/tests/Compile/CPPMultiLineStrings.hs formatted a5ace073f2a3 fay-0.24.2.0/tests/Compile/CPPTypecheck.hs @@ -2378,12 +2378,12 @@ formatted 4d201ce15d28 haxl-2.5.1.1/Haxl/DataSource/ConcurrentIO.hs formatted cf38b55569d1 haxl-2.5.1.1/Haxl/Prelude.hs formatted 0bf115c25c25 haxl-2.5.1.1/Setup.hs -formatted 5897e1a72e86 haxl-2.5.1.1/tests/AdoTests.hs +formatted b30d01a22e96 haxl-2.5.1.1/tests/AdoTests.hs formatted 7392cb2bf8df haxl-2.5.1.1/tests/AllTests.hs formatted 29963bfcd43e haxl-2.5.1.1/tests/BadDataSource.hs -formatted 9869a85f8734 haxl-2.5.1.1/tests/BatchTests.hs +formatted 3930b8064973 haxl-2.5.1.1/tests/BatchTests.hs formatted a75656cc58b4 haxl-2.5.1.1/tests/Bench.hs -formatted 6b4d75212e14 haxl-2.5.1.1/tests/CoreTests.hs +formatted c77a8f206311 haxl-2.5.1.1/tests/CoreTests.hs formatted 46378c08a2d4 haxl-2.5.1.1/tests/DataCacheTest.hs formatted 8120f9ee1106 haxl-2.5.1.1/tests/DataSourceDispatchTests.hs formatted 04f8f254da6b haxl-2.5.1.1/tests/ExampleDataSource.hs @@ -2396,11 +2396,11 @@ formatted 08f288ec8741 haxl-2.5.1.1/tests/MonadBench.hs formatted be417b8bc52f haxl-2.5.1.1/tests/OutgoneFetchesTests.hs formatted f760bff6e190 haxl-2.5.1.1/tests/ParallelTests.hs -formatted c757b6a749ba haxl-2.5.1.1/tests/ProfileTests.hs +formatted bdcd901d6365 haxl-2.5.1.1/tests/ProfileTests.hs formatted 478999c2d1bd haxl-2.5.1.1/tests/SleepDataSource.hs formatted 23f293b1253d haxl-2.5.1.1/tests/StatsTests.hs formatted 0deec7d41cb2 haxl-2.5.1.1/tests/TestBadDataSource.hs -formatted 6270eac19e14 haxl-2.5.1.1/tests/TestExampleDataSource.hs +formatted 8c99d9ddfade haxl-2.5.1.1/tests/TestExampleDataSource.hs formatted 33f33c2b6767 haxl-2.5.1.1/tests/TestMain.hs formatted c0a01d1bb863 haxl-2.5.1.1/tests/TestTypes.hs formatted 0cdf14515138 haxl-2.5.1.1/tests/TestUtils.hs @@ -2413,21 +2413,21 @@ formatted 7855a4bfe6fc hedgehog-1.7/src/Hedgehog/Internal/Discovery.hs formatted 15b153c4095e hedgehog-1.7/src/Hedgehog/Internal/Distributive.hs formatted db3d79ebed8e hedgehog-1.7/src/Hedgehog/Internal/Exception.hs -formatted 94960f681457 hedgehog-1.7/src/Hedgehog/Internal/Gen.hs +formatted 93bc9212bbae hedgehog-1.7/src/Hedgehog/Internal/Gen.hs formatted 82bd44e46c74 hedgehog-1.7/src/Hedgehog/Internal/HTraversable.hs formatted 0b6e930c617c hedgehog-1.7/src/Hedgehog/Internal/Opaque.hs formatted 0c41d0d4f087 hedgehog-1.7/src/Hedgehog/Internal/Prelude.hs -formatted a48f67a8e4b7 hedgehog-1.7/src/Hedgehog/Internal/Property.hs +formatted 099ade9775e8 hedgehog-1.7/src/Hedgehog/Internal/Property.hs formatted 144a39866885 hedgehog-1.7/src/Hedgehog/Internal/Queue.hs formatted 9d14d12ad0b0 hedgehog-1.7/src/Hedgehog/Internal/Range.hs formatted e83fa4c27743 hedgehog-1.7/src/Hedgehog/Internal/Region.hs -formatted ffa4ddc6361c hedgehog-1.7/src/Hedgehog/Internal/Report.hs -formatted 1c86cc2eaef4 hedgehog-1.7/src/Hedgehog/Internal/Runner.hs +formatted 1f1c1a46ba31 hedgehog-1.7/src/Hedgehog/Internal/Report.hs +formatted 12a45329d79f hedgehog-1.7/src/Hedgehog/Internal/Runner.hs formatted fb3eda304e9f hedgehog-1.7/src/Hedgehog/Internal/Seed.hs formatted 8b91f20c13a8 hedgehog-1.7/src/Hedgehog/Internal/Show.hs formatted c446e4f9c366 hedgehog-1.7/src/Hedgehog/Internal/Shrink.hs formatted c083b8dff0b7 hedgehog-1.7/src/Hedgehog/Internal/Source.hs -formatted ea48c5d7dba1 hedgehog-1.7/src/Hedgehog/Internal/State.hs +formatted e74cdd8b92d6 hedgehog-1.7/src/Hedgehog/Internal/State.hs formatted 8c1393826b50 hedgehog-1.7/src/Hedgehog/Internal/TH.hs formatted 79e0eb255f0f hedgehog-1.7/src/Hedgehog/Internal/Tree.hs formatted 42e8fad71904 hedgehog-1.7/src/Hedgehog/Internal/Tripping.hs @@ -2488,7 +2488,7 @@ formatted 367217908354 hledger-1.52.1/bench/bench.hs formatted 770ce114d693 hledger-1.52.1/test/unittest.hs formatted e865ae48f11b hlint-3.10/Setup.hs -formatted 0b9c394414b3 hlint-3.10/data/HLint_QuickCheck.hs +formatted df385b8f4253 hlint-3.10/data/HLint_QuickCheck.hs declined - hlint-3.10/data/HLint_TypeCheck.hs formatted 7f62e2698706 hlint-3.10/data/Test.hs formatted a3cf0d266650 hlint-3.10/src/Apply.hs @@ -2539,7 +2539,7 @@ formatted 3308ee100b88 hlint-3.10/src/Hint/Type.hs formatted c433ccccd5d9 hlint-3.10/src/Hint/Unsafe.hs formatted 48cd04ad2e02 hlint-3.10/src/HsColour.hs -formatted dd9801a47942 hlint-3.10/src/Idea.hs +formatted 12f5c15a3edb hlint-3.10/src/Idea.hs formatted 576b754ba5d4 hlint-3.10/src/Language/Haskell/HLint.hs formatted 7b8846cb4591 hlint-3.10/src/Main.hs formatted fcdf50a5835c hlint-3.10/src/Parallel.hs @@ -2624,7 +2624,7 @@ formatted 2665482bea3b hspec-core-2.11.17/test/Test/Hspec/Core/Formatters/V1Spec.hs formatted fdce61371e6b hspec-core-2.11.17/test/Test/Hspec/Core/Formatters/V2Spec.hs formatted 177347d407e1 hspec-core-2.11.17/test/Test/Hspec/Core/HooksSpec.hs -formatted ad736b09b724 hspec-core-2.11.17/test/Test/Hspec/Core/QuickCheck/UtilSpec.hs +formatted 4f036cf5daaf hspec-core-2.11.17/test/Test/Hspec/Core/QuickCheck/UtilSpec.hs formatted 775321ce08bf hspec-core-2.11.17/test/Test/Hspec/Core/Runner/EvalSpec.hs formatted 7eadb8336461 hspec-core-2.11.17/test/Test/Hspec/Core/Runner/JobQueueSpec.hs formatted 0d283fd19887 hspec-core-2.11.17/test/Test/Hspec/Core/Runner/PrintSlowSpecItemsSpec.hs @@ -2636,8 +2636,8 @@ formatted ad44f3bb30b2 hspec-core-2.11.17/test/Test/Hspec/Core/TreeSpec.hs formatted 9b07f9624b8d hspec-core-2.11.17/test/Test/Hspec/Core/UtilSpec.hs formatted e13927dd80dc hspec-core-2.11.17/vendor/Data/Algorithm/Diff.hs -partly-checked 03ba27ab9fd5 hspec-core-2.11.17/vendor/async-2.2.5/Control/Concurrent/Async.hs -formatted bea44982097a hspec-core-2.11.17/vendor/stm-2.5.0.1/Control/Concurrent/STM/TMVar.hs +partly-checked c9eef62258f8 hspec-core-2.11.17/vendor/async-2.2.5/Control/Concurrent/Async.hs +formatted 220d41b7fb0c hspec-core-2.11.17/vendor/stm-2.5.0.1/Control/Concurrent/STM/TMVar.hs formatted b3d4964504e7 http-client-0.7.19/Data/KeyedPool.hs formatted 3e436f1b2afb http-client-0.7.19/Network/HTTP/Client.hs formatted 547642efe2cc http-client-0.7.19/Network/HTTP/Client/Body.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 650cf9fb288c intero-0.1.40/src/Main.hs +partly-checked c4c4f282d93d 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 @@ -2871,7 +2871,7 @@ formatted 3df2a9c1d21f leksah-0.16.2.2/src/IDE/SymbolNavigation.hs formatted 265b135c829e leksah-0.16.2.2/src/IDE/TextEditor.hs formatted fc7e53f0e945 leksah-0.16.2.2/src/IDE/TextEditor/Class.hs -formatted 1c4c5952013a leksah-0.16.2.2/src/IDE/TextEditor/CodeMirror.hs +formatted 9467271dc7ec leksah-0.16.2.2/src/IDE/TextEditor/CodeMirror.hs formatted ead97fbc797b leksah-0.16.2.2/src/IDE/TextEditor/GtkSourceView.hs formatted 02fedce6ee7f leksah-0.16.2.2/src/IDE/TextEditor/Yi.hs formatted 74ead3c637fd leksah-0.16.2.2/src/IDE/TextEditor/Yi/Config.hs @@ -2889,11 +2889,11 @@ formatted 67948814999e lens-5.3.6/benchmarks/unsafe.hs formatted 6b5d9407288a lens-5.3.6/examples/Aeson.hs formatted fcea15eace15 lens-5.3.6/examples/Plates.hs -formatted 42c84063ca40 lens-5.3.6/examples/Pong.hs +formatted 6016ef723b2e lens-5.3.6/examples/Pong.hs formatted 1e7ca6c2bac4 lens-5.3.6/examples/Turtle.hs formatted e865ae48f11b lens-5.3.6/lens-properties/Setup.hs formatted 03d5b652be06 lens-5.3.6/lens-properties/src/Control/Lens/Properties.hs -formatted 078f1b9b6754 lens-5.3.6/src/Control/Exception/Lens.hs +formatted fb677a8ca744 lens-5.3.6/src/Control/Exception/Lens.hs formatted 4fb8b462c692 lens-5.3.6/src/Control/Lens.hs formatted dab5fde53fc2 lens-5.3.6/src/Control/Lens/At.hs formatted 1a555e9740b2 lens-5.3.6/src/Control/Lens/Combinators.hs @@ -2979,7 +2979,7 @@ formatted 5a4f7cf6359b lens-5.3.6/src/System/FilePath/Lens.hs formatted 18c87dbc74ee lens-5.3.6/src/System/IO/Error/Lens.hs formatted aa93fbb09ce5 lens-5.3.6/tests/BigRecord.hs -formatted 4bb6e1258874 lens-5.3.6/tests/T1024.hs +formatted 22c453e7b965 lens-5.3.6/tests/T1024.hs formatted 783da428b966 lens-5.3.6/tests/T799.hs formatted 735c78d5ee02 lens-5.3.6/tests/T917.hs formatted 1d3a1a7a064d lens-5.3.6/tests/T972.hs @@ -2988,8 +2988,8 @@ declined - lens-5.3.6/tests/properties.hs formatted 4bd3d2baa141 lens-5.3.6/tests/templates.hs formatted 2a47884feb32 lifted-base-0.2.3.12/Control/Concurrent/Chan/Lifted.hs -formatted ed858547b569 lifted-base-0.2.3.12/Control/Concurrent/Lifted.hs -formatted 9e73627aa56a lifted-base-0.2.3.12/Control/Concurrent/MVar/Lifted.hs +formatted 2878fb30d603 lifted-base-0.2.3.12/Control/Concurrent/Lifted.hs +formatted 5ca1cae42a21 lifted-base-0.2.3.12/Control/Concurrent/MVar/Lifted.hs formatted 7896c1c8db7e lifted-base-0.2.3.12/Control/Concurrent/QSem/Lifted.hs formatted 0e92e2e3c452 lifted-base-0.2.3.12/Control/Concurrent/QSemN/Lifted.hs formatted 5cc7e142b7a9 lifted-base-0.2.3.12/Control/Concurrent/SampleVar/Lifted.hs @@ -3745,7 +3745,7 @@ formatted 9390668ca723 purescript-0.15.15/src/Language/PureScript/Ide/Reexports.hs formatted 40ae0185eda5 purescript-0.15.15/src/Language/PureScript/Ide/SourceFile.hs formatted 4badb68aba43 purescript-0.15.15/src/Language/PureScript/Ide/State.hs -formatted 97156b72015a purescript-0.15.15/src/Language/PureScript/Ide/Types.hs +formatted 64c31342d1b6 purescript-0.15.15/src/Language/PureScript/Ide/Types.hs formatted a2547b22a5bd purescript-0.15.15/src/Language/PureScript/Ide/Usage.hs formatted c5c7f0134f7c purescript-0.15.15/src/Language/PureScript/Ide/Util.hs formatted a54bd99f9377 purescript-0.15.15/src/Language/PureScript/Interactive.hs @@ -4342,7 +4342,7 @@ formatted 7d15eaae39ff stack-9.9.9/src/Stack/Dot.hs formatted e3fe02818737 stack-9.9.9/src/Stack/Exec.hs formatted 69a1b5e114c2 stack-9.9.9/src/Stack/Fetch.hs -formatted 967c0ee2eef6 stack-9.9.9/src/Stack/GhcPkg.hs +formatted 7245d6806bca stack-9.9.9/src/Stack/GhcPkg.hs formatted 8e7700c60073 stack-9.9.9/src/Stack/Init.hs formatted 9f228f8da7ce stack-9.9.9/src/Stack/New.hs formatted a4120f7039a7 stack-9.9.9/src/Stack/Package.hs @@ -4358,7 +4358,7 @@ formatted cd2bb0d685de stack-9.9.9/src/Stack/Types/FlagName.hs formatted d8f8b074a086 stack-9.9.9/src/Stack/Types/GhcPkgId.hs formatted bd4be7dcc823 stack-9.9.9/src/Stack/Types/Internal.hs -formatted 6f80f79fae7e stack-9.9.9/src/Stack/Types/PackageIdentifier.hs +formatted 863509c942b8 stack-9.9.9/src/Stack/Types/PackageIdentifier.hs formatted 88a4f8bd73e5 stack-9.9.9/src/Stack/Types/PackageName.hs formatted cf90354db024 stack-9.9.9/src/Stack/Types/StackT.hs formatted c698b30fdbaf stack-9.9.9/src/Stack/Types/Version.hs @@ -4602,7 +4602,7 @@ formatted 7635d57189ea text-2.1.4/src/Data/Text/Internal/PrimCompat.hs formatted 634f3b2cbbde text-2.1.4/src/Data/Text/Internal/Private.hs formatted a41bd3d7edab text-2.1.4/src/Data/Text/Internal/Read.hs -formatted ec56c867ca01 text-2.1.4/src/Data/Text/Internal/Reverse.hs +formatted 7297075f77b5 text-2.1.4/src/Data/Text/Internal/Reverse.hs formatted 9ddb417cbaa3 text-2.1.4/src/Data/Text/Internal/Search.hs formatted 67bf06cca611 text-2.1.4/src/Data/Text/Internal/StrictBuilder.hs formatted ed455e9ee12d text-2.1.4/src/Data/Text/Internal/Transformation.hs @@ -4638,7 +4638,7 @@ formatted 13a8cbedafd1 text-2.1.4/tests/Tests/Properties/Transcoding.hs formatted 139bbe092e98 text-2.1.4/tests/Tests/Properties/Validate.hs formatted 75f4b0d7a5f3 text-2.1.4/tests/Tests/QuickCheckUtils.hs -formatted c6e25a3408e0 text-2.1.4/tests/Tests/RebindableSyntaxTest.hs +formatted 360188e62bc0 text-2.1.4/tests/Tests/RebindableSyntaxTest.hs formatted 939e997260ba text-2.1.4/tests/Tests/Regressions.hs formatted b7037d3f07cc text-2.1.4/tests/Tests/ShareEmpty.hs formatted f4e9f36f6be9 text-2.1.4/tests/Tests/SlowFunctions.hs @@ -4658,7 +4658,7 @@ formatted 0f617301ba5b time-1.16.0.1/lib/Data/Time/Calendar/CalendarDiffDays.hs formatted e210a7d3456b time-1.16.0.1/lib/Data/Time/Calendar/Days.hs formatted 03412f0b8356 time-1.16.0.1/lib/Data/Time/Calendar/Easter.hs -formatted f8d4d6f009e4 time-1.16.0.1/lib/Data/Time/Calendar/Gregorian.hs +formatted c8f966093a51 time-1.16.0.1/lib/Data/Time/Calendar/Gregorian.hs formatted be538512fc07 time-1.16.0.1/lib/Data/Time/Calendar/Julian.hs formatted 625e7b428153 time-1.16.0.1/lib/Data/Time/Calendar/JulianYearDay.hs formatted 9ba18c758e02 time-1.16.0.1/lib/Data/Time/Calendar/Month.hs @@ -4681,23 +4681,23 @@ formatted acaedfdab698 time-1.16.0.1/lib/Data/Time/Clock/Internal/UniversalTime.hs formatted cf441f809fdf time-1.16.0.1/lib/Data/Time/Clock/POSIX.hs formatted 6dd6034d73b4 time-1.16.0.1/lib/Data/Time/Clock/System.hs -formatted 7cdd69049dcf time-1.16.0.1/lib/Data/Time/Clock/TAI.hs +formatted bcae28d3d831 time-1.16.0.1/lib/Data/Time/Clock/TAI.hs formatted b600a5b5c744 time-1.16.0.1/lib/Data/Time/Format.hs formatted 6c005f66f0be time-1.16.0.1/lib/Data/Time/Format/Format/Class.hs -formatted 47f1688c0787 time-1.16.0.1/lib/Data/Time/Format/Format/Instances.hs -formatted 3764319de19b time-1.16.0.1/lib/Data/Time/Format/ISO8601.hs +formatted 200179c37154 time-1.16.0.1/lib/Data/Time/Format/Format/Instances.hs +formatted 14f4a5f4a56e time-1.16.0.1/lib/Data/Time/Format/ISO8601.hs formatted 76aa49c9292b time-1.16.0.1/lib/Data/Time/Format/Internal.hs formatted b7ae7592bcb6 time-1.16.0.1/lib/Data/Time/Format/Locale.hs -formatted 2cd514758801 time-1.16.0.1/lib/Data/Time/Format/Parse.hs +formatted b7301f512161 time-1.16.0.1/lib/Data/Time/Format/Parse.hs formatted 05a7f0bf5554 time-1.16.0.1/lib/Data/Time/Format/Parse/Class.hs -formatted cb2ccd8c40fd time-1.16.0.1/lib/Data/Time/Format/Parse/Instances.hs +formatted b579af300eaa time-1.16.0.1/lib/Data/Time/Format/Parse/Instances.hs formatted 4489a4cdab49 time-1.16.0.1/lib/Data/Time/LocalTime.hs formatted 93986a8450d1 time-1.16.0.1/lib/Data/Time/LocalTime/Internal/CalendarDiffTime.hs formatted 94f381fe1ad1 time-1.16.0.1/lib/Data/Time/LocalTime/Internal/Foreign.hs -formatted ca98c37fb34c time-1.16.0.1/lib/Data/Time/LocalTime/Internal/LocalTime.hs +formatted 4c9ff2a8a8a0 time-1.16.0.1/lib/Data/Time/LocalTime/Internal/LocalTime.hs formatted 9200ebaf067a time-1.16.0.1/lib/Data/Time/LocalTime/Internal/TimeOfDay.hs formatted 74496e557585 time-1.16.0.1/lib/Data/Time/LocalTime/Internal/TimeZone.hs -formatted 343d16749a70 time-1.16.0.1/lib/Data/Time/LocalTime/Internal/ZonedTime.hs +formatted a8370b544557 time-1.16.0.1/lib/Data/Time/LocalTime/Internal/ZonedTime.hs formatted c365d1aa63cd time-1.16.0.1/test/ForeignCalls.hs formatted fc8234c946fb time-1.16.0.1/test/ShowDefaultTZAbbreviations.hs formatted b51274826033 time-1.16.0.1/test/ShowTime.hs @@ -4934,7 +4934,7 @@ formatted 771e81db1b05 unordered-containers-0.2.21/benchmarks/Util/String.hs formatted 2b26017dfa9e unordered-containers-0.2.21/tests/Main.hs formatted 27005a00112e unordered-containers-0.2.21/tests/Properties.hs -formatted b06c5b9e0c6c unordered-containers-0.2.21/tests/Properties/HashMapLazy.hs +formatted 88e44fdb6cbd unordered-containers-0.2.21/tests/Properties/HashMapLazy.hs formatted f2a904c3a89a unordered-containers-0.2.21/tests/Properties/HashMapStrict.hs formatted 2212e9831f16 unordered-containers-0.2.21/tests/Properties/HashSet.hs formatted 3584a01b2cdd unordered-containers-0.2.21/tests/Properties/List.hs @@ -4968,7 +4968,7 @@ formatted d63508f44841 uuid-types-1.0.6.1/src/Data/UUID/Types/Internal/Builder.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 968ccc63cf5c vector-0.13.2.0/benchlib/Bench/Vector/Algo/AwShCC.hs formatted 8a7c35b680c0 vector-0.13.2.0/benchlib/Bench/Vector/Algo/FindIndexR.hs formatted 7536358d3c8c vector-0.13.2.0/benchlib/Bench/Vector/Algo/HybCC.hs formatted 31caf6daa18c vector-0.13.2.0/benchlib/Bench/Vector/Algo/Leaffix.hs diff --git a/corpora/vendored/declaration/class/empty-context-out.hs b/corpora/vendored/declaration/class/empty-context-out.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/declaration/class/empty-context-out.hs @@ -0,0 +1,10 @@ +module Report.Pretty where + +class () => Pretty a where + pretty :: a -> String + +class (Show a) => Loud a where + loud :: a -> String + +width :: () => Int +width = 80 diff --git a/corpora/vendored/declaration/class/empty-context.hs b/corpora/vendored/declaration/class/empty-context.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/declaration/class/empty-context.hs @@ -0,0 +1,10 @@ +module Report.Pretty where + +class () => Pretty a where + pretty :: a -> String + +class (Show a) => Loud a where + loud :: a -> String + +width :: () => Int +width = 80 diff --git a/corpora/vendored/declaration/data/empty-context-out.hs b/corpora/vendored/declaration/data/empty-context-out.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/declaration/data/empty-context-out.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE DatatypeContexts #-} +{-# LANGUAGE GADTs #-} + +module Report.Cells where + +data () => Cell a = Cell a + +newtype () => Width = Width Int + +data Some = forall a. () => Some a + +data Shown where + Shown :: () => Int -> Shown diff --git a/corpora/vendored/declaration/data/empty-context.hs b/corpora/vendored/declaration/data/empty-context.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/declaration/data/empty-context.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE DatatypeContexts #-} +{-# LANGUAGE GADTs #-} + +module Report.Cells where + +data () => Cell a = Cell a + +newtype () => Width = Width Int + +data Some = forall a. () => Some a + +data Shown where + Shown :: () => Int -> Shown diff --git a/corpora/vendored/declaration/value/typed-quote-written-across-lines-out.hs b/corpora/vendored/declaration/value/typed-quote-written-across-lines-out.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/declaration/value/typed-quote-written-across-lines-out.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- The body of a typed quote is indented under its bracket, as that of an +-- untyped one is. +untyped :: (Quote m) => m Exp +untyped = + [| + let x = 1 + in x + x + |] + +typed :: (Quote m) => Code m Int +typed = + [|| + let x = 1 + in x + x + ||] + +explicit :: (Quote m) => Code m Int +explicit = + [e|| + case lookup key table of + Just x -> x + Nothing -> 0 + ||] diff --git a/corpora/vendored/declaration/value/typed-quote-written-across-lines.hs b/corpora/vendored/declaration/value/typed-quote-written-across-lines.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/declaration/value/typed-quote-written-across-lines.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- The body of a typed quote is indented under its bracket, as that of an +-- untyped one is. +untyped :: Quote m => m Exp +untyped = + [| let x = 1 + in x + x |] + +typed :: Quote m => Code m Int +typed = + [|| let x = 1 + in x + x ||] + +explicit :: Quote m => Code m Int +explicit = [e|| case lookup key table of + Just x -> x + Nothing -> 0 ||] diff --git a/corpora/vendored/import/sorting-the-prelude-under-rebindable-syntax-out.hs b/corpora/vendored/import/sorting-the-prelude-under-rebindable-syntax-out.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/import/sorting-the-prelude-under-rebindable-syntax-out.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE RebindableSyntax #-} + +module Weather.Forecast where + +import Control.Monad (when) +import Data.List (foldl') +import Prelude (Double, (+)) +import Weather.Reading (Reading) + +warmer :: Double -> Double +warmer = (+ 1) diff --git a/corpora/vendored/import/sorting-the-prelude-under-rebindable-syntax.hs b/corpora/vendored/import/sorting-the-prelude-under-rebindable-syntax.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/import/sorting-the-prelude-under-rebindable-syntax.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE RebindableSyntax #-} + +module Weather.Forecast where + +import Weather.Reading (Reading) +import Prelude (Double, (+)) +import Data.List (foldl') +import Control.Monad (when) + +warmer :: Double -> Double +warmer = (+ 1) diff --git a/corpora/vendored/other/comment-before-closing-quote-out.hs b/corpora/vendored/other/comment-before-closing-quote-out.hs --- a/corpora/vendored/other/comment-before-closing-quote-out.hs +++ b/corpora/vendored/other/comment-before-closing-quote-out.hs @@ -10,9 +10,9 @@ typed = [|| - width * height - -- in pixels - ||] + width * height + -- in pixels + ||] declarations = [d| diff --git a/corpora/vendored/other/comment-inside-a-language-pragma-out.hs b/corpora/vendored/other/comment-inside-a-language-pragma-out.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/comment-inside-a-language-pragma-out.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE + ScopedTypeVariables + , LambdaCase -- for classify + , {- and for nothing else -} BangPatterns + #-} +{-# LANGUAGE TupleSections #-} + +module Kiln.Commented where + +-- GHC skips the comments inside the pragma and reads the names around +-- them, and a comment there stays where it is written. +classify :: Int -> String +classify = \case + 0 -> "zero" + _ -> "other" diff --git a/corpora/vendored/other/comment-inside-a-language-pragma.hs b/corpora/vendored/other/comment-inside-a-language-pragma.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/comment-inside-a-language-pragma.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE + ScopedTypeVariables + , LambdaCase -- for classify + , {- and for nothing else -} BangPatterns + #-} +{-# LANGUAGE DataKinds #-} +module Kiln.Commented where + +-- GHC skips the comments inside the pragma and reads the names around +-- them, and a comment there stays where it is written. +classify :: Int -> String +classify = \case + 0 -> "zero" + _ -> "other" diff --git a/corpora/vendored/other/cpp/conditional-from-a-where-clause-indented-with-a-tab-out.hs b/corpora/vendored/other/cpp/conditional-from-a-where-clause-indented-with-a-tab-out.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/cpp/conditional-from-a-where-clause-indented-with-a-tab-out.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE CPP #-} + +-- A conditional that begins among bindings indented with a tab and goes on +-- into the declarations after it stays one conditional, as it does where +-- they are indented with spaces. +module T where + +f :: Int -> Int +f x = y + where + y = x + 1 +#if defined(EXTRA) + z = 2 + +g :: Int +g = 1 +#else + +g :: Int +g = 2 +#endif diff --git a/corpora/vendored/other/cpp/conditional-from-a-where-clause-indented-with-a-tab.hs b/corpora/vendored/other/cpp/conditional-from-a-where-clause-indented-with-a-tab.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/cpp/conditional-from-a-where-clause-indented-with-a-tab.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE CPP #-} + +-- A conditional that begins among bindings indented with a tab and goes on +-- into the declarations after it stays one conditional, as it does where +-- they are indented with spaces. +module T where + +f :: Int -> Int +f x = y + where + y = x + 1 +#if defined(EXTRA) + z = 2 + +g :: Int +g = 1 +#else + +g :: Int +g = 2 +#endif diff --git a/corpora/vendored/other/cpp/macro-among-statements-out.hs b/corpora/vendored/other/cpp/macro-among-statements-out.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/cpp/macro-among-statements-out.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE CPP #-} + +-- A use standing for a statement stays at the column of the statements +-- around it. +module Solver.Trail where + +#ifdef ENABLE_TRACE +#define TRACING(x) x +#else +#define TRACING(x) +#endif + +step :: Int -> IO () +step n = do + print n + TRACING(print n) + print (n + 1) + +steps :: [Int] -> IO () +steps ns = do + let total = sum ns + TRACING(print total) + forM_ ns $ \n -> do + step n + TRACING(print n) + step (n + 1) + pure () diff --git a/corpora/vendored/other/cpp/macro-among-statements.hs b/corpora/vendored/other/cpp/macro-among-statements.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/cpp/macro-among-statements.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE CPP #-} + +-- A use standing for a statement stays at the column of the statements +-- around it. +module Solver.Trail where + +#ifdef ENABLE_TRACE +#define TRACING(x) x +#else +#define TRACING(x) +#endif + +step :: Int -> IO () +step n = do + print n + TRACING(print n) + print (n + 1) + +steps :: [Int] -> IO () +steps ns = do + let total = sum ns + TRACING(print total) + forM_ ns $ \n -> do + step n + TRACING(print n) + step (n + 1) + pure () diff --git a/corpora/vendored/other/cpp/macro-between-equations-out.hs b/corpora/vendored/other/cpp/macro-between-equations-out.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/cpp/macro-between-equations-out.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE CPP #-} + +-- A use standing for an equation stays at the margin between the equations +-- around it. +module Table.Lookup where + +#define ENTRY(k, v) lookupEntry k = v + +lookupEntry :: Int -> String +lookupEntry 0 = "zero" +ENTRY(1, "one") +lookupEntry _ = "many" diff --git a/corpora/vendored/other/cpp/macro-between-equations.hs b/corpora/vendored/other/cpp/macro-between-equations.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/cpp/macro-between-equations.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE CPP #-} + +-- A use standing for an equation stays at the margin between the equations +-- around it. +module Table.Lookup where + +#define ENTRY(k, v) lookupEntry k = v + +lookupEntry :: Int -> String +lookupEntry 0 = "zero" +ENTRY(1, "one") +lookupEntry _ = "many" diff --git a/corpora/vendored/other/cpp/macro-indented-with-a-tab-out.hs b/corpora/vendored/other/cpp/macro-indented-with-a-tab-out.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/cpp/macro-indented-with-a-tab-out.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE CPP #-} + +-- A use indented with a tab is at the column the tab moves it to: one at +-- the column of the code under it is a line of its own, and one further in +-- carries on the line above. +module Steps where + +#define ARG(x) (x) +#define STEP(x) print (x) + +g :: Int -> Maybe Int +g x = do + y <- + Just + ARG + (x) + pure y + +h :: Int -> IO () +h x = do + STEP(x ++ "";) + pure () diff --git a/corpora/vendored/other/cpp/macro-indented-with-a-tab.hs b/corpora/vendored/other/cpp/macro-indented-with-a-tab.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/cpp/macro-indented-with-a-tab.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE CPP #-} + +-- A use indented with a tab is at the column the tab moves it to: one at +-- the column of the code under it is a line of its own, and one further in +-- carries on the line above. +module Steps where + +#define ARG(x) (x) +#define STEP(x) print (x) + +g :: Int -> Maybe Int +g x = do + y <- Just + ARG(x) + pure y + +h :: Int -> IO () +h x = do + STEP(x ++ "";) + pure () diff --git a/corpora/vendored/other/cpp/preprocessor-turned-on-by-a-flag-out.hs b/corpora/vendored/other/cpp/preprocessor-turned-on-by-a-flag-out.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/cpp/preprocessor-turned-on-by-a-flag-out.hs @@ -0,0 +1,10 @@ +{-# OPTIONS -cpp #-} + +module Version where + +#if __GLASGOW_HASKELL__ >= 900 +f :: Int +#else +f :: Integer +#endif +f = 1 diff --git a/corpora/vendored/other/cpp/preprocessor-turned-on-by-a-flag.hs b/corpora/vendored/other/cpp/preprocessor-turned-on-by-a-flag.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/cpp/preprocessor-turned-on-by-a-flag.hs @@ -0,0 +1,9 @@ +{-# OPTIONS -cpp #-} +module Version where + +#if __GLASGOW_HASKELL__ >= 900 +f :: Int +#else +f :: Integer +#endif +f = 1 diff --git a/corpora/vendored/other/edition-named-by-the-module-out.hs b/corpora/vendored/other/edition-named-by-the-module-out.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/edition-named-by-the-module-out.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE GHC2024 #-} + +module Kiln.Edition where + +-- GHC compiles a module under the edition it names, so LambdaCase, which +-- GHC2024 turns on, is on. +firing :: Int -> Int +firing = \case + 0 -> 1 + n -> n diff --git a/corpora/vendored/other/edition-named-by-the-module.hs b/corpora/vendored/other/edition-named-by-the-module.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/edition-named-by-the-module.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE GHC2024 #-} +module Kiln.Edition where + +-- GHC compiles a module under the edition it names, so LambdaCase, which +-- GHC2024 turns on, is on. +firing :: Int -> Int +firing = \case + 0 -> 1 + n -> n diff --git a/corpora/vendored/other/editions-in-written-order-out.hs b/corpora/vendored/other/editions-in-written-order-out.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/editions-in-written-order-out.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE Haskell2010 #-} +{-# LANGUAGE GHC2021 #-} + +module Kiln.Edition where + +-- GHC compiles a module under the edition named last. +fire :: Int +fire = 1 diff --git a/corpora/vendored/other/editions-in-written-order.hs b/corpora/vendored/other/editions-in-written-order.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/editions-in-written-order.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE Haskell2010 #-} +{-# LANGUAGE GHC2021 #-} +module Kiln.Edition where + +-- GHC compiles a module under the edition named last. +fire :: Int +fire = 1 diff --git a/corpora/vendored/other/extension-taken-back-from-the-edition-out.hs b/corpora/vendored/other/extension-taken-back-from-the-edition-out.hs --- a/corpora/vendored/other/extension-taken-back-from-the-edition-out.hs +++ b/corpora/vendored/other/extension-taken-back-from-the-edition-out.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE TypeOperators #-} {-# LANGUAGE NoStarIsType #-} +{-# LANGUAGE TypeOperators #-} module M (type (*)) where diff --git a/corpora/vendored/other/extension-turned-off-above-one-implying-it-out.hs b/corpora/vendored/other/extension-turned-off-above-one-implying-it-out.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/extension-turned-off-above-one-implying-it-out.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE NoExplicitForAll #-} +{-# LANGUAGE RankNTypes #-} + +module Kiln.Rank where + +-- RankNTypes turns ExplicitForAll back on, so with it named last, a forall +-- can be written. +apply :: (forall a. a -> a) -> (Int, Bool) +apply f = (f 1, f True) diff --git a/corpora/vendored/other/extension-turned-off-above-one-implying-it.hs b/corpora/vendored/other/extension-turned-off-above-one-implying-it.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/extension-turned-off-above-one-implying-it.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE NoExplicitForAll #-} +{-# LANGUAGE RankNTypes #-} +module Kiln.Rank where + +-- RankNTypes turns ExplicitForAll back on, so with it named last, a forall +-- can be written. +apply :: (forall a. a -> a) -> (Int, Bool) +apply f = (f 1, f True) diff --git a/corpora/vendored/other/extension-turned-off-and-on-again-out.hs b/corpora/vendored/other/extension-turned-off-and-on-again-out.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/extension-turned-off-and-on-again-out.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE NoLambdaCase #-} +{-# LANGUAGE LambdaCase #-} + +module Kiln.Again where + +-- The name written last decides, so LambdaCase is on. +firing :: Int -> Int +firing = \case + 0 -> 1 + n -> n diff --git a/corpora/vendored/other/extension-turned-off-and-on-again.hs b/corpora/vendored/other/extension-turned-off-and-on-again.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/extension-turned-off-and-on-again.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE NoLambdaCase #-} +{-# LANGUAGE LambdaCase #-} +module Kiln.Again where + +-- The name written last decides, so LambdaCase is on. +firing :: Int -> Int +firing = \case + 0 -> 1 + n -> n diff --git a/corpora/vendored/other/extension-turned-on-under-an-option-turning-it-off-out.hs b/corpora/vendored/other/extension-turned-on-under-an-option-turning-it-off-out.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/extension-turned-on-under-an-option-turning-it-off-out.hs @@ -0,0 +1,11 @@ +{-# OPTIONS_GHC -XNoLambdaCase #-} +{-# LANGUAGE LambdaCase #-} + +module Kiln.Case where + +-- GHC reads the flags of the options pragmas and the names of the language +-- pragmas in the order they are written, so LambdaCase, named last, is on. +firing :: Int -> Int +firing = \case + 0 -> 1 + n -> n diff --git a/corpora/vendored/other/extension-turned-on-under-an-option-turning-it-off.hs b/corpora/vendored/other/extension-turned-on-under-an-option-turning-it-off.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/extension-turned-on-under-an-option-turning-it-off.hs @@ -0,0 +1,10 @@ +{-# OPTIONS_GHC -XNoLambdaCase #-} +{-# LANGUAGE LambdaCase #-} +module Kiln.Case where + +-- GHC reads the flags of the options pragmas and the names of the language +-- pragmas in the order they are written, so LambdaCase, named last, is on. +firing :: Int -> Int +firing = \case + 0 -> 1 + n -> n diff --git a/corpora/vendored/other/extensions-turned-on-by-flags-out.hs b/corpora/vendored/other/extensions-turned-on-by-flags-out.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/extensions-turned-on-by-flags-out.hs @@ -0,0 +1,15 @@ +{-# OPTIONS_GHC -XLambdaCase -fbang-patterns #-} +{-# OPTIONS_GHC -fglasgow-exts #-} + +module Flags where + +classify :: Int -> String +classify = \case + 0 -> "zero" + _ -> "other" + +strict :: Int -> Int +strict !n = n + +both :: (forall a. a -> a) -> (Int, Bool) +both f = (f 1, f True) diff --git a/corpora/vendored/other/extensions-turned-on-by-flags.hs b/corpora/vendored/other/extensions-turned-on-by-flags.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/extensions-turned-on-by-flags.hs @@ -0,0 +1,14 @@ +{-# OPTIONS_GHC -XLambdaCase -fbang-patterns #-} +{-# OPTIONS_GHC -fglasgow-exts #-} +module Flags where + +classify :: Int -> String +classify = \case + 0 -> "zero" + _ -> "other" + +strict :: Int -> Int +strict !n = n + +both :: (forall a. a -> a) -> (Int, Bool) +both f = (f 1, f True) diff --git a/corpora/vendored/other/old-options-pragma-in-written-order-out.hs b/corpora/vendored/other/old-options-pragma-in-written-order-out.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/old-options-pragma-in-written-order-out.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -Wall #-} +{-# OPTIONS -Wno-orphans #-} +{-# OPTIONS_GHC -Wno-unused-imports #-} +{-# OPTIONS -Wno-name-shadowing #-} + +module Kiln.Fire where + +-- GHC reads OPTIONS as it reads OPTIONS_GHC, so the two keep the order they +-- are written in among each other. +fire :: Int +fire = 1 diff --git a/corpora/vendored/other/old-options-pragma-in-written-order.hs b/corpora/vendored/other/old-options-pragma-in-written-order.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/old-options-pragma-in-written-order.hs @@ -0,0 +1,12 @@ +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS -Wno-orphans #-} +{-# OPTIONS_GHC -Wno-unused-imports #-} +{-# LANGUAGE BangPatterns #-} +{-# OPTIONS -Wno-name-shadowing #-} +module Kiln.Fire where + +-- GHC reads OPTIONS as it reads OPTIONS_GHC, so the two keep the order they +-- are written in among each other. +fire :: Int +fire = 1 diff --git a/corpora/vendored/other/options-in-written-order-out.hs b/corpora/vendored/other/options-in-written-order-out.hs --- a/corpora/vendored/other/options-in-written-order-out.hs +++ b/corpora/vendored/other/options-in-written-order-out.hs @@ -3,13 +3,15 @@ {-# OPTIONS_GHC -Wall #-} {-# OPTIONS_GHC -Wno-unused-imports #-} {-# OPTIONS_GHC -Wall #-} +{-# OPTIONS_GHC -Wall #-} {-# OPTIONS_GHC -fplugin=GHC.TypeLits.Normalise #-} {-# OPTIONS_GHC -fplugin=GHC.TypeLits.KnownNat.Solver #-} module Kiln.Glaze where -- GHC reads the flags of the options pragmas in the order they are written, --- a later one overriding an earlier one, so they keep that order, and only a --- pragma written twice in a row is written once. +-- a later one overriding an earlier one, so they keep that order, and a +-- pragma written twice in a row stays twice, since some flags count each +-- time they are given. glaze :: Int glaze = 1 diff --git a/corpora/vendored/other/options-in-written-order.hs b/corpora/vendored/other/options-in-written-order.hs --- a/corpora/vendored/other/options-in-written-order.hs +++ b/corpora/vendored/other/options-in-written-order.hs @@ -10,7 +10,8 @@ module Kiln.Glaze where -- GHC reads the flags of the options pragmas in the order they are written, --- a later one overriding an earlier one, so they keep that order, and only a --- pragma written twice in a row is written once. +-- a later one overriding an earlier one, so they keep that order, and a +-- pragma written twice in a row stays twice, since some flags count each +-- time they are given. glaze :: Int glaze = 1 diff --git a/corpora/vendored/other/pragma-below-the-module-line-out.hs b/corpora/vendored/other/pragma-below-the-module-line-out.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/pragma-below-the-module-line-out.hs @@ -0,0 +1,8 @@ +module Kiln.Size where + +{-# LANGUAGE OverloadedStrings #-} + +-- GHC reads pragmas above the module line alone, so OverloadedStrings is +-- off, and the pragma stays where it is written. +size :: Int +size = length "abc" diff --git a/corpora/vendored/other/pragma-below-the-module-line.hs b/corpora/vendored/other/pragma-below-the-module-line.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/pragma-below-the-module-line.hs @@ -0,0 +1,7 @@ +module Kiln.Size where +{-# LANGUAGE OverloadedStrings #-} + +-- GHC reads pragmas above the module line alone, so OverloadedStrings is +-- off, and the pragma stays where it is written. +size :: Int +size = length "abc" diff --git a/corpora/vendored/other/prelude-asked-for-above-rebindable-syntax-out.hs b/corpora/vendored/other/prelude-asked-for-above-rebindable-syntax-out.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/prelude-asked-for-above-rebindable-syntax-out.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE ImplicitPrelude #-} +{-# LANGUAGE RebindableSyntax #-} + +module Kiln.Rebound where + +-- RebindableSyntax turns ImplicitPrelude off, so with it named last, the +-- Prelude is not imported, and this map is the only one in scope. +map :: () +map = () + +glaze :: () +glaze = map diff --git a/corpora/vendored/other/prelude-asked-for-above-rebindable-syntax.hs b/corpora/vendored/other/prelude-asked-for-above-rebindable-syntax.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/prelude-asked-for-above-rebindable-syntax.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE ImplicitPrelude #-} +{-# LANGUAGE RebindableSyntax #-} +module Kiln.Rebound where + +-- RebindableSyntax turns ImplicitPrelude off, so with it named last, the +-- Prelude is not imported, and this map is the only one in scope. +map :: () +map = () + +glaze :: () +glaze = map diff --git a/corpora/vendored/other/splices-the-author-grouped-out.hs b/corpora/vendored/other/splices-the-author-grouped-out.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/splices-the-author-grouped-out.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} + +module Store.Lenses where + +makeLenses ''Config +-- A note written against the run it stands in, and staying inside it. +makeLenses ''Options + +makeLenses ''State +#if defined(PRISMS) +makePrisms ''Event +#endif +makeLenses ''Event diff --git a/corpora/vendored/other/splices-the-author-grouped.hs b/corpora/vendored/other/splices-the-author-grouped.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/splices-the-author-grouped.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} + +module Store.Lenses where + +makeLenses ''Config +-- A note written against the run it stands in, and staying inside it. +makeLenses ''Options + +makeLenses ''State +#if defined(PRISMS) +makePrisms ''Event +#endif +makeLenses ''Event diff --git a/corpora/vendored/other/string-literals-as-written-out.hs b/corpora/vendored/other/string-literals-as-written-out.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/string-literals-as-written-out.hs @@ -0,0 +1,41 @@ +-- A string comes out as written wherever it is, in a pattern, a pragma or +-- a rule's name: its gaps line up under its opening quote, and nothing is +-- escaped or quoted that was not. +module Text.Written where + +isLong :: String -> Bool +isLong + "a very long string \ + \that goes on" = True +isLong _ = False + +{-# DEPRECATED + old + "use the new one, \ + \which is better" + #-} +old :: Int +old = 1 + +{-# WARNING new ["one", "two"] #-} +new :: Int +new = 2 + +{-# RULES "f/∘" forall x. f (g x) = h x #-} + +f :: Int -> Int +f = id +{-# SCC f "f_label" #-} + +g :: Int -> Int +g = id +{-# SCC g #-} + +h :: Int -> Int +h = id + +x :: Int +x = {-# SCC foo #-} 1 + +y :: Int +y = {-# SCC "bar" #-} 2 diff --git a/corpora/vendored/other/string-literals-as-written.hs b/corpora/vendored/other/string-literals-as-written.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/string-literals-as-written.hs @@ -0,0 +1,37 @@ +-- A string comes out as written wherever it is, in a pattern, a pragma or +-- a rule's name: its gaps line up under its opening quote, and nothing is +-- escaped or quoted that was not. +module Text.Written where + +isLong :: String -> Bool +isLong "a very long string \ + \that goes on" = True +isLong _ = False + +{-# DEPRECATED old "use the new one, \ + \which is better" #-} +old :: Int +old = 1 + +{-# WARNING new ["one", "two"] #-} +new :: Int +new = 2 + +{-# RULES "f/∘" forall x. f (g x) = h x #-} + +f :: Int -> Int +f = id +{-# SCC f "f_label" #-} + +g :: Int -> Int +g = id +{-# SCC g #-} + +h :: Int -> Int +h = id + +x :: Int +x = {-# SCC foo #-} 1 + +y :: Int +y = {-# SCC "bar" #-} 2 diff --git a/src/Tilia/Cabal/Package.hs b/src/Tilia/Cabal/Package.hs --- a/src/Tilia/Cabal/Package.hs +++ b/src/Tilia/Cabal/Package.hs @@ -1,23 +1,23 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -- | Information coming from @.cabal@ files. module Tilia.Cabal.Package ( PackageProblem (..), describePackageProblem, readPackageDescription, + parsePackageDescription, declaredModules, + packageSourceDirs, + packageExtensions, PackageReader, newPackageReader, ComponentSection (..), BranchSections, - libraryBranches, - executableBranches, - suiteBranches, - benchmarkBranches, + Kind (..), + packageOf, + packageComponents, addedSources, sourceExtensions, isDeclaredModule, @@ -27,14 +27,17 @@ where import Control.Concurrent.MVar (modifyMVar, newMVar) +import Control.Monad ((<=<)) import Data.ByteString qualified as BS +import Data.Either (rights) +import Data.Foldable (toList) import Data.Generics.Schemes (listify) import Data.IORef -import Data.List (sortOn) +import Data.List (nub, sortOn) import Data.List.NonEmpty qualified as NE import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, mapMaybe) import Data.Ord (Down (..)) import Data.Set (Set) import Data.Set qualified as Set @@ -53,20 +56,20 @@ Executable (..), GenericPackageDescription (..), Library (..), + PackageDescription (..), PackageFlag (..), TestSuite (..), TestSuiteInterface (..), + pkgName, + unPackageName, + unUnqualComponentName, ) import Distribution.PackageDescription.Parsec (parseGenericPackageDescription) -import Distribution.Parsec (showPError, simpleParsec) +import Distribution.Parsec (PErrorWithSource (..), showPError, simpleParsec) import Distribution.System (buildArch, buildOS) import Distribution.Types.BuildInfo (usedExtensions) -import Distribution.Types.CondTree (mapTreeConstrs, simplifyCondTree) -#if MIN_VERSION_Cabal_syntax(3, 14, 0) +import Distribution.Types.CondTree (simplifyCondTree) import Distribution.Utils.Path (SymbolicPathX, getSymbolicPath) -#else -import Distribution.Utils.Path (getSymbolicPath) -#endif import Distribution.Version (Version, withinRange) import GHC.Driver.Session qualified as GHC import GHC.LanguageExtensions.Type (Extension) @@ -82,10 +85,10 @@ takeExtension, (), ) -import Tilia.Cabal.Project (cabalFilesIn) -import Tilia.Pragma (applyExtensionName, lookupEdition) +import Tilia.Cabal.Project (cabalFilesIn, startingDirectory) +import Tilia.Pragma (Defaults, defaultsOf, lookupEdition, nameSwitch) import Tilia.Process (readProgramOutput) -import Tilia.Utils (attempted, quietly) +import Tilia.Utils (attempted, pathUnder, quietly, tshow) -- | Why a file's extensions could not be settled. data PackageProblem @@ -113,15 +116,18 @@ T.pack file <> " names no component whose hs-source-dirs holds it" -- | What we retain from reading a .cabal file. -type PackageReader = FilePath -> IO (Either PackageProblem [Extension]) +type PackageReader = FilePath -> IO (Either PackageProblem Defaults) -- | A 'PackageReader' that remembers what it has already worked out. newPackageReader :: -- | The compiler's version, where the build plan names it, which spares -- asking the compiler. Maybe Version -> + -- | The @.cabal@ files of the project, which a module no @.cabal@ file + -- above it claims is looked for in. + [FilePath] -> IO PackageReader -newPackageReader planned = do +newPackageReader planned project = do covering <- newIORef Map.empty described <- newIORef Map.empty known <- newMVar (Just <$> planned) @@ -130,26 +136,25 @@ Nothing -> do version <- compilerVersion pure (Just version, version) + elsewhere file problem = do + found <- traverse (componentBranchesOf compiler described) project + pure $ case claiming file (concat (rights found)) of + Just c -> Right (componentExtensions c) + Nothing -> Left problem pure $ \path -> quietly (Left NoPackageFile) $ do file <- canonicalizePath path from <- startingDirectory file findCabalFile covering from >>= \case - Nothing -> pure (Left NoPackageFile) + Nothing -> elsewhere file NoPackageFile Just cabalFile -> componentBranchesOf compiler described cabalFile >>= \case Left problem -> pure (Left problem) Right components | equalFilePath file (takeDirectory cabalFile setupScript) -> - pure (Right (GHC.languageExtensions Nothing)) - | otherwise -> pure $ case claiming file components of - Just c -> Right (componentExtensions c) - Nothing -> Left (FileUnclaimed cabalFile) - --- | Where to start looking for a @.cabal@ file. -startingDirectory :: FilePath -> IO FilePath -startingDirectory path = do - isDirectory <- quietly False (doesDirectoryExist path) - pure (if isDirectory then path else takeDirectory path) + pure (Right (defaultsOf (GHC.languageExtensions Nothing) [])) + | Just c <- claiming file components -> + pure (Right (componentExtensions c)) + | otherwise -> elsewhere file (FileUnclaimed cabalFile) -- | One branch of a component, with everything in force in it already -- worked out. @@ -162,8 +167,8 @@ -- | Its entry points, relative to its source directories in the same -- way but with their extensions. componentEntries :: Set FilePath, - -- | The extensions it puts in force. - componentExtensions :: [Extension] + -- | What it puts in force. + componentExtensions :: Defaults } -- | Which branch holds the file, of those whose directories cover it. @@ -175,11 +180,14 @@ where covered = not . null . covering named c = any (declares c) (covering c) - declares c d = - 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] + declares c (_, under) = + isDeclaredModule (componentModules c) (componentEntries c) (joinPath under) + nearness = maximum . fmap (length . fst) . covering + covering c = + [ (d, under) + | d <- componentDirs c, + Just under@(_ : _) <- [pathUnder d file] + ] -- | Is a file, named relative to a source directory, one of the modules or -- entry points declared there? @@ -194,14 +202,6 @@ 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) - where - go [] (_ : _) = True - go (d : ds) (f : fs) = equalFilePath d f && go ds fs - go _ _ = False - -- | The nearest @.cabal@ file at or above a directory. findCabalFile :: -- | What is known already, by directory: the file covering it, or @@ -263,13 +263,21 @@ 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 + Right bytes -> pure (parsePackageDescription cabalFile bytes) + +-- | Parse what a @.cabal@ file holds, or say why it cannot be. +parsePackageDescription :: + -- | Where it comes from, named in what goes wrong. + FilePath -> + BS.ByteString -> + Either PackageProblem GenericPackageDescription +parsePackageDescription cabalFile bytes = + 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 + said = T.pack . showPError cabalFile . perror -- | The value a build of a package on this platform gives each variable its -- conditions ask about. @@ -339,14 +347,32 @@ -- | Every branch of every component of a package, in the order declared. packageBranches :: GenericPackageDescription -> [BranchSections] packageBranches described = + [b | (_, _, branches) <- packageComponents described, b <- branches] + +-- | The kinds of component a @.cabal@ file can declare, and the setup +-- script beside it. +data Kind = Lib | Exe | Test | Bench | Setup + deriving (Eq, Ord, Show) + +-- | Every component of a package, in the order declared: its kind, its +-- name, which for the main library is the package's own, and its branches. +packageComponents :: GenericPackageDescription -> [(Kind, Text, [BranchSections])] +packageComponents 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) + [ [(Lib, packageOf described, libraryBranches t) | t <- toList (condLibrary described)], + [(Lib, nameOf n, libraryBranches t) | (n, t) <- condSubLibraries described], + [(Exe, nameOf n, executableBranches t) | (n, t) <- condExecutables described], + [(Test, nameOf n, suiteBranches t) | (n, t) <- condTestSuites described], + [(Bench, nameOf n, benchmarkBranches t) | (n, t) <- condBenchmarks described] ] + where + nameOf = T.pack . unUnqualComponentName +-- | The name of a package. +packageOf :: GenericPackageDescription -> Text +packageOf = + T.pack . unPackageName . pkgName . package . packageDescription + -- | 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)] @@ -357,6 +383,31 @@ (sub, name) <- sectionModules section ] +-- | Every directory any branch of a package names for its files, and then +-- the package's own. +packageSourceDirs :: GenericPackageDescription -> [FilePath] +packageSourceDirs described = nub (named <> ["."]) + where + named = + [ getSymbolicPath d + | branch <- packageBranches described, + d <- hsSourceDirs (sectionInfo (ownSection branch)) + ] + +-- | What any branch of a package puts in force, all together: every edition +-- it names and every extension it turns on or off, in order. +packageExtensions :: GenericPackageDescription -> Defaults +packageExtensions described = + defaultsOf + baseline + (mapMaybe extensionSwitch (concatMap usedExtensions infos)) + where + infos = + [sectionInfo (ownSection branch) | branch <- packageBranches described] + baseline = case mapMaybe (ghcLanguage <=< defaultLanguage) infos of + [] -> GHC.languageExtensions (Just GHC.Haskell98) + editions -> nub (concatMap (GHC.languageExtensions . Just) editions) + -- | What one branch of a component declares. data ComponentSection = ComponentSection { -- | Its build settings. @@ -388,17 +439,17 @@ } -- | Every branch of a library. -libraryBranches :: CondTree ConfVar c Library -> [BranchSections] +libraryBranches :: CondTree ConfVar Library -> [BranchSections] libraryBranches = branchesOf $ \l -> declaring (libBuildInfo l) (exposedModules l <> signatures l) [] -- | Every branch of an executable. -executableBranches :: CondTree ConfVar c Executable -> [BranchSections] +executableBranches :: CondTree ConfVar Executable -> [BranchSections] executableBranches = branchesOf $ \e -> declaring (buildInfo e) [] [entryPoint (modulePath e)] -- | Every branch of a test suite. -suiteBranches :: CondTree ConfVar c TestSuite -> [BranchSections] +suiteBranches :: CondTree ConfVar TestSuite -> [BranchSections] suiteBranches = branchesOf $ \s -> case testInterface s of TestSuiteExeV10 _ path -> declaring (testBuildInfo s) [] [entryPoint path] @@ -406,7 +457,7 @@ _ -> declaring (testBuildInfo s) [] [] -- | Every branch of a benchmark. -benchmarkBranches :: CondTree ConfVar c Benchmark -> [BranchSections] +benchmarkBranches :: CondTree ConfVar Benchmark -> [BranchSections] benchmarkBranches = branchesOf $ \b -> case benchmarkInterface b of BenchmarkExeV10 _ path -> declaring (benchmarkBuildInfo b) [] [entryPoint path] @@ -416,13 +467,12 @@ branchesOf :: (Semigroup a) => (a -> ComponentSection) -> - CondTree ConfVar c a -> + CondTree ConfVar a -> [BranchSections] branchesOf f root = go mempty root where built valueOf = - sectionInfo . f . snd $ - simplifyCondTree valueOf (mapTreeConstrs (const ()) root) + sectionInfo (f (simplifyCondTree valueOf root)) go inherited node = let own = f (condTreeData node) in BranchSections inherited own built @@ -480,16 +530,8 @@ | otherwise = a b -- | The path of an entry point. --- --- Cabal 3.14 made a component's entry point a symbolic path; before that --- it was already the plain path we want. -#if MIN_VERSION_Cabal_syntax(3, 14, 0) entryPoint :: SymbolicPathX allowAbsolute from to -> FilePath entryPoint = normalise . getSymbolicPath -#else -entryPoint :: FilePath -> FilePath -entryPoint = normalise -#endif -- | The setup script of a package, beside its @.cabal@ file. -- @@ -504,18 +546,22 @@ [] -> ["."] ds -> ds --- | The extensions a component puts in force, before any module's pragmas. -extensionsInForce :: BuildInfo -> [Extension] +-- | What a component puts in force, before any module's pragmas. +extensionsInForce :: BuildInfo -> Defaults extensionsInForce bi = - foldl apply (GHC.languageExtensions edition) (usedExtensions bi) + defaultsOf + (GHC.languageExtensions edition) + (mapMaybe extensionSwitch (usedExtensions bi)) where edition = ghcLanguage (fromMaybe Cabal.Haskell98 (defaultLanguage bi)) - apply acc = \case - Cabal.EnableExtension e -> applyExtensionName acc (named e) - Cabal.DisableExtension e -> applyExtensionName acc ("No" <> named e) - _ -> acc - named = T.pack . show +-- | GHC's reading of an extension Cabal turns on or off, where GHC knows it. +extensionSwitch :: Cabal.Extension -> Maybe (GHC.OnOff Extension) +extensionSwitch = \case + Cabal.EnableExtension e -> nameSwitch (tshow e) + Cabal.DisableExtension e -> nameSwitch ("No" <> tshow e) + _ -> Nothing + -- | GHC's name for a language edition, when it has one. ghcLanguage :: Cabal.Language -> Maybe GHC.Language -ghcLanguage = lookupEdition . T.pack . show +ghcLanguage = lookupEdition . tshow diff --git a/src/Tilia/Cabal/Plan.hs b/src/Tilia/Cabal/Plan.hs --- a/src/Tilia/Cabal/Plan.hs +++ b/src/Tilia/Cabal/Plan.hs @@ -25,7 +25,6 @@ -- * Readiness Readiness (..), PlanComponent (..), - spellPlanComponent, plannedComponents, planPathFor, checkReadiness, @@ -51,7 +50,8 @@ (.:?), ) import Data.Aeson.Types (parseMaybe) -import Data.Choice (Choice, isTrue) +import Data.Choice (Choice, isFalse) +import Data.Containers.ListUtils (nubOrdOn) import Data.Foldable (toList, traverse_) import Data.List qualified import Data.List.NonEmpty (NonEmpty ((:|))) @@ -66,6 +66,9 @@ import Data.Text.Encoding qualified as T import Data.Text.Read qualified as T import Data.Time (UTCTime, getCurrentTime) +import Distribution.Package (pkgName, pkgVersion, unPackageName) +import Distribution.PackageDescription (package, packageDescription) +import Distribution.Pretty (prettyShow) import Distribution.Version (Version, mkVersion) import GHC.IO.Handle (hDuplicate) import System.Directory @@ -91,12 +94,13 @@ std_out, waitForProcess, ) +import Tilia.Cabal.Package (readPackageDescription) 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) +import Tilia.Utils (quietly, sha256Of) ---------------------------------------------------------------------------- -- The plan @@ -250,7 +254,8 @@ ) (_, Just "local") -> LocalPackage (maybe "" T.unpack (join sourcePath)) (_, Just "source-repo") -> SourceRepo - -- Anything else is treated as already present. + -- Anything else, a local or remote tarball among them, is + -- treated as already present. _ -> PreExisting } @@ -320,15 +325,12 @@ | 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 + isThePackage p dir = + either (const False) (describes p . package . packageDescription) + <$> readPackageDescription (dir T.unpack (ppName p) <> ".cabal") + describes p identifier = + T.pack (unPackageName (pkgName identifier)) == ppName p + && T.pack (prettyShow (pkgVersion identifier)) == ppVersion p -- | The version macros a plan settles. macrosOf :: BuildPlan -> Macros @@ -453,12 +455,8 @@ 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. + | -- | The plan is there, and the packages named have neither been + -- downloaded nor built. SourcesMissing [Text] deriving (Eq, Show) @@ -467,30 +465,40 @@ 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)) + readinessOf caching wanted projectDir =<< readBuildPlan (planPathFor projectDir) +-- | 'checkReadiness', given the plan as read. +readinessOf :: + -- | Whether to use the cache. + Choice "useCache" -> + -- | The components the run is about to format. + [PlanComponent] -> + -- | The project whose plan it is. + FilePath -> + -- | Its plan, or why it could not be read. + Either Text BuildPlan -> + IO Readiness +readinessOf caching wanted projectDir = \case + Left _ -> pure PlanMissing + Right plan -> do + cache <- openCache caching =<< tokenForBuildPlan plan + solved <- cachedSolveTime cache + 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 cache 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 +sourcesShortOf :: Cache -> BuildPlan -> IO [PlanPackage] +sourcesShortOf cache plan = do tarballs <- filter (isFetchable . fst) <$> plannedTarballs cache plan absent <- fmap fst <$> filterM (fmap not . doesFileExist . snd) tarballs if null absent @@ -593,7 +601,7 @@ IO (Either Text ()) prepareWith caching downloading cabal futility wanted projectDir = \case Ready -> pure (Right ()) - SourcesMissing _ -> fetch + SourcesMissing short -> fetch short PlanMissing -> solveThenFetch PlanStale _ -> solveThenFetch PlanNarrow _ -> @@ -606,24 +614,24 @@ 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 + fetch short + | isFalse downloading = pure (Right ()) + | otherwise = do refused <- fetchWasFutileFor futility - if null short || all (`elem` refused) short + if all (`elem` refused) short then pure (Right ()) else - fetch >>= \case + tryWholeProject ["build", ":all", "--only-download"] >>= \case Left err -> pure (Left err) - Right () -> do - left <- sourcesShortOf caching plan - rememberFutileFetch futility (fmap ppName left) - pure (Right ()) + Right () -> + withPlan ((Right () <$) . rememberFutileFetch futility) + fetchWhatIsShort = withPlan fetch + withPlan use = + readBuildPlan (planPathFor projectDir) >>= \case + Left _ -> pure (Right ()) + Right plan -> do + cache <- openCache caching =<< tokenForBuildPlan plan + use . fmap ppName =<< sourcesShortOf cache plan solveThenFetch = do started <- getCurrentTime tryWholeProject ["build", ":all", "--dry-run"] >>= \case @@ -631,7 +639,7 @@ Right () -> do rememberSolveTime futility started checkReadiness caching wanted projectDir >>= \case - SourcesMissing _ -> fetch + SourcesMissing short -> fetch short PlanNarrow _ -> rememberFutileSolve futility >> fetchWhatIsShort _ -> pure (Right ()) @@ -669,8 +677,9 @@ -- | The build plan to use. BuildPlan -> IO () -fetchUninstalled caching projectDir plan = - sourcesShortOf caching plan >>= \case +fetchUninstalled caching projectDir plan = do + cache <- openCache caching =<< tokenForBuildPlan plan + sourcesShortOf cache plan >>= \case [] -> pure () short -> void . runCabal projectDir $ @@ -691,31 +700,37 @@ 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) + written <- readBuildPlan (planPathFor projectDir) + readiness <- readinessOf caching wanted projectDir written + case (readiness, written) of + (Ready, Right plan) -> pure (Right plan) + _ -> + 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. +-- a tarball it downloads is not there and a fetch has not already failed +-- to bring it in, when @cabal@ is asked again. plannedTarballs :: Cache -> BuildPlan -> IO [(PlanPackage, FilePath)] plannedTarballs cache plan = cachedPackageCache cache >>= \case Just remembered -> do tarballs <- under remembered + refused <- cachedFutileFetch cache absent <- filterM (fmap not . doesFileExist . snd) - (filter (isFetchable . fst) tarballs) + [t | t@(p, _) <- tarballs, isFetchable p, ppName p `notElem` refused] if null absent then pure tarballs else asked Nothing -> asked where @@ -727,7 +742,7 @@ repos <- quietly [] (Data.List.sort <$> listDirectory cacheRoot) traverse (\p -> (,) p <$> tarballFor cacheRoot repos p) - [p | p <- bpPackages plan, not (isLocal p)] + (nubOrdOn (\p -> (ppName p, ppVersion p)) [p | p <- bpPackages plan, not (isLocal p)]) isLocal p = case ppSource p of LocalPackage _ -> True CheckedOut _ -> True diff --git a/src/Tilia/Cabal/Project.hs b/src/Tilia/Cabal/Project.hs --- a/src/Tilia/Cabal/Project.hs +++ b/src/Tilia/Cabal/Project.hs @@ -7,6 +7,7 @@ Marker (..), markerFile, findProjectRoot, + startingDirectory, cabalFilesIn, ) where @@ -49,30 +50,37 @@ -- | Walk upwards from a file or directory looking for a project. findProjectRoot :: FilePath -> IO (Maybe ProjectRoot) findProjectRoot start = quietly Nothing $ do - from <- startingDirectory + from <- startingDirectory =<< canonicalizePath start found <- traverse markersIn (from : ancestorsOf from) pure (listToMaybe (concatMap fst found <> concatMap snd found)) where - startingDirectory = do - absolute <- canonicalizePath start - isDirectory <- doesDirectoryExist absolute - pure (if isDirectory then absolute else takeDirectory absolute) - ancestorsOf directory = let parent = takeDirectory directory in if parent == directory then [] else parent : ancestorsOf parent markersIn directory = quietly ([], []) $ do entries <- listDirectory directory - packages <- cabalFilesIn directory + packages <- cabalFilesAmong directory entries pure ( [ProjectRoot directory ProjectFile | "cabal.project" `elem` entries], [ProjectRoot directory (PackageFile (takeFileName p)) | p <- take 1 packages] ) +-- | Where a walk upwards from a path starts: the path itself if it names a +-- directory, else the directory holding it. +startingDirectory :: FilePath -> IO FilePath +startingDirectory path = do + isDirectory <- quietly False (doesDirectoryExist path) + pure (if isDirectory then path else takeDirectory path) + -- | 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) +cabalFilesIn directory = + quietly [] (cabalFilesAmong directory =<< listDirectory directory) + +-- | The @.cabal@ files among a directory's entries, in order. +cabalFilesAmong :: FilePath -> [FilePath] -> IO [FilePath] +cabalFilesAmong directory entries = + filterM + doesFileExist + (fmap (directory ) (sort (filter (".cabal" `isSuffixOf`) entries))) diff --git a/src/Tilia/Cabal/Target.hs b/src/Tilia/Cabal/Target.hs --- a/src/Tilia/Cabal/Target.hs +++ b/src/Tilia/Cabal/Target.hs @@ -9,11 +9,12 @@ parseTarget, Component (..), Wanted (..), - TargetProblem (..), + TargetProblem, describeTargetProblem, componentsOfTarget, componentInPlan, filesOfComponents, + packageFilesOf, ) where @@ -31,14 +32,8 @@ import Data.Text.Encoding qualified as T import Distribution.Fields.Field (Field (..), FieldLine (..), Name (..)) import Distribution.Fields.Parser (readFields) -import Distribution.PackageDescription - ( GenericPackageDescription (..), - PackageDescription (..), - unPackageName, - unUnqualComponentName, - ) -import Distribution.Types.PackageId (PackageIdentifier (..)) -import System.Directory (doesFileExist, listDirectory) +import Distribution.PackageDescription (GenericPackageDescription (..)) +import System.Directory (canonicalizePath, doesFileExist, listDirectory) import System.FilePath ( dropTrailingPathSeparator, normalise, @@ -47,22 +42,21 @@ ) import Tilia.Cabal.Package ( ComponentSection (..), + Kind (..), PackageProblem, addedSources, - benchmarkBranches, describePackageProblem, - executableBranches, isDeclaredModule, joined, - libraryBranches, + packageComponents, + packageOf, readPackageDescription, setupScript, - suiteBranches, ) import Tilia.Cabal.Plan (PlanComponent (..)) import Tilia.Cabal.Project (Marker (..), ProjectRoot (..), cabalFilesIn, markerFile) -import Tilia.Ignore (belowRoot, ignoreFilesAbove, isIgnored) -import Tilia.Utils (fieldWords, quietly) +import Tilia.Ignore (withoutIgnored) +import Tilia.Utils (fieldWords, quietly, tshow) -- | Which components a run was asked for. data Target @@ -74,11 +68,6 @@ Qualified (Maybe Text) Kind Text deriving (Eq, Show) --- | The kinds of component a @.cabal@ file can declare, and the setup --- script beside it. -data Kind = Lib | Exe | Test | Bench | Setup - deriving (Eq, Ord, Show) - -- | Read a target as it was written on the command line. parseTarget :: String -> Either Text Target parseTarget written = case T.splitOn ":" (T.strip (T.pack written)) of @@ -91,7 +80,7 @@ where unrecognised = "unrecognised target " - <> T.pack (show written) + <> tshow written <> ": expected all, a package or component name, or one of\ \ lib:, exe:, test:, bench: followed by a name" kindNamed = \case @@ -120,7 +109,7 @@ componentPackage :: Text, -- | Which kind it is. componentKind :: Kind, - -- | Its name, which for a library is the package's own. + -- | Its name, which for the main library is the package's own. componentName :: Text, -- | The directory its @.cabal@ file sits in. componentRoot :: FilePath, @@ -203,8 +192,9 @@ -- | How a build plan names this component, if it has an entry of its own. -- --- A plan writes a library as @lib@ and everything else as its kind and --- name, which is not quite how a target is written: see 'spellComponent'. +-- A plan writes the main library as @lib@ and everything else, sub-libraries +-- among them, as its kind and name, which is not quite how a target is +-- written: see 'spellComponent'. -- A setup script has an entry only when the build type is @Custom@, so a -- plan is never expected to say anything about it. componentInPlan :: Component -> Maybe PlanComponent @@ -215,7 +205,7 @@ PlanComponent { pcPackage = componentPackage c, pcName = case kind of - Lib -> "lib" + Lib | componentName c == componentPackage c -> "lib" _ -> spellKind kind <> ":" <> componentName c } @@ -240,22 +230,17 @@ -- the ones the project's @.tiliaignore@ files exclude. filesOfComponents :: ProjectRoot -> [Component] -> IO [FilePath] filesOfComponents root components = do - candidates <- concat <$> traverse present (Map.toList directories) - let inProject = - [ (path, below) - | path <- candidates, - Just below <- [belowRoot (prPath root) path] + directories <- + Map.fromListWith (<>) + <$> sequence + [ (,wanted) <$> quietly d (canonicalizePath d) + | c <- components, + (written, wanted) <- Map.toList (componentSources c), + let d = joined (componentRoot c) written ] - ignoreFiles <- ignoreFilesAbove (prPath root) (fmap snd inProject) - let excluded = Set.fromList [path | (path, below) <- inProject, isIgnored ignoreFiles below] - pure (sort (filter (`Set.notMember` excluded) candidates)) + candidates <- concat <$> traverse present (Map.toList directories) + sort <$> withoutIgnored (prPath root) candidates where - directories = - Map.unionsWith - (<>) - [ Map.mapKeys (joined (asDirectory (componentRoot c))) (componentSources c) - | c <- components - ] present (directory, wanted) = do entries <- quietly [] (listDirectory directory) filterM @@ -302,11 +287,11 @@ packageToCabalFile root entry = do paths <- packageGlobToCabalFiles - root - (fmap T.unpack (T.split (== '/') (T.dropWhile (== '.') stripped))) + (if "/" `T.isPrefixOf` written then "/" else root) + (fmap T.unpack (T.split (== '/') written)) concat <$> traverse asPackage paths where - stripped = T.dropWhile (== '/') (T.strip entry) + written = T.strip entry asPackage path | ".cabal" `isSuffixOf` path = do there <- quietly False (doesFileExist path) @@ -358,11 +343,6 @@ | hasSetup ] --- | The name of a package. -packageOf :: GenericPackageDescription -> Text -packageOf = - T.pack . unPackageName . pkgName . Distribution.PackageDescription.package . packageDescription - -- | The directories a branch's declarations may be found in under one -- source directory. sourcesIn :: FilePath -> ComponentSection -> Map FilePath Wanted @@ -376,21 +356,11 @@ -- | The components of a parsed @.cabal@ file, in the order declared. declaredComponents :: FilePath -> GenericPackageDescription -> [Component] declaredComponents root described = - concat - [ foldMap - (pure . made Lib package . libraryBranches) - (condLibrary described), - [made Lib (nameOf n) (libraryBranches t) | (n, t) <- condSubLibraries described], - [made Exe (nameOf n) (executableBranches t) | (n, t) <- condExecutables described], - [made Test (nameOf n) (suiteBranches t) | (n, t) <- condTestSuites described], - [made Bench (nameOf n) (benchmarkBranches t) | (n, t) <- condBenchmarks described] - ] + [made kind name branches | (kind, name, branches) <- packageComponents described] where - package = packageOf described - nameOf = T.pack . unUnqualComponentName made kind name branches = Component - { componentPackage = package, + { componentPackage = packageOf described, componentKind = kind, componentName = name, componentRoot = root, diff --git a/src/Tilia/Comments.hs b/src/Tilia/Comments.hs --- a/src/Tilia/Comments.hs +++ b/src/Tilia/Comments.hs @@ -39,7 +39,17 @@ import Data.Text qualified as T 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.Pragma (withoutSkippedComments) +import Tilia.Source.Lines + ( Lines, + blankAt, + columnOf, + contentColumn, + directiveOnLine, + lineAt, + lineTexts, + offsetOf, + ) import Tilia.Span (Span (..), covers) import Tilia.Span.Ghc (spanOfReal) @@ -86,7 +96,8 @@ -- | What was on the line above a comment. data Above - = -- | The comment begins on the first line of the file. + = -- | Nothing: the comment begins on the first line of the file, or the + -- line above is not in this configuration. TopOfFile | -- | An empty line. BlankLine @@ -141,21 +152,20 @@ Nothing -> TopOfFile Just l | T.all isSpace l -> BlankLine - | otherwise -> ContentAt (contentStart l) + | otherwise -> ContentAt (contentColumn l) before' = maybe T.empty (T.stripEnd . T.take startColumn) openingLine codeBeforeStopsAt = do l <- openingLine if T.null before' then Nothing else Just (columnOf l (T.length before')) nextLine = listToMaybe - [ (n, contentStart l) + [ (n, contentColumn l) | (n, Just l) <- takeWhile (isJust . snd) [(n, lineAt n ls) | n <- [spanEndLine spn + 1 ..]], not (T.all isSpace l || isJust (directiveOnLine l)) ] - contentStart l = columnOf l (T.length (T.takeWhile isSpace l)) followed = case lineAt (spanEndLine spn) ls of Just l -> not (T.all isSpace (T.drop (offsetOf l (spanEndColumn spn)) l)) Nothing -> False @@ -374,7 +384,7 @@ spanStartColumn = if n == spanStartLine s then spanStartColumn s - else columnOf l (T.length (T.takeWhile isSpace l)), + else contentColumn l, spanEndLine = n, spanEndColumn = if n == spanEndLine s @@ -453,47 +463,28 @@ { -- | The name, upper-cased as GHC expects it, e.g. @LANGUAGE@. pragmaName :: Text, -- | Everything between the name and the closing @#-}@, with the - -- surrounding whitespace removed but nothing else touched. - pragmaBody :: Text + -- surrounding whitespace removed, on one line, and without the comments + -- GHC skips in a @LANGUAGE@ pragma. + pragmaBody :: Text, + -- | Whether it holds such a comment. + pragmaCommented :: Bool } deriving (Eq, Show) -- | Recognise a pragma. commentPragma :: Comment -> Maybe Pragma commentPragma c = do - inner <- T.stripSuffix "#-}" =<< T.stripPrefix "{-#" oneLine - let (name, body) = T.break isSpace (T.stripStart inner) + inner <- T.stripSuffix "#-}" =<< T.stripPrefix "{-#" (T.strip written) + let uncommented = withoutSkippedComments inner + (name, body) = T.break isSpace (T.stripStart uncommented) if T.null name then Nothing else Just Pragma { pragmaName = T.toUpper name, - pragmaBody = T.strip body + pragmaBody = T.strip (T.unwords (fmap T.strip (T.lines body))), + pragmaCommented = uncommented /= inner } where - oneLine = T.unwords (fmap T.strip (NE.toList (commentBody c))) - --- | How many characters of a line come before the compiler's column. --- --- A column is not a character offset. The lexer counts a tab as advancing to --- the next multiple of eight, so a line with a tab in it has more columns --- than it has characters, and cutting the text at a column would cut in the --- wrong place. In a file indented with tabs that is every line. -offsetOf :: Text -> Int -> Int -offsetOf line column = T.length (T.take (walk 0 1) line) - where - walk i c - | c >= column = i - | i >= T.length line = i + (column - c) - | otherwise = walk (i + 1) (afterChar (T.index line i) c) - --- | The compiler's column for the character at this offset. -columnOf :: Text -> Int -> Int -columnOf line offset = T.foldl' (flip afterChar) 1 (T.take offset line) - --- | Where the column moves to once this character has been read. -afterChar :: Char -> Int -> Int -afterChar ch c - | ch == '\t' = ((c - 1) `div` 8 + 1) * 8 + 1 - | otherwise = c + 1 + written = T.intercalate "\n" (NE.toList (commentBody c)) diff --git a/src/Tilia/Comments/Attach.hs b/src/Tilia/Comments/Attach.hs --- a/src/Tilia/Comments/Attach.hs +++ b/src/Tilia/Comments/Attach.hs @@ -9,7 +9,6 @@ ( attachComments, attachScopedComments, Margin (..), - noMargin, ) where diff --git a/src/Tilia/Cpp.hs b/src/Tilia/Cpp.hs --- a/src/Tilia/Cpp.hs +++ b/src/Tilia/Cpp.hs @@ -67,7 +67,7 @@ import Tilia.Source ( Lines, Written (..), - blankAt, + blankAcross, comments, dropping, linesOf, @@ -317,7 +317,7 @@ upTo 0 ( go (concatMap (`nestedIn` 0) gss) - : [ if holdsNothing r && all holdsNothing (take 1 (gsBranches gs)) + : [ if blankAcross r written && all (`blankAcross` written) (take 1 (gsBranches gs)) then 0 else go (nestedIn gs i <> concatMap (`nestedIn` 0) others) | (k, gs) <- zip [0 :: Int ..] gss, @@ -332,7 +332,6 @@ ) ] ) - holdsNothing (from, to) = all (`blankAt` written) [from .. to] upTo acc = \case _ | acc > limit -> acc [] -> acc diff --git a/src/Tilia/Cpp/Directives.hs b/src/Tilia/Cpp/Directives.hs --- a/src/Tilia/Cpp/Directives.hs +++ b/src/Tilia/Cpp/Directives.hs @@ -9,7 +9,7 @@ withoutRuledOut, withoutOpaque, CppError (..), - Malformation (..), + Malformation, describeCppError, -- * Splitting @@ -25,7 +25,6 @@ ruledOutBranch, unconditionalErrors, Assignment, - resolved, -- * The directives themselves Directive (..), @@ -46,7 +45,6 @@ ) where -import Data.Char (isAlphaNum, isSpace) import Data.List (sortOn, tails) import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map @@ -55,13 +53,17 @@ import Data.Text (Text) import Data.Text qualified as T import GHC.LanguageExtensions.Type (Extension (..)) -import Tilia.Cpp.Macros (Macros, guardHolds, impliedBy) +import Tilia.Cpp.Macros (Macros, guardHolds, impliedBy, isNameChar) import Tilia.Doc.Internal (Conditional (..)) import Tilia.Parser (ParseError, describeParseError) import Tilia.Source.Lines - ( conditionalKeywords, + ( Written (..), + blankAcross, + conditionalKeywords, + contentColumn, continuesGroup, directiveOnLine, + linesOf, opaqueKeywords, opensGroup, ) @@ -71,6 +73,7 @@ spanEndLine, spanStartLine, ) +import Tilia.Utils (tshow) ---------------------------------------------------------------------------- -- Reading a module @@ -165,23 +168,23 @@ describeCppError :: CppError -> Text describeCppError = \case MalformedConditional n k m -> - "the #" <> k <> " at line " <> T.pack (show n) <> case m of + "the #" <> k <> " at line " <> tshow n <> case m of NeverClosed -> " is never closed" NothingOpen -> " has no conditional to belong to" AfterElse -> " comes after the #else of its conditional" TooManyConfigurations -> "too many configurations to format" ConfigurationNotParsed c e -> describeParseError e <> inConfiguration c DirectiveInQuotedText n k -> - "the #" <> k <> " at line " <> T.pack (show n) <> " is inside a quasi-quote or a multi-line string" + "the #" <> k <> " at line " <> tshow n <> " is inside a quasi-quote or a multi-line string" MacroInQuotedText n t -> - t <> " at line " <> T.pack (show n) <> " is inside a quasi-quote or a multi-line string" + t <> " at line " <> tshow n <> " is inside a quasi-quote or a multi-line string" RuledOutBranch n -> "the branch at line " - <> T.pack (show n) + <> tshow n <> " is ruled out by a conditional around it that asks the same question" AbortingAlternative n -> "the alternative that the #error at line " - <> T.pack (show n) + <> tshow n <> " aborts cannot be formatted without parsing it" -- | Which configuration, in words. Empty where there is only one. @@ -261,17 +264,16 @@ branchLeaves :: Text -> Either CppError [Text] branchLeaves source = do forest <- readConditionals source - traverse - resolved - ( filter - (null . unconditionalErrors) - ( distinct - [ configurationOf forest a source - | a <- branchAssignments forest, - possible forest (completed forest a) - ] - ) - ) + pure + [ withoutOpaque leaf + | leaf <- + distinct + [ configurationOf forest a source + | a <- branchAssignments forest, + possible forest (completed forest a) + ], + null (unconditionalErrors leaf) + ] where distinct = Map.elems . Map.fromList . fmap (\t -> (t, t)) @@ -366,16 +368,14 @@ forest <- scanConditionals source listToMaybe (go Map.empty forest) where - written = zip [1 ..] (T.lines source) - holdsSomething (from, to) = - any (\(n, l) -> from <= n && n <= to && not (T.all isSpace l)) written + written = linesOf (Written source) go asked forest = concat [ [ opening | Just j <- [Map.lookup (gsGuards gs) asked], (i, opening, r) <- zip3 [0 :: Int ..] (gsOwnLines gs) (gsBranches gs), i /= j, - holdsSomething r + not (blankAcross r written) ] <> concat [ go (Map.insert (gsGuards gs) i asked) nested @@ -408,13 +408,13 @@ let answers = completed forest a, possible forest answers ] - traverse (\a -> (,) <$> reading before left a <*> reading after right a) choices + pure [(reading before left a, reading after right a) | a <- choices] where reading source forest assignment = let selected = configurationOf forest assignment source in if null (unconditionalErrors selected) - then Just <$> resolved selected - else Right Nothing + then Just (withoutOpaque selected) + else Nothing -- | An unconditional @#error@ means this configuration has no Haskell -- program to parse. Conditional errors are only considered after choosing a @@ -433,11 +433,6 @@ -- | Which branch every question was answered with to reach a configuration. type Assignment = Map [Guard] Int --- | 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 -resolved source = withoutOpaque source <$ readConditionals source - ---------------------------------------------------------------------------- -- The directives themselves @@ -646,7 +641,7 @@ written = directives source inDirective n = any (\d -> dLine d <= n && n <= dLastLine d) written code (n, l) = not (T.null (T.strip l) || inDirective n || uses l) - indentation = T.length . T.takeWhile isSpace + indentation l = contentColumn l - 1 closing = maybe False ((`elem` ("})]" :: String)) . fst) . T.uncons . T.stripStart uses l = Set.member name defined && enclosed arguments where @@ -672,4 +667,3 @@ '(' -> k + 1 ')' -> k - 1 _ -> k - isNameChar c = isAlphaNum c || c == '_' diff --git a/src/Tilia/Cpp/Macros.hs b/src/Tilia/Cpp/Macros.hs --- a/src/Tilia/Cpp/Macros.hs +++ b/src/Tilia/Cpp/Macros.hs @@ -7,6 +7,7 @@ ( Macros (..), guardHolds, impliedBy, + isNameChar, ) where @@ -329,5 +330,6 @@ isNameStart :: Char -> Bool isNameStart c = isAsciiLower c || isAsciiUpper c || c == '_' +-- | Can a character be part of a preprocessor name? isNameChar :: Char -> Bool isNameChar c = isNameStart c || isDigit c diff --git a/src/Tilia/Cpp/Merge.hs b/src/Tilia/Cpp/Merge.hs --- a/src/Tilia/Cpp/Merge.hs +++ b/src/Tilia/Cpp/Merge.hs @@ -43,7 +43,7 @@ unwrap, wrap, ) -import Tilia.Source (Lines, lineAt) +import Tilia.Source (Lines, lineAt, offsetOf) import Tilia.Span (Span (..), covers, endOf, meets, startOf, zeroWidth) -- | A conditional other than the one asked about that answering a question @@ -81,7 +81,7 @@ | s : others <- spines, all (agreeAll varied layout s) others = d - | Just xs <- traverse only spines = alongside layout xs + | Just xs <- traverse sole spines = alongside layout xs | otherwise = factored middle layout spines where spines = fmap (spineAt layout) ds @@ -124,9 +124,6 @@ inside <- sole [i | (i, s) <- zip [0 :: Int ..] spans, all (covers s) spans] openedAgainst inside layout =<< listToMaybe (drop inside xs) where - sole [i] = Just i - sole _ = Nothing - openedAgainst inside l d = case unwrap d of Just (w, x) -> wrap w <$> openedAgainst inside (layoutInside l w) x Nothing -> case spineAt l d of @@ -246,7 +243,7 @@ middle _ [] = mempty middle layout ss@(s : rest) | all (alike layout s) rest = mconcat s - | Just xs <- traverse only ss = go layout xs + | Just xs <- traverse sole ss = go layout xs | Just (c, tails) <- commaLed layout ss = c <> middle layout tails | otherwise = minimumBy @@ -433,8 +430,11 @@ Just (from, to) -> any (\(a, b) -> from < a && b < to) (concatMap printedFrom ds) Nothing -> False - only [d] = Just d - only _ = Nothing +-- | The one element of a list that has one. +sole :: [a] -> Maybe a +sole = \case + [x] -> Just x + _ -> Nothing -- | Would these two documents print the same, laid out like this? agree :: Varied -> Layout -> Doc -> Doc -> Bool @@ -548,12 +548,9 @@ [] -> Just base [(_, only)] -> Just only many -> case (spineAt layout base, [(v, spineAt layout d) | (v, d) <- many]) of - ([b], ss) | Just xs <- traverse (\(v, s) -> (,) v <$> single s) ss -> descend b xs + ([b], ss) | Just xs <- traverse (\(v, s) -> (,) v <$> sole s) ss -> descend b xs (bs, ss) -> spliced bs ss where - single [d] = Just d - single _ = Nothing - descend b xs = do own@(_, i) <- unwrap b others <- traverse (traverse unwrap) xs @@ -579,7 +576,7 @@ cluster _ [c] = Just c cluster bs cs | to - from == 1, - Just xs <- traverse (\c -> (,) (chVaried c) <$> single (chWith c)) cs, + Just xs <- traverse (\c -> (,) (chVaried c) <$> sole (chWith c)) cs, (b : _) <- drop from bs = ( \d -> Change @@ -769,7 +766,7 @@ Just s -> maybe False - (T.all isSpace . T.take (spanStartColumn s - 1)) + (\l -> T.all isSpace (T.take (offsetOf l (spanStartColumn s)) l)) (lineAt (spanStartLine s) written) Nothing -> False diff --git a/src/Tilia/Cpp/Place.hs b/src/Tilia/Cpp/Place.hs --- a/src/Tilia/Cpp/Place.hs +++ b/src/Tilia/Cpp/Place.hs @@ -13,6 +13,7 @@ ) where +import Control.Applicative ((<|>)) import Control.Monad (foldM) import Data.List (sortOn, unsnoc) import Data.Map.Strict (Map) @@ -61,7 +62,7 @@ wrap, ) import Tilia.Source (Lines, Written (..), blankAt, lineAt, linesOf) -import Tilia.Span (Span (..), mkSpan) +import Tilia.Span (Span (..), mkSpan, startPoint) -- | What the configurations of a module had besides their code. data CommentSummary = CommentSummary @@ -330,24 +331,23 @@ hulls = Map.filter ((> 1) . length) - (Map.fromListWith (<>) [(startPoint' s, [s]) | d <- ds, s <- outermost d]) + (Map.fromListWith (<>) [(startPoint s, [s]) | d <- ds, s <- outermost d]) rewrite seen = \case DLocated s x - | Set.notMember (startPoint' s) seen, - Just ss <- Map.lookup (startPoint' s) hulls -> - DLocated (foldr (<>) s ss) (rewrite (Set.insert (startPoint' s) seen) x) - | otherwise -> DLocated s (rewrite (Set.insert (startPoint' s) seen) x) + | Set.notMember (startPoint s) seen, + Just ss <- Map.lookup (startPoint s) hulls -> + DLocated (foldr (<>) s ss) (rewrite (Set.insert (startPoint s) seen) x) + | otherwise -> DLocated s (rewrite (Set.insert (startPoint s) seen) x) d@DCppChoice{} -> d d -> mapChildren (rewrite seen) d outermost = go Set.empty where go seen = \case DLocated s x - | Set.member (startPoint' s) seen -> go seen x - | otherwise -> s : go (Set.insert (startPoint' s) seen) x + | Set.member (startPoint s) seen -> go seen x + | otherwise -> s : go (Set.insert (startPoint s) seen) x DCppChoice{} -> [] d -> foldChildren (go seen) d - startPoint' s = (spanStartLine s, spanStartColumn s) -- | Give one alternative of a choice its anchors. anchoredIn :: @@ -462,62 +462,65 @@ Int -> -- | What to put there. Doc -> - -- | How to put it among the lines of something that begins above it, at - -- that thing's own indentation. + -- | How to put it before code printed further in, which carries on a line + -- above. (Doc -> Doc) -> Doc -> Doc -placeAt present written n body continuing = among [] body +placeAt present written n body continuing = among [] where - within ctx b d = case d of - DNest 0 x -> DNest 0 (within ctx b x) - DNest k x -> DNest k (within ctx body x) - DAlign x -> DAlign (within ctx body x) - DGroup l x -> DGroup l (within ctx b x) - DVariant x y -> DVariant (within ctx b x) (within ctx b y) + within ctx d = case d of + DNest k x -> DNest k (within ctx x) + DAlign x -> DAlign (within ctx x) + DGroup l x -> DGroup l (within ctx x) + DVariant x y -> DVariant (within ctx x) (within ctx y) DLocated s x - | spanStartLine s > n -> among ctx b d - | DCppChoice{} <- x -> DLocated s (within ctx b x) - | otherwise -> DLocated s (within ctx (continuing body) x) - DFence s x -> DFence s (within ctx b x) + | spanStartLine s > n -> among ctx d + | otherwise -> DLocated s (within ctx x) + DFence s x -> DFence s (within ctx x) DCppChoice cs bs e | present ctx -> d | otherwise -> case alternativeAt n cs of Everywhere -> DCppChoice cs - [(g, among (ctx <> [(cs, k)]) b x) | (k, (g, x)) <- zip [0 ..] bs] - (among (ctx <> [(cs, length bs)]) b e) + [(g, among (ctx <> [(cs, k)]) x) | (k, (g, x)) <- zip [0 ..] bs] + (among (ctx <> [(cs, length bs)]) e) Only k | k < length bs -> DCppChoice cs - (replaced k (among (ctx <> [(cs, k)]) b (maybe mempty snd (listToMaybe (drop k bs)))) bs) + (replaced k (among (ctx <> [(cs, k)]) (maybe mempty snd (listToMaybe (drop k bs)))) bs) e - | otherwise -> DCppChoice cs bs (among (ctx <> [(cs, k)]) b e) + | otherwise -> DCppChoice cs bs (among (ctx <> [(cs, k)]) e) Nowhere -> d - _ -> among ctx b d + _ -> among ctx d - among ctx b d + among ctx d | present ctx = d | otherwise = case break startsAfter (spine d) of (before, after) | Just (earlier, holder, spacing) <- lastBounded before, maybe False (>= n) (endOf holder) -> - mconcat (earlier <> [within ctx b holder] <> spacing <> after) + mconcat (earlier <> [within ctx holder] <> spacing <> after) | (later, holder : rest) <- break holds after -> - mconcat (before <> later <> [within ctx b holder] <> rest) + mconcat (before <> later <> [within ctx holder] <> rest) | Just (printed, anchor, spacing) <- lastBounded before, Just from <- endOf anchor, Just ls <- written -> if any (`blankAt` ls) [from .. n - 1] || not (all onlySpacing spacing) - then mconcat (before <> [includeWhen (blankAt (n - 1) ls) blankLine, b] <> after) - else mconcat (printed <> [anchor, b] <> spacing <> after) + then mconcat (before <> [includeWhen (blankAt (n - 1) ls) blankLine, putBefore after] <> after) + else mconcat (printed <> [anchor, putBefore (spacing <> after)] <> spacing <> after) | next : rest <- after, any (not . onlySpacing) (takeWhile unbounded (reverse before)) -> - mconcat (before <> [within ctx b next] <> rest) - | otherwise -> mconcat (before <> [b] <> after) + mconcat (before <> [within ctx next] <> rest) + | otherwise -> mconcat (before <> [putBefore after] <> after) + putBefore following = + if maybe False (> 0) (firstNesting (mconcat following)) + then continuing body + else body + holds = \case DLocated s _ -> spanStartLine s < n && n <= spanEndLine s _ -> False @@ -576,6 +579,17 @@ from < n, n < to ] + +-- | How many steps further in than itself a document prints its first +-- text, if it prints any. +firstNesting :: Doc -> Maybe Int +firstNesting = \case + DText _ -> Just 0 + DCat a b -> firstNesting a <|> firstNesting b + DNest k x -> (+ k) <$> firstNesting x + DVariant _ x -> firstNesting x + DCppChoice _ bs e -> foldr ((<|>) . firstNesting . snd) (firstNesting e) bs + d -> firstNesting . snd =<< unwrap d -- | The lines a document was printed from, first and last. boundsOf :: Doc -> Maybe (Int, Int) diff --git a/src/Tilia/Diff.hs b/src/Tilia/Diff.hs --- a/src/Tilia/Diff.hs +++ b/src/Tilia/Diff.hs @@ -19,6 +19,7 @@ import Data.Text (Text) import Data.Text qualified as T import Tilia.Palette (Color (..), Palette, paint) +import Tilia.Utils (tshow) -- | What a line of the comparison does. data Mark = Context | Removed | Added @@ -98,7 +99,7 @@ <> " @@" where span' which n = case slice range of - (l : _) -> T.pack (show (which l)) <> "," <> T.pack (show n) + (l : _) -> tshow (which l) <> "," <> tshow n [] -> "0,0" line (Line mark _ _ text) = case mark of diff --git a/src/Tilia/Doc.hs b/src/Tilia/Doc.hs --- a/src/Tilia/Doc.hs +++ b/src/Tilia/Doc.hs @@ -5,12 +5,7 @@ ) where -import Data.Text (Text) import Tilia.Doc.Internal ( Doc, - render, + printDoc, ) - --- | Render a document to source text. -printDoc :: Doc -> Text -printDoc = render diff --git a/src/Tilia/Doc/Body.hs b/src/Tilia/Doc/Body.hs --- a/src/Tilia/Doc/Body.hs +++ b/src/Tilia/Doc/Body.hs @@ -1,4 +1,5 @@ --- | Something that can appear as the body of an enclosing construct. +-- | The bodies of enclosing constructs, and how each joins what comes +-- before it. module Tilia.Doc.Body ( Body (..), attachBody, diff --git a/src/Tilia/Doc/Combinators.hs b/src/Tilia/Doc/Combinators.hs --- a/src/Tilia/Doc/Combinators.hs +++ b/src/Tilia/Doc/Combinators.hs @@ -16,6 +16,7 @@ LineStart (..), TrailingWhitespace (..), verbatimBreak, + verbatimLines, verbatim, emptyAnchor, insideBrackets, @@ -49,7 +50,6 @@ -- * Wrapping ClosingIndent (..), - bracket, parens, parensWith, brackets, @@ -127,12 +127,13 @@ verbatimBreak :: LineStart -> TrailingWhitespace -> Doc verbatimBreak = DVerbatimBreak +-- | Lines of text reproduced, each break between them a 'verbatimBreak'. +verbatimLines :: LineStart -> TrailingWhitespace -> [Text] -> Doc +verbatimLines start trailing = sepBy (verbatimBreak start trailing) . fmap txt + -- | Text reproduced exactly, line breaks and all. verbatim :: Text -> Doc -verbatim = - sepBy (verbatimBreak AtMargin KeepWhitespace) - . fmap txt - . T.splitOn "\n" +verbatim = verbatimLines AtMargin KeepWhitespace . T.splitOn "\n" -- | An empty anchor so that comments can attach to it in situations when -- nothing more substantial is present but the position is such that it @@ -269,18 +270,6 @@ ---------------------------------------------------------------------------- -- Wrapping --- | Surround with the given opening and closing documents, adding nothing --- of its own. -enclose :: - -- | Opening bracket. - Doc -> - -- | Closing bracket. - Doc -> - -- | Body. - Doc -> - Doc -enclose open close body = open <> body <> close - -- | Where the closing bracket of a broken bracket pair goes. data ClosingIndent = -- | Back out to the level the opening bracket is on. @@ -399,7 +388,7 @@ -- | Surround with backticks. backticks :: Doc -> Doc -backticks = enclose (txt "`") (txt "`") +backticks d = txt "`" <> d <> txt "`" ---------------------------------------------------------------------------- -- Punctuation diff --git a/src/Tilia/Doc/Internal.hs b/src/Tilia/Doc/Internal.hs --- a/src/Tilia/Doc/Internal.hs +++ b/src/Tilia/Doc/Internal.hs @@ -25,7 +25,7 @@ TrailingWhitespace (..), -- * Rendering - render, + printDoc, ) where @@ -403,8 +403,8 @@ } -- | Turn a document into text. -render :: Doc -> Text -render doc = finish (go env doc emptyOut) +printDoc :: Doc -> Text +printDoc doc = finish (go env doc emptyOut) where env = Env diff --git a/src/Tilia/Equivalence.hs b/src/Tilia/Equivalence.hs --- a/src/Tilia/Equivalence.hs +++ b/src/Tilia/Equivalence.hs @@ -1,12 +1,8 @@ {-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -- | Whether formatting changed what a module says. module Tilia.Equivalence @@ -67,8 +63,9 @@ triggerEscaped, ) import Tilia.Imports (normalizeImports) -import Tilia.Parser (ParsedModule (..)) -import Tilia.Pragma (languageNames) +import Tilia.Parser (ParsedModule (..), writtenInHeader) +import Tilia.Pragma (languageNames, pragmaFlags) +import Tilia.Pragma.Ghc (InForce (..), inForceAfter) import Tilia.Source (comments, sourceLines) import Tilia.Span (Span (..)) import Tilia.Span.Ghc (spanOf, spansOf) @@ -380,7 +377,7 @@ HsDocStringNext -> "pointer" HsDocStringPrevious -> "pointer" HsDocStringNamed n -> "named " <> T.pack n - HsDocStringGroup n -> "group " <> T.pack (show n) + HsDocStringGroup n -> "group " <> tshow n -- | What a doc string says, with the whitespace thrown away. docWords :: HsDocString -> [ByteString] @@ -428,7 +425,8 @@ -- Ordinary comments are compared as they will be printed, in order: the -- text is normalised on the way in, so a comment that came out unchanged -- reads back identically, and one that was mangled or moved past its --- neighbor does not. +-- neighbor does not, unless it trails a line and moved past comments on +-- lines of their own written below it. -- -- Except in the header, where the order says nothing. The pragmas are -- sorted and so are the imports, and a comment written against either @@ -440,6 +438,10 @@ -- legitimately rewrite one—a @-- ^ x@ that moves in front of what it -- documents has to become @-- | x@—so the text is not expected to survive, -- but the comment is. +-- +-- The pragmas of the header are also read as GHC reads them: the flags of +-- the options have to come out in the same order, and what GHC's own flag +-- reader puts in force after all of them has to stay the same. commentDifference :: -- | The module as written. ParsedModule -> @@ -449,6 +451,23 @@ commentDifference parsedBefore parsedAfter | not (Set.null lost) = Just ("lost the pragma " <> pragmaList lost) | not (Set.null gained) = Just ("invented the pragma " <> pragmaList gained) + | optionsBefore /= optionsAfter = + Just + ( "changed the flags of the options pragmas from " + <> flagList optionsBefore + <> " to " + <> flagList optionsAfter + ) + | haddockBefore /= haddockAfter = + Just + ( "changed the OPTIONS_HADDOCK pragmas from " + <> flagList haddockBefore + <> " to " + <> flagList haddockAfter + ) + | flagsBefore /= flagsAfter, + Just why <- inForceDifference (inForceAfter flagsBefore) (inForceAfter flagsAfter) = + Just why | docsBefore /= docsAfter = Just $ "the module's " @@ -477,6 +496,16 @@ Just lastLine -> (<= lastLine) . spanStartLine . commentSpan lost = pragmasOf before `Set.difference` pragmasOf after + headerBefore = headerPragmas parsedBefore + headerAfter = headerPragmas parsedAfter + flagsBefore = concatMap flagsOf headerBefore + flagsAfter = concatMap flagsOf headerAfter + flagsOf p = pragmaFlags (pragmaName p) (pragmaBody p) + optionsBefore = filter (not . T.isPrefixOf "-X") flagsBefore + optionsAfter = filter (not . T.isPrefixOf "-X") flagsAfter + haddockBefore = [pragmaBody p | p <- headerBefore, pragmaName p == "OPTIONS_HADDOCK"] + haddockAfter = [pragmaBody p | p <- headerAfter, pragmaName p == "OPTIONS_HADDOCK"] + flagList flags = "`" <> T.unwords flags <> "`" gained = pragmasOf after `Set.difference` pragmasOf before docsBefore = length (documentation before) docsAfter = length (documentation after) @@ -513,6 +542,45 @@ T.intercalate ", " . fmap (\(n, b) -> "{-# " <> n <> " " <> b <> " #-}") . Set.toList + +-- | The pragmas of a module's header, which are all the pragmas GHC reads, +-- in the order they are written. +headerPragmas :: ParsedModule -> [Pragma] +headerPragmas m = + mapMaybe commentPragma (takeWhile written (comments (pmSource m))) + where + written = writtenInHeader (pmHeaderEnd m) . commentSpan + +-- | How what the flags of a module's header settle changed, if it did. +inForceDifference :: InForce -> InForce -> Maybe Text +inForceDifference before after + | inForceEdition before /= inForceEdition after = + Just + ( "changed the edition in force from " + <> edition before + <> " to " + <> edition after + ) + | inForceSafety before /= inForceSafety after = + Just + ( "changed the Safe Haskell mode from " + <> tshow (inForceSafety before) + <> " to " + <> tshow (inForceSafety after) + ) + | null switched = Nothing + | otherwise = + Just + ( "changed how the header switches " + <> T.intercalate ", " (fmap tshow switched) + ) + where + switched = + [ e + | e <- Map.keys (inForceSwitches before <> inForceSwitches after), + Map.lookup e (inForceSwitches before) /= Map.lookup e (inForceSwitches after) + ] + edition = maybe "the default" tshow . inForceEdition -- | A comment's lines, as they are compared. bodyKey :: Comment -> NonEmpty Text diff --git a/src/Tilia/Fixity.hs b/src/Tilia/Fixity.hs --- a/src/Tilia/Fixity.hs +++ b/src/Tilia/Fixity.hs @@ -1,7 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -- | Working out the fixity of the operators a module uses. module Tilia.Fixity @@ -12,10 +11,11 @@ defaultFixity, spellFixity, readPrecedence, + opName, + qualifierOf, -- * Module declarations declaredFixities, - declaredNames, moduleName, -- * Module exports @@ -33,7 +33,6 @@ decides, Namespace (..), Fixities, - inBothNamespaces, Certain (..), ModuleChain (..), spellModuleChain, @@ -51,6 +50,7 @@ Unknown (..), operatorsUsed, unknownOperators, + disagreement, capturedUses, operatorSpelling, spellUnreadIn, @@ -73,7 +73,6 @@ import Data.Char (isUpper) import Data.Choice (Choice, isTrue) import Data.Foldable (toList) -import Data.Generics.Schemes (listify) import Data.List (nub, sortOn, tails) import Data.List.NonEmpty (NonEmpty ((:|)), nonEmpty) import Data.List.NonEmpty qualified as NE @@ -95,7 +94,7 @@ import Tilia.Palette (Color (Place), Palette, paint) import Tilia.Span (Span, covers) import Tilia.Span.Ghc (spanOf) -import Tilia.Utils (collected, spellList) +import Tilia.Utils (collected, spellList, tshow) ---------------------------------------------------------------------------- -- Fixities @@ -136,7 +135,7 @@ -- | A fixity, written the way it would be declared. spellFixity :: Fixity -> Text spellFixity (Fixity direction precedence) = - which direction <> " " <> T.pack (show precedence) + which direction <> " " <> tshow precedence where which = \case LeftAssoc -> "infixl" @@ -192,20 +191,13 @@ : [opName (unLoc (fdLName (unLoc f))) | f <- tcdATs] _ -> [] terms = \case - ValD _ b -> boundNames b + ValD _ b -> fmap opName (collectHsBindBinders CollNoDictBinders b) SigD _ sig -> signedNames sig ForD _ f -> [opName (unLoc (fd_name f))] TyClD _ d@DataDecl{} -> fmap snd (membersOf d) - TyClD _ ClassDecl{tcdSigs} -> concatMap (classMethods . unLoc) tcdSigs + TyClD _ ClassDecl{tcdSigs} -> concatMap (signedNames . unLoc) tcdSigs _ -> [] --- | The methods a class signature declares. -classMethods :: Sig GhcPs -> [OpName] -classMethods = \case - TypeSig _ ns _ -> fmap (opName . unLoc) ns - ClassOpSig _ _ ns _ -> fmap (opName . unLoc) ns - _ -> [] - -- | The members of the type or class a declaration declares, by -- namespace: a data type's constructors and record fields, a class's -- methods and associated families. @@ -217,7 +209,7 @@ DataDecl{tcdDataDefn} -> fmap (InTerms,) (concatMap (fromCon . unLoc) (consOf (dd_cons tcdDataDefn))) ClassDecl{tcdSigs, tcdATs} -> - fmap (InTerms,) (concatMap (classMethods . unLoc) tcdSigs) + fmap (InTerms,) (concatMap (signedNames . unLoc) tcdSigs) <> [(InTypes, opName (unLoc (fdLName (unLoc f)))) | f <- tcdATs] _ -> [] where @@ -273,19 +265,6 @@ where (types, terms) = declaredNamespaces hsModule --- | The names a binding brings into being. -boundNames :: HsBind GhcPs -> [OpName] -boundNames = \case - FunBind _ n _ -> [opName (unLoc n)] - PatBind _ p _ _ -> [opName n | VarPat _ (L _ n) <- listify isVarPat p] - PatSynBind _ (PSB _ n _ _ _) -> [opName (unLoc n)] - _ -> [] - where - isVarPat :: Pat GhcPs -> Bool - isVarPat = \case - VarPat{} -> True - _ -> False - -- | The module's own name, if it declares one. moduleName :: HsModule GhcPs -> Maybe Text moduleName = fmap (T.pack . moduleNameString . unLoc) . hsmodName @@ -366,8 +345,7 @@ data Import = Import { -- | The module being imported. importModule :: Text, - -- | Whether unqualified names are brought into scope. An import that is - -- @qualified@ brings none. + -- | Whether it is @qualified@, bringing no unqualified names in. importQualified :: Bool, -- | The name qualified uses go through: the alias if there is one, -- otherwise the module's own name. @@ -544,15 +522,6 @@ -- | The fixities a module offers. type Fixities = Map (Namespace, OpName) Fixity --- | Take fixities that say nothing about namespaces to govern both. -inBothNamespaces :: Map OpName Fixity -> Fixities -inBothNamespaces declared = - Map.fromList - [ ((namespace, op), fixity) - | (op, fixity) <- Map.toList declared, - namespace <- [InTypes, InTerms] - ] - -- | What a module certainly brings into scope for a module that imports -- it whole. data Certain = Certain @@ -871,7 +840,7 @@ inTypes = [n | HsOpTy _ _ _ (L _ n) _ <- gatheredTypes found] named namespace n = - (namespace, (qualifierOf n, OpName (T.pack (occNameString (rdrNameOcc n))))) + (namespace, (qualifierOf n, opName n)) -- | The uses of an operator in an expression that a local binding captures, -- by where the operator is written, with the fixity the binding's group @@ -958,15 +927,28 @@ unknownOperators scope found = Map.toList (Map.fromList (mapMaybe unsettled (concatMap operatorsUsed found))) where - unsettled (namespace, (qualifier, op)) = - case fixityInScope scope namespace qualifier op of - Just (answering, _) -> - ((qualifier, op),) . Ambiguous - <$> Map.lookup (qualifier, op) (reachAmbiguous (reachIn answering scope)) - Nothing -> case nonEmpty (unreadThatMightDeclare scope namespace qualifier op) of - Just missing -> Just ((qualifier, op), NotRead missing) - Nothing -> Nothing + unsettled (namespace, use@(qualifier, op)) = + (use,) <$> case lookupFixity scope namespace qualifier op of + Resolved _ _ -> Ambiguous <$> disagreement scope namespace qualifier op + Unresolved missing -> Just (NotRead missing) +-- | What the imports in scope bring a use in with, where they disagree, in +-- the namespace that answers for it. +disagreement :: + -- | The scope. + Scope -> + -- | The namespace the operator is written in. + Namespace -> + -- | The qualifier written at the use site, if any. + Maybe Text -> + -- | Operator being resolved. + OpName -> + -- | The module each import names and the fixity it brings. + Maybe (NonEmpty (Text, Fixity)) +disagreement scope namespace qualifier op = do + (answering, _) <- fixityInScope scope namespace qualifier op + Map.lookup (qualifier, op) (reachAmbiguous (reachIn answering scope)) + -- | An operator as a use site writes it, qualifier and all. operatorSpelling :: Maybe Text -> OpName -> Text operatorSpelling qualifier (OpName op) = maybe "" (<> ".") qualifier <> op @@ -1008,11 +990,8 @@ ---------------------------------------------------------------------------- -- Module summaries --- | Summary of a module: raw facts (per CPP configuration) about a module --- we read from source. This is built for both local modules and dependency --- modules when they come from tarballs. This is an optimization --- mechanism—we create a summary once and then share it during a run. For --- local modules it is also persisted in the cache on disk. +-- | What one CPP configuration of a module read from source says, whether +-- the module is the project's own or comes out of a tarball. data ModuleSummary = ModuleSummary { -- | The name it gives itself, if it gives one. summaryName :: Maybe Text, diff --git a/src/Tilia/Fixity/Archive.hs b/src/Tilia/Fixity/Archive.hs --- a/src/Tilia/Fixity/Archive.hs +++ b/src/Tilia/Fixity/Archive.hs @@ -25,14 +25,17 @@ import Data.Text (Text) import Data.Text qualified as T import Data.Text.Encoding qualified as T +import Distribution.PackageDescription (GenericPackageDescription) import GHC.Generics (Generic) -import Tilia.Fixity.Cabal (cabalFileAtTop, entryPosixPath, sourceDirs) +import Tilia.Cabal.Package (packageSourceDirs) +import Tilia.Fixity.Cabal (entryPosixPath, ownCabalFile) 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, + { -- | What the package's @.cabal@ file describes, the first one at the top + -- that parses. + archiveCabal :: Maybe GenericPackageDescription, -- | Every file that could hold a module, by where it sits, in the order -- the tarball has them. archiveFiles :: [(FilePath, BS.ByteString)] @@ -49,10 +52,9 @@ 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 + | Nothing <- cabal, + Just own <- ownCabalFile entry -> + sweep (Just own) found rest | Tar.NormalFile content _ <- Tar.entryContent entry, any (`isSuffixOf` entryPosixPath entry) moduleEndings -> sweep cabal ((entryPosixPath entry, BL.toStrict content) : found) rest @@ -63,7 +65,7 @@ moduleIn :: Text -> Archive -> Maybe InArchive moduleIn modName archive = listToMaybe (mapMaybe pick moduleEndings) where - dirs = maybe [] sourceDirs (archiveCabal archive) + dirs = maybe [] packageSourceDirs (archiveCabal archive) pick ending = inArchive ending . T.decodeUtf8Lenient . snd <$> listToMaybe (under sfx matching <> matching) @@ -73,7 +75,7 @@ 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 + | otherwise = ("/" <> d <> sfx) `isSuffixOf` path -- | Where a module's file is under the directory that holds it, without an -- extension. diff --git a/src/Tilia/Fixity/Cabal.hs b/src/Tilia/Fixity/Cabal.hs --- a/src/Tilia/Fixity/Cabal.hs +++ b/src/Tilia/Fixity/Cabal.hs @@ -1,33 +1,28 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} --- | Reading a package's modules out of its @.cabal@ file. +-- | Reading a package's description out of its source tarball. module Tilia.Fixity.Cabal ( packageModules, cabalFileInArchive, + ownCabalFile, cabalFileAtTop, entryPosixPath, - containedModules, - sourceDirs, - declaredExtensions, ) where import Codec.Archive.Tar qualified as Tar import Codec.Archive.Tar.Entry qualified as Tar import Codec.Compression.GZip qualified as GZip +import Control.Applicative ((<|>)) +import Control.DeepSeq (force) +import Control.Exception (evaluate) import Data.ByteString.Lazy qualified as BL -import Data.Char (isSpace) import Data.List (isSuffixOf) -import Data.List qualified -import Data.Maybe (mapMaybe) import Data.Text (Text) -import Data.Text qualified as T -import Data.Text.Encoding qualified as T -import GHC.Driver.Session qualified as GHC -import GHC.LanguageExtensions.Type (Extension) -import Tilia.Pragma (applyExtensionName, lookupEdition) -import Tilia.Utils (fieldWords, quietly) +import Distribution.PackageDescription (GenericPackageDescription) +import Tilia.Cabal.Package (declaredModules, parsePackageDescription) +import Tilia.Utils (quietly) -- | The modules a package holds, read from the @.cabal@ file in its -- source tarball. @@ -36,22 +31,32 @@ packageModules :: FilePath -> IO (Maybe [Text]) packageModules tarball = quietly Nothing $ do bytes <- BL.readFile tarball - pure (containedModules <$> cabalFileInArchive (Tar.read (GZip.decompress bytes))) + evaluate . force $ + fmap fst . declaredModules + <$> cabalFileInArchive (Tar.read (GZip.decompress bytes)) -- | The first @.cabal@ file at the top level of an archive. -- -- Stops as soon as it finds one. The archive is decompressed lazily, so a -- @.cabal@ near the front costs a fraction of the whole file. -cabalFileInArchive :: Tar.Entries e -> Maybe Text +cabalFileInArchive :: Tar.Entries e -> Maybe GenericPackageDescription cabalFileInArchive = \case - Tar.Next entry rest - | cabalFileAtTop (entryPosixPath entry), - Tar.NormalFile content _ <- Tar.entryContent entry -> - Just (T.decodeUtf8Lenient (BL.toStrict content)) - | otherwise -> cabalFileInArchive rest + Tar.Next entry rest -> ownCabalFile entry <|> cabalFileInArchive rest Tar.Done -> Nothing Tar.Fail _ -> Nothing +-- | What an archive's entry describes if it is the package's own @.cabal@ +-- file and parses. +ownCabalFile :: Tar.Entry -> Maybe GenericPackageDescription +ownCabalFile entry + | cabalFileAtTop path, + Tar.NormalFile content _ <- Tar.entryContent entry = + either (const Nothing) Just $ + parsePackageDescription path (BL.toStrict content) + | otherwise = Nothing + where + path = entryPosixPath entry + -- | Where an entry sits in its archive, written the way a tar file writes -- it. entryPosixPath :: Tar.Entry -> FilePath @@ -62,58 +67,3 @@ cabalFileAtTop path = ".cabal" `isSuffixOf` path && depth path == 2 where depth = (1 +) . length . filter (== '/') - --- | Every module a package holds, whether it exposes it or not. -containedModules :: Text -> [Text] -containedModules t = - modulesUnder "exposed-modules" t <> modulesUnder "other-modules" t - where - modulesUnder field = - concatMap moduleNames . fieldsNamed field . T.lines - where - moduleNames = filter looksLikeModule . fieldWords - looksLikeModule m = case T.uncons m of - Just (c, _) -> c `elem` ['A' .. 'Z'] - Nothing -> False - --- | Every directory a @.cabal@ file's modules could be under. -sourceDirs :: Text -> [Text] -sourceDirs contents = Data.List.nub (named <> ["."]) - where - 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 applyExtensionName baseline named - where - ls = T.lines contents - 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 fieldWords $ - fieldsNamed "extensions" ls <> fieldsNamed "default-extensions" ls - --- | The values of every field with the given name, wherever it appears and --- however deeply it is nested. -fieldsNamed :: Text -> [Text] -> [Text] -fieldsNamed name = go . filter (not . commented) - where - commented = T.isPrefixOf "--" . T.stripStart - go = \case - [] -> [] - (l : ls) - | Just value <- fieldValue l -> - let (continued, rest) = span (deeperThan (indentOf l)) ls - in T.unwords (value : fmap T.strip continued) : go rest - | otherwise -> go ls - fieldValue l = - let (key, rest) = T.break (== ':') l - in if T.toLower (T.strip key) == name && not (T.null rest) - then Just (T.strip (T.drop 1 rest)) - else Nothing - deeperThan n l = T.null (T.strip l) || indentOf l > n - indentOf = T.length . T.takeWhile isSpace diff --git a/src/Tilia/Fixity/Cache.hs b/src/Tilia/Fixity/Cache.hs --- a/src/Tilia/Fixity/Cache.hs +++ b/src/Tilia/Fixity/Cache.hs @@ -39,14 +39,12 @@ import Data.Set qualified as Set import Data.Text (Text) import Data.Text qualified as T -import Data.Text.IO qualified as T import Data.Time (UTCTime) import Data.Time.Format (defaultTimeLocale, formatTime) import Data.Time.Format.ISO8601 (iso8601ParseM, iso8601Show) import System.Directory ( XdgDirectory (XdgCache), createDirectoryIfMissing, - doesFileExist, getModificationTime, getXdgDirectory, renameFile, @@ -54,7 +52,7 @@ import System.FilePath (takeDirectory, ()) import Tilia.Fixity import Tilia.Fixity.PackageDb (Installed (..), InstalledPackage (..)) -import Tilia.Utils (quietly) +import Tilia.Utils (quietly, readUtf8File, tshow, writeUtf8File) -- | Where cached answers are kept together with a token unique to this -- build plan and environment, or nowhere, in which case nothing is @@ -75,7 +73,7 @@ -- | Bumped whenever cache format changes. formatVersion :: FilePath -formatVersion = "v2" +formatVersion = "v3" -- | Open, creating the directory if need be. -- @@ -471,7 +469,7 @@ [ op, renderNamespace namespace, renderDirection direction, - T.pack (show precedence) + tshow precedence ] where renderDirection = \case @@ -591,9 +589,7 @@ readIfPresent :: Maybe FilePath -> (Text -> a) -> IO (Maybe a) readIfPresent place parse = case place of Nothing -> pure Nothing - Just path -> quietly Nothing $ do - there <- doesFileExist path - if there then Just . parse <$> T.readFile path else pure Nothing + Just path -> fmap parse <$> readUtf8File path -- | Write via a temporary file and a rename, making the directory if need -- be. @@ -603,5 +599,5 @@ Just path -> quietly () $ do createDirectoryIfMissing True (takeDirectory path) let temporary = path <> ".tmp" - T.writeFile temporary contents + writeUtf8File temporary contents renameFile temporary path diff --git a/src/Tilia/Fixity/Debug.hs b/src/Tilia/Fixity/Debug.hs --- a/src/Tilia/Fixity/Debug.hs +++ b/src/Tilia/Fixity/Debug.hs @@ -4,9 +4,7 @@ -- | An account of how a module's fixities were determined. module Tilia.Fixity.Debug - ( FixityNotes (..), - ImportNote (..), - OperatorNote (..), + ( FixityNotes, fixityNotes, renderFixityNotes, ) @@ -30,12 +28,11 @@ Provenance (..), Resolution (..), Scope (..), + disagreement, lookupFixity, moduleImports, operatorSpelling, operatorsUsed, - reachAmbiguous, - reachIn, reachUnqualified, spellDisagreement, spellFixity, @@ -44,7 +41,7 @@ ) import Tilia.Palette (Color (Operator, Place), Palette, paint) import Tilia.Parser (ParsedModule (..)) -import Tilia.Utils (indent, lineWidth, wrapTo) +import Tilia.Utils (indent, tshow, wrappedUnder) -- | Everything that decided one module's fixities. data FixityNotes = FixityNotes @@ -153,8 +150,7 @@ OperatorNote { noteSpelling = operatorSpelling qualifier op, noteResolution = lookupFixity scope namespace qualifier op, - noteDisagreement = - Map.lookup (qualifier, op) (reachAmbiguous (reachIn namespace scope)) + noteDisagreement = disagreement scope namespace qualifier op } -- | Set out all the 'FixityNotes' per file. @@ -180,9 +176,7 @@ | otherwise = heading what : concatMap (entry . render) items heading what = indent 2 <> "· " <> what - entry line = case wrapTo (lineWidth - 8) line of - [] -> [] - (opening : rest) -> (indent 3 <> "· " <> opening) : fmap (indent 4 <>) rest + entry = wrappedUnder 4 (indent 3 <> "· ") fromImport i = named (noteModule i) @@ -223,7 +217,7 @@ DeclaredHere -> "declared in this module" DeclaredIn m -> "declared in " <> named m BuiltIn -> "built into the language" - ReportDefault -> "the Report's default, nothing in scope declaring it" + ReportDefault -> "the Report's default" ambiguously o = case noteDisagreement o of Nothing -> "" @@ -235,4 +229,4 @@ operators = \case 1 -> "1 operator" - n -> T.pack (show n) <> " operators" + n -> tshow n <> " operators" diff --git a/src/Tilia/Fixity/HiFile.hs b/src/Tilia/Fixity/HiFile.hs --- a/src/Tilia/Fixity/HiFile.hs +++ b/src/Tilia/Fixity/HiFile.hs @@ -35,6 +35,7 @@ import Tilia.Fixity.KnownKeys.Ghc910 qualified as Ghc910 import Tilia.Fixity.KnownKeys.Ghc912 qualified as Ghc912 import Tilia.Fixity.KnownKeys.Ghc914 qualified as Ghc914 +import Tilia.Utils (tshow) -- | What an interface file says about the operators its module offers. data HiFile = HiFile @@ -88,7 +89,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: " <> tshow magic)) version <- string series <- case take 3 version of "910" -> pure Series910 @@ -200,7 +201,7 @@ 2 -> pure InTypes 3 -> pure InTypes 4 -> InTerms <$ uleb - b -> failure ("unknown namespace " <> T.pack (show b)) + b -> failure ("unknown namespace " <> tshow b) s <- uleb pure (namespace, s) diff --git a/src/Tilia/Fixity/Interface.hs b/src/Tilia/Fixity/Interface.hs --- a/src/Tilia/Fixity/Interface.hs +++ b/src/Tilia/Fixity/Interface.hs @@ -12,12 +12,11 @@ where import Control.DeepSeq (NFData) -import Control.Monad ((<=<)) import Data.ByteString qualified as BS import Data.Char (isUpper) import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map -import Data.Maybe (isNothing, mapMaybe, maybeToList) +import Data.Maybe (isNothing, mapMaybe) import Data.Set (Set) import Data.Set qualified as Set import Data.Text (Text) @@ -26,15 +25,16 @@ import Tilia.Fixity import Tilia.Fixity.HiFile (HiExport (..), HiFile (..), HiName (..), decodeHiFile) import Tilia.Process (readProgramOutput) -import Tilia.Utils (quietly) +import Tilia.Utils (blocksOf, indented, quietly) -- | What an interface says about the operators a module offers. data Interface = Interface { -- | The fixities the module declares itself for the names it exports, -- by the namespace each governs. interfaceDeclares :: Fixities, - -- | The names it reexports, each with the source module. - interfaceReexports :: [(Text, OpName)], + -- | The names it reexports, each with the source module and the + -- namespace it is exported in. + interfaceReexports :: [(Text, Namespace, OpName)], -- | The members it exports with each name, which is what @T(..)@ in an -- import list stands for. interfaceMembers :: Map OpName (Set OpName), @@ -58,8 +58,8 @@ IO (Maybe Interface) readInterface modName path = quietly Nothing $ - (fromHiFile modName <=< decodeHiFile) <$> BS.readFile path >>= \case - Right interface -> pure (Just interface) + decodeHiFile <$> BS.readFile path >>= \case + Right hi -> pure (either (const Nothing) Just (fromHiFile modName hi)) Left _ -> readProgramOutput "ghc" ["--show-iface", path] >>= \case Nothing -> pure Nothing @@ -79,8 +79,8 @@ Set.member (namespace, op) exportedHere ], interfaceReexports = - [ (m, op) - | (Just m, _, op) <- concatMap mentioned hiExports, + [ (m, namespace, op) + | HiName m namespace op <- concatMap exportedNames hiExports, m /= hiModule ], interfaceMembers = Map.map (Set.map snd) members, @@ -92,7 +92,7 @@ } } where - exported = concatMap exportedNames hiExports + exported = mapMaybe known (concatMap exportedNames hiExports) exportedHere = Set.fromList [(namespace, op) | (_, namespace, op) <- exported] members = @@ -104,11 +104,8 @@ let kids = filter (/= parent) (mapMaybe known ns) ] exportedNames = \case - Avail n -> maybeToList (known n) - AvailTC _ ns -> mapMaybe known ns - mentioned = \case - Avail n -> maybeToList (known n) - AvailTC p ns -> maybeToList (known p) <> mapMaybe known ns + Avail n -> [n] + AvailTC _ ns -> ns known = \case HiName m namespace op -> Just (Just m, namespace, op) BuiltInSyntax namespace op -> Just (Nothing, namespace, op) @@ -128,7 +125,11 @@ fixities (foldMap ownExports (sectionsNamed "exports:")) ), - interfaceReexports = concatMap reexports (sectionsNamed "exports:"), + interfaceReexports = + [ (m, namespace, op) + | (m, op) <- concatMap reexports (sectionsNamed "exports:"), + namespace <- [InTypes, InTerms] + ], interfaceMembers = Map.unionsWith Set.union (fmap membersIn (sectionsNamed "exports:")), interfaceExports = Nothing @@ -137,26 +138,27 @@ holdsModule l = case T.words l of ("interface" : m : _) -> m == modName _ -> False - sectionsNamed name = - [ T.replace "|{" "{" body - | (heading, body) <- sections out, - heading == name - ] + sectionsNamed name = [body | (heading, body) <- sections out, heading == name] fixities = Map.fromList (concatMap declared (sectionsNamed "fixities")) declared = mapMaybe fixityEntry . T.splitOn "," ownExports section = Set.fromList - [ OpName name - | (parent, kids) <- exportEntries section, - name <- parent : kids, - isNothing (moduleOf name) - ] - reexports = concatMap reexportsIn . T.words + [OpName name | name <- exportedIn section, isNothing (moduleOf name)] + reexports section = + [ (m, OpName name) + | Just (m, name) <- fmap moduleOf (exportedIn section), + not (T.null name) + ] + exportedIn section = + [ name + | (parent, parentExported, kids) <- exportEntries section, + name <- [parent | parentExported] <> kids + ] membersIn section = Map.fromListWith Set.union [ (nameOnly parent, Set.fromList (fmap nameOnly kids)) - | (parent, kids@(_ : _)) <- exportEntries section + | (parent, _, kids@(_ : _)) <- exportEntries section ] -- | The names an interface declares as types. @@ -170,8 +172,6 @@ keyword `elem` (["data", "type", "newtype", "class"] :: [Text]), name <- take 1 (dropWhile (`elem` (["family", "role", "instance"] :: [Text])) rest) ] - where - indented l = maybe False (== ' ') (fst <$> T.uncons l) -- | Sort declared fixities into the namespaces they govern. namespaced :: Set OpName -> Map OpName Fixity -> Fixities @@ -184,17 +184,11 @@ -- | Split the output into sections. sections :: Text -> [(Text, Text)] -sections = go . T.lines - where - go = \case - [] -> [] - (l : ls) - | indented l -> go ls - | otherwise -> - let (body, rest) = span indented ls - (heading, opening) = T.breakOn " " l - in (heading, T.unwords (opening : body)) : go rest - indented l = maybe False (== ' ') (fst <$> T.uncons l) +sections out = + [ (heading, T.unwords (opening : body)) + | (l, body) <- blocksOf (T.lines out), + let (heading, opening) = T.breakOn " " l + ] -- | One entry of a @fixities@ line: @infixl 9 !@ and the like. fixityEntry :: Text -> Maybe (OpName, Fixity) @@ -210,8 +204,10 @@ _ -> Nothing -- | Split an exports section into its entries, keeping the members an entry --- wears in braces with the name they belong to. -exportEntries :: Text -> [(Text, [Text])] +-- wears in braces with the name they belong to, and whether that name is +-- exported itself, which a bar before the braces, as in @T|{...}@, says it +-- is not. +exportEntries :: Text -> [(Text, Bool, [Text])] exportEntries = go where go text = case T.uncons (T.dropWhile (== ' ') text) of @@ -222,22 +218,16 @@ in case T.uncons rest of Just ('{', inside) -> let (kids, after) = T.break (== '}') inside - in (bare name, T.words kids) : go (T.drop 1 after) - _ -> (bare name, []) : go rest + entry = case T.unsnoc (bare name) of + Just (parent, '|') -> (parent, False, T.words kids) + _ -> (bare name, True, T.words kids) + in entry : go (T.drop 1 after) + _ -> (bare name, True, []) : go rest bare = T.dropWhileEnd (== ',') -- | An exported name without the module that declared it. nameOnly :: Text -> OpName nameOnly t = OpName (maybe t snd (moduleOf t)) - --- | The names an export entry reexports, with the module that declared --- each. -reexportsIn :: Text -> [(Text, OpName)] -reexportsIn = mapMaybe qualified . T.split (`elem` ("{}," :: String)) - where - qualified name = case moduleOf name of - Just (m, n) | not (T.null n) -> Just (m, OpName n) - _ -> Nothing -- | Split a name into the module that declared it and the name itself. moduleOf :: Text -> Maybe (Text, Text) diff --git a/src/Tilia/Fixity/PackageDb.hs b/src/Tilia/Fixity/PackageDb.hs --- a/src/Tilia/Fixity/PackageDb.hs +++ b/src/Tilia/Fixity/PackageDb.hs @@ -13,7 +13,6 @@ where import Control.Monad (filterM) -import Data.Char (isSpace) import Data.List (nub) import Data.Map.Strict qualified as Map import Data.Maybe (mapMaybe) @@ -22,7 +21,7 @@ import System.Directory (doesDirectoryExist, findExecutable) import System.FilePath (()) import Tilia.Process (readProgramOutput) -import Tilia.Utils (fieldWords, quietly) +import Tilia.Utils (blocksOf, fieldWords, looksLikeModule, quietly) -- | An installed package. data InstalledPackage = InstalledPackage @@ -137,9 +136,6 @@ (m : rest) | looksLikeModule m -> m : go rest (_ : rest) -> go rest [] -> [] - looksLikeModule m = case T.uncons m of - Just (c, _) -> c `elem` ['A' .. 'Z'] && not (T.any (== ':') m) - Nothing -> False -- | The modules an @exposed-modules@ field names that another package -- holds, each with its name there. @@ -154,19 +150,9 @@ -- | Split a record into its fields. parseFields :: Text -> Map.Map Text Text -parseFields = Map.fromList . mapMaybe field . groups . T.lines +parseFields = Map.fromList . mapMaybe field . blocksOf . T.lines where - groups = \case - [] -> [] - (l : ls) - | isContinuation l -> groups ls - | otherwise -> - let (continued, rest) = span isContinuation ls - in (l : continued) : groups rest - isContinuation l = not (T.null l) && isSpace (T.head l) - - field [] = Nothing - field (l : rest) = case T.breakOn ":" l of + field (l, rest) = case T.breakOn ":" l of (key, value) | not (T.null value) -> Just (T.strip key, T.unwords (T.drop 1 value : fmap T.strip rest)) diff --git a/src/Tilia/Fixity/Plan.hs b/src/Tilia/Fixity/Plan.hs --- a/src/Tilia/Fixity/Plan.hs +++ b/src/Tilia/Fixity/Plan.hs @@ -20,15 +20,13 @@ where import Control.Applicative ((<|>)) -import Control.Concurrent (getNumCapabilities) +import Control.Concurrent (MVar, 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.Containers.ListUtils (nubOrd) import Data.Foldable (toList) import Data.List.NonEmpty (NonEmpty ((:|))) import Data.List.NonEmpty qualified as NE @@ -39,28 +37,33 @@ 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.Package + ( PackageReader, + declaredModules, + newPackageReader, + packageExtensions, + 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.Cabal (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.Memo (Flights, memoized, newFlights, newMemo) import Tilia.Parser -import Tilia.Pragma (effectiveExtensions) -import Tilia.Utils (byteOrderMark, inParallel, quietly, readFileText, sha256Of) +import Tilia.Pragma (Defaults, effectiveExtensions) +import Tilia.Utils (byteOrderMark, inParallel, quietly, readUtf8File, sha256Of, sha256OfFile, tshow) ---------------------------------------------------------------------------- -- Resolving @@ -93,7 +96,7 @@ BuildPlan -> IO Resolver newResolver plan = do - packageReader <- newPackageReader (plannedCompiler plan) + packageReader <- newPackageReader (plannedCompiler plan) [] newResolverVia (Do #useCache) [FromInterface, FromSource] packageReader plan -- | 'newResolver', restricted to the routes given. @@ -140,17 +143,13 @@ 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 + interfaceOf <- interfaceMemo flights $ \modName -> + case Map.lookup modName interfaces of + Nothing -> pure Nothing + Just (_, path) -> + bracket_ (waitQSem reading) (signalQSem reading) $ + readInterface modName path let workings = Workings { wkRoutes = routes, @@ -184,7 +183,7 @@ configurationsOf (macrosOf plan) extensions modName text stamp = digestOf . T.intercalate "\n" $ - [T.pack (show extensions), macrosRead, text] + [tshow extensions, macrosRead, text] case digestOf . T.pack <$> Map.lookup modName local of Nothing -> summarized Just key -> @@ -193,19 +192,35 @@ (cachedSummaries cache key stamp) (storeSummaries cache key stamp) (Just <$> summarized) - macrosRead = T.pack (show (macrosOf plan)) + macrosRead = tshow (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 + fmap packageExtensions . (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 module's interface, read once, with the primops' fixities standing +-- in for that of @GHC.Prim@, which has no file. +interfaceMemo :: + -- | Who is working out what, across the resolver's tables. + MVar Flights -> + -- | How to read a module's interface. + (Text -> IO (Maybe Interface)) -> + IO (Text -> IO (Maybe Interface)) +interfaceMemo flights read' = do + interfacesRead <- newMemo + pure $ \modName -> + memoized flights interfacesRead Nothing modName $ + case Map.lookup modName primopFixities of + Just declared -> pure (Just (asInterface declared)) + Nothing -> read' modName + -- | 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 :: @@ -214,15 +229,9 @@ 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 + interfaceOf <- interfaceMemo flights $ \modName -> + (either (const Nothing) Just . fromHiFile modName =<<) <$> given modName pure Resolver { askModule = \modName -> @@ -329,7 +338,7 @@ writtenForHsc path = pure mempty | Just path <- Map.lookup modName wkLocal = - readFileText path >>= \case + readUtf8File path >>= \case Nothing -> pure unreadable Just source -> fromSummaries (wkReach visiting') modName @@ -407,11 +416,8 @@ 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] + held <- fromCabalFile cache tarball p + pure [(m, (key, tarball)) | m <- concat (catMaybes [exposed, held])] -- | Where each installed module's compiled interface is. interfaceIndex :: [InstalledPackage] -> Map Text (Text, FilePath) @@ -458,23 +464,23 @@ declarers <- inParallel asked - (distinct (fmap fst (interfaceReexports iface))) + (distinct [m | (m, _, _) <- 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] + Map.union (interfaceDeclares iface) . Map.fromList $ + [ ((namespace, op), fixity) + | (m, namespace, op) <- interfaceReexports iface, + Just declared <- [declarer m], + Just fixity <- + [Map.lookup (namespace, op) (interfaceDeclares declared)] ], establishedUnsettled = Map.fromListWith Set.union - [ ([m], Set.fromList [(InTypes, op), (InTerms, op)]) - | (m, op) <- interfaceReexports iface, + [ ([m], Set.singleton (namespace, op)) + | (m, namespace, op) <- interfaceReexports iface, Nothing <- [declarer m] ], establishedUntold = Set.empty, @@ -491,9 +497,6 @@ 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. @@ -501,11 +504,13 @@ -- | 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 = +fromCabalFile cache tarball p = recalled (cachedModules cache key) (storeModules cache key) $ verified p tarball >>= \case False -> pure Nothing True -> packageModules tarball + where + key = cacheKey p -- | Does the tarball hash to what the plan says it should? verified :: PlanPackage -> FilePath -> IO Bool @@ -516,12 +521,6 @@ 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. @@ -622,7 +621,7 @@ -- | 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)) + Map.unions <$> traverse forPackage (nubOrd (concatMap directoryOf (bpPackages plan))) where directoryOf p = case ppSource p of LocalPackage dir -> [dir] @@ -919,8 +918,8 @@ configurationsOf :: -- | What the plan settles about the questions its conditionals ask. Macros -> - -- | What extensions the module's package puts in force. - [Extension] -> + -- | What the module's package puts in force. + Defaults -> -- | The module's name, for the parser to put in its errors. Text -> -- | Its text. @@ -937,6 +936,6 @@ named = T.unpack modName -- | Does this module see the Prelude without importing it? -hasImplicitPrelude :: [Extension] -> Text -> Choice "implicitPrelude" +hasImplicitPrelude :: Defaults -> Text -> Choice "implicitPrelude" hasImplicitPrelude extensions source = fromBool (ImplicitPrelude `elem` effectiveExtensions extensions source) diff --git a/src/Tilia/Format.hs b/src/Tilia/Format.hs --- a/src/Tilia/Format.hs +++ b/src/Tilia/Format.hs @@ -34,6 +34,7 @@ import Data.Text (Text) import Data.Text qualified as T import Data.Version (Version, versionBranch) +import GHC.Driver.Session (OnOff (..)) import GHC.LanguageExtensions.Type (Extension (ImplicitPrelude)) import Tilia.Cabal.Package ( PackageProblem (..), @@ -51,6 +52,7 @@ versionMacros, ) import Tilia.Cabal.Project (ProjectRoot (..), findProjectRoot) +import Tilia.Cabal.Target (packageFilesOf) import Tilia.Cpp ( CppError (..), correspondingBranches, @@ -90,7 +92,7 @@ pmGathered, pmModule, ) -import Tilia.Pragma (effectiveExtensions, movesPositions) +import Tilia.Pragma (defaultsOf, effectiveExtensions, movesPositions) import Tilia.Render (RenderConfig (..), defaultRenderConfig, renderModule) import Tilia.Utils (collected, spellList, tshow) @@ -117,6 +119,8 @@ NotEquivalent FilePath Text | -- | Formatting is not idempotent. NotIdempotent FilePath Text + | -- | Formatting the file threw an exception, shown. + Threw FilePath Text -- | Say what went wrong. describeFormatError :: Palette -> FormatError -> Text @@ -132,7 +136,10 @@ <> describePackageProblem problem NotParsed e -> "cannot parse " <> located (describeParseError e) PositionPragmas path -> - "will not format " <> file path <> ": it uses {-# LINE #-} pragmas, and no reformatting can leave those true" + "will not format " + <> file path + <> ": it uses {-# LINE #-} or {-# COLUMN #-} pragmas, and no" + <> " reformatting can leave those true" CppUnsupported path why -> "will not format " <> file path <> ": " <> describeCppError why Unreadable path why -> "cannot read " <> file path <> ": " <> why @@ -140,6 +147,8 @@ "formatting " <> file path <> " changed the program: " <> why NotIdempotent path why -> "formatting " <> file path <> " is not idempotent: " <> why + Threw path why -> + "formatting " <> file path <> " threw an exception: " <> why UnknownFixity path unknown -> "will not format " <> file path @@ -180,6 +189,7 @@ Unreadable{} -> 16 NotEquivalent{} -> 17 NotIdempotent{} -> 18 + Threw{} -> 19 CppUnsupported _ why -> case why of MalformedConditional{} -> 9 TooManyConfigurations -> 10 @@ -200,14 +210,11 @@ Unreadable{} -> False NotEquivalent{} -> False NotIdempotent{} -> False + Threw{} -> False NoProject{} -> False NoBuildPlan{} -> False -- | What a run works out once and then uses for every file. --- --- Finding the project, solving its build plan and building a resolver cost --- about as much as formatting a small file, and none of it depends on which --- file is being formatted. data Session = Session { -- | The project. sessionRoot :: ProjectRoot, @@ -222,9 +229,8 @@ sessionCheckAst :: Choice "checkAst", -- | Whether to check idempotence. sessionCheckIdempotence :: Choice "checkIdempotence", - -- | An account of how each file's fixities were determined. 'Nothing' - -- when this information was not requested, which is what keeps an - -- ordinary run from doing any of the work. + -- | An account of how each file's fixities were determined, or 'Nothing' + -- where none was asked for. sessionFixityNotes :: Maybe (IORef (Map FilePath FixityNotes)) } @@ -267,7 +273,8 @@ then [FromInterface, FromSource] <$ liftIO (fetchUninstalled caching root plan) else pure [FromInterface] pure (plan, routes) - packageReader <- liftIO (newPackageReader (plannedCompiler plan)) + packages <- liftIO (packageFilesOf project) + packageReader <- liftIO (newPackageReader (plannedCompiler plan) packages) resolver <- liftIO (newResolverVia caching routes packageReader plan) notes <- if isTrue debugFixity @@ -288,7 +295,9 @@ -- otherwise works out with Cabal, the package database, and the sources of -- dependencies. data Compiled = Compiled - { -- | The extensions the component puts in force. + { -- | The extensions the component puts in force, which an edition a + -- module names adds to, as which of them its own edition brought is not + -- known. compiledExtensions :: [Extension], -- | The version of the compiler. compiledWith :: Version, @@ -322,7 +331,8 @@ versionMacros (Just (numbers compiledWith)) (fmap numbers compiledPackages), - sessionPackage = \_ -> pure (Right compiledExtensions), + sessionPackage = + \_ -> pure (Right (defaultsOf [] (On <$> compiledExtensions))), sessionCheckAst = checkAst, sessionCheckIdempotence = checkIdempotence, sessionFixityNotes = Nothing @@ -330,10 +340,8 @@ where numbers = fmap toInteger . versionBranch --- | What the run made of every file's operators, by file. --- --- Empty unless the session was asked to keep an account of it. Nothing here --- is rendered; 'Tilia.Fixity.Debug.renderFixityNotes' does that. +-- | What the run made of every file's operators, by file, empty unless the +-- session keeps an account of it. fixityNotesOf :: Session -> IO (Map FilePath FixityNotes) fixityNotesOf session = case sessionFixityNotes session of Nothing -> pure Map.empty diff --git a/src/Tilia/Ignore.hs b/src/Tilia/Ignore.hs --- a/src/Tilia/Ignore.hs +++ b/src/Tilia/Ignore.hs @@ -7,11 +7,11 @@ parseIgnoreFile, isIgnored, isIgnoredInProject, - ignoreFilesAbove, - belowRoot, + withoutIgnored, ) where +import Data.ByteString qualified as BS import Data.Char ( isAlpha, isAlphaNum, @@ -25,17 +25,17 @@ isSymbol, isUpper, ) -import Data.List (inits, isPrefixOf, isSuffixOf, stripPrefix, tails) +import Data.List (inits, isPrefixOf, isSuffixOf, tails) 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 -import Data.Text.IO qualified as T +import Data.Text.Encoding qualified as T import System.Directory (canonicalizePath, doesFileExist) -import System.FilePath (joinPath, normalise, splitDirectories, ()) -import Tilia.Utils (quietly) +import System.FilePath (joinPath, ()) +import Tilia.Utils (pathUnder, quietly) -- | The patterns of one ignore file, in the order they are written. newtype IgnoreFile = IgnoreFile [Pattern] @@ -257,12 +257,26 @@ IO Bool isIgnoredInProject root path = quietly False $ do file <- canonicalizePath path - case belowRoot root file of - Nothing -> pure False - Just below -> do - ignoreFiles <- ignoreFilesAbove root [below] - pure (isIgnored ignoreFiles below) + null <$> withoutIgnored root [file] +-- | The files the @.tiliaignore@ files of a project do not ignore, in the +-- order given. +withoutIgnored :: + -- | The project root, canonical. + FilePath -> + -- | The files, canonical. + [FilePath] -> + IO [FilePath] +withoutIgnored root files = do + ignoreFiles <- ignoreFilesAbove root (Map.elems below) + pure + [ file + | file <- files, + maybe True (not . isIgnored ignoreFiles) (Map.lookup file below) + ] + where + below = Map.fromList [(file, b) | file <- files, Just b <- [pathUnder root file]] + -- | The @.tiliaignore@ files in the project root and in every directory -- between it and the given files, each by its directory's segments relative -- to the root. @@ -276,15 +290,7 @@ let file = joinPath (root : directory) ".tiliaignore" exists <- doesFileExist file if exists - then (\t -> [(directory, parseIgnoreFile t)]) <$> T.readFile file + then do + bytes <- BS.readFile file + pure [(directory, parseIgnoreFile (T.decodeUtf8Lenient bytes))] else pure [] - --- | A path's segments relative to the project root, if it is under it. -belowRoot :: - -- | The project root. - FilePath -> - -- | The path. - FilePath -> - Maybe [FilePath] -belowRoot root path = - stripPrefix (splitDirectories root) (splitDirectories (normalise path)) diff --git a/src/Tilia/Imports.hs b/src/Tilia/Imports.hs --- a/src/Tilia/Imports.hs +++ b/src/Tilia/Imports.hs @@ -1,6 +1,5 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE LambdaCase #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-} -- | Putting a module's imports in order. diff --git a/src/Tilia/Parser.hs b/src/Tilia/Parser.hs --- a/src/Tilia/Parser.hs +++ b/src/Tilia/Parser.hs @@ -5,6 +5,7 @@ -- | Turning source text into a syntax tree and a comment stream. module Tilia.Parser ( ParsedModule (..), + writtenInHeader, parseModule, parseConfiguration, readAlike, @@ -19,16 +20,15 @@ import Data.Foldable (toList) import Data.IntMap.Strict (IntMap) import Data.IntMap.Strict qualified as IntMap -import Data.List (isSuffixOf, nub, sortOn) -import Data.Maybe (listToMaybe, mapMaybe) +import Data.List (isSuffixOf, sortOn) +import Data.Maybe (catMaybes, listToMaybe) import Data.Text (Text) import Data.Text qualified as T import Data.Text.Encoding qualified as T import GHC.Data.EnumSet qualified as EnumSet import GHC.Data.FastString (mkFastString) import GHC.Data.StringBuffer qualified as GHC -import GHC.Driver.Session qualified as GHC -import GHC.Hs (HsModule (..)) +import GHC.Hs (AnnsModule (..), EpAnn (anns), HsModule (..), XModulePs (..)) import GHC.Hs.Extension (GhcPs) import GHC.LanguageExtensions.Type (Extension) import GHC.Parser qualified as GHC @@ -39,7 +39,7 @@ import GHC.Utils.Error qualified as GHC import GHC.Utils.Outputable qualified as GHC import Tilia.Gathered (Gathered (..), gathered) -import Tilia.Pragma (effectiveExtensions) +import Tilia.Pragma (Defaults, effectiveExtensions) import Tilia.Source (Lines, Source, SourceType (..), Written (..), lineTexts, linesOf, sourceOf) import Tilia.Span (Span (..), startPoint) import Tilia.Span.Ghc (spanOf) @@ -59,8 +59,8 @@ -- The lexer skips a @#!@ line, which puts it in no annotation and no -- node, so nothing downstream could put it back. pmPrologue :: [Text], - -- | Where the file header stops and the module proper begins, if the - -- module has anything after its header. + -- | Where the file header stops: at the @module@ line, or where a + -- module without one begins, if it has anything but a header. -- -- GHC reads pragmas from the header and nowhere else, so this is the -- line that decides whether a @{-# … #-}@ is a pragma at all. One @@ -69,11 +69,18 @@ pmHeaderEnd :: Maybe Span } +-- | Was something that begins here written in the header, before what +-- 'pmHeaderEnd' marks? +writtenInHeader :: Maybe Span -> Span -> Bool +writtenInHeader headerEnd s = + maybe True ((startPoint s <) . startPoint) headerEnd + -- | Parse a module. parseModule :: -- | Parser config. ParserConfig -> - -- | Path, used only in positions reported back. + -- | Path, reported back in positions, whose extension tells a signature + -- from a module. FilePath -> -- | The source. Text -> @@ -84,7 +91,8 @@ -- | Parse one configuration of a module. parseConfiguration :: ParserConfig -> - -- | Path, used only in positions reported back. + -- | Path, reported back in positions, whose extension tells a signature + -- from a module. FilePath -> -- | The lines of the module as written, except for the lines that do not -- belong to this configuration. @@ -138,8 +146,9 @@ . GHC.diagnosticMessage GHC.NoDiagnosticOpts . GHC.errMsgDiagnostic --- | Return each line a token other than a comment begins on, and whether --- the leftmost such token on the line begins an item of the top level. +-- | Return each line a token other than a comment begins on, down to the +-- first item of the top level after the imports, and whether the leftmost +-- such token on the line begins an item of the top level. -- 'Nothing' if the module has no imports, writes its top level in explicit -- braces, or does not lex. importLayout :: @@ -223,41 +232,22 @@ stateFor :: ParserConfig -> FilePath -> Text -> GHC.PState stateFor config path source = GHC.initParserState - (parserOpts config') + (parserOpts (effectiveExtensions (pcDefaults config) source)) (GHC.stringBufferFromByteString (T.encodeUtf8 source)) (GHC.mkRealSrcLoc (mkFastString path) 1 1) - where - config' = - config - { pcExtensions = withImplied (effectiveExtensions (pcExtensions config) source) - } -- | Would the parser read these two texts with the same extensions? readAlike :: ParserConfig -> Text -> Text -> Bool readAlike config a b = bits a == bits b where - bits t = - GHC.pExtsBitmap - ( parserOpts - config - { pcExtensions = withImplied (effectiveExtensions (pcExtensions config) t) - } - ) - --- | Close a set of extensions under what they imply. -withImplied :: [Extension] -> [Extension] -withImplied = settle . nub - where - settle es = - let es' = nub (es <> concatMap implied es) - in if length es' == length es then es else settle es' - implied e = [to | (from, GHC.On to) <- GHC.impliedXFlags, from == e] + bits = + GHC.pExtsBitmap . parserOpts . effectiveExtensions (pcDefaults config) -- | Options to parse with. -parserOpts :: ParserConfig -> GHC.ParserOpts -parserOpts ParserConfig{pcExtensions} = +parserOpts :: [Extension] -> GHC.ParserOpts +parserOpts extensions = GHC.mkParserOpts - (EnumSet.fromList pcExtensions) + (EnumSet.fromList extensions) quietDiagnostics False -- safe imports True -- keep Haddock tokens @@ -290,8 +280,12 @@ -- | The start of the first thing that is not part of the header. headerEndOf :: HsModule GhcPs -> Maybe Span headerEndOf hsModule = - listToMaybe . sortOn startPoint $ - mapMaybe spanOf (hsmodImports hsModule) <> mapMaybe spanOf (hsmodDecls hsModule) + listToMaybe . sortOn startPoint . catMaybes $ + [spanOf (am_mod moduleAnns), spanOf (am_sig moduleAnns)] + <> fmap spanOf (hsmodImports hsModule) + <> fmap spanOf (hsmodDecls hsModule) + where + moduleAnns = anns (hsmodAnn (hsmodExt hsModule)) -- | Why a module did not parse. data ParseError = ParseError @@ -308,8 +302,8 @@ -- | Parser configuration. newtype ParserConfig = ParserConfig - { -- | Extensions to enable before parsing. - pcExtensions :: [Extension] + { -- | What the component of the module puts in force before its pragmas. + pcDefaults :: Defaults } -- | What a file's name says it holds. diff --git a/src/Tilia/Pragma.hs b/src/Tilia/Pragma.hs --- a/src/Tilia/Pragma.hs +++ b/src/Tilia/Pragma.hs @@ -1,22 +1,38 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -- | Pragma-related helpers. module Tilia.Pragma ( movesPositions, + Defaults, + defaultsOf, effectiveExtensions, lookupExtension, lookupEdition, - applyExtensionName, + nameSwitch, + flagSwitches, + optionFlags, + pragmaFlags, languageNames, + withoutSkippedComments, + sameInForce, ) where +import Control.Monad ((<=<)) +import Data.Char (isAlphaNum, isSpace) import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map +import Data.Maybe (mapMaybe, maybeToList) +import Data.Set qualified as Set import Data.Text (Text) import Data.Text qualified as T +import GHC.Data.FastString (fsLit) import GHC.Driver.Session qualified as GHC import GHC.LanguageExtensions.Type (Extension (..)) +import GHC.Parser.Header (toArgs) +import GHC.Types.SrcLoc (mkRealSrcLoc, unLoc) +import Tilia.Utils (tshow) -- | Recognize @{-# LINE #-}@ and @{-# COLUMN #-}@ pragmas. movesPositions :: Text -> Bool @@ -25,43 +41,152 @@ positional body = T.toUpper (T.takeWhile (/= ' ') body) `elem` ["LINE", "COLUMN"] +-- | What a component puts in force before the pragmas of a module: its +-- @default-language@ and its @default-extensions@. +data Defaults = Defaults + { -- | What it turns on and off on top of its edition, in order, and on top + -- of an edition the module names in its place. + defaultsSwitches :: [GHC.OnOff Extension], + -- | What its edition and those switches put in force, worked out once. + defaultsInForce :: [Extension] + } + deriving (Eq, Show) + +-- | What a component puts in force, given the extensions of its edition and +-- what it switches on top of them, in order. +defaultsOf :: [Extension] -> [GHC.OnOff Extension] -> Defaults +defaultsOf edition switches = Defaults switches (foldl' switch edition switches) + -- | The extensions actually in force in a module. +-- +-- As with GHC, the edition the header names last takes the place of the +-- component's, wherever it is named, and what the component and then the +-- header switch is switched on top of it. effectiveExtensions :: - -- | What the package the module belongs to puts in force, which is its - -- @default-language@ and @default-extensions@ already resolved into a - -- set. - [Extension] -> - -- | The module's source, read here for its @LANGUAGE@ pragmas alone. + -- | What the component the module belongs to puts in force. + Defaults -> + -- | The module's source, read here for the @LANGUAGE@, @OPTIONS_GHC@ and + -- @OPTIONS@ pragmas of its header alone. Text -> [Extension] -effectiveExtensions package = - foldl' applyExtensionName package . concatMap pragmaNames . pragmaBodies +effectiveExtensions defaults source = + foldl' switch inForce (concat switches) where - pragmaNames body = - let (keyword, names) = T.break (== ' ') body - in if T.toUpper keyword == "LANGUAGE" - then languageNames names - else [] + (editions, switches) = unzip (fmap ofPragma (headerPragmaBodies source)) + ofPragma body = + let (keyword, rest) = T.break (== ' ') body + in editionsAndSwitches (T.toUpper keyword) rest + inForce = case concat editions of + [] -> defaultsInForce defaults + named -> + foldl' + switch + (GHC.languageExtensions (Just (last named))) + (defaultsSwitches defaults) --- | Turn on the extension a name spells, or off where the name puts @No@ in --- front of one, leaving the set as it is for a name that spells neither. -applyExtensionName :: [Extension] -> Text -> [Extension] -applyExtensionName acc name = - case T.stripPrefix "No" name >>= lookupExtension of - Just off -> filter (/= off) acc - Nothing -> case lookupExtension name of - Just on | on `notElem` acc -> acc <> [on] - _ -> acc +-- | Do two orders of the same pragmas, each given by its name and body, +-- leave the same extensions on? +-- +-- Where none of them turns an extension off, every order turns on the same. +sameInForce :: [(Text, Text)] -> [(Text, Text)] -> Bool +sameInForce a b = not (turnsOff a) || inForce a == inForce b + where + turnsOff = foldl' (switchWith (const id) (\_ _ -> True)) False . switches + inForce = foldl' (switchWith Set.insert Set.delete) Set.empty . switches + switches = concatMap (uncurry switchesOf) +-- | What a pragma of this name and body turns on and off. +switchesOf :: Text -> Text -> [GHC.OnOff Extension] +switchesOf name = snd . editionsAndSwitches name + +-- | The editions a pragma of this name and body names, and what it turns on +-- and off. +editionsAndSwitches :: Text -> Text -> ([GHC.Language], [GHC.OnOff Extension]) +editionsAndSwitches name body = + ( mapMaybe (lookupEdition <=< T.stripPrefix "-X") flags, + concatMap flagSwitches flags + ) + where + flags = pragmaFlags name body + +-- | The flags a pragma of this name and body gives GHC: each name of a +-- @LANGUAGE@ pragma after @-X@, and the flags of an options pragma. +pragmaFlags :: Text -> Text -> [Text] +pragmaFlags name body = case name of + "LANGUAGE" -> ["-X" <> n | n <- languageNames body] + "OPTIONS_GHC" -> optionFlags body + "OPTIONS" -> optionFlags body + _ -> [] + +-- | The flags of the body of an options pragma, split as GHC splits them. +optionFlags :: Text -> [Text] +optionFlags body = + either (const (T.words body)) (fmap (T.pack . unLoc)) $ + toArgs (mkRealSrcLoc (fsLit "") 1 1) (T.unpack body) + +-- | The extension a name turns on, or off where it puts @No@ in front of one. +nameSwitch :: Text -> Maybe (GHC.OnOff Extension) +nameSwitch name = case T.stripPrefix "No" name >>= lookupExtension of + Just off -> Just (GHC.Off off) + Nothing -> GHC.On <$> lookupExtension name + +-- | What a flag of an @OPTIONS_GHC@ or @OPTIONS@ pragma turns on and off. +flagSwitches :: Text -> [GHC.OnOff Extension] +flagSwitches flag + | Just name <- T.stripPrefix "-X" flag = maybeToList (nameSwitch name) + | flag == "-cpp" = [GHC.On Cpp] + | flag == "-fglasgow-exts" = GHC.On <$> GHC.glasgowExtsFlags + | flag == "-fno-glasgow-exts" = GHC.Off <$> GHC.glasgowExtsFlags + | Just name <- T.stripPrefix "-fno-" flag = GHC.Off <$> oldFlag name + | Just name <- T.stripPrefix "-f" flag = GHC.On <$> oldFlag name + | otherwise = [] + where + oldFlag name = maybeToList (Map.lookup name extensionsByOldFlag) + +-- | Turn an extension on or off in a list kept in the order extensions were +-- turned on in. +switch :: [Extension] -> GHC.OnOff Extension -> [Extension] +switch = switchWith turnOn (filter . (/=)) + where + turnOn e acc = if e `elem` acc then acc else acc <> [e] + +-- | Turn an extension on, and then what it implies, or turn it off alone, as +-- GHC does. +switchWith :: + -- | How to turn one extension on. + (Extension -> a -> a) -> + -- | How to turn one extension off. + (Extension -> a -> a) -> + -- | What is on so far. + a -> + -- | What to turn on or off. + GHC.OnOff Extension -> + a +switchWith on off acc = \case + GHC.On e -> + foldl' (switchWith on off) (on e acc) (Map.findWithDefault [] e impliedBy) + GHC.Off e -> off e acc + +-- | What GHC turns on or off besides when it turns an extension on. +impliedBy :: Map Extension [GHC.OnOff Extension] +impliedBy = + Map.fromListWith + (flip (<>)) + [(from, [implied]) | (from, implied) <- GHC.impliedXFlags] + -- | The extensions a @LANGUAGE@ pragma names, as written. languageNames :: Text -> [Text] languageNames = filter (not . T.null) . fmap T.strip . T.splitOn "," -- | Parse the name of an edition of the language, such as @GHC2021@. lookupEdition :: Text -> Maybe GHC.Language -lookupEdition name = - lookup name [(T.pack (show e), e) | e <- [minBound .. maxBound]] +lookupEdition name = Map.lookup name editionsByName +-- | Every edition of the language this compiler knows, by its name. +editionsByName :: Map Text GHC.Language +editionsByName = + Map.fromList [(tshow e, e) | e <- [minBound .. maxBound]] + -- | Parse an extension name. lookupExtension :: Text -> Maybe Extension lookupExtension name = Map.lookup name extensionsByName @@ -69,46 +194,115 @@ -- | Every extension this compiler knows, by the name one writes in a -- pragma. extensionsByName :: Map Text Extension -extensionsByName = - Map.fromList - [(T.pack (GHC.flagSpecName f), GHC.flagSpecFlag f) | f <- GHC.xFlags] +extensionsByName = byFlagName GHC.xFlags +-- | Every extension an old @-f@ flag such as @-fbang-patterns@ turns on, by +-- the flag without its @-f@. +extensionsByOldFlag :: Map Text Extension +extensionsByOldFlag = byFlagName GHC.fLangFlags + +-- | Extensions by the names of the flags that turn them on. +byFlagName :: [GHC.FlagSpec Extension] -> Map Text Extension +byFlagName flags = + Map.fromList [(T.pack (GHC.flagSpecName f), GHC.flagSpecFlag f) | f <- flags] + -- | What every @{-# … #-}@ in a module has between its braces, each on one -- line. pragmaBodies :: Text -> [Text] -pragmaBodies = go +pragmaBodies = scanPragmas past where - go = step . T.dropWhile (\c -> c /= '{' && c /= '-' && c /= '"') + past go t = case T.uncons t of + Just ('"', after) -> go (skipString after) + Just ('\'', after) -> go (skipCharacter after) + _ -> go (skipCode t) - step t + skipString = inString . T.dropWhile (\c -> c /= '"' && c /= '\\') + + inString t + | T.null t = t + | Just after <- T.stripPrefix "\\" t = skipString (T.drop 1 after) + | Just after <- T.stripPrefix "\"" t = after + | otherwise = skipString (T.drop 1 t) + + skipCharacter t = case T.unpack (T.take 2 t) of + ['\\', _] -> T.drop 1 (T.dropWhile (/= '\'') (T.drop 2 t)) + [c, '\''] | c /= '\'' -> T.drop 2 t + _ -> t + + skipCode t = + let (plain, rest) = T.break opens (T.drop 1 t) + before = maybe (T.head t) snd (T.unsnoc plain) + in if "'" `T.isPrefixOf` rest && inName before then skipCode rest else rest + opens c = c == '{' || c == '-' || c == '"' || c == '\'' + inName c = isAlphaNum c || c == '_' || c == '\'' + +-- | What the @{-# … #-}@ of a module's header have between their braces, each +-- on one line: those above the first thing that is neither a comment, a +-- directive nor a pragma, which are all GHC reads. +headerPragmaBodies :: Text -> [Text] +headerPragmaBodies = scanPragmas past + where + past go t = case T.uncons t of + Just (c, _) + | isSpace c -> go (T.stripStart t) + | c == '#' -> go (T.dropWhile (/= '\n') t) + _ -> [] + +-- | The bodies of the pragmas of a module, each on one line, carrying on past +-- what is neither a comment nor a pragma as the given function does. +scanPragmas :: ((Text -> [Text]) -> Text -> [Text]) -> Text -> [Text] +scanPragmas past = go + where + go t | T.null t = [] | Just body <- T.stripPrefix "{-#" t = case T.breakOn "#-}" body of (_, after) | T.null after -> [] - (inner, after) -> T.unwords (T.words inner) : go (T.drop 3 after) + (inner, after) -> + T.unwords (T.words (withoutSkippedComments inner)) + : go (T.drop 3 after) | Just after <- T.stripPrefix "{-" t = go (skipBlock (1 :: Int) after) | opensLineComment t = go (T.dropWhile (/= '\n') t) - | Just after <- T.stripPrefix "\"" t = go (skipString after) - | otherwise = go (T.drop 1 t) + | otherwise = past go t - opensLineComment t = case T.stripPrefix "--" t of - Nothing -> False - Just rest -> maybe True (not . symbolic . fst) (T.uncons rest) +-- | What a pragma holds between its @{-#@ and its @#-}@, without the +-- comments GHC skips in it: those of a @LANGUAGE@ pragma, which then comes +-- out on one line. +withoutSkippedComments :: Text -> Text +withoutSkippedComments inner + | T.any (\c -> c == '-' || c == '{') inner, + T.toUpper keyword == "LANGUAGE" = + T.unwords (T.words (withoutComments inner)) + | otherwise = inner + where + keyword = T.takeWhile (not . isSpace) (T.stripStart inner) - symbolic c = c `elem` ("!#$%&*+./<=>?@\\^|-~:" :: String) +-- | A text without its comments, each of which leaves a space behind. +withoutComments :: Text -> Text +withoutComments t + | T.null t = t + | Just after <- T.stripPrefix "{-" t = + " " <> withoutComments (skipBlock (1 :: Int) after) + | opensLineComment t = withoutComments (T.dropWhile (/= '\n') t) + | otherwise = + let (plain, rest) = T.break (\c -> c == '{' || c == '-') (T.drop 1 t) + in T.take 1 t <> plain <> withoutComments rest - skipBlock 0 t = t - skipBlock n t0 = inBlock n (T.dropWhile (\c -> c /= '{' && c /= '-') t0) +-- | Does a line comment begin here? +opensLineComment :: Text -> Bool +opensLineComment t = case T.stripPrefix "--" t of + Nothing -> False + Just rest -> + maybe True (not . symbolic . fst) (T.uncons (T.dropWhile (== '-') rest)) + where + symbolic c = c `elem` ("!#$%&*+./<=>?@\\^|-~:" :: String) - inBlock n t +-- | What follows the end of a block comment this deep in comments. +skipBlock :: Int -> Text -> Text +skipBlock 0 t = t +skipBlock n t0 = inBlock (T.dropWhile (\c -> c /= '{' && c /= '-') t0) + where + inBlock t | T.null t = t | Just after <- T.stripPrefix "{-" t = skipBlock (n + 1) after | Just after <- T.stripPrefix "-}" t = skipBlock (n - 1) after | otherwise = skipBlock n (T.drop 1 t) - - skipString = inString . T.dropWhile (\c -> c /= '"' && c /= '\\') - - inString t - | T.null t = t - | Just after <- T.stripPrefix "\\" t = skipString (T.drop 1 after) - | Just after <- T.stripPrefix "\"" t = after - | otherwise = skipString (T.drop 1 t) diff --git a/src/Tilia/Pragma/Ghc.hs b/src/Tilia/Pragma/Ghc.hs new file mode 100644 --- /dev/null +++ b/src/Tilia/Pragma/Ghc.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE LambdaCase #-} +{-# OPTIONS_GHC -Wno-missing-fields #-} + +-- | What GHC's own reader of flags makes of the flags of a header. +module Tilia.Pragma.Ghc + ( InForce (..), + inForceAfter, + readFlags, + ) +where + +import Data.List (isPrefixOf) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Maybe (mapMaybe) +import Data.Text (Text) +import Data.Text qualified as T +import GHC.Driver.CmdLine (Flag (..), processArgs) +import GHC.Driver.Session qualified as GHC +import GHC.LanguageExtensions.Type (Extension) +import GHC.Platform (genericPlatform) +import GHC.Settings +import GHC.Settings.Config (cProjectVersion) +import GHC.Types.SafeHaskell (SafeHaskellMode) +import GHC.Types.SrcLoc (noLoc) +import GHC.Unit.Types (stringToUnitId) +import GHC.Utils.Fingerprint (fingerprint0) +import Tilia.Pragma (flagSwitches) + +-- | What the flags of a header settle, whatever was in force before them. +data InForce = InForce + { -- | Whether the flags, with what they imply, last turn each extension + -- they switch on or off. + inForceSwitches :: Map Extension Bool, + -- | The edition named last, if one is. + inForceEdition :: Maybe GHC.Language, + -- | The Safe Haskell mode. + inForceSafety :: SafeHaskellMode + } + +-- | What GHC's flag reader makes of these flags, read in order. +inForceAfter :: [Text] -> InForce +inForceAfter flags = + InForce + { inForceSwitches = Map.fromList (fmap switched (reverse (GHC.extensions dflags))), + inForceEdition = GHC.language dflags, + inForceSafety = GHC.safeHaskell dflags + } + where + dflags = readFlags flags + switched = \case + GHC.On e -> (e, True) + GHC.Off e -> (e, False) + +-- | What GHC's flag reader makes of these flags, read in order from its +-- defaults, of the flags that can switch an extension, the edition or the +-- Safe Haskell mode. +readFlags :: [Text] -> GHC.DynFlags +readFlags flags = snd (GHC.runCmdLineP reading defaults) + where + reading = processArgs named (fmap noLoc args) (\_ -> pure []) + named = mapMaybe ((`Map.lookup` switchingFlags) . drop 1) args + args = fmap T.unpack flags + +-- | The flags of GHC's that can switch an extension, the edition or the Safe +-- Haskell mode, by name: the @-X@ ones and the rest of those 'flagSwitches' +-- reads. +switchingFlags :: Map String (Flag (GHC.CmdLineP GHC.DynFlags)) +switchingFlags = + Map.fromList + [(flagName f, f) | f <- GHC.flagsDynamic, switching (flagName f)] + where + switching name = + "X" `isPrefixOf` name || not (null (flagSwitches (T.pack ('-' : name)))) + +-- | What GHC puts in force before it reads any flag. +defaults :: GHC.DynFlags +defaults = GHC.defaultDynFlags settings + +-- | Enough of a compiler's settings for its flag reader, which runs no tool. +settings :: Settings +settings = + Settings + { sGhcNameVersion = GhcNameVersion "ghc" cProjectVersion, + sFileSettings = FileSettings{}, + sTargetPlatform = genericPlatform, + sToolSettings = ToolSettings{toolSettings_opt_P_fingerprint = fingerprint0}, + sPlatformMisc = PlatformMisc{}, + sUnitSettings = UnitSettings (stringToUnitId "base"), + sRawSettings = [] + } diff --git a/src/Tilia/Render/Class.hs b/src/Tilia/Render/Class.hs --- a/src/Tilia/Render/Class.hs +++ b/src/Tilia/Render/Class.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE DataKinds #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} @@ -19,15 +18,13 @@ import Data.Choice (fromBool, pattern Do) import Data.Foldable (fold) -import Data.Function (on) -import Data.List (sortBy) import Data.Maybe (isNothing) import GHC.Builtin.Types (cTupleTyConName, isCTupleTyConName) import GHC.Core.Coercion.Axiom (Role (..)) import GHC.Hs import GHC.Types.Fixity (LexicalFixity (..)) import GHC.Types.Name.Reader (RdrName (..)) -import GHC.Types.SrcLoc (GenLocated (..), leftmost_smallest, unLoc) +import GHC.Types.SrcLoc (GenLocated (..), unLoc) import Tilia.Doc.Combinators import Tilia.Render.Context import Tilia.Render.Data (dataDecl) @@ -87,7 +84,7 @@ body = includeUnless (null members) - (breakOrSpace <> indent (knotDeclsGrouped (ctxKnot ctx) ctx Associated members)) + (breakOrSpace <> indent (knotDeclsGrouped (ctxKnot ctx) ctx members)) members = inSourceOrder @@ -112,6 +109,7 @@ <> space <> indent (commaSep (fmap (align . at_ ctx (funDep ctx)) fdeps)) +-- | One functional dependency of a class, as in @a b -> c@. funDep :: Ctx -> FunDep GhcPs -> Doc funDep ctx (FunDep _ before after) = hsep (fmap (name ctx) before) @@ -146,7 +144,7 @@ body = includeUnless (null members) . indent $ - breakOrSpace <> knotDeclsGrouped (ctxKnot ctx) ctx Associated members + breakOrSpace <> knotDeclsGrouped (ctxKnot ctx) ctx members members = inSourceOrder @@ -258,6 +256,8 @@ includeUnless (null given) $ hardBreak <> indent (vsep (fmap (at_ ctx (tyFamInstEqn ctx)) given)) +-- | What the head of a family says of its result, a kind or a variable +-- naming it, if anything. familyResultSig :: Ctx -> LFamilyResultSig GhcPs -> Maybe Doc familyResultSig ctx (L _ sig) = case sig of NoSig NoExtField -> Nothing @@ -266,6 +266,7 @@ TyVarSig NoExtField bndr -> Just (txt "=" <> breakOrSpace <> at ctx bndr (tyVarBndr ctx)) +-- | The injectivity annotation of a type family, as in @| r -> a@. injectivityAnn :: Ctx -> InjectivityAnn GhcPs -> Doc injectivityAnn ctx (InjectivityAnn _ from to) = txt "|" @@ -312,8 +313,3 @@ Nominal -> txt "nominal" Representational -> txt "representational" Phantom -> txt "phantom" - --- | Merge several lists of declarations back into the order they were --- written in. -inSourceOrder :: [[LHsDecl GhcPs]] -> [LHsDecl GhcPs] -inSourceOrder = sortBy (leftmost_smallest `on` getLocA) . concat diff --git a/src/Tilia/Render/Context.hs b/src/Tilia/Render/Context.hs --- a/src/Tilia/Render/Context.hs +++ b/src/Tilia/Render/Context.hs @@ -43,17 +43,14 @@ ) where -import Data.List.NonEmpty (NonEmpty) import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map import Data.Set (Set) import Data.Set qualified as Set import Data.Text (Text) -import Data.Text qualified as T import GHC.Hs hiding (Fixity) import GHC.LanguageExtensions.Type (Extension (NegativeLiterals)) -import GHC.Types.Name.Occurrence (occNameString) -import GHC.Types.Name.Reader (RdrName (..), rdrNameOcc) +import GHC.Types.Name.Reader (RdrName (..)) import GHC.Types.SrcLoc (GenLocated (..)) import GHC.Types.SrcLoc qualified as GHC import Tilia.Comments (Comment (..), CommentStyle (..), carriesOn, commentTrailing) @@ -61,10 +58,11 @@ import Tilia.Fixity ( Fixity, Namespace (..), - OpName (..), Resolution (..), Scope, lookupFixity, + opName, + qualifierOf, ) import Tilia.Render.Layout (Bracing (..)) import Tilia.Source @@ -114,10 +112,10 @@ -- | Signature declarations, needed by @let@ and @where@ bodies. knotSig :: Ctx -> Sig GhcPs -> Doc, -- | A run of declarations, needed by Template Haskell brackets. - knotDecls :: Ctx -> FamilyStyle -> [LHsDecl GhcPs] -> Doc, + knotDecls :: Ctx -> [LHsDecl GhcPs] -> Doc, -- | A run of declarations that keeps the author's blank lines, needed -- by class and instance bodies. - knotDeclsGrouped :: Ctx -> FamilyStyle -> [LHsDecl GhcPs] -> Doc + knotDeclsGrouped :: Ctx -> [LHsDecl GhcPs] -> Doc } -- | Whether a family or data declaration stands on its own or inside a @@ -186,14 +184,9 @@ operatorFixity :: Ctx -> Namespace -> RdrName -> Maybe Fixity operatorFixity ctx namespace name = do scope <- ctxScope ctx - case lookupFixity scope namespace qualifier op of + case lookupFixity scope namespace (qualifierOf name) (opName name) of Resolved fixity _ -> Just fixity Unresolved _ -> Nothing - where - op = OpName (T.pack (occNameString (rdrNameOcc name))) - qualifier = case name of - Qual m _ -> Just (T.pack (moduleNameString m)) - _ -> Nothing ---------------------------------------------------------------------------- -- What lies between two spans @@ -392,11 +385,11 @@ ---------------------------------------------------------------------------- -- Haddocks --- | The author's own text for the Haddock at this position, if we kept it. -writtenHaddock :: Ctx -> Maybe Span -> Maybe (NonEmpty Text) +-- | The Haddock the author wrote at this position, if we kept it. +writtenHaddock :: Ctx -> Maybe Span -> Maybe Comment writtenHaddock ctx ms = do s <- ms - c <- Map.lookup (spanStartLine s, spanStartColumn s) (ctxHaddocks ctx) + c <- Map.lookup (startPoint s) (ctxHaddocks ctx) case commentStyle c of - DocComment -> Just (commentBody c) + DocComment -> Just c _ -> Nothing diff --git a/src/Tilia/Render/Data.hs b/src/Tilia/Render/Data.hs --- a/src/Tilia/Render/Data.hs +++ b/src/Tilia/Render/Data.hs @@ -205,10 +205,10 @@ argsAndResult = arguments <> resultType -- GHC keeps a GADT's result type without the brackets it was written - -- with, and there is one shape that does not survive losing them. A - -- kind signature needs them back: @MkT :: Int -> T :: Star@ reads as a - -- second signature on the constructor rather than as a kind on its - -- result, and does not parse at all. + -- with, and three shapes need them back: a kind signature, as + -- @MkT :: Int -> T :: Star@ does not parse, and a @forall@ or a context + -- making up the whole signature, which would be read as the + -- constructor's own. resultType = case unLoc con_res_ty of HsKindSig{} -> parens (hsType ctx con_res_ty) HsForAllTy{} | standsAlone -> parens (hsType ctx con_res_ty) @@ -361,6 +361,4 @@ ) <> indent (space <> txt "=" <> separator <> hsType ctx rhs) where - separator - | typeIsDocumented (unLoc rhs) = hardBreak - | otherwise = breakOrSpace + separator = typeBreak (typeIsDocumented (unLoc rhs)) diff --git a/src/Tilia/Render/Declaration.hs b/src/Tilia/Render/Declaration.hs --- a/src/Tilia/Render/Declaration.hs +++ b/src/Tilia/Render/Declaration.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE DataKinds #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} @@ -36,16 +35,17 @@ import Tilia.Render.Signature import Tilia.Render.Type import Tilia.Source (SourceType (..)) -import Tilia.Span import Tilia.Span.Ghc --- | A run of declarations, with blank lines wherever we think they belong. -decls :: Ctx -> FamilyStyle -> [LHsDecl GhcPs] -> Doc -decls = declRun Disregard +-- | A run of declarations standing on their own, with blank lines wherever +-- we think they belong. +decls :: Ctx -> [LHsDecl GhcPs] -> Doc +decls ctx = declRun Disregard ctx Free --- | A run of declarations that keeps the author's grouping. -declsKeepingGroups :: Ctx -> FamilyStyle -> [LHsDecl GhcPs] -> Doc -declsKeepingGroups = declRun Respect +-- | A run of declarations in a class or an instance, which keeps the +-- author's grouping. +declsKeepingGroups :: Ctx -> [LHsDecl GhcPs] -> Doc +declsKeepingGroups ctx = declRun Respect ctx Associated -- | Whether the author's own blank lines are consulted. data Grouping @@ -119,7 +119,7 @@ _ -> False belongs previous current = (not isSignatureFile && isSignatureSeries ctx previous current) - || isDerivingSeries ctx previous current + || isSeries ctx previous current || relatedDecls d current || relatedDecls previous current @@ -131,12 +131,15 @@ not (commentPrintedBetween ctx (spanOf x) (spanOf y)) _ -> False --- | Two standalone @deriving@ declarations the author ran together. -isDerivingSeries :: Ctx -> LHsDecl GhcPs -> LHsDecl GhcPs -> Bool -isDerivingSeries ctx x@(L _ a) y@(L _ b) = case (a, b) of - (DerivD{}, DerivD{}) -> - not (separatedByBlank ctx (spanOf x) (spanOf y)) +-- | Two standalone @deriving@ declarations, or two splices, the author ran +-- together. +isSeries :: Ctx -> LHsDecl GhcPs -> LHsDecl GhcPs -> Bool +isSeries ctx x@(L _ a) y@(L _ b) = case (a, b) of + (DerivD{}, DerivD{}) -> ranTogether + (SpliceD{}, SpliceD{}) -> ranTogether _ -> False + where + ranTogether = not (separatedByBlank ctx (spanOf x) (spanOf y)) -- | The kinds of declaration that grouping distinguishes. data Kind @@ -151,7 +154,6 @@ | FamilyDeclaration | TypeSynonym | PragmaDeclaration - | TopLevelSplice | DocumentsNext | DocumentsPrevious | Unremarkable @@ -169,7 +171,7 @@ SigD _ sig | Just n <- specialisedName sig -> (PragmaDeclaration, [n]) ValD _ (FunBind _ (L _ n) _) -> (FunctionBody, [n]) - ValD _ (PatBind _ p _ _) -> (FunctionBody, boundNames p) + ValD _ (PatBind _ p _ _) -> (FunctionBody, collectPatBinders CollNoDictBinders p) ValD _ (PatSynBind _ (PSB _ (L _ n) _ _ _)) -> (PatternDefinition, [n]) AnnD _ (HsAnnotation _ (ValueAnnProvenance (L _ n)) _) -> (PragmaDeclaration, [n]) AnnD _ (HsAnnotation _ (TypeAnnProvenance (L _ n)) _) -> (PragmaDeclaration, [n]) @@ -180,36 +182,16 @@ TyClD _ (SynDecl _ (L _ n) _ _ _) -> (TypeSynonym, [n]) TyClD _ (FamDecl _ (FamilyDecl _ _ _ (L _ n) _ _ _ _)) -> (FamilyDeclaration, [n]) KindSigD _ (StandaloneKindSig _ (L _ n) _) -> (KindSignature, [n]) - SpliceD _ (SpliceDecl _ _ _) -> (TopLevelSplice, []) DocD _ (DocCommentNext _) -> (DocumentsNext, []) DocD _ (DocCommentPrev _) -> (DocumentsPrevious, []) _ -> (Unremarkable, []) --- | The names a pattern binding brings into scope. -boundNames :: LPat GhcPs -> [RdrName] -boundNames (L _ p) = case p of - VarPat _ (L _ n) -> [n] - AsPat _ (L _ n) inner -> n : boundNames inner - NPlusKPat _ (L _ n) _ _ _ _ -> [n] - LazyPat _ inner -> boundNames inner - BangPat _ inner -> boundNames inner - ParPat _ inner -> boundNames inner - SigPat _ inner _ -> boundNames inner - ViewPat _ _ inner -> boundNames inner - SumPat _ inner _ _ -> boundNames inner - TuplePat _ ps _ -> concatMap boundNames ps - ListPat _ ps -> concatMap boundNames ps - OrPat _ ps -> concatMap boundNames (NE.toList ps) - ConPat _ _ details -> concatMap boundNames (hsConPatArgs details) - _ -> [] - -- | Should these two declarations be printed with no blank line between -- them? relatedDecls :: LHsDecl GhcPs -> LHsDecl GhcPs -> Bool relatedDecls a b = case (kindA, kindB) of (DocumentsNext, _) -> True (_, DocumentsPrevious) -> True - (TopLevelSplice, TopLevelSplice) -> not (blankBetween (spanOf a) (spanOf b)) pair | pair `elem` relatedKinds -> shareAName namesA namesB _ -> False where diff --git a/src/Tilia/Render/Expression.hs b/src/Tilia/Render/Expression.hs --- a/src/Tilia/Render/Expression.hs +++ b/src/Tilia/Render/Expression.hs @@ -1,11 +1,9 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} -- | Expressions, and the equations and blocks built out of them. @@ -19,9 +17,8 @@ import Control.Applicative ((<|>)) import Data.Choice (Choice, fromBool, isTrue, pattern Is, pattern Isn't) -import Data.Function (on) import Data.Generics.Schemes (listify) -import Data.List (sortBy, unsnoc) +import Data.List (unsnoc) import Data.List.NonEmpty (NonEmpty (..)) import Data.List.NonEmpty qualified as NE import Data.Map.Strict qualified as Map @@ -34,11 +31,9 @@ import GHC.Types.Fixity (LexicalFixity (..)) import GHC.Types.Name.Occurrence (isVarOcc, occNameString) import GHC.Types.Name.Reader (RdrName (..), mkVarUnqual, rdrNameOcc) -import GHC.Types.SourceText import GHC.Types.SrcLoc ( GenLocated (..), isZeroWidthSpan, - leftmost_smallest, noSrcSpan, unLoc, ) @@ -51,7 +46,7 @@ ) import Tilia.Render.Context import Tilia.Render.Layout -import Tilia.Render.Literal (stringLiteral) +import Tilia.Render.Literal (hsLit, writtenString) import Tilia.Render.Name import Tilia.Render.Operator import Tilia.Render.Pattern @@ -74,11 +69,7 @@ HsOverLabel src _ -> txt "#" <> sourceText src HsIPVar _ (HsIPName n) -> txt "?" <> outputable n HsOverLit _ v -> outputable (ol_val v) - HsLit _ lit -> case lit of - HsString (SourceText s) _ -> stringLiteral s - HsStringPrim (SourceText s) _ -> stringLiteral s - HsMultilineString (SourceText s) _ -> stringLiteral s - other -> outputable other + HsLit _ lit -> hsLit lit HsLam _ variant' mg -> lambda ctx site variant' (ExprBody ctx) mg HsApp _ f x -> application ctx site f x HsAppType at' e a -> @@ -169,12 +160,7 @@ <> joinedBy "::" <> indent (hsSigType ctx hswc_body) ArithSeq _ _ range -> arithSeq ctx here (closingFor site) range - HsTypedBracket (bracketAnn, _) e -> - txt opener - <> breakOrNothing - <> insideBrackets here (hsExpr ctx e) - <> breakOrNothing - <> txt "||]" + HsTypedBracket (bracketAnn, _) e -> quoted here opener "||]" (hsExpr ctx e) where opener = case bracketAnn of BracketNoE{} -> "[||" @@ -191,7 +177,7 @@ HsPragE _ prag x -> case prag of HsPragSCC _ n -> txt "{-# SCC " - <> outputable n + <> writtenString n <> txt " #-}" <> breakOrSpace <> nest (if siteInBlock site then 1 else 0) (hsExpr ctx x) @@ -507,17 +493,7 @@ <> breakOrSpace <> indent (hsExpr ctx trS_using) RecStmt{..} -> - txt "rec" - <> space - <> align - ( at ctx recS_stmts $ \xs -> - items (siteBracing site) $ - keepBlanks - (separatedByBlank ctx) - [ (spanOf s, at_ ctx (stmtBody ctx site mkBody) s) - | s <- xs - ] - ) + txt "rec" <> space <> align (stmtBlock ctx site mkBody recS_stmts) -- | The statements of a block, with the break that introduces them. statements :: @@ -532,7 +508,21 @@ XRec GhcPs [LStmt GhcPs (XRec GhcPs body)] -> Doc statements ctx site mkBody es = - breakOrSpace <> underSite site (at ctx es block) + breakOrSpace <> underSite site (stmtBlock ctx site mkBody es) + +-- | The statements of a block, each laid out as an item of it. +stmtBlock :: + ( Body b, + Anno [LStmt GhcPs (XRec GhcPs body)] ~ SrcSpanAnnLW, + Anno (Stmt GhcPs (XRec GhcPs body)) ~ SrcSpanAnnA, + Anno body ~ SrcSpanAnnA + ) => + Ctx -> + Site -> + BodyOf body b -> + XRec GhcPs [LStmt GhcPs (XRec GhcPs body)] -> + Doc +stmtBlock ctx site mkBody es = at ctx es block where block xs = items (siteBracing site) $ @@ -699,10 +689,7 @@ | (position, item) <- positioned sorted ] where - sorted = - sortBy - (leftmost_smallest `on` getLocA) - (fmap (fmap Left) binds <> fmap (fmap Right) sigs) + sorted = inSourceOrder [fmap (fmap Left) binds, fmap (fmap Right) sigs] rendered position item = blockItem position NoBrace $ \b -> at_ ctx (either (valDecl ctx b) (knotSig (ctxKnot ctx) ctx)) item @@ -889,11 +876,7 @@ | isCaseStyle style, null (unLoc mg_alts) = txt "{}" | otherwise = items blockBracing (fmap rendered (positioned (unLoc mg_alts))) where - blockBracing = case style of - CaseStyle -> ifEmpty - LambdaCaseStyle -> ifEmpty - _ -> NoBrace - ifEmpty = if null (unLoc mg_alts) then MayBrace else bracing + blockBracing = if isCaseStyle style then bracing else NoBrace rendered (position, m) = blockItem position bracing (\b -> at_ ctx (renderMatch b) m) renderMatch b m@Match{..} = @@ -1008,13 +991,10 @@ _ -> True separator - | length grhssGRHSs > 1 = mempty + | hasGuards = mempty | otherwise = case style of - FunctionStyle _ | hasGuards -> mempty FunctionStyle _ -> space <> indent (txt "=") - PatternBindStyle | hasGuards -> mempty PatternBindStyle -> space <> indent (txt "=") - s | isCaseStyle s && hasGuards -> mempty _ -> space <> txt "->" body = sepBy breakOrSpace (fmap alternative (NE.toList grhssGRHSs)) @@ -1196,24 +1176,19 @@ -- | A Template Haskell quotation. quotation :: Ctx -> Maybe Span -> HsQuote GhcPs -> Doc quotation ctx here = \case - ExpBr (bracketAnn, _) e -> quoted (flavour bracketAnn) (hsExpr ctx e) + ExpBr (bracketAnn, _) e -> quotedAs (flavour bracketAnn) (hsExpr ctx e) where flavour = \case BracketNoE{} -> "" BracketHasE{} -> "e" - PatBr _ p -> quoted "p" (hsPat ctx p) + PatBr _ p -> quotedAs "p" (hsPat ctx p) DecBrL _ decls -> - quoted "d" (starGuard decls (knotDecls (ctxKnot ctx) ctx Free decls)) + quotedAs "d" (starGuard decls (knotDecls (ctxKnot ctx) ctx decls)) DecBrG _ _ -> error "Tilia: DecBrG is produced by the renamer" - TypBr _ ty -> quoted "t" (starGuard ty (hsType ctx ty)) + TypBr _ ty -> quotedAs "t" (starGuard ty (hsType ctx ty)) VarBr _ isSingle n -> txt (if isSingle then "'" else "''") <> name ctx n where - quoted flavour body = - txt "[" - <> txt flavour - <> txt "|" - <> breakOrNothing - <> indent (insideBrackets here body <> breakOrNothing <> txt "|]") + quotedAs flavour = quoted here ("[" <> flavour <> "|") "|]" starGuard x body | risky = space <> body <> space | otherwise = body @@ -1228,6 +1203,22 @@ ClosedTypeFamily Nothing -> True _ -> False +-- | The body of a quotation between its brackets, indented where it breaks. +quoted :: + -- | Where the quotation is written. + Maybe Span -> + -- | The opening bracket. + Text -> + -- | The closing bracket. + Text -> + -- | The body. + Doc -> + Doc +quoted here opener closer body = + txt opener + <> breakOrNothing + <> indent (insideBrackets here body <> breakOrNothing <> txt closer) + -- | An item of a block: the last one keeps the block's bracing, and any -- other may brace itself when the block is flat. blockItem :: Position -> Bracing -> (Bracing -> Doc) -> Doc @@ -1306,6 +1297,8 @@ HsCmdLam{} -> Hanging _ -> Normal +-- | Does this command at the top of an arrow form absorb the line break +-- that introduces it? cmdTopHangs :: HsCmdTop GhcPs -> Placement cmdTopHangs (HsCmdTop _ c) = cmdHangs (unLoc c) diff --git a/src/Tilia/Render/Haddock.hs b/src/Tilia/Render/Haddock.hs --- a/src/Tilia/Render/Haddock.hs +++ b/src/Tilia/Render/Haddock.hs @@ -18,14 +18,13 @@ import Data.Data (Data) import Data.Generics.Schemes (listify) import Data.List (dropWhileEnd) -import Data.List.NonEmpty (NonEmpty (..)) import Data.List.NonEmpty qualified as NE import Data.Maybe (fromMaybe, mapMaybe) import Data.Text (Text) import Data.Text qualified as T import GHC.Hs import GHC.Types.SrcLoc (GenLocated (..), getLoc, unLoc) -import Tilia.Comments (afterOpener, triggerOn) +import Tilia.Comments (Comment (..), afterOpener, bracketed, singleLine, triggerOn) import Tilia.Doc.Combinators import Tilia.Gathered (Gathered (..)) import Tilia.Render.Context @@ -75,13 +74,11 @@ docBody :: Ctx -> DocStyle -> LHsDoc GhcPs -> (Doc, Bool) docBody ctx style doc@(L l str) = case reusableText ctx style doc of - Just written -> + Just c -> ( maybe id located (spanOfSrcSpan l) $ align - $ sepBy - (verbatimBreak AtIndent TrimWhitespace) - (fmap txt (NE.toList written)), - selfClosing written + $ verbatimLines AtIndent TrimWhitespace (NE.toList (commentBody c)), + selfClosing c ) Nothing | null written' -> (writtenAt emptyBlock, True) @@ -95,7 +92,7 @@ <> mconcat (replicate trailingBlanks (hardBreak <> txt "--")) trailingBlanks = case writtenHaddock ctx (spanOfSrcSpan l) of Nothing -> 0 - Just ls -> length (takeWhile isBlankLine (reverse (NE.toList ls))) + Just c -> length (takeWhile isBlankLine (reverse (NE.toList (commentBody c)))) isBlankLine t = T.null (T.strip (fromMaybe t (T.stripPrefix "--" (T.strip t)))) line' isFirst t = (if isFirst then txt (opener style) else txt "--") @@ -105,7 +102,7 @@ align $ txt (blockOpener style) <> space - <> sepBy (verbatimBreak AtIndent TrimWhitespace) (fmap txt written') + <> verbatimLines AtIndent TrimWhitespace written' <> space <> txt "-}" asBlock = writtenAsBlock ctx doc @@ -131,7 +128,7 @@ -- | Did the author write this Haddock as a block comment? writtenAsBlock :: Ctx -> LHsDoc GhcPs -> Bool writtenAsBlock ctx doc = - maybe False isBlockForm (writtenHaddock ctx (spanOfSrcSpan (getLoc doc))) + maybe False bracketed (writtenHaddock ctx (spanOfSrcSpan (getLoc doc))) -- | The anchor of a named documentation chunk. docSectionName :: String -> Text @@ -143,11 +140,11 @@ -- the one it was written in, since the text carries the style in its first -- characters, nor when it holds nothing but the spaces the end of a line -- loses. -reusableText :: Ctx -> DocStyle -> LHsDoc GhcPs -> Maybe (NonEmpty Text) +reusableText :: Ctx -> DocStyle -> LHsDoc GhcPs -> Maybe Comment reusableText ctx style doc = do - written <- writtenHaddock ctx (spanOfSrcSpan (getLoc doc)) - if openedInStyle style (NE.head written) && not onlySpaces - then Just written + c <- writtenHaddock ctx (spanOfSrcSpan (getLoc doc)) + if openedInStyle style (NE.head (commentBody c)) && not onlySpaces + then Just c else Nothing where onlySpaces = not (null text) && all isSpace text && '\n' `notElem` text @@ -169,13 +166,9 @@ Section n -> T.replicate n "*" Chunk n -> "$" <> T.pack n --- | Was the reused text a block comment? -isBlockForm :: NonEmpty Text -> Bool -isBlockForm written = "{-" `T.isPrefixOf` T.stripStart (NE.head written) - --- | May code follow the reused text on the line it ends? -selfClosing :: NonEmpty Text -> Bool -selfClosing written = isBlockForm written && null (NE.tail written) +-- | May code follow a Haddock on the line it ends? +selfClosing :: Comment -> Bool +selfClosing c = bracketed c && singleLine c -- | Lay the document out on several lines if printing this fragment will -- emit a Haddock that takes whole lines. @@ -194,7 +187,7 @@ docs -> any takesWholeLines docs where takesWholeLines doc = case reusableText ctx Pipe doc of - Just written -> not (selfClosing written) + Just c -> not (selfClosing c) Nothing -> not (null (docLines (writtenAsBlock ctx doc) (unLoc doc))) -- | The spans of every Haddock in a module. diff --git a/src/Tilia/Render/Header.hs b/src/Tilia/Render/Header.hs --- a/src/Tilia/Render/Header.hs +++ b/src/Tilia/Render/Header.hs @@ -14,8 +14,9 @@ import Control.Applicative ((<|>)) import Data.Function (on) import Data.List (sortOn) +import Data.List.NonEmpty (NonEmpty) import Data.List.NonEmpty qualified as NE -import Data.Maybe (isJust) +import Data.Maybe (isJust, isNothing) import Data.Set qualified as Set import Data.Text (Text) import Data.Text qualified as T @@ -25,7 +26,8 @@ import GHC.Types.SrcLoc (GenLocated (..), unLoc) import Tilia.Comments (Comment (..), Pragma (..), commentPragma) import Tilia.Doc.Combinators -import Tilia.Pragma (languageNames, lookupEdition) +import Tilia.Parser (writtenInHeader) +import Tilia.Pragma (languageNames, lookupEdition, sameInForce) import Tilia.Render.Context import Tilia.Render.Declaration (decls) import Tilia.Render.Haddock @@ -42,42 +44,29 @@ hpSpan :: Span, -- | How many preprocessor directives the header has above it. hpRun :: Int, - -- | @LANGUAGE@, @OPTIONS_GHC@ or @OPTIONS_HADDOCK@. + -- | @LANGUAGE@, @OPTIONS_GHC@, @OPTIONS@ or @OPTIONS_HADDOCK@. hpName :: Text, -- | One extension, or the whole of an options string. - hpBody :: Text + hpBody :: Text, + -- | The lines it was written on, where it is a language pragma holding a + -- comment, which it keeps as written. + hpWritten :: Maybe (NonEmpty Text) } deriving (Eq, Show) -- | Where a pragma sorts among the others. -- --- The derived ordering is the whole of the policy: language pragmas first, --- then @OPTIONS_GHC@, then @OPTIONS_HADDOCK@; and within the language --- pragmas, by the class of extension. +-- The derived ordering is the policy wherever it leaves the same extensions +-- in force: the editions first, in the order they are written, then the +-- other language pragmas, by name, then @OPTIONS_GHC@ and @OPTIONS@, then +-- @OPTIONS_HADDOCK@. data PragmaOrder - = LanguageOrder ExtensionClass + = EditionOrder + | LanguageOrder | OptionsGhcOrder | OptionsHaddockOrder deriving (Eq, Ord, Show) --- | Which group an extension sorts into. --- --- Sorting the extensions alphabetically outright would change what a module --- means, because an extension can turn others on and a later one can turn --- them off again. Sorting only within these groups keeps the relationships --- that matter: a pack before what it enables, an enabling before a --- disabling, and the stragglers that have to come last at the end. -data ExtensionClass - = -- | @GHC2021@, @Haskell2010@ and the like. - Pack - | -- | Anything else. - Enabling - | -- | An extension written with a @No@ prefix. - Disabling - | -- | Extensions that only work when nothing follows them. - Last' - deriving (Eq, Ord, Show) - -- | Pick the header pragmas out of a comment stream. takeHeaderPragmas :: -- | The module as written. @@ -108,28 +97,27 @@ { hpSpan = commentSpan c, hpRun = directivesAbove (spanStartLine (commentSpan c)), hpName = pragmaName p, - hpBody = pragmaBody p + hpBody = pragmaBody p, + hpWritten = + if pragmaCommented p then Just (commentBody c) else Nothing } headerPragma c = do p <- commentPragma c _ <- pragmaOrder (pragmaName p) (pragmaBody p) - if inHeader headerEnd (commentSpan c) then Just p else Nothing + if writtenInHeader headerEnd (commentSpan c) then Just p else Nothing -- | Where a pragma sorts, given its name and its body, or 'Nothing' for one -- the header does not hoist. pragmaOrder :: Text -> Text -> Maybe PragmaOrder pragmaOrder named body = case named of - "LANGUAGE" -> Just (LanguageOrder (classifyExtension body)) + "LANGUAGE" + | namesAnEdition body -> Just EditionOrder + | otherwise -> Just LanguageOrder "OPTIONS_GHC" -> Just OptionsGhcOrder + "OPTIONS" -> Just OptionsGhcOrder "OPTIONS_HADDOCK" -> Just OptionsHaddockOrder _ -> Nothing --- | Was this written above everything the compiler reads as code? -inHeader :: Maybe Span -> Span -> Bool -inHeader headerEnd s = case headerEnd of - Nothing -> True - Just end -> spanStartLine s < spanStartLine end - -- | Take the Stack script header off the front of a comment stream. takeStackHeader :: -- | Where the header ends. @@ -142,45 +130,51 @@ cs -> (mempty, cs) where isStackHeader c = - inHeader headerEnd (commentSpan c) + writtenInHeader headerEnd (commentSpan c) && T.isPrefixOf "stack" (T.stripStart (T.drop 2 (NE.head (commentBody c)))) reproduce c = - sepBy (verbatimBreak AtMargin TrimWhitespace) (fmap txt (NE.toList (commentBody c))) + verbatimLines AtMargin TrimWhitespace (NE.toList (commentBody c)) --- | The pragmas of a header, one per line, sorted, with the options in the --- order they were written, which is the order GHC reads their flags in. +-- | The pragmas of a header, one per line, with the options in the order +-- they were written, which is the order GHC reads their flags in, and every +-- one of them kept, since a flag such as @-fplugin-opt@ counts each time it +-- is given. +-- +-- The pragmas between two directives are sorted unless that would leave other +-- extensions in force, in which case they keep the order they were written in. pragmaBlock :: [HeaderPragma] -> Doc -pragmaBlock = foldMap render . dedupe . sortOn order . concatMap split +pragmaBlock = + foldMap render + . dedupe + . concatMap (sorted . NE.toList) + . NE.groupBy ((==) `on` hpRun) + . concatMap split where - order p = (hpRun p, orderOf p, extension p) - extension p = if hpName p == "LANGUAGE" then hpBody p else "" + sorted run = + let candidate = sortOn order run + in if sameInForce (named candidate) (named run) then candidate else run + named = fmap (\p -> (hpName p, hpBody p)) + order p = (orderOf p, extension p) + extension p + | orderOf p == Just LanguageOrder = hpBody p + | otherwise = "" key p = (hpRun p, orderOf p, hpBody p) orderOf p = pragmaOrder (hpName p) (hpBody p) - dedupe = fmap NE.head . NE.groupBy ((==) `on` key) + dedupe = fmap NE.head . NE.groupBy repeated + repeated a b = hpName a == "LANGUAGE" && key a == key b split p - | hpName p == "LANGUAGE" = + | hpName p == "LANGUAGE", + isNothing (hpWritten p) = [ p{hpBody = body} | body <- languageNames (hpBody p) ] | otherwise = [p] - render p = - located - (hpSpan p) - (txt "{-# " <> txt (hpName p) <> space <> txt (hpBody p) <> txt " #-}") - <> hardBreak - --- | Which group an extension belongs to. -classifyExtension :: Text -> ExtensionClass -classifyExtension t - | namesAnEdition t = Pack - -- @ImplicitPrelude@ and @CUSKs@ are turned off by other extensions, so - -- asking for either of them only takes effect at the end. - | t == "ImplicitPrelude" = Last' - | t == "CUSKs" = Last' - | otherwise = case T.uncons (T.drop 2 t) of - Just (c, _) | "No" `T.isPrefixOf` t, c `elem` ['A' .. 'Z'] -> Disabling - _ -> Enabling + render p = located (hpSpan p) (written p) <> hardBreak + written p = case hpWritten p of + Nothing -> + txt "{-# " <> txt (hpName p) <> space <> txt (hpBody p) <> txt " #-}" + Just ls -> verbatim (T.intercalate "\n" (NE.toList ls)) -- | Does this name a whole edition of the language rather than one -- extension of it? @@ -210,7 +204,7 @@ (null hsmodDecls) ( hardBreak <> declarationsStart - <> declarationLayout (decls ctx Free hsmodDecls) + <> declarationLayout (decls ctx hsmodDecls) ) where declarationLayout = case (hsmodDecls, spansOf hsmodDecls) of @@ -330,7 +324,7 @@ IEGroup NoExtField n str -> haddock ctx (Section n) Open str IEDoc NoExtField str -> haddock ctx Pipe Open str IEDocNamed NoExtField n -> case writtenHaddock ctx here of - Just written -> sepBy (verbatimBreak AtIndent TrimWhitespace) (fmap txt (NE.toList written)) + Just c -> verbatimLines AtIndent TrimWhitespace (NE.toList (commentBody c)) Nothing -> txt (docSectionName n) where plain warning n doc = diff --git a/src/Tilia/Render/Literal.hs b/src/Tilia/Render/Literal.hs --- a/src/Tilia/Render/Literal.hs +++ b/src/Tilia/Render/Literal.hs @@ -5,7 +5,9 @@ -- | String literals. module Tilia.Render.Literal - ( stringLiteral, + ( hsLit, + writtenString, + stringLiteral, ) where @@ -16,10 +18,28 @@ import Data.Text (Text) import Data.Text qualified as T import GHC.Data.FastString (FastString, unpackFS) +import GHC.Hs (GhcPs, HsLit (..)) import GHC.Parser.CharClass (is_space) +import GHC.Types.SourceText (SourceText (..), StringLiteral (..)) import Tilia.Doc.Combinators import Tilia.Render.Layout (Position (..), positioned) +import Tilia.Render.Name (outputable) +-- | A literal, a string one as its author wrote it. +hsLit :: HsLit GhcPs -> Doc +hsLit = \case + HsString (SourceText s) _ -> stringLiteral s + HsStringPrim (SourceText s) _ -> stringLiteral s + HsMultilineString (SourceText s) _ -> stringLiteral s + other -> outputable other + +-- | A string literal as its author wrote it, or the bare text it holds where +-- none was written, as for an unquoted @SCC@ label. +writtenString :: StringLiteral -> Doc +writtenString l = case sl_st l of + SourceText s -> stringLiteral s + NoSourceText -> txt (T.pack (unpackFS (sl_fs l))) + -- | A string literal, from the text the author wrote. stringLiteral :: FastString -> Doc stringLiteral src = case takeApart (T.pack (unpackFS src)) of @@ -33,10 +53,7 @@ where body = case litKind literal of Regular -> variant onOneLine acrossLines - Multiline -> - sepBy - (verbatimBreak AtIndent KeepWhitespace) - (fmap txt (litParts literal)) + Multiline -> verbatimLines AtIndent KeepWhitespace (litParts literal) onOneLine = txt (joinParts (litParts literal)) acrossLines = sepBy breakOrSpace (fmap continued (positioned (litParts literal))) diff --git a/src/Tilia/Render/Pattern.hs b/src/Tilia/Render/Pattern.hs --- a/src/Tilia/Render/Pattern.hs +++ b/src/Tilia/Render/Pattern.hs @@ -22,10 +22,10 @@ import GHC.Hs import GHC.Types.Basic (Arity, Boxity (..), ConTag) import GHC.Types.Name.Reader (RdrName) -import GHC.Types.SrcLoc (GenLocated (..)) import Tilia.Doc.Combinators import Tilia.Render.Context import Tilia.Render.Layout +import Tilia.Render.Literal (hsLit) import Tilia.Render.Name import Tilia.Render.Type import Tilia.Span @@ -37,14 +37,12 @@ -- | A pattern whose outermost bracket closes where it is told to. hsPatClosing :: Ctx -> ClosingIndent -> LPat GhcPs -> Doc -hsPatClosing ctx = hsPatIn ctx NoBrace (Isn't #inAsPat) +hsPatClosing ctx = hsPatIn ctx (Isn't #inAsPat) -- | A pattern that knows where it stands. hsPatIn :: -- | The context. Ctx -> - -- | Bracing an or-pattern inherits. - Bracing -> -- | Is this inside an as-pattern? Choice "inAsPat" -> -- | Where its outermost bracket closes. @@ -52,15 +50,13 @@ -- | The pattern. LPat GhcPs -> Doc -hsPatIn ctx bracing inAsPat closing l = - at ctx l (patBody ctx bracing inAsPat closing (spanOf l)) +hsPatIn ctx inAsPat closing l = + at ctx l (patBody ctx inAsPat closing (spanOf l)) -- | Every shape a pattern can take. patBody :: -- | The context. Ctx -> - -- | Bracing an or-pattern inherits. - Bracing -> -- | Is this inside an as-pattern? Choice "inAsPat" -> -- | Where its outermost bracket closes. @@ -70,12 +66,12 @@ -- | The pattern. Pat GhcPs -> Doc -patBody ctx bracing inAsPat closing here = \case +patBody ctx inAsPat closing here = \case WildPat _ -> txt "_" VarPat _ n -> name ctx n LazyPat _ p -> txt "~" <> recur p AsPat _ n p -> - name ctx n <> txt "@" <> hsPatIn ctx bracing (Is #inAsPat) Indented p + name ctx n <> txt "@" <> hsPatIn ctx (Is #inAsPat) Indented p ParPat _ p -> parensWith closing (insideBrackets here (recur p)) BangPat _ p -> txt "!" <> recur p ListPat _ ps -> @@ -86,16 +82,16 @@ closing (insideBrackets here (commaSep (fmap (align . recur) ps))) OrPat _ ps -> - itemsSepBy (fromBool (isTrue inAsPat)) bracing (fmap recur (NE.toList ps)) + itemsSepBy (fromBool (isTrue inAsPat)) NoBrace (fmap recur (NE.toList ps)) SumPat _ p tag arity -> unboxedSum closing tag arity (recur p) - ConPat _ con details -> conPattern ctx bracing inAsPat here con details + ConPat _ con details -> conPattern ctx inAsPat here con details ViewPat _ e p -> align $ knotExpr (ctxKnot ctx) ctx plainSite e <> joinedBy "->" <> indent (recur p) SplicePat _ splice -> knotSplice (ctxKnot ctx) ctx DollarSplice splice - LitPat _ lit -> outputable lit + LitPat _ lit -> hsLit lit NPat _ v (isJust -> negated) _ -> includeWhen negated (txt "-" <> negativeLiteralGap ctx) <> at ctx v (outputable . ol_val) @@ -109,14 +105,12 @@ EmbTyPat _ (HsTP _ ty) -> txt "type" <> space <> hsType ctx ty InvisPat _ (HsTP _ ty) -> txt "@" <> hsType ctx ty where - recur = hsPatIn ctx bracing inAsPat Indented + recur = hsPatIn ctx inAsPat Indented -- | A constructor pattern, in whichever of its three forms. conPattern :: -- | The context. Ctx -> - -- | Bracing an or-pattern inherits. - Bracing -> -- | Is this inside an as-pattern? Choice "inAsPat" -> -- | Where the pattern was written. @@ -126,7 +120,7 @@ -- | What it was applied to. HsConPatDetails GhcPs -> Doc -conPattern ctx bracing inAsPat here con = \case +conPattern ctx inAsPat here con = \case PrefixCon args -> align $ name ctx con @@ -141,13 +135,12 @@ recur l <> attachOperator Normal (spanOf l) (spanOf con) (spanOf r) (name ctx con) (recur r) where - recur = hsPatIn ctx bracing inAsPat Indented + recur = hsPatIn ctx inAsPat Indented field = either wildcard (at_ ctx (patFieldBind ctx)) wildcard l = at ctx l (const (txt "..")) visibleFields dotdot fields = case dotdot of Nothing -> Right <$> fields - Just l@(L _ (RecFieldsDotDot n)) -> - (Right <$> take n fields) <> [Left l] + Just l -> (Right <$> fields) <> [Left l] -- | One field of a record pattern. patFieldBind :: Ctx -> HsRecField GhcPs (LPat GhcPs) -> Doc diff --git a/src/Tilia/Render/Pragma.hs b/src/Tilia/Render/Pragma.hs --- a/src/Tilia/Render/Pragma.hs +++ b/src/Tilia/Render/Pragma.hs @@ -26,6 +26,7 @@ import GHC.Unit.Module.Warnings import Tilia.Doc.Combinators import Tilia.Render.Context +import Tilia.Render.Literal (writtenString) import Tilia.Render.Name -- | Wrap a body in pragma braces. @@ -121,5 +122,5 @@ -- | One message is written bare; several go in a list. literalList :: [LocatedE StringLiteral] -> Doc literalList = \case - [l] -> outputable l - ls -> brackets (commaSep (fmap outputable ls)) + [l] -> writtenString (unLoc l) + ls -> brackets (commaSep (fmap (writtenString . unLoc) ls)) diff --git a/src/Tilia/Render/Signature.hs b/src/Tilia/Render/Signature.hs --- a/src/Tilia/Render/Signature.hs +++ b/src/Tilia/Render/Signature.hs @@ -23,7 +23,6 @@ InlinePragma (..), InlineSpec (..), RuleMatchInfo (..), - RuleName, ) import GHC.Types.Fixity (Fixity (..), FixityDirection (..)) import GHC.Types.Name.Reader (RdrName) @@ -32,6 +31,7 @@ import Tilia.Doc.Combinators import Tilia.Render.Context import Tilia.Render.Expression (hsExpr) +import Tilia.Render.Literal (writtenString) import Tilia.Render.Name import Tilia.Render.Pragma import Tilia.Render.Type @@ -68,7 +68,7 @@ -- | The type they are given. LHsSigType GhcPs -> Doc -typeSig _ _ [] _ = mempty +typeSig _ _ [] _ = error "Tilia: a signature names something" typeSig ctx indentTail (n : ns) sigType | null ns = name ctx n <> typeAscription ctx sigType | otherwise = @@ -158,8 +158,8 @@ (joinedBy "::" <> commaSep (fmap (hsSigType ctx) types)) ) where - -- A pragma that says neither when to inline nor whether to is saying - -- nothing, so the phase is left off rather than printed as @[~]@. + -- A @NOINLINE@ written without a phase reads as never active, so that + -- phase is left off rather than printed as @[~]@. phase = case (inl_inline, inl_act) of (NoInline _, NeverActive) -> mempty _ -> activation inl_act @@ -223,7 +223,7 @@ sccSig :: Ctx -> LocatedN RdrName -> Maybe (XRec GhcPs StringLiteral) -> Doc sccSig ctx n literal = pragma "SCC" . indent $ - name ctx n <> foldMap (\l -> breakOrSpace <> outputable l) literal + name ctx n <> foldMap (\l -> breakOrSpace <> writtenString (unLoc l)) literal -- | @type T :: k@. standaloneKindSig :: Ctx -> StandaloneKindSig GhcPs -> Doc @@ -250,8 +250,8 @@ -- | One rule of a @RULES@ block. ruleDecl :: Ctx -> RuleDecl GhcPs -> Doc -ruleDecl ctx (HsRule _ ruleName phase binders lhs rhs) = - at ctx ruleName ruleNameLiteral +ruleDecl ctx (HsRule (_, written) ruleName phase binders lhs rhs) = + at ctx ruleName (\n -> writtenString (StringLiteral written n Nothing)) <> space <> activation phase <> space @@ -263,11 +263,6 @@ <> txt "=" <> indent (breakOrSpace <> hsExpr ctx rhs) ) - --- | A rule's name is a string literal, and printing it as one is what puts --- the quotes back. -ruleNameLiteral :: RuleName -> Doc -ruleNameLiteral n = outputable (HsString NoSourceText n :: HsLit GhcPs) -- | The @forall@s a rule or a @SPECIALIZE@ pragma binds. ruleBinders :: Ctx -> RuleBndrs GhcPs -> Doc diff --git a/src/Tilia/Render/Type.hs b/src/Tilia/Render/Type.hs --- a/src/Tilia/Render/Type.hs +++ b/src/Tilia/Render/Type.hs @@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -27,6 +26,7 @@ typeArgument, typeArgSpan, typeIsDocumented, + typeBreak, asSigType, ) where @@ -143,7 +143,7 @@ HsRecTy _ fields -> recordFields ctx Nothing fields where recur = typeBody ctx documented Nothing - betweenArgs = if isTrue documented then hardBreak else breakOrSpace + betweenArgs = typeBreak (isTrue documented) -- | A chain of type operators, regrouped by precedence. typeChain :: Ctx -> LHsType GhcPs -> LocatedN RdrName -> LHsType GhcPs -> Doc @@ -193,8 +193,8 @@ IsPromoted -> txt "'" NotPromoted -> mempty --- | The tick on a promoted name, held off it when the name itself begins --- with one, since @''@ is the spelling of a type-level quote. +-- | The tick on a promoted name, held off it where the name's second +-- character is a tick too, as @'B'@ would read as a character literal. promotion :: PromotionFlag -> LocatedN RdrName -> Doc promotion NotPromoted _ = mempty promotion IsPromoted n = @@ -234,6 +234,11 @@ SrcStrict -> txt "!" NoSrcStrict -> mempty +-- | The break between the parts of a type, a hard one where the type +-- carries documentation, which ends its line. +typeBreak :: Bool -> Doc +typeBreak documented = if documented then hardBreak else breakOrSpace + -- | Does any argument of this type carry documentation? typeIsDocumented :: HsType GhcPs -> Bool typeIsDocumented = any documented . spine @@ -269,11 +274,9 @@ _ -> t -- | A context standing to the left of a @=>@, with the arrow and the break --- after it, or nothing where the context is empty. +-- after it. leftContext :: Ctx -> LHsContext GhcPs -> Doc -leftContext ctx ctxt - | null (unLoc ctxt) = mempty - | otherwise = context ctx ctxt <> joinedBy "=>" +leftContext ctx ctxt = context ctx ctxt <> joinedBy "=>" -- | A context over anything that can stand as a constraint. contextOf :: @@ -390,18 +393,14 @@ hsSigTypeBody ctx HsSig{..} = outerBndrs ctx afterBinders sig_bndrs <> hsType ctx sig_body where - afterBinders - | typeIsDocumented (unLoc sig_body) = hardBreak - | otherwise = breakOrSpace + afterBinders = typeBreak (typeIsDocumented (unLoc sig_body)) -- | The @:: t@ that follows a name. typeAscription :: Ctx -> LHsSigType GhcPs -> Doc typeAscription ctx sigType = indent (space <> txt "::" <> separator <> hsSigType ctx sigType) where - separator - | typeIsDocumented (unLoc (sig_body (unLoc sigType))) = hardBreak - | otherwise = breakOrSpace + separator = typeBreak (typeIsDocumented (unLoc (sig_body (unLoc sigType)))) -- | Give a plain type the shape of a signature type. asSigType :: LHsType GhcPs -> LHsSigType GhcPs diff --git a/src/Tilia/Run.hs b/src/Tilia/Run.hs --- a/src/Tilia/Run.hs +++ b/src/Tilia/Run.hs @@ -25,16 +25,16 @@ ) where +import Control.Exception (evaluate) import Data.ByteString qualified as BS import Data.List (sortOn) import Data.Map.Strict qualified as Map import Data.Text (Text) import Data.Text qualified as T -import Data.Text.Encoding qualified as T import System.FilePath (takeExtension) import Tilia.Diff (diffInFull) import Tilia.Format - ( FormatError (Unreadable), + ( FormatError (Threw, Unreadable), Session, describeFormatError, formatErrorExitCode, @@ -49,8 +49,9 @@ byteOrderMark, inParallel, indent, - lineWidth, - wrapTo, + tshow, + wrappedUnder, + writeUtf8File, ) ---------------------------------------------------------------------------- @@ -107,7 +108,7 @@ runOver session = inParallel one where one path = do - !outcome <- + outcome <- readAsUtf8 path >>= \case Left why -> pure (Failed (Unreadable path why)) Right before -> outcomeOf session path before @@ -123,10 +124,13 @@ Text -> IO Outcome outcomeOf session path before = - formatSource session path (setNewlineStyle Lf source) >>= \case - Left e -> pure (if refused e then Declined e else Failed e) - Right formatted -> pure (formattingOutcome before (mark <> formatted)) + either (Failed . Threw path) id + <$> attempted (evaluate . outcome =<< formatted) where + formatted = formatSource session path (setNewlineStyle Lf source) + outcome = \case + Left e -> if refused e then Declined e else Failed e + Right it -> formattingOutcome before (mark <> it) (mark, source) = byteOrderMark before -- | Read a source file as UTF-8. @@ -152,7 +156,7 @@ -- | Put a formatted file back, and only if it changed. writeBack :: (FilePath, Outcome) -> IO () writeBack (path, outcome) = case outcome of - Changed _ after -> BS.writeFile path (T.encodeUtf8 after) + Changed _ after -> writeUtf8File path after _ -> pure () ---------------------------------------------------------------------------- @@ -274,17 +278,14 @@ -- | Render the number of files. count :: Palette -> Int -> Text -> Text count palette n extension = - T.pack (show n) + tshow n <> " " <> paint palette Place extension <> (if n == 1 then " file" else " files") -- | One case among several, opened by a bullet and wrapped underneath it. bulleted :: Palette -> FormatError -> [Text] -bulleted palette e = case wrapTo (lineWidth - 6) (describeFormatError palette e) of - [] -> [] - (opening : rest) -> - (indent 2 <> "· " <> opening) : fmap (indent 3 <>) rest +bulleted palette e = wrappedUnder 3 (indent 2 <> "· ") (describeFormatError palette e) -- | Something to say under a mark of its own, wrapped to fit beneath it. noted :: @@ -293,8 +294,5 @@ (Text, Color) -> Text -> [Text] -noted palette (mark, color) text = case wrapTo (lineWidth - 6) text of - [] -> [] - (opening : rest) -> - (indent 1 <> marker palette color mark <> " " <> opening) - : fmap (indent 3 <>) rest +noted palette (mark, color) = + wrappedUnder 3 (indent 1 <> marker palette color mark <> " ") diff --git a/src/Tilia/Source.hs b/src/Tilia/Source.hs --- a/src/Tilia/Source.hs +++ b/src/Tilia/Source.hs @@ -14,6 +14,8 @@ sourceLines, lineAt, blankAt, + blankAcross, + offsetOf, directivePresentOnLine, directiveOnLine, diff --git a/src/Tilia/Source/Lines.hs b/src/Tilia/Source/Lines.hs --- a/src/Tilia/Source/Lines.hs +++ b/src/Tilia/Source/Lines.hs @@ -11,6 +11,10 @@ lineTexts, lineAt, blankAt, + blankAcross, + offsetOf, + columnOf, + contentColumn, directivePresentOnLine, directiveOnLine, conditionalKeywords, @@ -77,6 +81,39 @@ -- | Was this line empty? blankAt :: Int -> Lines -> Bool blankAt n = maybe False (T.all isSpace) . lineAt n + +-- | Were all the lines from one to another, both included, empty? +blankAcross :: (Int, Int) -> Lines -> Bool +blankAcross (from, to) ls = all (`blankAt` ls) [from .. to] + +-- | How many characters of a line come before the compiler's column. +-- +-- A column is not a character offset. The lexer counts a tab as advancing to +-- the next multiple of eight, so a line with a tab in it has more columns +-- than it has characters, and cutting the text at a column would cut in the +-- wrong place. In a file indented with tabs that is every line. +offsetOf :: Text -> Int -> Int +offsetOf line column = T.length (T.take (walk 0 1) line) + where + walk i c + | c >= column = i + | i >= T.length line = i + (column - c) + | otherwise = walk (i + 1) (afterChar (T.index line i) c) + +-- | The compiler's column for the character at this offset. +columnOf :: Text -> Int -> Int +columnOf line offset = T.foldl' (flip afterChar) 1 (T.take offset line) + +-- | The compiler's column for the first character of a line that is not +-- white space. +contentColumn :: Text -> Int +contentColumn l = columnOf l (T.length (T.takeWhile isSpace l)) + +-- | Where the column moves to once this character has been read. +afterChar :: Char -> Int -> Int +afterChar ch c + | ch == '\t' = ((c - 1) `div` 8 + 1) * 8 + 1 + | otherwise = c + 1 -- | Does this line hold a preprocessor directive? directivePresentOnLine :: Int -> Lines -> Bool diff --git a/src/Tilia/Span.hs b/src/Tilia/Span.hs --- a/src/Tilia/Span.hs +++ b/src/Tilia/Span.hs @@ -4,7 +4,6 @@ mkSpan, isSingleLine, sameLine, - blankBetween, meets, covers, zeroWidth, @@ -52,11 +51,6 @@ sameLine :: Maybe Span -> Maybe Span -> Bool sameLine (Just a) (Just b) = spanEndLine a == spanStartLine b sameLine _ _ = False - --- | Was there an empty line between the two? -blankBetween :: Maybe Span -> Maybe Span -> Bool -blankBetween (Just a) (Just b) = spanStartLine b > spanEndLine a + 1 -blankBetween _ _ = False -- | Do the two cover any of the same input? -- diff --git a/src/Tilia/Span/Ghc.hs b/src/Tilia/Span/Ghc.hs --- a/src/Tilia/Span/Ghc.hs +++ b/src/Tilia/Span/Ghc.hs @@ -7,12 +7,15 @@ spanOf, spansOf, bracketsSpan, + inSourceOrder, ) where +import Data.Function (on) +import Data.List (sortBy) import Data.Maybe (mapMaybe) import GHC.Parser.Annotation (AnnListBrackets (..), HasLoc, getHasLoc) -import GHC.Types.SrcLoc (GenLocated) +import GHC.Types.SrcLoc (GenLocated, getLoc, leftmost_smallest) import GHC.Types.SrcLoc qualified as GHC import Tilia.Span (Span, mkSpan) @@ -40,6 +43,11 @@ ListBraces open close -> spanOf open <> spanOf close ListSquare open close -> spanOf open <> spanOf close _ -> Nothing + +-- | Merge several lists of located things back into the order they were +-- written in. +inSourceOrder :: (HasLoc l) => [[GenLocated l a]] -> [GenLocated l a] +inSourceOrder = sortBy (leftmost_smallest `on` (getHasLoc . getLoc)) . concat -- | The span covering every located thing in the list. spansOf :: (HasLoc l) => [GenLocated l a] -> Maybe Span diff --git a/src/Tilia/Utils.hs b/src/Tilia/Utils.hs --- a/src/Tilia/Utils.hs +++ b/src/Tilia/Utils.hs @@ -1,19 +1,25 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -- | Miscellaneous utilities. module Tilia.Utils ( quietly, attempted, - readFileText, + readUtf8File, + writeUtf8File, fieldWords, + blocksOf, + indented, + looksLikeModule, + pathUnder, asUtf8, byteOrderMark, sha256Of, + sha256OfFile, lineWidth, indent, wrapTo, + wrappedUnder, visibleLength, spellList, collected, @@ -23,17 +29,26 @@ where import Control.Concurrent - ( forkIO, + ( forkFinally, getNumCapabilities, newEmptyMVar, putMVar, takeMVar, ) -import Control.Exception (SomeException, displayException, try) -import Control.Monad (replicateM) +import Control.Exception + ( SomeAsyncException, + SomeException, + catch, + displayException, + fromException, + throwIO, + ) +import Control.Monad (replicateM, (>=>)) import Crypto.Hash.SHA256 qualified as SHA256 import Data.ByteString qualified as BS import Data.ByteString.Base16 qualified as B16 +import Data.ByteString.Lazy qualified as BL +import Data.Char (isSpace) import Data.Foldable (for_, traverse_) import Data.IORef (atomicModifyIORef', newIORef, readIORef) import Data.Map.Strict qualified as Map @@ -41,38 +56,81 @@ import Data.Text qualified as T import Data.Text.Encoding qualified as T import System.Directory (doesFileExist) +import System.FilePath (equalFilePath, normalise, splitDirectories) -- | 'show' a value and take the result as 'Text'. tshow :: (Show a) => a -> Text tshow = T.pack . show --- | Run an action, falling back on the given value if it throws. +-- | Run an action, falling back on the given value if it throws, but for +-- an asynchronous exception, which asks it to stop. quietly :: a -> IO a -> IO a quietly fallback action = - try action >>= \case - Left (_ :: SomeException) -> pure fallback - Right a -> pure a + action `catch` \e -> if asynchronous e then throwIO e else pure fallback --- | Read a file, if it is there and is text. -readFileText :: FilePath -> IO (Maybe Text) -readFileText path = quietly Nothing $ do +-- | Read a file as UTF-8, leniently, if it is there and can be read. +readUtf8File :: FilePath -> IO (Maybe Text) +readUtf8File path = quietly Nothing $ do there <- doesFileExist path if there then Just . T.decodeUtf8Lenient <$> BS.readFile path else pure Nothing +-- | Write a file as UTF-8. +writeUtf8File :: FilePath -> Text -> IO () +writeUtf8File path = BS.writeFile path . T.encodeUtf8 + -- | The words of a field's value, which whitespace and commas separate. fieldWords :: Text -> [Text] fieldWords = filter (not . T.null) . concatMap (T.split (== ',')) . T.words +-- | Group lines into blocks, each a line at the margin with the indented +-- lines under it, dropping indented lines before the first. +blocksOf :: [Text] -> [(Text, [Text])] +blocksOf = \case + [] -> [] + l : ls + | indented l -> blocksOf ls + | otherwise -> + let (under, rest) = span indented ls + in (l, under) : blocksOf rest + +-- | Does a line begin with white space? +indented :: Text -> Bool +indented = maybe False (isSpace . fst) . T.uncons + +-- | A path's segments under a directory, if it is at or under it. +pathUnder :: FilePath -> FilePath -> Maybe [FilePath] +pathUnder directory path = + go (splitDirectories directory) (splitDirectories (normalise path)) + where + go [] fs = Just fs + go (d : ds) (f : fs) | equalFilePath d f = go ds fs + go _ _ = Nothing + +-- | Could a word name a module: does it begin with a capital letter and +-- hold no colon? +looksLikeModule :: Text -> Bool +looksLikeModule m = case T.uncons m of + Just (c, _) -> c `elem` ['A' .. 'Z'] && not (T.any (== ':') m) + Nothing -> False + -- | Run an action and return its result or the exception it threw rendered --- as 'Text'. +-- as 'Text', but for an asynchronous exception, which asks it to stop. attempted :: IO a -> IO (Either Text a) attempted action = - try action >>= \case - Left (e :: SomeException) -> pure (Left (T.pack (displayException e))) - Right a -> pure (Right a) + (Right <$> action) `catch` \e -> + if asynchronous e + then throwIO e + else pure (Left (T.pack (displayException e))) +-- | Does an exception ask what it interrupts to stop, as an interrupt or a +-- cancellation does? +asynchronous :: SomeException -> Bool +asynchronous e = case fromException e of + Just (_ :: SomeAsyncException) -> True + Nothing -> False + -- | Decode source as UTF-8. asUtf8 :: BS.ByteString -> Either Text Text asUtf8 bytes = case T.decodeUtf8' bytes of @@ -86,8 +144,16 @@ -- | The SHA-256 of a text's UTF-8 encoding, in hexadecimal. sha256Of :: Text -> Text -sha256Of = T.decodeUtf8Lenient . B16.encode . SHA256.hash . T.encodeUtf8 +sha256Of = hex . SHA256.hash . T.encodeUtf8 +-- | The SHA-256 of a file, in hexadecimal. +sha256OfFile :: FilePath -> IO Text +sha256OfFile = fmap (hex . SHA256.hashlazy) . BL.readFile + +-- | Bytes as lower-case hexadecimal. +hex :: BS.ByteString -> Text +hex = T.decodeUtf8Lenient . B16.encode + -- | The line width for the terminal output of this program. lineWidth :: Int lineWidth = 76 @@ -96,6 +162,14 @@ indent :: Int -> Text indent level = T.replicate (2 * level) " " +-- | Text wrapped under an opening as wide as the given level of indentation: +-- the opening begins the first line and the rest are indented to that +-- level. +wrappedUnder :: Int -> Text -> Text -> [Text] +wrappedUnder level opening text = case wrapTo (lineWidth - 2 * level) text of + [] -> [] + first : rest -> (opening <> first) : fmap (indent level <>) rest + -- | Break text into lines that fit the room given, at spaces. wrapTo :: Int -> Text -> [Text] wrapTo room = concatMap (go . T.words) . T.lines @@ -135,7 +209,8 @@ (before, (_, vs) : after) -> before <> [(k, vs <> [v])] <> after _ -> seen <> [(k, [v])] --- | Run an action over every element at once, as far as the machine allows. +-- | Run an action over every element at once, as far as the machine allows, +-- passing on an exception it throws. inParallel :: (a -> IO b) -> [a] -> IO [b] inParallel act xs = do capabilities <- getNumCapabilities @@ -152,6 +227,6 @@ atomicModifyIORef' answers (\m -> (Map.insert i y m, ())) worker done <- replicateM (max 1 (min capabilities (length xs))) newEmptyMVar - for_ done $ \signal -> forkIO (worker >> putMVar signal ()) - traverse_ takeMVar done + for_ done $ \signal -> forkFinally worker (putMVar signal) + traverse_ (takeMVar >=> either throwIO pure) done Map.elems <$> readIORef answers diff --git a/tests/Tilia/Cabal/PackageSpec.hs b/tests/Tilia/Cabal/PackageSpec.hs --- a/tests/Tilia/Cabal/PackageSpec.hs +++ b/tests/Tilia/Cabal/PackageSpec.hs @@ -4,20 +4,34 @@ -- | Information obtained from @.cabal@ files. module Tilia.Cabal.PackageSpec (spec) where +import Data.Either (isRight) +import Data.Foldable (for_) import Data.List (isSuffixOf, sort) import Data.Text (Text) import Data.Text qualified as T -import Data.Text.IO qualified as T import GHC.LanguageExtensions.Type (Extension (..)) import System.Directory (createDirectoryIfMissing, removeFile) import System.FilePath (()) import System.IO.Temp (withSystemTempDirectory) import Test.Hspec -import Tilia.Cabal.Package (PackageProblem (..), newPackageReader) +import Tilia.Cabal.Package + ( PackageProblem (..), + newPackageReader, + parsePackageDescription, + ) import Tilia.Cabal.Plan (BuildPlan (..), plannedCompiler) +import Tilia.Pragma (Defaults, effectiveExtensions) +import Tilia.TestUtils (withFiles) +import Tilia.Utils (writeUtf8File) spec :: Spec spec = do + describe "a .cabal file" $ + it "parses whatever version of the format it declares, up to the newest" $ + for_ ["2.4", "3.0", "3.4", "3.8", "3.12", "3.14", "3.16", "3.18"] $ \v -> + let held = "cabal-version: " <> v <> "\nname: t\nversion: 0\nlibrary\n" + in parsePackageDescription "t.cabal" held `shouldSatisfy` isRight + describe "the component a file belongs to" $ do it "is the one whose source directory holds it" $ inPackage twoComponents ["src", "test"] $ \root -> do @@ -83,7 +97,8 @@ it "are the language edition's" $ inPackage twoComponents ["src"] $ \root -> do library <- asked (root "src" "M.hs") - (length <$> library) `shouldSatisfy` either (const False) (> 40) + (length . (`effectiveExtensions` "") <$> library) + `shouldSatisfy` either (const False) (> 40) it "are Haskell98's where it names no edition, as cabal builds it" $ inPackage namesNoEdition ["src"] $ \root -> do @@ -115,7 +130,7 @@ it "take the compiler's version from the plan where it names one" $ inPackage conditionalExtensions ["src"] $ \root -> do - ask <- newPackageReader (plannedCompiler (BuildPlan "ghc-8.4.4" [])) + ask <- newPackageReader (plannedCompiler (BuildPlan "ghc-8.4.4" [])) [] library <- ask (root "src" "M.hs") (has StarIsType library, has BangPatterns library) `shouldBe` (True, True) @@ -139,24 +154,58 @@ complaints `shouldSatisfy` not . null other -> expectationFailure ("expected a parse failure, got " <> show other) + describe "a module no package above it claims" $ do + it "is claimed by a package of the project that names it" + $ withFiles + [ ("one/one.cabal", reachingOut "../common"), + ("common/Common.hs", "module Common where\n") + ] + $ \root -> do + ask <- newPackageReader Nothing [root "one" "one.cabal"] + (has LambdaCase <$> ask (root "common" "Common.hs")) + `shouldReturn` True + + it "is claimed so where the package above it does not name it" + $ withFiles + [ ("one/one.cabal", reachingOut "../two/shared"), + ("two/two.cabal", twoComponents), + ("two/shared/Common.hs", "module Common where\n") + ] + $ \root -> do + ask <- + newPackageReader + Nothing + [root "one" "one.cabal", root "two" "two.cabal"] + (has LambdaCase <$> ask (root "two" "shared" "Common.hs")) + `shouldReturn` True + + it "is still unclaimed where no package of the project names it" + $ withFiles + [ ("one/one.cabal", reachingOut "../common"), + ("other/Other.hs", "module Other where\n") + ] + $ \root -> do + ask <- newPackageReader Nothing [root "one" "one.cabal"] + ask (root "other" "Other.hs") `shouldReturn` Left NoPackageFile + describe "a reader kept between files" $ do it "answers as a fresh one would" $ inPackage twoComponents ["src", "test"] $ \root -> do - ask <- newPackageReader Nothing + ask <- newPackageReader Nothing [] kept <- traverse ask (modules root) fresh <- traverse asked (modules root) kept `shouldBe` fresh it "reads a package once, not once per file" $ inPackage twoComponents ["src"] $ \root -> do - ask <- newPackageReader Nothing + ask <- newPackageReader Nothing [] first <- ask (root "src" "A.hs") removeFile (root "demo.cabal") ask (root "src" "B.hs") `shouldReturn` first it "remembers every directory the walk went through" $ inPackage twoComponents ["src" "deep"] $ \root -> do - ask <- newPackageReader Nothing + ask <- newPackageReader Nothing [] deep <- ask (root "src" "deep" "A.hs") removeFile (root "demo.cabal") ask (root "src" "B.hs") `shouldReturn` deep @@ -343,6 +392,21 @@ " default-extensions: BangPatterns" ] +-- | A library with @LambdaCase@ on that declares @Common@, which is in the +-- source directory given, outside the package. +reachingOut :: Text -> Text +reachingOut shared = + T.unlines + [ "cabal-version: 2.4", + "name: reaching", + "version: 0", + "library", + " exposed-modules: Common", + " hs-source-dirs: src " <> shared, + " default-language: Haskell2010", + " default-extensions: LambdaCase" + ] + conditionalLibrary :: Text conditionalLibrary = T.unlines @@ -362,28 +426,28 @@ inPackage :: Text -> [FilePath] -> (FilePath -> IO a) -> IO a inPackage contents dirs use = withSystemTempDirectory "tilia-package" $ \root -> do - T.writeFile (root "demo.cabal") contents + writeUtf8File (root "demo.cabal") contents mapM_ (createDirectoryIfMissing True . (root )) (sort dirs) use root -- | Ask about one file with a reader of its own, which is what a test that -- is not about caching wants. -asked :: FilePath -> IO (Either PackageProblem [Extension]) +asked :: FilePath -> IO (Either PackageProblem Defaults) asked path = do - ask <- newPackageReader Nothing + ask <- newPackageReader Nothing [] ask path -- | One module in each of the two components. modules :: FilePath -> [FilePath] modules root = [root "src" "M.hs", root "test" "S.hs"] -unreadableOrMissing :: Either PackageProblem [Extension] -> Bool +unreadableOrMissing :: Either PackageProblem Defaults -> Bool unreadableOrMissing = either (const True) (const False) -has :: Extension -> Either PackageProblem [Extension] -> Bool -has e = either (const False) (e `elem`) +has :: Extension -> Either PackageProblem Defaults -> Bool +has e = either (const False) ((e `elem`) . (`effectiveExtensions` "")) -unclaimed :: Either PackageProblem [Extension] -> Bool +unclaimed :: Either PackageProblem Defaults -> Bool unclaimed = either isFileUnclaimed (const False) where isFileUnclaimed = \case diff --git a/tests/Tilia/Cabal/ProjectSpec.hs b/tests/Tilia/Cabal/ProjectSpec.hs --- a/tests/Tilia/Cabal/ProjectSpec.hs +++ b/tests/Tilia/Cabal/ProjectSpec.hs @@ -3,11 +3,10 @@ -- | Finding the project a file belongs to. module Tilia.Cabal.ProjectSpec (spec) where -import System.Directory (createDirectoryIfMissing) import System.FilePath (()) -import System.IO.Temp (withSystemTempDirectory) import Test.Hspec import Tilia.Cabal.Project +import Tilia.TestUtils (withFiles) spec :: Spec spec = do @@ -33,28 +32,28 @@ describe "marker precedence" $ do it "prefers cabal.project to a bare .cabal file" $ - withTree [("cabal.project", ""), ("thing.cabal", "")] $ \dir -> do + withFiles [("cabal.project", ""), ("thing.cabal", "")] $ \dir -> do root <- findProjectRoot dir (prMarker <$> root) `shouldBe` Just ProjectFile it "accepts a bare .cabal file when there is no project" $ - withTree [("thing.cabal", "")] $ \dir -> do + withFiles [("thing.cabal", "")] $ \dir -> do root <- findProjectRoot dir (prMarker <$> root) `shouldBe` Just (PackageFile "thing.cabal") it "passes over a stack.yaml, which cabal does not read" $ - withTree [("stack.yaml", ""), ("thing.cabal", "")] $ \dir -> do + withFiles [("stack.yaml", ""), ("thing.cabal", "")] $ \dir -> do root <- findProjectRoot dir (prMarker <$> root) `shouldBe` Just (PackageFile "thing.cabal") it "climbs out of a stack project to the package it is asked about" $ - withTree [("stack.yaml", ""), ("packages/inner/inner.cabal", "")] $ + withFiles [("stack.yaml", ""), ("packages/inner/inner.cabal", "")] $ \dir -> do root <- findProjectRoot (dir "packages" "inner") prPath <$> root `shouldBe` Just (dir "packages" "inner") it "climbs past a package to the project that contains it" - $ withTree + $ withFiles [ ("cabal.project", ""), ("packages/inner/placeholder", "") ] @@ -63,7 +62,7 @@ (prMarker <$> root) `shouldBe` Just ProjectFile it "climbs past a package that has its own .cabal" - $ withTree + $ withFiles [ ("cabal.project", ""), ("packages/inner/inner.cabal", "") ] @@ -73,7 +72,7 @@ (prMarker <$> root) `shouldBe` Just ProjectFile it "takes the nearest project of the ones above" - $ withTree + $ withFiles [ ("cabal.project", ""), ("packages/inner/cabal.project", ""), ("packages/inner/inner.cabal", "") @@ -83,7 +82,7 @@ prPath <$> root `shouldBe` Just (dir "packages" "inner") it "takes the nearest package when no project is above either" - $ withTree + $ withFiles [ ("outer.cabal", ""), ("packages/inner/inner.cabal", "") ] @@ -92,7 +91,7 @@ (prMarker <$> root) `shouldBe` Just (PackageFile "inner.cabal") it "climbs to a project past a package that is not the one asked about" - $ withTree + $ withFiles [ ("cabal.project", ""), ("outer.cabal", ""), ("packages/inner/inner.cabal", "") @@ -103,22 +102,9 @@ describe "no project" $ it "gives up rather than guessing" $ - withTree [("lonely/Thing.hs", "module Thing where")] $ \dir -> do + withFiles [("lonely/Thing.hs", "module Thing where")] $ \dir -> do root <- findProjectRoot (dir "lonely") case root of Nothing -> pure () Just found -> prPath found `shouldNotBe` (dir "lonely") - --- | Build a throwaway tree of files and run an action on its root. -withTree :: [(FilePath, String)] -> (FilePath -> IO a) -> IO a -withTree files action = - withSystemTempDirectory "tilia-project" $ \dir -> do - mapM_ (create dir) files - action dir - where - create dir (path, contents) = do - let full = dir path - createDirectoryIfMissing True (parentOf full) - writeFile full contents - parentOf = reverse . drop 1 . dropWhile (/= '/') . reverse diff --git a/tests/Tilia/Cabal/TargetSpec.hs b/tests/Tilia/Cabal/TargetSpec.hs --- a/tests/Tilia/Cabal/TargetSpec.hs +++ b/tests/Tilia/Cabal/TargetSpec.hs @@ -7,13 +7,13 @@ import Data.List (isSuffixOf, sort) import Data.Text (Text) import Data.Text qualified as T -import Data.Text.IO qualified as T -import System.Directory (createDirectoryIfMissing) import System.FilePath (takeFileName, ()) -import System.IO.Temp (withSystemTempDirectory) import Test.Hspec +import Tilia.Cabal.Plan (PlanComponent (..)) import Tilia.Cabal.Project (Marker (..), ProjectRoot (..), findProjectRoot) import Tilia.Cabal.Target +import Tilia.TestUtils (withFiles) +import Tilia.Utils (writeUtf8File) spec :: Spec spec = do @@ -129,6 +129,44 @@ Left problem -> expectationFailure (T.unpack (describeTargetProblem problem)) Right cs -> sort (fmap componentPackage cs) `shouldBe` ["one", "two"] + it "reads a package an entry goes up to" + $ withProject + [ ("proj/cabal.project", "packages: ../lib\n"), + ("lib/lib.cabal", packageWith "lib" ["src"] ["L"]), + ("lib/src/L.hs", "module L where\n") + ] + $ \root -> do + let project = ProjectRoot (prPath root "proj") ProjectFile + componentsOfTarget project Everything >>= \case + Left problem -> expectationFailure (T.unpack (describeTargetProblem problem)) + Right cs -> do + files <- filesOfComponents project cs + fmap takeFileName files `shouldBe` ["L.hs"] + + it "reads a package an absolute entry names" + $ withProject + [ ("proj/cabal.project", ""), + ("lib/lib.cabal", package "lib" "src") + ] + $ \root -> do + writeUtf8File + (prPath root "proj" "cabal.project") + ("packages: " <> T.pack (prPath root "lib") <> "\n") + componentsOfTarget (ProjectRoot (prPath root "proj") ProjectFile) Everything + >>= \case + Left problem -> expectationFailure (T.unpack (describeTargetProblem problem)) + Right cs -> fmap componentPackage cs `shouldBe` ["lib"] + + it "reads a package in a directory whose name begins with a dot" + $ withProject + [ ("cabal.project", "packages: .hidden\n"), + (".hidden/hidden.cabal", package "hidden" "src") + ] + $ \root -> + componentsOfTarget root Everything >>= \case + Left problem -> expectationFailure (T.unpack (describeTargetProblem problem)) + Right cs -> fmap componentPackage cs `shouldBe` ["hidden"] + it "expands a glob in the packages field" $ withProject [ ("cabal.project", "packages: pkgs/*/*.cabal\n"), @@ -236,6 +274,25 @@ length cs `shouldBe` 2 fmap takeFileName files `shouldBe` ["One.hs", "Shared.hs", "Two.hs"] + it "names a file once when two packages reach its directory differently" + $ withProject + [ ("cabal.project", "packages: one two\n"), + ("one/one.cabal", packageWith "one" ["src", "shared"] ["A", "Common"]), + ("one/src/A.hs", "module A where\n"), + ("one/shared/Common.hs", "module Common where\n"), + ("two/two.cabal", packageWith "two" ["src", "../one/shared"] ["B", "Common"]), + ("two/src/B.hs", "module B where\n") + ] + $ \root -> + componentsOfTarget root Everything >>= \case + Left problem -> expectationFailure (T.unpack (describeTargetProblem problem)) + Right cs -> do + files <- filesOfComponents root cs + files + `shouldBe` fmap + (prPath root ) + ["one/shared/Common.hs", "one/src/A.hs", "two/src/B.hs"] + it "leaves out files no component declares" $ withProject [ ("only.cabal", packageWith "only" ["."] ["A"]), @@ -388,6 +445,14 @@ filesFor (Called "only") `shouldReturn` ["Setup.hs", "A.hs"] filesFor (Qualified Nothing Lib "only") `shouldReturn` ["A.hs"] + it "names each library the way a plan does" $ + withProject [("both.cabal", withSubLibrary)] $ \root -> + componentsOfTarget root Everything >>= \case + Left problem -> expectationFailure (T.unpack (describeTargetProblem problem)) + Right cs -> + fmap (fmap pcName . componentInPlan) cs + `shouldBe` [Just "lib", Just "lib:inner"] + it "does not offer the setup script as a target" $ withProject [ ("only.cabal", packageWith "only" ["src"] ["A"]), @@ -465,14 +530,8 @@ -- | Lay out a project in a temporary directory and hand over its root. withProject :: [(FilePath, Text)] -> (ProjectRoot -> IO a) -> IO a withProject files act = - withSystemTempDirectory "tilia-target" $ \directory -> do - mapM_ (place directory) files - act (ProjectRoot directory (marker files)) + withFiles files $ \directory -> act (ProjectRoot directory (marker files)) where - place directory (path, contents) = do - createDirectoryIfMissing True (directory parent path) - T.writeFile (directory path) contents - parent = reverse . drop 1 . dropWhile (/= '/') . reverse marker fs | any ((== "cabal.project") . fst) fs = ProjectFile | (named : _) <- [p | (p, _) <- fs, ".cabal" `isSuffixOf` p] = PackageFile named @@ -496,6 +555,23 @@ " main-is: Two.hs", " hs-source-dirs: app", " other-modules: Shared", + " default-language: Haskell2010" + ] + +-- | A package with a main library and a sub-library. +withSubLibrary :: Text +withSubLibrary = + T.unlines + [ "cabal-version: 3.0", + "name: both", + "version: 0.1.0.0", + "", + "library", + " hs-source-dirs: src", + " default-language: Haskell2010", + "", + "library inner", + " hs-source-dirs: inner", " default-language: Haskell2010" ] diff --git a/tests/Tilia/CommentsSpec.hs b/tests/Tilia/CommentsSpec.hs --- a/tests/Tilia/CommentsSpec.hs +++ b/tests/Tilia/CommentsSpec.hs @@ -118,18 +118,26 @@ describe "pragmas" $ do it "recognises one" $ (commentPragma <$> commentsIn "{-# LANGUAGE CPP #-}\nmodule M where\nx = 1\n") - `shouldBe` [Just (Pragma "LANGUAGE" "CPP")] + `shouldBe` [Just (Pragma "LANGUAGE" "CPP" False)] + it "reads a language pragma past the comments in it, as GHC does" $ + (commentPragma <$> commentsIn "{-# LANGUAGE\n CPP -- for the version\n , {- c -} LambdaCase\n #-}\nmodule M where\n") + `shouldBe` [Just (Pragma "LANGUAGE" "CPP , LambdaCase" True)] + it "leaves a comment's dashes in an options pragma, which GHC reads" $ + (fmap pragmaBody . commentPragma <$> commentsIn "{-# OPTIONS_GHC -Wall -- no #-}\nmodule M where\n") + `shouldBe` [Just "-Wall -- no"] it "upper-cases the name" $ (fmap pragmaName . commentPragma <$> commentsIn "{-# language CPP #-}\nmodule M where\nx = 1\n") `shouldBe` [Just "LANGUAGE"] it "is not fooled by an ordinary block comment" $ (commentPragma <$> commentsIn "module M where\n{- not a pragma -}\nx = 1\n") `shouldBe` [Nothing] - it "reports the header boundary" $ + it "reports the header boundary at the module line" $ headerLine "{-# LANGUAGE CPP #-}\nmodule M where\nimport Data.List\nx = 1\n" - `shouldBe` Just 3 - it "reports no boundary for a module with only a header" $ - headerLine "{-# LANGUAGE CPP #-}\nmodule M where\n" `shouldBe` Nothing + `shouldBe` Just 2 + it "reports it where a module without a module line begins" $ + headerLine "{-# LANGUAGE CPP #-}\nimport Data.List\nx = 1\n" `shouldBe` Just 2 + it "reports no boundary for a module of pragmas alone" $ + headerLine "{-# LANGUAGE CPP #-}\n" `shouldBe` Nothing describe "what is deliberately not normalized" $ do it "keeps blank lines inside a comment" $ diff --git a/tests/Tilia/Corpus.hs b/tests/Tilia/Corpus.hs --- a/tests/Tilia/Corpus.hs +++ b/tests/Tilia/Corpus.hs @@ -1,7 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -- | Corpora of Haskell to run the formatter over. module Tilia.Corpus @@ -33,7 +32,6 @@ import Data.Set qualified as Set import Data.Text (Text) import Data.Text qualified as T -import GHC.LanguageExtensions.Type (Extension) import Network.HTTP.Client qualified as HTTP import Network.HTTP.Req import System.Directory @@ -42,7 +40,6 @@ doesDirectoryExist, doesFileExist, getXdgDirectory, - listDirectory, removePathForcibly, renameDirectory, renameFile, @@ -50,6 +47,8 @@ import System.Environment (lookupEnv) import System.FilePath (splitDirectories, takeDirectory, ()) import Tilia.Cabal.Package (newPackageReader, sourceExtensions) +import Tilia.Pragma (Defaults) +import Tilia.TestUtils (haskellFilesIn) import Tilia.Utils (quietly) ---------------------------------------------------------------------------- @@ -89,6 +88,9 @@ -- A name with no extension stands for a directory and takes everything -- under it. expectSkip :: [FilePath], + -- | Examples GHC's own parser cannot read, run all the same to check + -- that it still cannot. + expectUnreadable :: [FilePath], -- | Examples the formatter is supposed to refuse. expectDeclined :: [FilePath] } @@ -121,6 +123,7 @@ Listed Lists { expectSkip = [], + expectUnreadable = [], expectDeclined = [ "other" "position-pragmas.hs", "other" "cpp" "unbalanced.hs", @@ -148,7 +151,12 @@ ("data" "examples"), corpusReference = ReferenceMarked "-out", corpusExpectations = - Listed Lists{expectSkip = ormoluSkip, expectDeclined = []}, + Listed + Lists + { expectSkip = ormoluSkip, + expectUnreadable = ormoluUnreadable, + expectDeclined = [] + }, corpusInPackages = False } @@ -176,8 +184,8 @@ { expectSkip = [ "numeric" "should_run" "quotRem2Large.hs", "perf" "compiler" "parsing001.hs" - ] - <> ghcUnreadable, + ], + expectUnreadable = ghcUnreadable, expectDeclined = ghcDeclined }, corpusInPackages = False @@ -186,13 +194,15 @@ -- | GHC test suite files the formatter is right to refuse. ghcDeclined :: [FilePath] ghcDeclined = - [ "ghci.debugger" "HappyTest.hs", + [ "driver" "T17786.hs", + "ghci.debugger" "HappyTest.hs", "parser" "should_compile" "ColumnPragma.hs", "parser" "should_compile" "T7118.hs", "perf" "compiler" "T20261.hs", "perf" "compiler" "T5631.hs", "programs" "joao-circular" "Funcs_Parser_Lazy.hs", - "quasiquotation" "T4150.hs" + "quasiquotation" "T4150.hs", + "th" "T23378A.hs" ] -- | Packages from Hackage. @@ -342,6 +352,7 @@ "declaration" "value" "function" "infix" "esqueleto-0.hs", "declaration" "value" "function" "infix" "esqueleto-1.hs", "declaration" "class" "default-signatures.hs", + "declaration" "class" "super-classes.hs", "declaration" "type-families" "closed-type-family" "with-comments.hs", "declaration" "deriving" "singleline.hs", "declaration" "deriving" "multiline.hs", @@ -363,10 +374,29 @@ "declaration" "splice" "quasiquote.hs", "declaration" "value" "function" "quasi-quotes.hs", "declaration" "value" "function" "operator-comments-0.hs", - "declaration" "signature" "fixity" "infix.hs" + "declaration" "signature" "fixity" "infix.hs", + "declaration" "class" "associated-data2.hs", + "declaration" "class" "associated-types2.hs", + "declaration" "class" "dependency-super-classes.hs", + "declaration" "class" "functional-dependencies.hs", + "declaration" "class" "multi-parameters2.hs", + "declaration" "data" "gadt" "multiline.hs", + "declaration" "data" "gadt" "simple.hs", + "import" "no-implicit-prelude-package.hs", + "other" "pragma-sorting.hs", + "declaration" "splice" "bracket.hs", + "declaration" "class" "type-operators3.hs", + "other" "cpp" "lonely-hash.hs", + "other" "cpp" "separation-0a.hs", + "other" "cpp" "separation-0b.hs", + "other" "cpp" "separation-1a.hs", + "other" "cpp" "separation-1b.hs", + "other" "cpp" "separation-2a.hs", + "other" "cpp" "separation-2b.hs", + "other" "cpp" "shifted.hs", + "other" "cpp" "simple-import.hs" ] <> ormoluRecordBraces - <> ormoluUnreadable -- | Ormolu examples with a space between a record and its braces. ormoluRecordBraces :: [FilePath] @@ -383,14 +413,14 @@ "declaration" "value" "function" "record" "updaters.hs", "declaration" "value" "function" "record" "wildcards.hs", "declaration" "value" "pattern-synonyms" "bidirectional.hs", - "declaration" "value" "pattern-synonyms" "unidirectional.hs" + "declaration" "value" "pattern-synonyms" "unidirectional.hs", + "declaration" "value" "function" "pragmas.hs" ] -- | Ormolu examples GHC's own parser cannot read. ormoluUnreadable :: [FilePath] ormoluUnreadable = - [ "declaration" "class" "type-operators3.hs", - "declaration" "data" "datatype-contexts.hs", + [ "declaration" "data" "datatype-contexts.hs", "declaration" "foreign" "foreign-import-multiline.hs", "declaration" "value" "function" "application-1.hs", "declaration" "value" "function" "application-2.hs", @@ -408,17 +438,6 @@ "declaration" "value" "function" "pattern" "or-patterns.hs", "declaration" "value" "function" "type-applications.hs", "other" "comment-before-hanging.hs", - "other" "cpp" "continuation.hs", - "other" "cpp" "cpp-and-imports.hs", - "other" "cpp" "lonely-hash.hs", - "other" "cpp" "separation-0a.hs", - "other" "cpp" "separation-0b.hs", - "other" "cpp" "separation-1a.hs", - "other" "cpp" "separation-1b.hs", - "other" "cpp" "separation-2a.hs", - "other" "cpp" "separation-2b.hs", - "other" "cpp" "shifted.hs", - "other" "cpp" "simple-import.hs", "other" "necessary-brackets.hs" ] @@ -432,58 +451,16 @@ "annotations" "should_fail" "annfail13.hs", "arrows" "should_fail" "T2111.hs", "arrows" "should_fail" "arrowfail003.hs", - "cabal" "fileStatus.hs", - "codeGen" "should_run" "CheckBoundsOK.hs", - "codeGen" "should_run" "T10245.hs", "codeGen" "should_run" "T12855.hs", - "codeGen" "should_run" "T2080.hs", - "codeGen" "should_run" "T7600.hs", - "codeGen" "should_run" "cas_int.hs", - "codeGen" "should_run" "cgrun044.hs", - "codeGen" "should_run" "cgrun071.hs", - "codeGen" "should_run" "cgrun072.hs", - "codeGen" "should_run" "cgrun075.hs", - "codeGen" "should_run" "cgrun076.hs", - "codeGen" "should_run" "cgrun077.hs", - "codeGen" "should_run" "cgrun079.hs", - "codeGen" "should_run" "cgrun080.hs", - "concurrent" "should_run" "T5611.hs", - "concurrent" "should_run" "T5611a.hs", - "concurrent" "should_run" "conc036.hs", - "concurrent" "should_run" "conc037.hs", - "concurrent" "should_run" "conc038.hs", - "concurrent" "should_run" "foreignInterruptible.hs", "corelint" "T21115.hs", - "deSugar" "should_run" "T5742.hs", "dependent" "should_fail" "RenamingStar.hs", - "dmdanal" "should_compile" "T9208.hs", - "driver" "FullGHCVersion.hs", - "driver" "T10869.hs", - "driver" "T10869A.hs", - "driver" "T10970.hs", - "driver" "T11763.hs", - "driver" "T12135.hs", - "driver" "T12674" "-T12674.hs", - "driver" "T12752pass.hs", + "dependent" "should_fail" "T16326_Fail7.hs", "driver" "T16167.hs", "driver" "T16476a.hs", "driver" "T16476b.hs", - "driver" "T16521" "A.hs", - "driver" "T17786.hs", - "driver" "T2464.hs", - "driver" "T3389.hs", - "driver" "T8526" "A.hs", "driver" "bug1677" "Foo.hs", - "driver" "multipleHomeUnits" "c-file" "C.hs", - "driver" "multipleHomeUnits" "cpp-includes" "CPPIncludes.hs", - "driver" "multipleHomeUnits" "cpp-includes" "CPPIncludes_Down.hs", - "driver" "recomp011" "Main.hs", - "driver" "recomp021" "A.hs", - "driver" "should_fail" "T12752.hs", - "eyeball" "inline2.hs", "ffi" "should_fail" "capi_wrapper.hs", "ffi" "should_fail" "ccall_value.hs", - "ffi" "should_run" "T22159.hs", "gadt" "records-fail1.hs", "generics" "Uniplate" "GUniplate.hs", "ghci.debugger" "mdo.hs", @@ -494,62 +471,28 @@ "ghci" "prog013" "Bad.hs", "ghci" "scripts" "ghci022.hs", "ghci" "scripts" "ghci044a.hs", - "ghci" "should_run" "PackedDataCon" "ByteCode.hs", - "ghci" "should_run" "PackedDataCon" "Obj.hs", - "ghci" "should_run" "UnboxedTuples" "ByteCode.hs", - "ghci" "should_run" "UnboxedTuples" "Obj.hs", - "ghci" "should_run" "UnliftedDataTypeInterp" "ByteCode.hs", - "ghci" "should_run" "UnliftedDataTypeInterp" "Obj.hs", "haddock" "should_compile_flag_haddock" "haddockA004.hs", "haddock" "should_compile_flag_haddock" "haddockA011.hs", - "haddock" "should_compile_flag_haddock" "haddockA041.hs", "haddock" "should_compile_noflag_haddock" "haddockC004.hs", "haddock" "should_compile_noflag_haddock" "haddockC011.hs", "haddock" "should_fail_flag_haddock" "haddockE003.hs", - "hiefile" "should_compile" "CPP.hs", - "hiefile" "should_compile" "T22416.hs", - "hiefile" "should_compile" "hie002.hs", - "indexed-types" "should_compile" "T12538.hs", - "javascript" "T23346.hs", - "lib" "integer" "IntegerConversionRules.hs", "linear" "should_fail" "LinearNoExt.hs", "linear" "should_fail" "LinearNoExtU.hs", "linear" "should_fail" "T20083.hs", - "mdo" "should_compile" "mdo001.hs", - "mdo" "should_compile" "mdo002.hs", - "mdo" "should_compile" "mdo003.hs", - "mdo" "should_compile" "mdo004.hs", - "mdo" "should_compile" "mdo005.hs", - "mdo" "should_compile" "mdo006.hs", - "mdo" "should_fail" "mdofail001.hs", - "mdo" "should_fail" "mdofail002.hs", - "mdo" "should_fail" "mdofail003.hs", - "mdo" "should_fail" "mdofail004.hs", "mdo" "should_fail" "mdofail005.hs", - "mdo" "should_fail" "mdofail006.hs", - "mdo" "should_run" "mdorun001.hs", - "mdo" "should_run" "mdorun002.hs", - "mdo" "should_run" "mdorun003.hs", - "mdo" "should_run" "mdorun005.hs", "module" "Mod178_2.hs", "module" "T11432.hs", "module" "T11432a.hs", "module" "T12026.hs", + "module" "mod182.hs", "module" "mod183.hs", "module" "mod69.hs", "module" "mod70.hs", "module" "mod76.hs", "module" "mod89.hs", "module" "mod98.hs", - "numeric" "should_run" "T12136.hs", - "numeric" "should_run" "T20291.hs", - "numeric" "should_run" "foundation.hs", "parser" "should_compile" "T10582.hs", - "parser" "should_compile" "T15279.hs", "parser" "should_compile" "read023.hs", - "parser" "should_compile" "read039.hs", - "parser" "should_compile" "read046.hs", - "parser" "should_compile" "read058.hs", "parser" "should_fail" "ExportCommaComma.hs", "parser" "should_fail" "InfixAppPatErr.hs", "parser" "should_fail" "MultilineStringsInnerTab.hs", @@ -568,6 +511,7 @@ "parser" "should_fail" "OpaqueParseFail3.hs", "parser" "should_fail" "Or1.hs", "parser" "should_fail" "OrPatInExprErr.hs", + "parser" "should_fail" "ParserNoForallUnicode.hs", "parser" "should_fail" "ParserNoLambdaCase.hs", "parser" "should_fail" "ParserNoMultiWayIf.hs", "parser" "should_fail" "ParserNoTH1.hs", @@ -594,12 +538,14 @@ "parser" "should_fail" "T1344c.hs", "parser" "should_fail" "T13450.hs", "parser" "should_fail" "T13450TH.hs", + "parser" "should_fail" "T14588.hs", "parser" "should_fail" "T15730.hs", "parser" "should_fail" "T15730b.hs", "parser" "should_fail" "T15849.hs", "parser" "should_fail" "T16270.hs", "parser" "should_fail" "T16270h.hs", "parser" "should_fail" "T16999.hs", + "parser" "should_fail" "T17162.hs", "parser" "should_fail" "T17865.hs", "parser" "should_fail" "T17879a.hs", "parser" "should_fail" "T17879b.hs", @@ -624,6 +570,7 @@ "parser" "should_fail" "T25258b.hs", "parser" "should_fail" "T25258c.hs", "parser" "should_fail" "T25530.hs", + "parser" "should_fail" "T26418.hs", "parser" "should_fail" "T3095.hs", "parser" "should_fail" "T3153.hs", "parser" "should_fail" "T3751.hs", @@ -633,6 +580,7 @@ "parser" "should_fail" "T3811e.hs", "parser" "should_fail" "T3811f.hs", "parser" "should_fail" "T5425.hs", + "parser" "should_fail" "T8258NoGADTs.hs", "parser" "should_fail" "T8431.hs", "parser" "should_fail" "T8501a.hs", "parser" "should_fail" "T8501b.hs", @@ -720,21 +668,7 @@ "patsyn" "should_fail" "export-syntax.hs", "patsyn" "should_fail" "import-syntax.hs", "perf" "compiler" "T12234.hs", - "perf" "compiler" "T14683.hs", - "perf" "compiler" "T18698" "T18698.hs", - "perf" "should_run" "T13623.hs", "plugins" "T20803a.hs", - "plugins" "plugin-recomp" "Common.hs", - "primops" "should_run" "T4442.hs", - "primops" "should_run" "UnalignedAddrPrimOps.hs", - "printer" "Ppr010.hs", - "printer" "Ppr027.hs", - "profiling" "should_compile" "T19894" "Fold.hs", - "profiling" "should_compile" "T19894" "Operations.hs", - "profiling" "should_compile" "T19894" "Step.hs", - "profiling" "should_compile" "T19894" "StreamD.hs", - "profiling" "should_compile" "T19894" "StreamK.hs", - "profiling" "should_compile" "T19894" "Unfold.hs", "profiling" "should_compile" "T19894" "inline.hs", "profiling" "should_fail" "T17916.hs", "profiling" "should_fail" "proffail001.hs", @@ -761,30 +695,17 @@ "quotes" "TH_spliceViewPat" "A.hs", "rename" "should_fail" "T12879.hs", "rename" "should_fail" "T14907a.hs", - "rename" "should_fail" "T9032.hs", "rename" "should_fail" "T9437.hs", "rename" "should_fail" "rnfail016.hs", "rename" "should_fail" "rnfail016a.hs", + "rename" "should_fail" "rnfail052.hs", "roles" "should_fail" "Roles7.hs", - "rts" "T12497.hs", - "rts" "linker" "T20494.hs", - "rts" "linker" "T5435.hs", - "rts" "stack002.hs", - "runghc" "T6132.hs", - "safeHaskell" "flags" "Flags01.hs", - "safeHaskell" "safeLanguage" "SafeLang18.hs", "saks" "should_fail" "saks_fail007.hs", "saks" "should_fail" "saks_fail024.hs", "saks" "should_fail" "saks_fail025.hs", - "simplCore" "T9646" "Main.hs", - "simplCore" "T9646" "StrictPrim.hs", - "simplCore" "T9646" "Type.hs", "simplCore" "should_compile" "T13658.hs", - "simplCore" "should_compile" "T21694.hs", "simplCore" "should_compile" "T5821.hs", - "simplCore" "should_compile" "T8832.hs", "simplCore" "should_fail" "T25117b.hs", - "simplCore" "should_run" "T21575.hs", "splice-imports" "SI27.hs", "stage1" "T2632.hs", "th" "T10279.hs", @@ -792,15 +713,10 @@ "th" "T10819.hs", "th" "T10891.hs", "th" "T11484.hs", - "th" "T16180.hs", "th" "T16326_TH.hs", "th" "T16980a.hs", - "th" "T23309A.hs", - "th" "T23378A.hs", - "th" "T2817.hs", "th" "T3177.hs", "th" "T3177a.hs", - "th" "T4436.hs", "th" "T5217.hs", "th" "T6018th.hs", "th" "T8807.hs", @@ -808,7 +724,6 @@ "th" "TH_ExplicitForAllRules_a.hs", "th" "TH_class1.hs", "th" "TH_dataD1.hs", - "th" "TH_foreignCallingConventions.hs", "th" "TH_implicitParams.hs", "th" "TH_lookupName.hs", "th" "TH_raiseErr1.hs", @@ -820,7 +735,6 @@ "th" "TH_reifyExplicitForAllFams.hs", "th" "TH_reifyInstances.hs", "th" "TH_reifyLinear.hs", - "th" "TH_reifyLocalDefs.hs", "th" "TH_reifyMkName.hs", "th" "TH_repE2.hs", "th" "TH_repGuard.hs", @@ -840,23 +754,21 @@ "th" "TH_spliceE3.hs", "th" "TH_spliceE4.hs", "th" "TH_spliceExpr1.hs", - "th" "TH_spliceGuard.hs", "th" "TH_tf1.hs", "th" "TH_tf3.hs", "th" "TH_unresolvedInfix.hs", "th" "TH_unresolvedInfix2.hs", - "typecheck" "should_compile" "FloatFDs.hs", "typecheck" "should_compile" "tc134.hs", "typecheck" "should_fail" "ExplicitSpecificity3.hs", "typecheck" "should_fail" "ExplicitSpecificity8.hs", "typecheck" "should_fail" "T13446.hs", "typecheck" "should_fail" "T14761b.hs", "typecheck" "should_fail" "T2126.hs", - "typecheck" "should_fail" "T3102.hs", + "typecheck" "should_fail" "T3155.hs", "typecheck" "should_fail" "T9634.hs", "typecheck" "should_fail" "tcfail089.hs", - "typecheck" "should_run" "T1735.hs", - "typecheck" "should_run" "T1735_Help" "Main.hs", + "typecheck" "should_fail" "tcfail166.hs", + "typecheck" "should_fail" "tcfail183.hs", "typecheck" "should_run" "T4809.hs", "unboxedsums" "UnboxedSumsTH_Fail.hs", "unboxedsums" "unboxedsums4.hs", @@ -867,10 +779,7 @@ "vdq-rta" "should_fail" "T24159_pat_parse_error_5.hs", "vdq-rta" "should_fail" "T24159_pat_parse_error_6.hs", "warnings" "should_fail" "CaretDiagnostics2.hs", - "warnings" "should_fail" "SpecEMultipleTys.hs", - "wcompat-warnings" "WCompatWarningsOff.hs", - "wcompat-warnings" "WCompatWarningsOn.hs", - "wcompat-warnings" "WCompatWarningsOnOff.hs" + "warnings" "should_fail" "SpecEMultipleTys.hs" ] ---------------------------------------------------------------------------- @@ -892,7 +801,7 @@ -- @.cabal@ file. 'Nothing' for a corpus whose examples are not modules -- of a package, see 'corpusInPackages', and for one whose package could -- not be read. - exampleExtensions :: Maybe [Extension] + exampleExtensions :: Maybe Defaults } deriving (Eq, Show) @@ -908,7 +817,7 @@ -- releases keep theirs, which the fixity benchmarks read. obtain :: Corpus -> IO (Either Text [Example]) obtain corpus = case corpusSource corpus of - Vendored dir -> Right <$> examplesIn corpus dir + Vendored dir -> Right <$> examplesIn corpus dir [dir] Fetched url root -> do home <- corpusCache let unpacked = home corpusName corpus @@ -918,14 +827,14 @@ Left problem -> pure (Left problem) Right () -> do removePathForcibly archive - Right <$> examplesIn corpus (unpacked root) + Right <$> examplesIn corpus (unpacked root) [unpacked root] HackageReleases releases -> do home <- corpusCache let root = home corpusName corpus createDirectoryIfMissing True root inTurn root releases >>= \case Left problem -> pure (Left problem) - Right () -> Right <$> examplesIn corpus root + Right () -> Right <$> examplesIn corpus root (fmap (root ) releases) where inTurn _ [] = pure (Right ()) inTurn root (name : rest) = @@ -1037,10 +946,11 @@ ---------------------------------------------------------------------------- -- Enumerating --- | Every example in an unpacked corpus, in a settled order. -examplesIn :: Corpus -> FilePath -> IO [Example] -examplesIn corpus root = do - found <- sort <$> haskellFilesIn root +-- | Every example in these directories of an unpacked corpus, named from +-- its root, in a settled order. +examplesIn :: Corpus -> FilePath -> [FilePath] -> IO [Example] +examplesIn corpus root dirs = do + found <- sort . concat <$> traverse haskellFilesIn dirs reader <- packageReaderFor corpus let present = Set.fromList found files = filter (not . skipped) found @@ -1081,18 +991,9 @@ fromMaybe "" (listToMaybe (filter (`isSuffixOf` f) sourceExtensions)) -- | What each of a corpus's examples has in force before its own pragmas. -packageReaderFor :: Corpus -> IO (FilePath -> IO (Maybe [Extension])) +packageReaderFor :: Corpus -> IO (FilePath -> IO (Maybe Defaults)) packageReaderFor corpus | not (corpusInPackages corpus) = pure (const (pure Nothing)) | otherwise = do - reader <- newPackageReader Nothing + reader <- newPackageReader Nothing [] pure (fmap (either (const Nothing) Just) . reader) - -haskellFilesIn :: FilePath -> IO [FilePath] -haskellFilesIn dir = do - isDir <- doesDirectoryExist dir - if not isDir - then pure [dir | any (`isSuffixOf` dir) sourceExtensions] - else do - entries <- quietly [] (listDirectory dir) - concat <$> traverse (haskellFilesIn . (dir )) entries diff --git a/tests/Tilia/Corpus/Manifest.hs b/tests/Tilia/Corpus/Manifest.hs --- a/tests/Tilia/Corpus/Manifest.hs +++ b/tests/Tilia/Corpus/Manifest.hs @@ -19,11 +19,9 @@ readReport, writeReport, reasonLines, - accepting, ) where -import Control.Exception (SomeException, try) import Crypto.Hash.SHA256 qualified as SHA256 import Data.ByteString.Base16 qualified as B16 import Data.List (sortOn) @@ -32,10 +30,9 @@ import Data.Text (Text) import Data.Text qualified as T import Data.Text.Encoding qualified as T -import Data.Text.IO qualified as T import System.Directory (createDirectoryIfMissing) -import System.Environment (lookupEnv) import System.FilePath (takeDirectory) +import Tilia.Utils (readUtf8File, writeUtf8File) ---------------------------------------------------------------------------- -- What an example does @@ -107,9 +104,9 @@ -- with a message about a file. readManifest :: FilePath -> IO Manifest readManifest path = - try (T.readFile path) >>= \case - Left (_ :: SomeException) -> pure Map.empty - Right text -> pure (Map.fromList (concatMap entry (T.lines text))) + readUtf8File path >>= \case + Nothing -> pure Map.empty + Just text -> pure (Map.fromList (concatMap entry (T.lines text))) where entry line = case T.words line of (what : digest : rest) @@ -124,7 +121,8 @@ writeManifest :: FilePath -> Manifest -> IO () writeManifest path manifest = do createDirectoryIfMissing True (takeDirectory path) - T.writeFile path (T.unlines (header <> fmap line (Map.toAscList manifest))) + writeUtf8File path $ + T.unlines (header <> fmap line (Map.toAscList manifest)) where header = [ "# What each example of this corpus does today, one line each.", @@ -149,9 +147,9 @@ -- 'readManifest'. readReport :: FilePath -> IO Report readReport path = - try (T.readFile path) >>= \case - Left (_ :: SomeException) -> pure Map.empty - Right text -> pure (go Nothing Map.empty (T.lines text)) + readUtf8File path >>= \case + Nothing -> pure Map.empty + Just text -> pure (go Nothing Map.empty (T.lines text)) where go section report = \case [] -> report @@ -173,7 +171,8 @@ writeReport :: FilePath -> [(FilePath, Outcome, Text)] -> IO () writeReport path entries = do createDirectoryIfMissing True (takeDirectory path) - T.writeFile path (T.unlines (header <> concatMap section grouped)) + writeUtf8File path $ + T.unlines (header <> concatMap section grouped) where interesting = [e | e@(_, outcome, _) <- entries, outcome /= Formatted] grouped = @@ -204,11 +203,3 @@ -- | The lines a report gives an example's reason. reasonLines :: Text -> [Text] reasonLines = fmap (" " <>) . T.lines . T.strip - --- | Is this run supposed to write the records rather than check against --- them? -accepting :: IO Bool -accepting = - lookupEnv "TILIA_CORPUS_ACCEPT" >>= \case - Just s | s `notElem` ["", "0", "no", "false"] -> pure True - _ -> pure False diff --git a/tests/Tilia/CorpusSpec.hs b/tests/Tilia/CorpusSpec.hs --- a/tests/Tilia/CorpusSpec.hs +++ b/tests/Tilia/CorpusSpec.hs @@ -1,6 +1,5 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -- | Formatting other people's Haskell. module Tilia.CorpusSpec (spec) where @@ -15,8 +14,9 @@ import Data.Text (Text) import Data.Text qualified as T import Data.Text.Encoding (decodeUtf8') -import GHC.LanguageExtensions.Type (Extension) -import System.FilePath (replaceExtension) +import System.Directory (createDirectoryIfMissing) +import System.FilePath (replaceExtension, ()) +import System.IO.Temp (withSystemTempDirectory) import Test.Hspec hiding (Example, after, before, example) import Tilia.Corpus import Tilia.Corpus.Manifest @@ -29,7 +29,7 @@ ParsedModule (..), parseModule, ) -import Tilia.Pragma (movesPositions) +import Tilia.Pragma (Defaults, movesPositions) import Tilia.Span (spanStartColumn, spanStartLine) import Tilia.Span.Ghc (spanOfSrcSpan) import Tilia.TestConfig (formatCppExample, printExample) @@ -39,10 +39,22 @@ countLeaves, effectiveExtensionsFor, parserConfigFor, + switchedOn, + withEnvironment, ) spec :: Spec spec = do + describe "obtaining Hackage releases" $ + it "takes in only the releases listed, whatever else is in the cache" $ + withSystemTempDirectory "tilia-corpus" $ \cache -> do + for_ ["listed-1.0", "unlisted-1.0"] $ \release -> do + createDirectoryIfMissing True (cache "hackage" release) + writeFile (cache "hackage" release "M.hs") "module M where\n" + obtained <- + withEnvironment [("TILIA_CORPUS_DIR", cache)] . obtain $ + hackagePackages{corpusSource = HackageReleases ["listed-1.0"]} + fmap (fmap exampleName) obtained `shouldBe` Right ["listed-1.0/M.hs"] corpusSpec vendoredExamples corpusSpec ormoluExamples corpusSpec ghcTestSuite @@ -70,17 +82,19 @@ parallel $ for_ examples $ \example -> it (exampleName example) $ do result <- run example - case verdict (Set.member (exampleName example) declines) result of + let holds = Set.member (exampleName example) + case verdict (holds unreadable) (holds declines) result of Passes -> pure () Fails why -> expectationFailure (T.unpack why) Reserved why -> pendingWith (T.unpack why) where + unreadable = Set.fromList (expectUnreadable listed) declines = Set.fromList (expectDeclined listed) -- | A corpus checked against a generated record of what it does. againstRecord :: FilePath -> (Example -> IO Result) -> [Example] -> Spec againstRecord path run examples = do - accept <- runIO accepting + accept <- runIO (switchedOn "TILIA_CORPUS_ACCEPT") if accept then accepted else checked where reportPath = replaceExtension path ".report" @@ -234,11 +248,16 @@ -- | What is to be said about what one example produced. verdict :: + -- | Does the corpus say this one cannot be read? + Bool -> -- | Does the corpus say this one should be declined? Bool -> Result -> Verdict -verdict declines (Result outcome why _) = case outcome of +verdict True _ (Result outcome _ _) + | outcome `elem` [DoesNotParse, NotUtf8] = Passes + | otherwise = Fails "the corpus says this cannot be read, and it was read" +verdict False declines (Result outcome why _) = case outcome of Broken -> Fails why NotUtf8 -> Fails (unlisted "is not UTF-8") DoesNotParse -> Fails (unlisted ("does not parse, at " <> why)) @@ -301,7 +320,7 @@ -- | Everything that can be established about one example without doing any -- more input or output. -checkPure :: Palette -> FilePath -> Maybe [Extension] -> Text -> Maybe Text -> Result +checkPure :: Palette -> FilePath -> Maybe Defaults -> Text -> Maybe Text -> Result checkPure palette path package source expected | movesPositions source = Result Declined "a pragma that moves positions, which we do not rewrite" noDigest @@ -367,7 +386,7 @@ -- | Everything that can be established about an example with conditionals in -- it. -checkCpp :: Palette -> FilePath -> Maybe [Extension] -> Text -> Maybe Text -> Result +checkCpp :: Palette -> FilePath -> Maybe Defaults -> Text -> Maybe Text -> Result checkCpp palette path package source expected = case formatCppExample package path source of Left why -> Result Declined (describeCppError why) noDigest Right formatted -> case (countLeaves source, countLeaves formatted) of diff --git a/tests/Tilia/Cpp/PropertiesSpec.hs b/tests/Tilia/Cpp/PropertiesSpec.hs --- a/tests/Tilia/Cpp/PropertiesSpec.hs +++ b/tests/Tilia/Cpp/PropertiesSpec.hs @@ -17,7 +17,7 @@ import Tilia.Equivalence (syntaxDifference) import Tilia.Parser (parseModule, pmModule) import Tilia.Render (defaultRenderConfig) -import Tilia.TestUtils (answeredLeaves, defaultParserConfig) +import Tilia.TestUtils (answeredLeaves, defaultParserConfig, parses) import Tilia.Utils (tshow) spec :: Spec @@ -102,11 +102,6 @@ formatted m k = case format (sourceOf m) of Left _ -> property Discard Right out -> property (k out) - -parses :: Text -> Bool -parses t = case parseModule defaultParserConfig "M.hs" t of - Left _ -> False - Right _ -> True difference :: Text -> Text -> Maybe Text difference before after = do diff --git a/tests/Tilia/CppSpec.hs b/tests/Tilia/CppSpec.hs --- a/tests/Tilia/CppSpec.hs +++ b/tests/Tilia/CppSpec.hs @@ -4,6 +4,7 @@ -- | Whether documents printed from different configurations line up. module Tilia.CppSpec (spec) where +import Data.Either (isLeft, isRight) import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map import Data.Maybe (isJust, maybeToList) @@ -20,11 +21,14 @@ import Tilia.Source (directiveOnLine) import Tilia.Span (Span) import Tilia.TestUtils - ( configurations, + ( answeredLeaves, + answeredLinearLeaves, + configurations, countLeaves, defaultParserConfig, leaves, linearLeaves, + parses, ) -- | Format a module which uses the C preprocessor, configured with nothing. @@ -253,6 +257,14 @@ (said (linearLeaves atDeclarations), said (leaves atDeclarations)) `shouldSatisfy` uncurry (==) + it "leaves out a configuration that aborts with #error" $ + said + ( (\every -> all (`elem` every)) + <$> answeredLeaves abortingBranches + <*> answeredLinearLeaves abortingBranches + ) + `shouldBe` Right True + describe "directives it cannot read" $ do it "refuses a module whose conditionals do not balance" $ formatCpp unbalanced `shouldBe` Left "the #ifdef at line 3 is never closed" @@ -654,6 +666,28 @@ "#endif" ] +-- | Branches that abort with @#error@, the first of one conditional and the +-- last of another. +abortingBranches :: Text +abortingBranches = + T.unlines + [ "module M where", + "", + "#if !defined(__GLASGOW_HASKELL__)", + "#error \"Only GHC is supported.\"", + "#endif", + "", + "wordSize :: Int", + "wordSize =", + "#if WORD_SIZE_IN_BITS == 64", + " 64", + "#elif WORD_SIZE_IN_BITS == 32", + " 32", + "#else", + "#error \"Unsupported word size.\"", + "#endif" + ] + -- | An @#else@ that the @#if@ around it rules out, which no configuration -- takes. ruledOut :: Text @@ -689,10 +723,6 @@ ---------------------------------------------------------------------------- -- Asking it -isLeft, isRight :: Either a b -> Bool -isLeft = either (const True) (const False) -isRight = either (const False) (const True) - sameBranch :: (Maybe Text, Maybe Text) -> Either Text () sameBranch (Nothing, Nothing) = Right () sameBranch (Just input, Just output) = sameProgram input output @@ -707,10 +737,6 @@ Left _ -> Left ("did not parse:\n" <> text) Right parsed -> Right (pmModule parsed) sameBranch _ = Left "preprocessing changed between succeeding and failing" - --- | Does a configuration parse, with what its own pragmas turn on? -parses :: Text -> Bool -parses t = either (const False) (const True) (parseModule defaultParserConfig "example.hs" t) -- | How many modules parsing every branch of a module comes to. branchesParsed :: Text -> Maybe Int diff --git a/tests/Tilia/Doc/InternalSpec.hs b/tests/Tilia/Doc/InternalSpec.hs --- a/tests/Tilia/Doc/InternalSpec.hs +++ b/tests/Tilia/Doc/InternalSpec.hs @@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} --- | The span algebra and the rendering engine's primitives. +-- | The rendering engine's primitives. module Tilia.Doc.InternalSpec (spec) where import Data.Text (Text) @@ -15,18 +15,6 @@ spec :: Spec spec = do - describe "Span" $ do - it "recognises a single-line span" $ - isSingleLine (mkSpan (3, 1) (3, 40)) `shouldBe` True - it "recognises a multi-line span" $ - isSingleLine (mkSpan (3, 1) (4, 1)) `shouldBe` False - it "unions to cover both operands" $ - mkSpan (1, 5) (1, 9) <> mkSpan (3, 2) (4, 1) - `shouldBe` mkSpan (1, 5) (4, 1) - it "takes the earlier start column when starts share a line" $ - mkSpan (1, 9) (1, 20) <> mkSpan (1, 3) (1, 5) - `shouldBe` mkSpan (1, 3) (1, 20) - describe "atoms" $ do it "renders nothing for an empty document" $ out mempty `shouldBe` "" diff --git a/tests/Tilia/Doc/PropertiesSpec.hs b/tests/Tilia/Doc/PropertiesSpec.hs --- a/tests/Tilia/Doc/PropertiesSpec.hs +++ b/tests/Tilia/Doc/PropertiesSpec.hs @@ -11,7 +11,6 @@ import Tilia.Doc import Tilia.Doc.Combinators import Tilia.Gen -import Tilia.Span spec :: Spec spec = do @@ -64,20 +63,6 @@ property $ \(AnyDoc d) -> do out (broken (mempty <> d)) === out (broken d) .&&. out (broken (d <> mempty)) === out (broken d) - - describe "Span" $ do - it "unions associatively" $ - property $ \(AnySpan a) (AnySpan b) (AnySpan c) -> - (a <> b) <> c === a <> (b <> c) - - it "unions to something covering both operands" $ - property $ \(AnySpan a) (AnySpan b) -> - let u = a <> b - in counterexample (show u) (covers u a && covers u b) - - it "is idempotent under union" $ - property $ - \(AnySpan a) -> a <> a === a -- | Everything that is not whitespace, in order. -- diff --git a/tests/Tilia/EditorSpec.hs b/tests/Tilia/EditorSpec.hs --- a/tests/Tilia/EditorSpec.hs +++ b/tests/Tilia/EditorSpec.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE DataKinds #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} @@ -7,16 +6,14 @@ -- | Formatting what an editor holds of a module. module Tilia.EditorSpec (spec) where -import Data.ByteString qualified as BS +import Control.Exception (throwIO) import Data.Choice (pattern Don't) import Data.Map.Strict qualified as Map import Data.Text (Text) import Data.Text qualified as T -import Data.Text.Encoding qualified as T import Data.Version (makeVersion) import GHC.LanguageExtensions.Type (Extension (..)) -import System.Directory (createDirectoryIfMissing) -import System.FilePath (takeDirectory, ()) +import System.FilePath (()) import System.IO.Temp (withSystemTempDirectory) import Test.Hspec import Tilia.Editor @@ -29,6 +26,7 @@ import Tilia.Fixity.HiFile (HiExport (..), HiFile (..), HiName (..)) import Tilia.Format (FormatError, formatErrorExitCode) import Tilia.Run (Outcome (..)) +import Tilia.TestUtils (withOpsProject) spec :: Spec spec = describe "formatting what an editor holds" $ do @@ -120,6 +118,11 @@ buffer ("src" "Uses.hs") "module Uses where\nf = \\case\n _ -> 1\n" `shouldReturn` CameTo "module Uses where\n\nf = \\case\n _ -> 1\n" + it "fails a module whose formatting throws rather than throwing itself" $ + withCompiled $ \buffer -> + buffer ("src" "Uses.hs") "module Uses where\nimport Boom\nx=a b\n" + `shouldReturn` CameFailed 19 + it "leaves out the branches the versions it is given rule out" $ withCompiled $ \buffer -> buffer ("src" "Uses.hs") versioned `shouldReturn` CameOut @@ -219,12 +222,7 @@ -- handed to the test as a way to format a buffer as one of its files. withProject :: ((FilePath -> Text -> IO Came) -> Expectation) -> Expectation withProject act = - inProject $ \dir project -> do - let planFile = dir "elsewhere" "plan.json" - write planFile $ - "{\"compiler-id\":\"ghc-0.0\",\"install-plan\":[\ - \{\"pkg-name\":\"fake\",\"pkg-version\":\"0.1.0.0\",\ - \\"pkg-src\":{\"type\":\"local\",\"path\":\"./.\"}}]}" + inProject $ \project planFile -> act $ \file text -> do let path = project file editorSession @@ -241,10 +239,11 @@ -- | The project of 'withProject', with what compiling it would establish -- given instead of a plan: @LambdaCase@ in force, version 0.1.0.0 of the --- package, and the interfaces of @Ops@ and of an empty @Prelude@. +-- package, and the interfaces of @Ops@ and of an empty @Prelude@; asking for +-- that of @Boom@ throws. withCompiled :: ((FilePath -> Text -> IO Came) -> Expectation) -> Expectation withCompiled act = - inProject $ \_ project -> + inProject $ \project _ -> act $ \file text -> do let path = project file compiledSession path compiled (Don't #checkAst) (Don't #checkIdempotence) @@ -257,7 +256,9 @@ { compiledExtensions = [ImplicitPrelude, LambdaCase], compiledWith = makeVersion [9, 14, 1], compiledPackages = Map.singleton "fake" (makeVersion [0, 1, 0, 0]), - compiledInterface = pure . (`Map.lookup` interfaces) + compiledInterface = \case + "Boom" -> throwIO (userError "boom") + m -> pure (Map.lookup m interfaces) } interfaces = Map.fromList @@ -273,40 +274,18 @@ -- | A project with a module declaring @infixl 6 <+>@, one beginning with a -- byte order mark declaring @infixr 0 <->@, and a @.tiliaignore@ excluding --- @src/Generated.hs@, given to the test with the directory it is in. +-- @src/Generated.hs@, given to the test with a plan for it. inProject :: (FilePath -> FilePath -> Expectation) -> Expectation -inProject act = - withSystemTempDirectory "tilia-editor" $ \dir -> do - let project = dir "project" - write (project "fake.cabal") $ - T.unlines - [ "cabal-version: 2.4", - "name: fake", - "version: 0.1.0.0", - "library", - " exposed-modules: Ops, Marked", - " hs-source-dirs: src", - " default-language: Haskell2010" - ] - write (project "src" "Ops.hs") $ - T.unlines - [ "module Ops ((<+>)) where", - "infixl 6 <+>", - "(<+>) :: a -> a -> a", - "(<+>) = const" - ] - write (project "src" "Marked.hs") $ - T.unlines - [ "\xFEFFmodule Marked ((<->)) where", - "infixr 0 <->", - "(<->) :: a -> a -> a", - "(<->) = const" - ] - write (project ".tiliaignore") "src/Generated.hs\n" - act dir project - --- | Write a file, with the directories it is in. -write :: FilePath -> Text -> IO () -write path text = do - createDirectoryIfMissing True (takeDirectory path) - BS.writeFile path (T.encodeUtf8 text) +inProject = + withOpsProject + [ ( "src" "Marked.hs", + T.unlines + [ "\xFEFFmodule Marked ((<->)) where", + "infixr 0 <->", + "(<->) :: a -> a -> a", + "(<->) = const" + ] + ), + (".tiliaignore", "src/Generated.hs\n") + ] + [] diff --git a/tests/Tilia/EquivalenceSpec.hs b/tests/Tilia/EquivalenceSpec.hs --- a/tests/Tilia/EquivalenceSpec.hs +++ b/tests/Tilia/EquivalenceSpec.hs @@ -137,6 +137,77 @@ "module M where\nimport Data.Maybe\nimport Data.Char () -- not needed, just\n -- re-exported\n" `losesTheCommentsOf` "module M where\n\nimport Data.Char () -- not needed, just\nimport Data.Maybe\n" + describe "what the header puts in force" $ do + it "does not mind language pragmas sorted where that changes nothing" $ + "{-# LANGUAGE NoStarIsType #-}\n{-# LANGUAGE TypeOperators #-}\nmodule M where\n" + `keepsTheCommentsOf` "{-# LANGUAGE TypeOperators #-}\n{-# LANGUAGE NoStarIsType #-}\nmodule M where\n" + + it "does not mind options sorted below the language pragmas" $ + "{-# OPTIONS_GHC -Wall #-}\n{-# LANGUAGE LambdaCase #-}\nmodule M where\n" + `keepsTheCommentsOf` "{-# LANGUAGE LambdaCase #-}\n{-# OPTIONS_GHC -Wall #-}\nmodule M where\n" + + it "does not mind Haddock's options sorted below GHC's" $ + "{-# OPTIONS_HADDOCK not-home #-}\n{-# OPTIONS_GHC -Wall #-}\nmodule M where\n" + `keepsTheCommentsOf` "{-# OPTIONS_GHC -Wall #-}\n{-# OPTIONS_HADDOCK not-home #-}\nmodule M where\n" + + it "notices Haddock's options coming out in another order" $ + differsBecause + "{-# OPTIONS_HADDOCK hide #-}\n{-# OPTIONS_HADDOCK not-home #-}\nmodule M where\n" + "{-# OPTIONS_HADDOCK not-home #-}\n{-# OPTIONS_HADDOCK hide #-}\nmodule M where\n" + "changed the OPTIONS_HADDOCK pragmas" + + it "notices the flags of options coming out in another order" $ + differsBecause + "{-# OPTIONS_GHC -Wall #-}\n{-# OPTIONS -Wno-orphans #-}\nmodule M where\n" + "{-# OPTIONS -Wno-orphans #-}\n{-# OPTIONS_GHC -Wall #-}\nmodule M where\n" + "changed the flags of the options pragmas" + + it "notices an options pragma written twice coming out once" $ + differsBecause + "{-# OPTIONS_GHC -fplugin-opt=P:x #-}\n{-# OPTIONS_GHC -fplugin-opt=P:x #-}\nmodule M where\n" + "{-# OPTIONS_GHC -fplugin-opt=P:x #-}\nmodule M where\n" + "changed the flags of the options pragmas" + + it "notices an extension turned off by names moved past each other" $ + differsBecause + "{-# LANGUAGE NoLambdaCase #-}\n{-# LANGUAGE LambdaCase #-}\nmodule M where\n" + "{-# LANGUAGE LambdaCase #-}\n{-# LANGUAGE NoLambdaCase #-}\nmodule M where\n" + "switches LambdaCase" + + it "notices an extension turned off past one implying it" $ + differsBecause + "{-# LANGUAGE NoMonoLocalBinds #-}\n{-# LANGUAGE TypeFamilies #-}\nmodule M where\n" + "{-# LANGUAGE TypeFamilies #-}\n{-# LANGUAGE NoMonoLocalBinds #-}\nmodule M where\n" + "switches MonoLocalBinds" + + it "notices the Prelude turned back on past RebindableSyntax" $ + differsBecause + "{-# LANGUAGE ImplicitPrelude #-}\n{-# LANGUAGE RebindableSyntax #-}\nmodule M where\n" + "{-# LANGUAGE RebindableSyntax #-}\n{-# LANGUAGE ImplicitPrelude #-}\nmodule M where\n" + "switches ImplicitPrelude" + + it "notices an option turning off what a language pragma turns on" $ + differsBecause + "{-# OPTIONS_GHC -XNoLambdaCase #-}\n{-# LANGUAGE LambdaCase #-}\nmodule M where\n" + "{-# LANGUAGE LambdaCase #-}\n{-# OPTIONS_GHC -XNoLambdaCase #-}\nmodule M where\n" + "switches LambdaCase" + + it "notices a pragma moved into the header, though GHC's defaults have it" $ + differsBecause + "module M where\n{-# LANGUAGE MultiParamTypeClasses #-}\n" + "{-# LANGUAGE MultiParamTypeClasses #-}\nmodule M where\n" + "MultiParamTypeClasses" + + it "notices another edition named last" $ + differsBecause + "{-# LANGUAGE Haskell2010 #-}\n{-# LANGUAGE GHC2021 #-}\nmodule M where\n" + "{-# LANGUAGE GHC2021 #-}\n{-# LANGUAGE Haskell2010 #-}\nmodule M where\n" + "changed the edition in force" + + it "does not mind a pragma below the header, which GHC does not read" $ + "module M where\n{-# LANGUAGE NoLambdaCase #-}\n{-# LANGUAGE LambdaCase #-}\nf = 1\n" + `keepsTheCommentsOf` "module M where\n{-# LANGUAGE LambdaCase #-}\n{-# LANGUAGE NoLambdaCase #-}\nf = 1\n" + ---------------------------------------------------------------------------- -- Helpers @@ -152,6 +223,12 @@ keepsTheCommentsOf :: Text -> Text -> Expectation keepsTheCommentsOf went came = difference went came `shouldBe` Nothing + +-- | Two modules that differ, for a reason that says the given thing. +differsBecause :: Text -> Text -> Text -> Expectation +differsBecause went came reason = case difference went came of + Nothing -> expectationFailure "saw no difference" + Just why -> why `shouldSatisfy` T.isInfixOf reason losesTheCommentsOf :: Text -> Text -> Expectation losesTheCommentsOf went came = diff --git a/tests/Tilia/Fixity/CabalSpec.hs b/tests/Tilia/Fixity/CabalSpec.hs --- a/tests/Tilia/Fixity/CabalSpec.hs +++ b/tests/Tilia/Fixity/CabalSpec.hs @@ -1,16 +1,30 @@ {-# LANGUAGE OverloadedStrings #-} --- | Reading a @.cabal@ file's fields without a cabal parser. +-- | Reading a package's description out of its @.cabal@ file and its +-- tarball. module Tilia.Fixity.CabalSpec (spec) where import Codec.Archive.Tar qualified as Tar import Codec.Archive.Tar.Entry qualified as Tar +import Codec.Compression.GZip qualified as GZip import Data.ByteString.Lazy qualified as BL import Data.Text (Text) +import Data.Text qualified as T import Data.Text.Encoding qualified as T +import Distribution.PackageDescription (GenericPackageDescription) import GHC.LanguageExtensions.Type (Extension (..)) +import System.FilePath (()) +import System.IO.Temp (withSystemTempDirectory) import Test.Hspec +import Tilia.Cabal.Package + ( declaredModules, + describePackageProblem, + packageExtensions, + packageSourceDirs, + parsePackageDescription, + ) import Tilia.Fixity.Cabal +import Tilia.Pragma (effectiveExtensions) spec :: Spec spec = do @@ -40,11 +54,28 @@ cabalFileInArchive ( archiveOf [ ("hspec-2.11.17/Setup.lhs", "main = undefined\n"), - ("hspec-2.11.17/hspec.cabal", "library\n exposed-modules: Test.Hspec, Test.Hspec.Runner\n") + ( "hspec-2.11.17/hspec.cabal", + header + <> "library\n\ + \ exposed-modules: Test.Hspec, Test.Hspec.Runner\n" + ) ] ) - `shouldSatisfy` maybe False (elem "Test.Hspec.Runner" . containedModules) + `shouldSatisfy` maybe False (elem "Test.Hspec.Runner" . modulesOf) + describe "a tarball that cannot be read" $ do + it "leaves its package unread when it is not gzip" $ + withTarball "not really a tarball" $ \path -> + packageModules path `shouldReturn` Nothing + + it "leaves its package unread when it is cut short in its cabal file" $ do + let names = ["M" <> T.pack (show n) | n <- [1 .. 5000 :: Int]] + cabal = + header <> "library\n exposed-modules: " <> T.intercalate ", " names + whole = GZip.compress (Tar.write [entryFor "big-1.0/big.cabal" cabal]) + withTarball (BL.take (BL.length whole `div` 2) whole) $ \path -> + packageModules path `shouldReturn` Nothing + describe "plain fields" $ do it "reads a one-line field" $ exposed "library\n exposed-modules: A.B, C.D\n" @@ -77,14 +108,11 @@ exposed "library\n exposed-modules:\n A\n build-depends: base\n" `shouldMatchList` ["A"] - it "ignores anything that is not a module name" $ - exposed "library\n exposed-modules: A, base >=4, -Wall\n" - `shouldMatchList` ["A"] - describe "conditionals" $ do it "takes a branch nested inside an if" $ exposed - "library\n\ + "flag fancy\n\ + \library\n\ \ exposed-modules: A\n\ \ if flag(fancy)\n\ \ exposed-modules: B\n" @@ -101,7 +129,9 @@ it "takes a branch nested two deep" $ exposed - "library\n\ + "flag a\n\ + \flag b\n\ + \library\n\ \ if flag(a)\n\ \ if flag(b)\n\ \ exposed-modules: Deep\n" @@ -126,12 +156,25 @@ `shouldMatchList` ["A", "C"] it "keeps reading source directories past one" $ - sourceDirs "library\n hs-source-dirs: src\n-- a comment\ntest-suite t\n hs-source-dirs: tests\n" + sourceDirs + "library\n\ + \ hs-source-dirs: src\n\ + \-- a comment\n\ + \test-suite t\n\ + \ type: exitcode-stdio-1.0\n\ + \ main-is: T.hs\n\ + \ hs-source-dirs: tests\n" `shouldBe` ["src", "tests", "."] describe "where a component with no hs-source-dirs lives" $ do it "offers the package directory even when other components name one" $ - sourceDirs "library\n build-depends: base\ntest-suite t\n hs-source-dirs: tests\n" + sourceDirs + "library\n\ + \ build-depends: base\n\ + \test-suite t\n\ + \ type: exitcode-stdio-1.0\n\ + \ main-is: T.hs\n\ + \ hs-source-dirs: tests\n" `shouldBe` ["tests", "."] it "offers it last, so a named directory is tried first" $ @@ -186,6 +229,8 @@ "library\n\ \ default-language: Haskell2010\n\ \test-suite spec\n\ + \ type: exitcode-stdio-1.0\n\ + \ main-is: T.hs\n\ \ default-language: GHC2021\n" `shouldSatisfy` elem TypeOperators @@ -194,6 +239,8 @@ "library\n\ \ default-language: Haskell2010\n\ \test-suite spec\n\ + \ type: exitcode-stdio-1.0\n\ + \ main-is: T.hs\n\ \ default-language: GHC2021\n" `shouldSatisfy` elem ImplicitPrelude @@ -204,7 +251,12 @@ it "takes every component's, since it does not know which one asks" $ do let found = extensions - "library\n default-extensions: LambdaCase\ntest-suite t\n default-extensions: MultiWayIf\n" + "library\n\ + \ default-extensions: LambdaCase\n\ + \test-suite t\n\ + \ type: exitcode-stdio-1.0\n\ + \ main-is: T.hs\n\ + \ default-extensions: MultiWayIf\n" found `shouldSatisfy` elem LambdaCase found `shouldSatisfy` elem MultiWayIf @@ -221,17 +273,43 @@ -- | The modules a @.cabal@ of this shape holds. exposed :: Text -> [Text] -exposed = containedModules +exposed = modulesOf . described +-- | The directories a @.cabal@ of this shape offers modules under. +sourceDirs :: Text -> [FilePath] +sourceDirs = packageSourceDirs . described + -- | What a @.cabal@ of this shape puts in force. extensions :: Text -> [Extension] -extensions = declaredExtensions +extensions = (`effectiveExtensions` "") . packageExtensions . described +-- | What a @.cabal@ file holding the fields given describes. +described :: Text -> GenericPackageDescription +described fields = + either (error . T.unpack . describePackageProblem) id $ + parsePackageDescription "t.cabal" (T.encodeUtf8 (header <> fields)) + +-- | The fields a @.cabal@ file needs before its components. +header :: Text +header = "cabal-version: 2.4\nname: t\nversion: 0\n" + +-- | The names of the modules a package declares. +modulesOf :: GenericPackageDescription -> [Text] +modulesOf = fmap fst . declaredModules + -- | A tar entry at the given path, holding the given text. entryFor :: FilePath -> Text -> Tar.Entry entryFor path contents = case Tar.toTarPath False path of Left why -> error why Right tarPath -> Tar.fileEntry tarPath (BL.fromStrict (T.encodeUtf8 contents)) + +-- | Run something with a tarball holding these bytes. +withTarball :: BL.ByteString -> (FilePath -> Expectation) -> Expectation +withTarball bytes act = + withSystemTempDirectory "tilia-tarball" $ \dir -> do + let path = dir "big-1.0.tar.gz" + BL.writeFile path bytes + act path -- | An archive of those entries, in order. archiveOf :: [(FilePath, Text)] -> Tar.Entries e diff --git a/tests/Tilia/Fixity/CacheSpec.hs b/tests/Tilia/Fixity/CacheSpec.hs --- a/tests/Tilia/Fixity/CacheSpec.hs +++ b/tests/Tilia/Fixity/CacheSpec.hs @@ -17,7 +17,7 @@ import Tilia.Fixity import Tilia.Fixity.Cache import Tilia.Fixity.PackageDb (Installed (..), InstalledPackage (..)) -import Tilia.TestUtils (withEnvironment) +import Tilia.TestUtils (underAsciiLocale, withEnvironment) spec :: Spec spec = do @@ -65,6 +65,14 @@ ] storeEstablished cache "thing-1.0" "Edges" established cachedEstablished cache "thing-1.0" "Edges" `shouldReturn` Just established + + it "round-trips a name that is not ASCII under any locale" $ \cache -> do + let established = + declaring [((InTerms, OpName "∘"), Fixity RightAssoc 9)] + underAsciiLocale $ do + storeEstablished cache "thing-1.0" "Compose" established + cachedEstablished cache "thing-1.0" "Compose" + `shouldReturn` Just established it "remembers that a module declares nothing" $ \cache -> do storeEstablished cache "thing-1.0" "Quiet" mempty diff --git a/tests/Tilia/Fixity/DebugSpec.hs b/tests/Tilia/Fixity/DebugSpec.hs --- a/tests/Tilia/Fixity/DebugSpec.hs +++ b/tests/Tilia/Fixity/DebugSpec.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} @@ -17,14 +16,14 @@ ( Direction (..), Established (..), Fixity (..), + Namespace (..), OpName (..), - inBothNamespaces, resolveScope, ) import Tilia.Fixity.Debug (fixityNotes, renderFixityNotes) import Tilia.Palette (Palette (Plain)) import Tilia.Parser (pmModule) -import Tilia.TestUtils (parsed) +import Tilia.TestUtils (inBothNamespaces, parsed) import Tilia.Utils (lineWidth, visibleLength) spec :: Spec @@ -90,6 +89,20 @@ "import Left\nimport Right\nf a b = a <+> b\n" >>= (`mentions` "the imports disagree about it: infixl 6 in Left but infixr 5 in Right") + it "says when they disagree about a constructor written among types" $ do + let offers = [("Left", infixl' 6), ("Right", Fixity RightAssoc 5)] + answerOf m = + mempty + { establishedFixities = + Map.fromList + [((InTerms, OpName ":>"), f) | Just f <- [lookup m offers]] + } + notesAgainst answerOf "import Left\nimport Right\ntype T = Int :> Int\n" + >>= ( `mentions` + "the imports disagree about it: \ + \infixl 6 in Left but infixr 5 in Right" + ) + it "gives an operator one line however often it is written" $ do told <- notesFor [("Prelude", Just [])] "f a b c = a b c a\n" length (filter (T.isInfixOf "") told) `shouldBe` 1 @@ -173,20 +186,26 @@ [(Text, Maybe [(Text, Fixity)])] -> Text -> IO [Text] -notesThrough chains world source = - renderFixityNotes Plain . Map.singleton "M.hs" - <$> fixityNotes (Is #implicitPrelude) (pure . answerOf) scope (pure module') +notesThrough chains world = notesAgainst answerOf where - scope = resolveScope (Is #implicitPrelude) answerOf (pure hsModule) answerOf m = case exportsOf m of Just fixities -> mempty{establishedFixities = fixities} Nothing -> mempty{establishedUntold = Set.singleton (fromMaybe [] (lookup m chains))} - hsModule = pmModule module' - module' = parsed ("module M where\n" <> source) exportsOf m = do declared <- lookup m world inBothNamespaces . Map.fromList . fmap (\(op, fixity) -> (OpName op, fixity)) <$> declared + +-- | The account given of a module, against what reading each module it +-- imports established. +notesAgainst :: (Text -> Established) -> Text -> IO [Text] +notesAgainst answerOf source = + renderFixityNotes Plain . Map.singleton "M.hs" + <$> fixityNotes (Is #implicitPrelude) (pure . answerOf) scope (pure module') + where + scope = resolveScope (Is #implicitPrelude) answerOf (pure hsModule) + hsModule = pmModule module' + module' = parsed ("module M where\n" <> source) infixl' :: Int -> Fixity infixl' = Fixity LeftAssoc diff --git a/tests/Tilia/Fixity/DependenciesSpec.hs b/tests/Tilia/Fixity/DependenciesSpec.hs --- a/tests/Tilia/Fixity/DependenciesSpec.hs +++ b/tests/Tilia/Fixity/DependenciesSpec.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE DataKinds #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} @@ -19,7 +18,6 @@ import Data.ByteString qualified as BS import Data.Choice (pattern Don't, pattern Is) import Data.Foldable (for_) -import Data.List (isSuffixOf, sort) import Data.Map.Strict qualified as Map import Data.Set qualified as Set import Data.Text (Text) @@ -27,8 +25,7 @@ import Data.Text.Encoding qualified as T import GHC.Hs (HsModule) import GHC.Hs.Extension (GhcPs) -import System.Directory (doesDirectoryExist, doesFileExist, listDirectory) -import System.FilePath (()) +import System.Directory (doesFileExist) import Test.Hspec import Tilia.BootFixities (bootFixities) import Tilia.Cabal.Plan @@ -40,7 +37,7 @@ import Tilia.Fixity.Plan import Tilia.Gathered (gathered) import Tilia.Parser -import Tilia.TestUtils (defaultParserConfig, routedResolver) +import Tilia.TestUtils (defaultParserConfig, haskellFilesIn, routedResolver) import Tilia.WithProjectPlan ( Dependency (..), compilerShipped, @@ -276,18 +273,6 @@ Left _ -> Nothing Right pm -> Just (pmModule pm) ) - -haskellFilesIn :: FilePath -> IO [FilePath] -haskellFilesIn dir = do - entries <- sort <$> listDirectory dir - concat <$> traverse below entries - where - below entry = do - let path = dir entry - isDir <- doesDirectoryExist path - if isDir - then haskellFilesIn path - else pure [path | ".hs" `isSuffixOf` path] -- | What a module exports, where reading it settles every name. fixitiesThrough :: Resolver -> Text -> IO (Maybe Fixities) diff --git a/tests/Tilia/Fixity/HiFileSpec.hs b/tests/Tilia/Fixity/HiFileSpec.hs --- a/tests/Tilia/Fixity/HiFileSpec.hs +++ b/tests/Tilia/Fixity/HiFileSpec.hs @@ -83,7 +83,9 @@ shown <- maybe Nothing (parseInterface m) <$> readProgramOutput "ghc" ["--show-iface", path] - let found = [(m, x) | Just s <- [shown], x <- disagreements declared m d s] + let found = case shown of + Nothing -> [(m, "ghc --show-iface gave nothing to compare")] + Just s -> [(m, x) | x <- disagreements declared m d s] found <$ evaluate (length found) _ -> pure [] @@ -138,7 +140,7 @@ byOperator (interfaceDeclares i) <> Set.unions [ byOperator (Map.filterWithKey (\(_, o) _ -> o == op) fixities) - | (from, op) <- interfaceReexports i, + | (from, _, op) <- interfaceReexports i, from /= m, Just fixities <- [declared from] ] diff --git a/tests/Tilia/Fixity/InterfaceSpec.hs b/tests/Tilia/Fixity/InterfaceSpec.hs --- a/tests/Tilia/Fixity/InterfaceSpec.hs +++ b/tests/Tilia/Fixity/InterfaceSpec.hs @@ -7,6 +7,7 @@ -- an interface, not a documented one. module Tilia.Fixity.InterfaceSpec (spec) where +import Data.List (nub) import Data.Map.Strict qualified as Map import Data.Set qualified as Set import Data.Text (Text) @@ -77,11 +78,9 @@ ("Data.Aeson.Types.FromJSON", OpName "parseJSON") ] - it "takes a record field, written after a bar" $ + it "takes a record field written after a bar, and not its type" $ passesOn "exports:\n Data.Aeson.Encoding.Internal.Encoding'|{Data.Aeson.Encoding.Internal.fromEncoding}\n" - `shouldBe` [ ("Data.Aeson.Encoding.Internal", OpName "Encoding'"), - ("Data.Aeson.Encoding.Internal", OpName "fromEncoding") - ] + `shouldBe` [("Data.Aeson.Encoding.Internal", OpName "fromEncoding")] it "keeps a type apart from the module holding it" $ passesOn "exports:\n Data.Aeson.Types.Internal.Value\n" @@ -103,8 +102,7 @@ it "reads them among the members of a type exported without itself" $ passesOn "exports:\n GHC.Internal.Bits.Bits|{GHC.Internal.Bits..&. GHC.Internal.Bits..|. GHC.Internal.Bits.complement}\n" - `shouldBe` [ ("GHC.Internal.Bits", OpName "Bits"), - ("GHC.Internal.Bits", OpName ".&."), + `shouldBe` [ ("GHC.Internal.Bits", OpName ".&."), ("GHC.Internal.Bits", OpName ".|."), ("GHC.Internal.Bits", OpName "complement") ] @@ -193,6 +191,15 @@ (fromHiFile "M" (HiFile "M" [AvailTC (inM InTypes "T") [inM InTerms "field"]] [])) `shouldBe` Right (Just (Set.fromList [(InTerms, OpName "field")])) + it "passes on the members of a type exported without itself" $ + fmap + interfaceReexports + ( fromHiFile + "M" + (HiFile "M" [AvailTC (inN InTypes ":<:") [inN InTerms "inj"]] []) + ) + `shouldBe` Right [("N", InTerms, OpName "inj")] + describe "a fixity for a name the module does not export" $ do it "is left out of a decoded interface" $ fmap @@ -213,6 +220,9 @@ declares "exports:\n <+>\n parser\nfixities infixl 3 <+>, infixr 2 <~>\n" `shouldBe` [(OpName "<+>", Fixity LeftAssoc 3)] + it "is left out for a type a bar says is exported without itself" $ + declares "exports:\n :<:|{inj}\nfixities infixr 4 :<:\n" `shouldBe` [] + it "is left out where the module passes on another name spelled the same" $ declares "exports:\n GHC.Internal.Base.>>=\nfixities infixr 2 >>=\n" `shouldBe` [] @@ -234,7 +244,10 @@ fmap (Map.toList . interfaceDeclares) (parseInterface "Data.Aeson" out) `shouldBe` Just [((InTerms, OpName "!"), Fixity LeftAssoc 9)] fmap interfaceReexports (parseInterface "Data.Aeson" out) - `shouldBe` Just [("Data.Aeson.Types.FromJSON", OpName ".:")] + `shouldBe` Just + [ ("Data.Aeson.Types.FromJSON", InTypes, OpName ".:"), + ("Data.Aeson.Types.FromJSON", InTerms, OpName ".:") + ] describe "output it will not read" $ do it "refuses what does not name a module at all" $ @@ -264,8 +277,14 @@ declaresIn = maybe [] (Map.toList . interfaceDeclares) . parseInterface "M" . (header "M" <>) +-- | What a module of this shape passes on, namespace aside. passesOn :: Text -> [(Text, OpName)] -passesOn = maybe [] interfaceReexports . parseInterface "M" . (header "M" <>) +passesOn = + nub + . fmap (\(m, _, op) -> (m, op)) + . maybe [] interfaceReexports + . parseInterface "M" + . (header "M" <>) -- | The members of each exported name, in a settled order. members :: Text -> [(OpName, [OpName])] @@ -277,3 +296,7 @@ -- | A name the module @M@ declares. inM :: Namespace -> Text -> HiName inM namespace = HiName "M" namespace . OpName + +-- | A name another module, N, declares. +inN :: Namespace -> Text -> HiName +inN namespace = HiName "N" namespace . OpName diff --git a/tests/Tilia/Fixity/PlanSpec.hs b/tests/Tilia/Fixity/PlanSpec.hs --- a/tests/Tilia/Fixity/PlanSpec.hs +++ b/tests/Tilia/Fixity/PlanSpec.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE DataKinds #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} @@ -22,7 +21,7 @@ import Control.Monad (forM_, when) import Data.ByteString.Lazy qualified as BL import Data.Choice (pattern Do, pattern Don't, pattern Is) -import Data.Foldable (traverse_) +import Data.Foldable (for_, traverse_) import Data.IORef (IORef, modifyIORef', newIORef, readIORef, writeIORef) import Data.List (isInfixOf) import Data.List qualified @@ -32,7 +31,6 @@ import Data.Text (Text) import Data.Text qualified as T import Data.Text.Encoding qualified as T -import Data.Text.IO qualified as T import Data.Time (addUTCTime, getCurrentTime) import System.Directory ( createDirectoryIfMissing, @@ -52,7 +50,12 @@ import Tilia.Cabal.Plan qualified as Plan import Tilia.Cpp.Macros (Macros (..)) import Tilia.Fixity -import Tilia.Fixity.Cache (PlanToken (..), openCache, storePackageCache) +import Tilia.Fixity.Cache + ( PlanToken (..), + openCache, + storeFutileFetch, + storePackageCache, + ) import Tilia.Fixity.HiFile (HiExport (..), HiFile (..), HiName (..)) import Tilia.Fixity.PackageDb ( Installed (..), @@ -63,8 +66,14 @@ import Tilia.Fixity.Plan import Tilia.Parser import Tilia.Process (readProgramOutput) -import Tilia.TestUtils (parsed, routedResolver, unreadOnly, withEnvironment) -import Tilia.Utils (inParallel) +import Tilia.TestUtils + ( parsed, + routedResolver, + unreadOnly, + withEnvironment, + withOpsProject, + ) +import Tilia.Utils (inParallel, writeUtf8File) import Tilia.WithProjectPlan (withProjectPlan) spec :: Spec @@ -202,6 +211,49 @@ `shouldReturn` Right () readIORef steps `shouldReturn` [] + it "does not fetch again what fetching did not bring in" $ + withTempProject (Just wantingATarball) $ \dir -> do + steps <- newIORef [] + refused <- newIORef [] + let futility = + undiscoveredFutility + { fetchWasFutileFor = readIORef refused, + rememberFutileFetch = writeIORef refused + } + missing = SourcesMissing ["tilia-phantom"] + again = prepareWith (obliging steps) futility [] dir missing + again `shouldReturn` Right () + readIORef refused `shouldReturn` ["tilia-phantom"] + again `shouldReturn` Right () + readIORef steps `shouldReturn` [fetching] + + it "does not fetch after a solve what fetching did not bring in" $ + withTempProject Nothing $ \dir -> do + steps <- newIORef [] + let cabal args = do + record steps args + when (args == solving) (writePlan dir wantingATarball) + pure (Right ()) + futility = + undiscoveredFutility{fetchWasFutileFor = pure ["tilia-phantom"]} + prepareWith cabal futility [] dir PlanMissing `shouldReturn` Right () + readIORef steps `shouldReturn` [solving] + + it "takes nothing for futile when told not to download" $ + withTempProject (Just narrowAndWanting) $ \dir -> do + refused <- newIORef [] + let futility = + undiscoveredFutility + { solveWasFutile = pure True, + rememberFutileFetch = writeIORef refused + } + narrow = PlanNarrow ["thing:test:tests"] + offline = Plan.prepareWith (Do #useCache) (Don't #download) + steps <- newIORef [] + offline (obliging steps) futility [component "test:tests"] dir narrow + `shouldReturn` Right () + readIORef refused `shouldReturn` [] + it "runs nothing at all when nothing is missing" $ do steps <- newIORef [] prepareWith (obliging steps) undiscoveredFutility [] "." Ready `shouldReturn` Right () @@ -566,7 +618,7 @@ it "leaves a file+noindex repository's tarballs where they are" $ withSystemTempDirectory "tilia-noindex" $ \repo -> do - T.writeFile (repo "thing-1.0.tar.gz") "not really a tarball" + writeUtf8File (repo "thing-1.0.tar.gz") "not really a tarball" withCache [] (fromRepository ("{\"type\":\"local-repo-no-index\",\"path\":\"" <> T.pack repo <> "\"}")) @@ -625,30 +677,37 @@ describe "and where it was remembered" $ do it "is not asked again where the plan's tarballs are there" $ - withRemembered True $ \root asked found -> do + withRemembered True [] $ \root asked found -> do asked `shouldBe` [] found `shouldBe` [root "hackage.haskell.org/thing/1.0/thing-1.0.tar.gz"] it "is asked again where a tarball of the plan is not there" $ - withRemembered False $ \_ asked _ -> + withRemembered False [] $ \_ asked _ -> asked `shouldBe` ["path"] + it "is not asked again for a tarball fetching did not bring in" $ + withRemembered False ["thing"] $ \_ asked _ -> + asked `shouldBe` [] + -- | Find the tarballs of a plan wanting one package from Hackage, where the -- package cache was remembered to be a directory of its own, holding the --- tarball or not, and hand over the directory, the commands the stand-in --- for @cabal@ was given, and where each tarball was found. +-- tarball or not, and a fetch was remembered not to bring in the packages +-- given, and hand over the directory, the commands the stand-in for +-- @cabal@ was given, and where each tarball was found. withRemembered :: Bool -> + [Text] -> (FilePath -> [String] -> [FilePath] -> Expectation) -> Expectation -withRemembered holding act = +withRemembered holding refused act = withSystemTempDirectory "tilia-remembered" $ \root -> do let at = root "hackage.haskell.org" "thing" "1.0" when holding $ do createDirectoryIfMissing True at - T.writeFile (at "thing-1.0.tar.gz") "not really a tarball" + writeUtf8File (at "thing-1.0.tar.gz") "not really a tarball" cache <- openCache (Do #useCache) (PlanToken (T.pack (takeBaseName root))) storePackageCache cache root + storeFutileFetch cache refused withTempProject (Just (fromRepository hackage)) $ \dir -> readBuildPlan (planPathFor dir) >>= \case Left why -> expectationFailure (T.unpack why) @@ -709,43 +768,14 @@ <> "\",\"pkg-src\":{\"type\":\"repo-tar\",\"repo\":\ \{\"type\":\"secure-repo\",\"uri\":\"http://hackage.haskell.org/\"}}}" --- | A project with one local module declaring @infixl 6 <+>@, and a plan --- for it kept outside of it that names the project relatively, as --- @haskell.nix@ writes it, along with the other entries given. +-- | 'withOpsProject' with the other entries of the plan given, and a cache +-- of its own. withGivenPlan :: [Text] -> (FilePath -> FilePath -> Expectation) -> Expectation withGivenPlan others act = - withSystemTempDirectory "tilia-given" $ \dir -> do - let project = dir "project" - planFile = dir "elsewhere" "plan.json" - createDirectoryIfMissing True (project "src") - createDirectoryIfMissing True (takeDirectory planFile) - T.writeFile (project "fake.cabal") $ - T.unlines - [ "cabal-version: 2.4", - "name: fake", - "version: 0.1.0.0", - "library", - " exposed-modules: Ops", - " hs-source-dirs: src", - " default-language: Haskell2010" - ] - T.writeFile (project "src" "Ops.hs") $ - T.unlines - [ "module Ops ((<+>)) where", - "infixl 6 <+>", - "(<+>) :: a -> a -> a", - "(<+>) = const" - ] - T.writeFile planFile $ - "{\"compiler-id\":\"ghc-0.0\",\"install-plan\":[" - <> T.intercalate - "," - ( "{\"pkg-name\":\"fake\",\"pkg-version\":\"0.1.0.0\",\ - \\"pkg-src\":{\"type\":\"local\",\"path\":\"./.\"}}" - : others - ) - <> "]}" - withEnvironment [("XDG_CACHE_HOME", dir "cache")] (act project planFile) + withOpsProject [] others $ \project planFile -> + withEnvironment + [("XDG_CACHE_HOME", takeDirectory project "cache")] + (act project planFile) -- | The @cabal@ commands something runs, as told by a stand-in put first -- on the path that fails, and what it came to. @@ -782,7 +812,7 @@ withIndexIn :: FilePath -> IO () withIndexIn root = do createDirectoryIfMissing True (root "hackage.haskell.org") - T.writeFile (root "hackage.haskell.org" "01-index.tar") "" + writeUtf8File (root "hackage.haskell.org" "01-index.tar") "" -- | Run something on where @plannedTarballs@ looked, against a package -- cache holding the entries given. @@ -800,7 +830,7 @@ withEnvironment [("CABAL_DIR", cabalDir)] $ withSystemTempDirectory "tilia-repo-plan" $ \dir -> do createDirectoryIfMissing True (takeDirectory (planPathFor dir)) - T.writeFile (planPathFor dir) planText + writeUtf8File (planPathFor dir) planText readBuildPlan (planPathFor dir) >>= \case Left why -> expectationFailure (T.unpack why) Right plan -> @@ -818,7 +848,7 @@ T.unpack held T.unpack version createDirectoryIfMissing True at - T.writeFile + writeUtf8File (at T.unpack (held <> "-" <> version <> ".tar.gz")) "not really a tarball" @@ -890,7 +920,7 @@ withFakeCheckout clones act = withSystemTempDirectory "tilia-checkout" $ \dir -> do createDirectoryIfMissing True (takeDirectory (planPathFor dir)) - T.writeFile (planPathFor dir) fromAGitRepository + writeUtf8File (planPathFor dir) fromAGitRepository traverse_ (unpack dir) clones withEnvironment [("XDG_CACHE_HOME", dir "cache")] (act dir) where @@ -898,8 +928,10 @@ let at = dir "dist-newstyle" "src" named belongsTo = takeWhile (/= '-') named createDirectoryIfMissing True (at "src" "Private") - T.writeFile (at belongsTo <> ".cabal") (describing (T.pack belongsTo) version) - T.writeFile (at "src" "Private" "Ops.hs") privateOps + writeUtf8File + (at belongsTo <> ".cabal") + (describing (T.pack belongsTo) version) + writeUtf8File (at "src" "Private" "Ops.hs") privateOps describing named' version = T.unlines [ "cabal-version: 2.4", @@ -1001,6 +1033,16 @@ it "says nothing about a module given an interface of another" $ do resolver <- newResolverFrom (\_ -> given "Ops") fixitiesOf resolver "Facade" `shouldReturn` Nothing + + it "gives no fixity of a class to a module passing on its methods" $ do + resolver <- newResolverFrom given + fixitiesOf resolver "Methods" `shouldReturn` Just Map.empty + + it "copies a fixity passed on in the namespace it is passed on in" $ do + resolver <- newResolverFrom given + fixitiesOf resolver "Terms" + `shouldReturn` Just + (Map.singleton (InTerms, OpName "+++") (Fixity RightAssoc 5)) where plus = Map.singleton (InTerms, OpName "<+>") (Fixity RightAssoc 5) given m = pure (Map.lookup m interfaces) @@ -1019,8 +1061,49 @@ hiExports = [Avail (HiName "Ops" InTerms (OpName "<+>"))], hiFixities = [] } + ), + ( "Classes", + HiFile + { hiModule = "Classes", + hiExports = + [ AvailTC + (inClasses InTypes ":<:") + [inClasses InTypes ":<:", inClasses InTerms "inj"] + ], + hiFixities = [(InTypes, OpName ":<:", Fixity RightAssoc 4)] + } + ), + ( "Methods", + HiFile + { hiModule = "Methods", + hiExports = + [AvailTC (inClasses InTypes ":<:") [inClasses InTerms "inj"]], + hiFixities = [] + } + ), + ( "Both", + HiFile + { hiModule = "Both", + hiExports = + [ Avail (inBoth InTerms "+++"), + AvailTC (inBoth InTypes "+++") [inBoth InTypes "+++"] + ], + hiFixities = + [ (InTerms, OpName "+++", Fixity RightAssoc 5), + (InTypes, OpName "+++", Fixity LeftAssoc 6) + ] + } + ), + ( "Terms", + HiFile + { hiModule = "Terms", + hiExports = [Avail (inBoth InTerms "+++")], + hiFixities = [] + } ) ] + inClasses namespace = HiName "Classes" namespace . OpName + inBoth namespace = HiName "Both" namespace . OpName -- | A module of the project's own, which an earlier run has read. readBefore :: Spec @@ -1035,7 +1118,8 @@ it "is read again once its text has changed" $ withFakePlan [("src/Ops.hs", declaring "infixl 6")] $ \plan -> do _ <- newResolver plan >>= (`fixitiesOf` "Ops") - traverse_ (\dir -> T.writeFile (dir "src" "Ops.hs") (declaring "infixr 2")) (localDirsOf plan) + for_ (localDirsOf plan) $ \dir -> + writeUtf8File (dir "src" "Ops.hs") (declaring "infixr 2") newResolver plan >>= (`fixitiesOf` "Ops") >>= (`shouldBe` Just (Map.singleton (InTerms, OpName "<+>") (Fixity RightAssoc 2))) @@ -1860,7 +1944,7 @@ act dir writePlan :: FilePath -> Text -> IO () -writePlan dir = T.writeFile (planPathFor dir) +writePlan dir = writeUtf8File (planPathFor dir) -- | A project whose @.cabal@ file changed after its plan was written, under -- a plan of its own, so that what it leaves in the cache is its own. @@ -1875,7 +1959,7 @@ \\"pkg-src\":{\"type\":\"local\",\"path\":\"/nowhere\"}}]}" now <- getCurrentTime setModificationTime (planPathFor dir) (addUTCTime (-60) now) - T.writeFile (dir "thing.cabal") "" + writeUtf8File (dir "thing.cabal") "" setModificationTime (dir "thing.cabal") (addUTCTime (-30) now) act dir @@ -2056,7 +2140,7 @@ if any ((".cabal" `Data.List.isSuffixOf`) . fst) sources then pure () else - T.writeFile (dir "fake.cabal") $ + writeUtf8File (dir "fake.cabal") $ T.unlines [ "cabal-version: 2.4", "name: fake", @@ -2066,8 +2150,8 @@ " hs-source-dirs: src", " default-language: Haskell2010" ] - traverse_ (\(path, text) -> T.writeFile (dir path) text) sources - T.writeFile (dir "plan.json") $ + traverse_ (\(path, text) -> writeUtf8File (dir path) text) sources + writeUtf8File (dir "plan.json") $ "{\"compiler-id\":\"ghc-0.0\",\"install-plan\":\ \[{\"pkg-name\":\"fake\",\"pkg-version\":\"0.1.0.0\",\ \\"pkg-src\":{\"type\":\"local\",\"path\":\"" @@ -2104,7 +2188,7 @@ writeTarball tarball $ (held T.unpack name <> ".cabal", cabal) : [(held path, text) | (path, text) <- sources] - T.writeFile (dir "plan.json") plan + writeUtf8File (dir "plan.json") plan withEnvironment [("CABAL_DIR", dir), ("XDG_CACHE_HOME", dir "cache")] $ readBuildPlan (dir "plan.json") >>= \case Left why -> error (T.unpack why) diff --git a/tests/Tilia/FixitySpec.hs b/tests/Tilia/FixitySpec.hs --- a/tests/Tilia/FixitySpec.hs +++ b/tests/Tilia/FixitySpec.hs @@ -20,7 +20,7 @@ import Tilia.Fixity import Tilia.Parser import Tilia.Span (spanStartColumn, spanStartLine) -import Tilia.TestUtils (parsed, unreadOnly) +import Tilia.TestUtils (inBothNamespaces, parsed, unreadOnly) spec :: Spec spec = do @@ -143,6 +143,10 @@ fmap snd (unsettledIn "module M where\nimport Terms\nimport Other.Terms\nf a b = a :> b\n") `shouldBe` [Ambiguous termsDisagreeing] + it "declines a type that writes a constructor they disagree about" $ + fmap snd (unsettledIn "module M where\nimport Terms\nimport Other.Terms\ntype T = Int :> Int\n") + `shouldBe` [Ambiguous termsDisagreeing] + describe "what a module says it exports" $ do it "has nothing to say about a module with no export list" $ exportsOfSource "module M where\nf = 1\n" `shouldBe` Nothing @@ -241,6 +245,22 @@ it "passes over every one for a name the module defines itself" $ lookupFixity (fullScope definesItsOwn) InTerms Nothing (OpName "clamp") `shouldBe` Resolved defaultFixity ReportDefault + + it "passes over every one for a name an as-pattern binds" $ + lookupFixity + (fullScope "module M where\nimport Opaque\nplus@_ = (+)\n") + InTerms + Nothing + (OpName "plus") + `shouldBe` Resolved defaultFixity ReportDefault + + it "still blames one for a name bound inside the function of a view pattern" $ + lookupFixity + (fullScope "{-# LANGUAGE ViewPatterns #-}\nmodule M where\nimport Opaque\n((\\clamp -> clamp) -> n) = 1\n") + InTerms + Nothing + (OpName "clamp") + `shouldBe` Unresolved (unreadOnly "Opaque") it "passes over every one for a use under the module's own name" $ lookupFixity (fullScope definesItsOwn) InTerms (Just "M") (OpName "clamp") diff --git a/tests/Tilia/IgnoreSpec.hs b/tests/Tilia/IgnoreSpec.hs --- a/tests/Tilia/IgnoreSpec.hs +++ b/tests/Tilia/IgnoreSpec.hs @@ -5,12 +5,11 @@ import Data.Map.Strict qualified as Map import Data.Text (Text) -import Data.Text.IO qualified as T -import System.Directory (canonicalizePath, createDirectoryIfMissing) import System.FilePath (splitDirectories, takeDirectory, ()) -import System.IO.Temp (withSystemTempDirectory) import Test.Hspec import Tilia.Ignore +import Tilia.TestUtils (underAsciiLocale, withFiles) +import Tilia.Utils (writeUtf8File) spec :: Spec spec = do @@ -91,6 +90,14 @@ isIgnoredInProject root (root "src" "inner" ".." "Generated.hs") `shouldReturn` True isIgnoredInProject root (root "src" "New.hs") `shouldReturn` False + it "is ignored by a .tiliaignore that is not ASCII under any locale" $ + withProject $ \root -> do + writeUtf8File (root ".tiliaignore") $ + "# generated code — do not format\nsrc/Generated.hs\n" + let generated = root "src" "Generated.hs" + underAsciiLocale (isIgnoredInProject root generated) + `shouldReturn` True + it "is not ignored when it is outside of the project" $ withProject $ \root -> isIgnoredInProject root (takeDirectory root "Generated.hs") `shouldReturn` False @@ -98,16 +105,12 @@ -- | A project with @src/Generated.hs@, which its root's @.tiliaignore@ -- ignores, and a @.tiliaignore@ in @src/inner@ ignoring boot files. withProject :: (FilePath -> Expectation) -> Expectation -withProject act = - withSystemTempDirectory "tilia-ignore" $ \dir -> do - root <- canonicalizePath dir - let write path text = do - createDirectoryIfMissing True (takeDirectory (root path)) - T.writeFile (root path) text - write ".tiliaignore" "src/Generated.hs\n" - write ("src" "Generated.hs") "module Generated where\n" - write ("src" "inner" ".tiliaignore") "*.hs-boot\n" - act root +withProject = + withFiles + [ (".tiliaignore", "src/Generated.hs\n"), + ("src" "Generated.hs", "module Generated where\n"), + ("src" "inner" ".tiliaignore", "*.hs-boot\n") + ] -- | Check which of the paths a single ignore file at the root ignores. ignores :: Text -> [FilePath] -> [FilePath] -> Expectation diff --git a/tests/Tilia/PragmaSpec.hs b/tests/Tilia/PragmaSpec.hs --- a/tests/Tilia/PragmaSpec.hs +++ b/tests/Tilia/PragmaSpec.hs @@ -3,10 +3,27 @@ -- | What a module's pragmas say, read off the text. module Tilia.PragmaSpec (spec) where +import Data.Map.Strict (Map) +import Data.Set qualified as Set import Data.Text (Text) +import Data.Text qualified as T +import GHC.Data.EnumSet qualified as EnumSet +import GHC.Driver.Session + ( Language (..), + OnOff (..), + extensionFlags, + fLangFlags, + flagSpecName, + glasgowExtsFlags, + languageExtensions, + xFlags, + ) import GHC.LanguageExtensions.Type (Extension (..)) import Test.Hspec +import Test.Hspec.QuickCheck (modifyMaxSuccess) +import Test.QuickCheck import Tilia.Pragma +import Tilia.Pragma.Ghc (InForce (..), inForceAfter, readFlags) spec :: Spec spec = do @@ -19,7 +36,10 @@ ("one written without spaces", "{-#LINE 1 \"Other.hs\"#-}\n"), ("one written over several lines", "{-# LINE 1\n \"Other.hs\" #-}\n"), ("one below the header", "module M where\nx = 1\n{-# LINE 9 \"O.hs\" #-}\n"), - ("one among pragmas that do not move anything", langThenLine) + ("one among pragmas that do not move anything", langThenLine), + ( "one after a character literal holding a double quote", + "module M where\nq = '\"'\n{-# LINE 9 \"O.hs\" #-}\n" + ) ] (\source -> movesPositions source `shouldBe` True) @@ -30,51 +50,167 @@ ("an INLINE pragma", "module M where\n{-# INLINE f #-}\nf = id\n"), ("a pragma whose name merely starts with one", "{-# LINEAR 1 #-}\n"), ("an unclosed pragma", "{-# LINE 1 \"Other.hs\"\n"), - ("the word in a comment", "-- {-* LINE 1 *-}\nmodule M where\n") + ("the word in a comment", "-- {-* LINE 1 *-}\nmodule M where\n"), + ("one in a string", "module M where\nx = \"{-# LINE 1 #-}\"\n"), + ( "one in a string after a character literal holding a double quote", + "module M where\nq = '\"'\nx = \"{-# LINE 1 #-}\"\n" + ), + ( "one in a string after a character literal holding an escaped one", + "module M where\nq = '\\\"'\nx = \"{-# LINE 1 #-}\"\n" + ), + ( "one in a string after a name ending in a prime", + "module M where\nx = f'\"'\"\ny = \"{-# LINE 1 #-}\"\n" + ) ] (\source -> movesPositions source `shouldBe` False) describe "the extensions in force" $ do it "keeps what the package puts in force" $ - effectiveExtensions [ImplicitPrelude, GADTs] "module M where\n" + inForceUnder [ImplicitPrelude, GADTs] "module M where\n" `shouldBe` [ImplicitPrelude, GADTs] it "reads one extension" $ - effectiveExtensions [] "{-# LANGUAGE BangPatterns #-}\nmodule M where\n" + inForceUnder [] "{-# LANGUAGE BangPatterns #-}\nmodule M where\n" `shouldBe` [BangPatterns] it "reads several from one pragma" $ - effectiveExtensions + inForceUnder [] - "{-# LANGUAGE GADTs, RankNTypes #-}\nmodule M where\n" - `shouldBe` [GADTs, RankNTypes] + "{-# LANGUAGE LambdaCase, MagicHash #-}\nmodule M where\n" + `shouldBe` [LambdaCase, MagicHash] it "reads several pragmas" $ - effectiveExtensions + inForceUnder [] - "{-# LANGUAGE GADTs #-}\n{-# LANGUAGE MagicHash #-}\n" - `shouldBe` [GADTs, MagicHash] - it "ignores other pragmas" $ + "{-# LANGUAGE LambdaCase #-}\n{-# LANGUAGE MagicHash #-}\n" + `shouldBe` [LambdaCase, MagicHash] + it "ignores flags that turn on no extension" $ + inForceUnder + [] + "{-# OPTIONS_GHC -Wall #-}\n{-# LANGUAGE LambdaCase #-}\n" + `shouldBe` [LambdaCase] + it "reads the -X flags of OPTIONS_GHC" $ + inForceUnder + [GADTs] + "{-# OPTIONS_GHC -Wall -XLambdaCase -XNoGADTs #-}\nmodule M where\n" + `shouldBe` [LambdaCase] + it "reads the flags of OPTIONS" $ + inForceUnder [] "{-# OPTIONS -XLambdaCase #-}\n" + `shouldBe` [LambdaCase] + it "reads the flags of an options pragma as GHC splits them" $ + inForceUnder [] "{-# OPTIONS_GHC \"-XLambdaCase\" #-}\n" + `shouldBe` [LambdaCase] + it "reads -cpp as turning on CPP" $ + inForceUnder [] "{-# OPTIONS_GHC -cpp #-}\n" + `shouldBe` [Cpp] + it "reads the old -f spellings of extensions" $ + inForceUnder + [ImplicitPrelude] + "{-# OPTIONS_GHC -fbang-patterns -fno-implicit-prelude #-}\n" + `shouldBe` [BangPatterns] + it "reads -fglasgow-exts as turning on what it stands for" $ + inForceUnder [] "{-# OPTIONS_GHC -fglasgow-exts #-}\n" + `shouldSatisfy` \es -> all (`elem` es) glasgowExtsFlags + it "reads -fno-glasgow-exts as turning that off again" $ + inForceUnder + [] + "{-# OPTIONS_GHC -fglasgow-exts -fno-glasgow-exts #-}\n" + `shouldSatisfy` not . any (`elem` glasgowExtsFlags) + it "reads the pragmas in the order they are written" $ + inForceUnder + [] + ( "{-# LANGUAGE LambdaCase #-}\n" + <> "{-# OPTIONS_GHC -XNoLambdaCase -XMagicHash #-}\n" + <> "{-# LANGUAGE NoMagicHash #-}\n" + ) + `shouldBe` [] + it "reads the names of a language pragma past the comments in it" $ + inForceUnder + [] + "{-# LANGUAGE\n LambdaCase -- for f\n , {- c -} MagicHash\n #-}\nmodule M where\n" + `shouldBe` [LambdaCase, MagicHash] + it "ignores a pragma below the module line, which GHC does not read" $ + inForceUnder [] "module M where\n{-# LANGUAGE LambdaCase #-}\n" + `shouldBe` [] + it "reads the pragmas between the directives of a header" $ + inForceUnder + [] + "{-# LANGUAGE CPP #-}\n#if 1\n{-# LANGUAGE LambdaCase #-}\n#endif\nmodule M where\n" + `shouldBe` [Cpp, LambdaCase] + it "takes an edition the module names in place of the component's" $ + inForceUnder + (languageExtensions (Just Haskell2010)) + "{-# LANGUAGE GHC2024 #-}\nmodule M where\n" + `shouldBe` languageExtensions (Just GHC2024) + it "keeps what the component switches on top of the module's edition" $ effectiveExtensions + (defaultsOf (languageExtensions (Just Haskell2010)) [On OverloadedStrings]) + "{-# LANGUAGE GHC2021 #-}\nmodule M where\n" + `shouldSatisfy` \es -> all (`elem` es) [OverloadedStrings, ImportQualifiedPost] + it "switches what the module switches on top of its edition, wherever named" $ + inForceUnder [] - "{-# OPTIONS_GHC -Wall #-}\n{-# LANGUAGE GADTs #-}\n" - `shouldBe` [GADTs] + "{-# LANGUAGE NoLambdaCase #-}\n{-# LANGUAGE GHC2024 #-}\nmodule M where\n" + `shouldSatisfy` notElem LambdaCase + it "takes the edition named last" $ + inForceUnder + [] + "{-# LANGUAGE GHC2024 #-}\n{-# LANGUAGE Haskell2010 #-}\nmodule M where\n" + `shouldBe` languageExtensions (Just Haskell2010) + it "reads an edition from a -X flag" $ + inForceUnder [] "{-# OPTIONS_GHC -XGHC2024 #-}\nmodule M where\n" + `shouldBe` languageExtensions (Just GHC2024) + it "ignores the options of other compilers" $ + inForceUnder [] "{-# OPTIONS_JHC -fffi -cpp #-}\n" + `shouldBe` [] it "ignores an unknown extension rather than failing" $ - effectiveExtensions [] "{-# LANGUAGE GADTs, NotARealExtension #-}\n" - `shouldBe` [GADTs] + inForceUnder [] "{-# LANGUAGE LambdaCase, NotARealExtension #-}\n" + `shouldBe` [LambdaCase] it "treats a No-prefix as turning one off" $ - effectiveExtensions + inForceUnder [ImplicitPrelude] "{-# LANGUAGE NoImplicitPrelude #-}\n" `shouldBe` [] it "lets a module refuse what its package put in force" $ - effectiveExtensions [ImplicitPrelude, GADTs] "{-# LANGUAGE NoGADTs #-}\n" + inForceUnder [ImplicitPrelude, GADTs] "{-# LANGUAGE NoGADTs #-}\n" `shouldBe` [ImplicitPrelude] it "lets a module take back a Prelude its package turned off" $ - effectiveExtensions [GADTs] "{-# LANGUAGE ImplicitPrelude #-}\n" + inForceUnder [GADTs] "{-# LANGUAGE ImplicitPrelude #-}\n" `shouldBe` [GADTs, ImplicitPrelude] it "does not repeat an extension named twice" $ - effectiveExtensions + inForceUnder [] - "{-# LANGUAGE GADTs #-}\n{-# LANGUAGE GADTs #-}\n" - `shouldBe` [GADTs] + "{-# LANGUAGE LambdaCase #-}\n{-# LANGUAGE LambdaCase #-}\n" + `shouldBe` [LambdaCase] + it "turns on what an extension implies, as GHC does" $ + inForceUnder [] "{-# LANGUAGE RankNTypes #-}\n" + `shouldBe` [RankNTypes, ExplicitForAll] + it "turns off what an extension implies is off" $ + inForceUnder + [ImplicitPrelude] + "{-# LANGUAGE RebindableSyntax #-}\n" + `shouldBe` [RebindableSyntax] + it "leaves on what an extension turned off had implied" $ + inForceUnder [] "{-# LANGUAGE RankNTypes, NoRankNTypes #-}\n" + `shouldBe` [ExplicitForAll] + it "lets a later name turn off what an earlier one implied" $ + inForceUnder [] "{-# LANGUAGE RankNTypes, NoExplicitForAll #-}\n" + `shouldBe` [RankNTypes] + modifyMaxSuccess (const 5000) . describe "against GHC's own flag reader" $ do + it "leaves on what GHC leaves on" $ + forAll (listOf1 (pragmaOf headerNames)) $ \pragmas -> + let ours = + effectiveExtensions + (defaultsOf (languageExtensions Nothing) []) + (headerOf pragmas) + theirs = + EnumSet.toList (extensionFlags (readFlags (concatMap flagsOf pragmas))) + in counterexample (T.unpack (headerOf pragmas)) $ + Set.fromList ours === Set.fromList theirs + it "takes two orders to be alike where GHC switches alike" $ + forAll (listOf1 (pragmaOf extensionNames)) $ \pragmas -> + forAll (shuffle pragmas) $ \shuffled -> + counterexample (T.unpack (headerOf pragmas <> headerOf shuffled)) $ + sameInForce (fmap namedBody pragmas) (fmap namedBody shuffled) + === (ghcSwitches pragmas == ghcSwitches shuffled) + describe "lookupExtension" $ do it "knows an extension by the name one writes" $ lookupExtension "LambdaCase" `shouldBe` Just LambdaCase @@ -87,3 +223,56 @@ langThenLine :: Text langThenLine = "{-# LANGUAGE LambdaCase #-}\nmodule M where\n{-# LINE 3 \"O.hs\" #-}\n" + +-- | The extensions in force in a module of a component whose edition puts +-- these in force and which switches nothing itself. +inForceUnder :: [Extension] -> Text -> [Extension] +inForceUnder edition = effectiveExtensions (defaultsOf edition []) + +-- | A pragma of a header, as its name and its body, with the flags it hands +-- GHC. +type HeaderPragma = (Text, Text, [Text]) + +-- | A pragma that names one of these, or spells an extension as an old flag. +pragmaOf :: [Text] -> Gen HeaderPragma +pragmaOf names = oneof [language, options] + where + language = do + name <- elements names + pure ("LANGUAGE", name, ["-X" <> name]) + options = do + flag <- elements oldFlags + pure ("OPTIONS_GHC", flag, [flag]) + oldFlags = + ["-cpp", "-fglasgow-exts", "-fno-glasgow-exts"] + <> concat + [ ["-f" <> name, "-fno-" <> name] + | name <- T.pack . flagSpecName <$> fLangFlags + ] + +-- | Every name of an extension, with @No@ in front and without. +extensionNames :: [Text] +extensionNames = names <> fmap ("No" <>) names + where + names = T.pack . flagSpecName <$> xFlags + +-- | Every name a @LANGUAGE@ pragma can hold: the extensions and the editions. +headerNames :: [Text] +headerNames = + extensionNames <> [T.pack (show l) | l <- [minBound .. maxBound :: Language]] + +-- | A module of nothing but a header of these pragmas. +headerOf :: [HeaderPragma] -> Text +headerOf pragmas = + T.concat ["{-# " <> n <> " " <> b <> " #-}\n" | (n, b, _) <- pragmas] + <> "module M where\n" + +flagsOf :: HeaderPragma -> [Text] +flagsOf (_, _, flags) = flags + +namedBody :: HeaderPragma -> (Text, Text) +namedBody (n, b, _) = (n, b) + +-- | How GHC takes these pragmas to switch each extension. +ghcSwitches :: [HeaderPragma] -> Map Extension Bool +ghcSwitches = inForceSwitches . inForceAfter . concatMap flagsOf diff --git a/tests/Tilia/RunSpec.hs b/tests/Tilia/RunSpec.hs --- a/tests/Tilia/RunSpec.hs +++ b/tests/Tilia/RunSpec.hs @@ -30,7 +30,7 @@ import Tilia.Format (FormatError (..), formatErrorExitCode, refused) import Tilia.Palette (Color (Bad), Palette (..)) import Tilia.Run -import Tilia.Utils (inParallel, lineWidth, visibleLength, wrapTo) +import Tilia.Utils (inParallel, lineWidth, visibleLength, wrapTo, writeUtf8File) spec :: Spec spec = do @@ -52,9 +52,10 @@ NoProject "A.hs", NoBuildPlan "." "cabal said no", NotEquivalent "A.hs" "f = 1 became f = 2", - NotIdempotent "A.hs" "line 12 differs" + NotIdempotent "A.hs" "line 12 differs", + Threw "A.hs" "boom" ] - `shouldBe` [False, False, False, False, False, False] + `shouldBe` [False, False, False, False, False, False, False] describe "what became of a file" $ do it "counts a rewrite as a difference and nothing else" $ @@ -453,6 +454,10 @@ it "copes with having nothing to do" $ inParallel pure ([] :: [Int]) `shouldReturn` [] + it "passes on what one of them throws rather than waiting for it" $ + inParallel (\n -> if n == 3 then error "boom" else pure n) [1 .. 8 :: Int] + `shouldThrow` errorCall "boom" + it "really does run them at once" $ do capabilities <- getNumCapabilities let rounds = ceiling (20 / fromIntegral capabilities :: Double) :: Int @@ -479,7 +484,7 @@ withSource contents act = withSystemTempDirectory "tilia-run" $ \directory -> do let path = directory "A.hs" - T.writeFile path contents + writeUtf8File path contents act path -- | The same, for a file that has to hold exactly these bytes. diff --git a/tests/Tilia/SpanSpec.hs b/tests/Tilia/SpanSpec.hs new file mode 100644 --- /dev/null +++ b/tests/Tilia/SpanSpec.hs @@ -0,0 +1,33 @@ +-- | The span algebra. +module Tilia.SpanSpec (spec) where + +import Test.Hspec +import Test.QuickCheck +import Tilia.Gen (AnySpan (..)) +import Tilia.Span + +spec :: Spec +spec = do + it "recognises a single-line span" $ + isSingleLine (mkSpan (3, 1) (3, 40)) `shouldBe` True + it "recognises a multi-line span" $ + isSingleLine (mkSpan (3, 1) (4, 1)) `shouldBe` False + it "unions to cover both operands" $ + mkSpan (1, 5) (1, 9) <> mkSpan (3, 2) (4, 1) + `shouldBe` mkSpan (1, 5) (4, 1) + it "takes the earlier start column when starts share a line" $ + mkSpan (1, 9) (1, 20) <> mkSpan (1, 3) (1, 5) + `shouldBe` mkSpan (1, 3) (1, 20) + + it "unions associatively" $ + property $ \(AnySpan a) (AnySpan b) (AnySpan c) -> + (a <> b) <> c === a <> (b <> c) + + it "unions to something covering both operands" $ + property $ \(AnySpan a) (AnySpan b) -> + let u = a <> b + in counterexample (show u) (covers u a && covers u b) + + it "is idempotent under union" $ + property $ + \(AnySpan a) -> a <> a === a diff --git a/tests/Tilia/TestConfig.hs b/tests/Tilia/TestConfig.hs --- a/tests/Tilia/TestConfig.hs +++ b/tests/Tilia/TestConfig.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} @@ -16,7 +15,6 @@ import Data.Map.Strict qualified as Map import Data.Set qualified as Set import Data.Text (Text) -import GHC.LanguageExtensions.Type (Extension) import Tilia.BootFixities (bootFixities) import Tilia.Cpp (CppError, everyBranch, formatWithCpp) import Tilia.Doc (printDoc) @@ -30,19 +28,19 @@ Provenance (..), Reach (..), Scope (..), - inBothNamespaces, operatorsUsed, resolveScope, unreadable, ) import Tilia.Parser (ParsedModule (..)) +import Tilia.Pragma (Defaults) import Tilia.Render (RenderConfig (..), defaultRenderConfig, renderModule) -import Tilia.TestUtils (effectiveExtensionsFor, parserConfigFor) +import Tilia.TestUtils (effectiveExtensionsFor, inBothNamespaces, parserConfigFor) -- | How to format one corpus example. exampleRenderConfig :: -- | What the package around it puts in force, if it is a module of one. - Maybe [Extension] -> + Maybe Defaults -> Text -> -- | Its configurations, parsed. NonEmpty ParsedModule -> @@ -81,7 +79,7 @@ -- | Print a corpus example that does not use the preprocessor. printExample :: -- | What the package around it puts in force, if it is a module of one. - Maybe [Extension] -> + Maybe Defaults -> Text -> -- | It, parsed. ParsedModule -> @@ -93,7 +91,7 @@ -- | Format a corpus example that uses the preprocessor. formatCppExample :: -- | What the package around it puts in force, if it is a module of one. - Maybe [Extension] -> + Maybe Defaults -> FilePath -> Text -> Either CppError Text diff --git a/tests/Tilia/TestUtils.hs b/tests/Tilia/TestUtils.hs --- a/tests/Tilia/TestUtils.hs +++ b/tests/Tilia/TestUtils.hs @@ -1,16 +1,23 @@ -{-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternSynonyms #-} -- | Helpers several specs share. module Tilia.TestUtils ( withEnvironment, + withFiles, + withOpsProject, + switchedOn, + underAsciiLocale, parserConfigFor, defaultParserConfig, effectiveExtensionsFor, parsed, + parses, commentsIn, + haskellFilesIn, unreadOnly, + inBothNamespaces, fingerprint, routedResolver, @@ -28,17 +35,30 @@ import Data.Bits (xor) import Data.Char (ord) import Data.Choice (pattern Do) -import Data.Foldable (traverse_) +import Data.Either (isRight) +import Data.Foldable (for_, traverse_) +import Data.List (isSuffixOf, sort) import Data.List.NonEmpty (NonEmpty (..)) +import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map import Data.Maybe (fromMaybe, isJust, listToMaybe) import Data.Text (Text) import Data.Text qualified as T import Data.Word (Word64) import GHC.Driver.Session qualified as GHC +import GHC.IO.Encoding (getLocaleEncoding, setLocaleEncoding) import GHC.LanguageExtensions.Type (Extension (..)) +import System.Directory + ( canonicalizePath, + createDirectoryIfMissing, + doesDirectoryExist, + listDirectory, + ) import System.Environment (lookupEnv, setEnv, unsetEnv) -import Tilia.Cabal.Package (newPackageReader) +import System.FilePath (takeBaseName, takeDirectory, takeExtension, ()) +import System.IO (mkTextEncoding) +import System.IO.Temp (withSystemTempDirectory) +import Tilia.Cabal.Package (newPackageReader, sourceExtensions) import Tilia.Cabal.Plan (BuildPlan, plannedCompiler) import Tilia.Comments (Comment) import Tilia.Cpp.Directives @@ -52,11 +72,11 @@ implied, nestedIn, readConditionals, - resolved, scanConditionals, unconditionalErrors, + withoutOpaque, ) -import Tilia.Fixity (ModuleChain (..)) +import Tilia.Fixity (Fixities, Fixity, ModuleChain (..), Namespace (..), OpName) import Tilia.Fixity.Plan (Resolver, Route, newResolverVia) import Tilia.Parser ( ParsedModule (..), @@ -64,8 +84,9 @@ describeParseError, parseModule, ) -import Tilia.Pragma (effectiveExtensions) +import Tilia.Pragma (Defaults, defaultsOf, effectiveExtensions) import Tilia.Source (comments) +import Tilia.Utils (quietly, writeUtf8File) -- | Run something with the given variables set, and the environment as it -- was afterwards however it turns out. @@ -79,11 +100,90 @@ pure (key, was) restore = traverse_ (\(key, was) -> maybe (unsetEnv key) (setEnv key) was) +-- | Run something on a new temporary directory, by its canonical path, +-- holding these files at their paths in it. +withFiles :: [(FilePath, Text)] -> (FilePath -> IO a) -> IO a +withFiles files act = + withSystemTempDirectory "tilia" $ \dir -> do + root <- canonicalizePath dir + for_ files $ \(path, text) -> do + createDirectoryIfMissing True (takeDirectory (root path)) + writeUtf8File (root path) text + act root + +-- | Run something on a project of one package, @fake@, whose module @Ops@ +-- declares @infixl 6 <+>@, and on a plan for it kept outside it that names +-- the project relatively, as @haskell.nix@ writes it. +withOpsProject :: + -- | Further files of the project, by their paths in it, each @.hs@ file + -- one more module of the package. + [(FilePath, Text)] -> + -- | Further entries of the plan. + [Text] -> + -- | Given the project's directory and the plan's path. + (FilePath -> FilePath -> IO a) -> + IO a +withOpsProject files others act = + withFiles + ( [ ("project" "fake.cabal", cabal), + ("project" "src" "Ops.hs", ops), + ("elsewhere" "plan.json", plan) + ] + <> [("project" path, text) | (path, text) <- files] + ) + $ \dir -> act (dir "project") (dir "elsewhere" "plan.json") + where + cabal = + T.unlines + [ "cabal-version: 2.4", + "name: fake", + "version: 0.1.0.0", + "library", + " exposed-modules: " <> T.intercalate ", " ("Ops" : modules), + " hs-source-dirs: src", + " default-language: Haskell2010" + ] + modules = + [ T.pack (takeBaseName path) + | (path, _) <- files, + takeExtension path == ".hs" + ] + ops = + T.unlines + [ "module Ops ((<+>)) where", + "infixl 6 <+>", + "(<+>) :: a -> a -> a", + "(<+>) = const" + ] + plan = + "{\"compiler-id\":\"ghc-0.0\",\"install-plan\":[" + <> T.intercalate + "," + ( "{\"pkg-name\":\"fake\",\"pkg-version\":\"0.1.0.0\",\ + \\"pkg-src\":{\"type\":\"local\",\"path\":\"./.\"}}" + : others + ) + <> "]}" + +-- | Is an environment variable set to anything but empty, @0@, @no@ or +-- @false@? +switchedOn :: String -> IO Bool +switchedOn name = + maybe False (`notElem` ["", "0", "no", "false"]) <$> lookupEnv name + +-- | Run something with files opened in ASCII, as under @LANG=C@, and the +-- locale's encoding as it was afterwards however it turns out. +underAsciiLocale :: IO a -> IO a +underAsciiLocale act = do + ascii <- mkTextEncoding "ASCII" + bracket getLocaleEncoding setLocaleEncoding $ \_ -> + setLocaleEncoding ascii >> act + -- | What to parse a module with, given what its package puts in force, or -- 'Nothing' for a module of no package, which is read as GHC2021. -parserConfigFor :: Maybe [Extension] -> ParserConfig +parserConfigFor :: Maybe Defaults -> ParserConfig parserConfigFor = - ParserConfig . fromMaybe (GHC.languageExtensions (Just GHC.GHC2021)) + ParserConfig . fromMaybe (defaultsOf (GHC.languageExtensions (Just GHC.GHC2021)) []) -- | What to parse a module of no package with. defaultParserConfig :: ParserConfig @@ -96,8 +196,8 @@ -- That is less than 'parserConfigFor' reads such a module with, so that -- what is printed, @import qualified@ for one, reads the same under every -- edition. -effectiveExtensionsFor :: Maybe [Extension] -> Text -> [Extension] -effectiveExtensionsFor = effectiveExtensions . fromMaybe [ImplicitPrelude] +effectiveExtensionsFor :: Maybe Defaults -> Text -> [Extension] +effectiveExtensionsFor = effectiveExtensions . fromMaybe (defaultsOf [ImplicitPrelude] []) -- | Parse a module, or stop the test saying why it does not parse. parsed :: Text -> ParsedModule @@ -105,6 +205,20 @@ Left problem -> error (T.unpack (describeParseError problem)) Right m -> m +-- | Does a module parse, with what its own pragmas turn on? +parses :: Text -> Bool +parses = isRight . parseModule defaultParserConfig "M.hs" + +-- | Every file of Haskell source at or under a path, in order. +haskellFilesIn :: FilePath -> IO [FilePath] +haskellFilesIn path = do + isDir <- doesDirectoryExist path + if not isDir + then pure [path | any (`isSuffixOf` path) sourceExtensions] + else do + entries <- sort <$> quietly [] (listDirectory path) + concat <$> traverse (haskellFilesIn . (path )) entries + -- | Every comment in a module. commentsIn :: Text -> [Comment] commentsIn = comments . pmSource . parsed @@ -114,6 +228,15 @@ unreadOnly :: Text -> NonEmpty ModuleChain unreadOnly m = ModuleChain (m :| []) :| [] +-- | Take fixities that say nothing about namespaces to govern both. +inBothNamespaces :: Map OpName Fixity -> Fixities +inBothNamespaces declared = + Map.fromList + [ ((namespace, op), fixity) + | (op, fixity) <- Map.toList declared, + namespace <- [InTypes, InTerms] + ] + -- | FNV-1a, a hash of a string that is the same on every machine and every -- run. fingerprint :: String -> Word64 @@ -125,7 +248,7 @@ -- it reads. routedResolver :: [Route] -> BuildPlan -> IO Resolver routedResolver routes plan = do - packageReader <- newPackageReader (plannedCompiler plan) + packageReader <- newPackageReader (plannedCompiler plan) [] newResolverVia (Do #useCache) routes packageReader plan -- | Split a module on its first outermost conditional, and on every other @@ -187,8 +310,7 @@ 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 + Nothing -> answeredLeaf answers source Just c -> concat <$> traverse @@ -202,21 +324,30 @@ fmap (filter (isJust . implied . Map.toList . fst)) . go Map.empty where go answers source = case configurations source of - Nothing -> (\t -> [(answers, t)]) <$> resolved source + Nothing -> answeredLeaf answers 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 + <*> (concat <$> 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) +-- first branch, and the answers that give it, unless it aborts with +-- @#error@. +answeredBaseline :: Assignment -> Text -> Either CppError [(Assignment, Text)] answeredBaseline answers source = case configurations source of - Nothing -> (answers,) <$> resolved source + Nothing -> answeredLeaf answers source Just c -> case cfgTexts c of - [] -> Right (answers, source) + [] -> Right [(answers, source)] t : _ -> answeredBaseline (Map.insert (cfgGuards c) 0 answers) t + +-- | A module with every conditional answered, and the answers that reach +-- it, unless it aborts with @#error@. +answeredLeaf :: Assignment -> Text -> Either CppError [(Assignment, Text)] +answeredLeaf answers source + | null (unconditionalErrors source) = + [(answers, withoutOpaque source)] <$ readConditionals source + | otherwise = Right [] diff --git a/tilia.cabal b/tilia.cabal --- a/tilia.cabal +++ b/tilia.cabal @@ -1,6 +1,6 @@ cabal-version: 2.4 name: tilia -version: 0.1.2.0 +version: 0.1.3.0 license: BSD-3-Clause license-file: LICENSE.md author: Mark Karpov @@ -25,6 +25,7 @@ extra-doc-files: CHANGELOG.md + HACKING.md README.md source-repository head @@ -36,7 +37,9 @@ default: False manual: True -common common-ghc-options +common shared + default-language: GHC2021 + build-depends: base >=4.20 && <5 ghc-options: -O2 -Wall @@ -50,8 +53,12 @@ -haddock -Winvalid-haddock +common ghc-lib-parser + build-depends: ghc-lib-parser >=9.14 && <9.15 + library - import: common-ghc-options + import: shared + import: ghc-lib-parser exposed-modules: Tilia.Cabal.Package Tilia.Cabal.Plan @@ -94,6 +101,7 @@ Tilia.Palette Tilia.Parser Tilia.Pragma + Tilia.Pragma.Ghc Tilia.Process Tilia.Render Tilia.Render.Class @@ -119,12 +127,10 @@ Tilia.Utils hs-source-dirs: src - default-language: GHC2021 build-depends: - Cabal-syntax >=3.12 && <3.17, + Cabal-syntax >=3.18 && <3.19, aeson >=2.1 && <3, array >=0.5 && <0.6, - base >=4.20 && <5, base16-bytestring >=1 && <2, bytestring >=0.11 && <0.13, choice >=0.2 && <0.3, @@ -133,7 +139,6 @@ deepseq >=1.4 && <1.6, directory ^>=1.3, filepath >=1.4 && <1.6, - ghc-lib-parser >=9.14 && <9.15, process >=1.6 && <1.7, syb >=0.7 && <0.8, tar >=0.6 && <0.8, @@ -143,14 +148,12 @@ zlib >=0.6 && <0.8, executable tilia - import: common-ghc-options + import: shared main-is: Main.hs hs-source-dirs: app other-modules: Paths_tilia autogen-modules: Paths_tilia - default-language: GHC2021 build-depends: - base >=4.20 && <5, bytestring >=0.11 && <0.13, choice >=0.2 && <0.3, directory ^>=1.3, @@ -176,7 +179,8 @@ "-with-rtsopts=-N12 -A32m" test-suite tests - import: common-ghc-options + import: shared + import: ghc-lib-parser type: exitcode-stdio-1.0 main-is: Main.hs build-tool-depends: hspec-discover:hspec-discover >=2 && <3 @@ -219,15 +223,15 @@ Tilia.Render.OperatorSpec Tilia.RenderSpec Tilia.RunSpec + Tilia.SpanSpec Tilia.TestConfig Tilia.TestUtils Tilia.WithProjectPlan - default-language: GHC2021 build-depends: + Cabal-syntax >=3.18 && <3.19, QuickCheck >=2.14 && <3, array >=0.5 && <0.6, - base >=4.20 && <5, base16-bytestring >=1 && <2, bytestring >=0.11 && <0.13, choice >=0.2 && <0.3, @@ -235,7 +239,6 @@ cryptohash-sha256 >=0.11 && <0.12, directory ^>=1.3, filepath >=1.4 && <1.6, - ghc-lib-parser >=9.14 && <9.15, hspec >=2 && <3, http-client >=0.7 && <0.8, req >=3.13 && <4, @@ -252,7 +255,8 @@ "-with-rtsopts=-M8G -N" benchmark bench - import: common-ghc-options + import: shared + import: ghc-lib-parser type: exitcode-stdio-1.0 main-is: Main.hs hs-source-dirs: @@ -270,9 +274,7 @@ Tilia.TestUtils c-sources: bench/cbits/counter.c - default-language: GHC2021 build-depends: - base >=4.20 && <5, base16-bytestring >=1 && <2, bytestring >=0.11 && <0.13, choice >=0.2 && <0.3, @@ -281,12 +283,12 @@ deepseq >=1.4 && <1.6, directory ^>=1.3, filepath >=1.4 && <1.6, - ghc-lib-parser >=9.14 && <9.15, http-client >=0.7 && <0.8, optparse-applicative >=0.14 && <0.20, process >=1.6.12 && <1.7, req >=3.13 && <4, tar >=0.6 && <0.8, + temporary ^>=1.3, text >=2.1 && <3, tilia, zlib >=0.6 && <0.8,