diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,303 @@ +## Tilia 0.1.4.0 + +* An import is resolved first among the modules of the importing file's own + component, as GHC resolves it, so a test suite's own `Utils` gives its + operators their fixities rather than a library's `Utils`, and a module + another component holds no longer stands in for a dependency's module of + that name. [PR 348](https://github.com/mrkkrp/tilia/pull/348). +* A pattern synonym bundled with a type in an export list, as in + `T (E, (:<))`, keeps its fixity, and `T (.., P)` exports every constructor + of `T` with its fixity, rather than the modules importing them taking + these operators for `infixl 9`. + [PR 348](https://github.com/mrkkrp/tilia/pull/348). +* Two runs storing one answer in the cache at once no longer leave it + holding part of the answer, or none, which a later run could take for a + module declaring fewer fixities, or none. + [PR 348](https://github.com/mrkkrp/tilia/pull/348). +* A `cabal.project` that takes its `packages` from a file it imports with + `import:`, directly or through further imports, has those packages + formatted, as `cabal` builds them, rather than being reported as naming no + packages, and an edit to an imported file makes the build plan stale, as + it does for `cabal`. An import from a URL is passed over. + [PR 348](https://github.com/mrkkrp/tilia/pull/348). +* An entry of the `packages` field of a `cabal.project` written with `**`, + as `**/*.cabal`, or with more than one `*` in a name, as `pkgs/*-*`, finds + the packages it finds for `cabal`, rather than none. + [PR 348](https://github.com/mrkkrp/tilia/pull/348). +* `inplace` counts a file it cannot write, such as a read-only one, among + the failed files, says why, and goes on with the rest, printing its + summary and exiting with a code of its own, 20, rather than stopping at + that file with exit code 1, which `check` uses for a file that would + change. [PR 348](https://github.com/mrkkrp/tilia/pull/348). +* A dependency's module is read only from its path under one of the + package's source directories, rather than from any file in its tarball + whose path ends the same way, which could be another module's, and a + source directory written as `src/` or `./src` is found. + [PR 348](https://github.com/mrkkrp/tilia/pull/348). +* `cabal path`, which tells where `cabal` keeps the sources it downloads, + runs in the project's directory rather than in the one Tilia runs in, so a + `remote-repo-cache` set in the project's `cabal.project` is found, as when + `for-editor` formats a file from outside its project, and what it says is + remembered for that project alone. + [PR 348](https://github.com/mrkkrp/tilia/pull/348). +* An operator in a type takes the fixity of the type of its name where one + may be in scope, and that of a promoted constructor only where none can + be, while one written with a tick, as in `':+:`, takes the constructor's. + [PR 348](https://github.com/mrkkrp/tilia/pull/348). +* The constructors of a data instance exported with their family, as in + `F (..)`, keep their fixities. + [PR 348](https://github.com/mrkkrp/tilia/pull/348). +* An operator that one CPP configuration of a module declares a fixity for + and another exports without one is left unsettled, rather than taken to + have the declared fixity in every configuration. + [PR 348](https://github.com/mrkkrp/tilia/pull/348). +* `--check-ast` no longer reports a comment as gained where it is written + under the last import or the `module` line, further left than the comment + at the end of that line, and goes with the code after it. + [PR 348](https://github.com/mrkkrp/tilia/pull/348). +* The diffs `check` prints apply with `git apply` and `patch`: a hunk at the + end of a file no longer shows an empty line after the last one, a file + without a newline at its end gets `\ No newline at end of file`, and + carriage returns are kept, so a file whose formatting changes only its + line endings gets a diff headed with its name. + [PR 348](https://github.com/mrkkrp/tilia/pull/348). +* Only the comment Stack reads its options from, the one at the margin of + the first line, or of the line under the `#!` line, whose first word is + `stack`, is taken for a Stack script header, so a comment such as + `-- stacks of disks` at the top of a module stays an ordinary one rather + than being split from its next line by an empty one. + [PR 348](https://github.com/mrkkrp/tilia/pull/348). +* A Haddock written between `{-` and `-}` that documents nothing has only + the trigger of its first line escaped, rather than a backslash also being + put before anything on its other lines that looks like a trigger. + [PR 348](https://github.com/mrkkrp/tilia/pull/348). +* The lines of a block comment keep their columns against its first line + where tabs indent them, a tab counting up to the next multiple of eight as + GHC counts it, rather than losing or keeping a character of indentation + for each character before the comment. + [PR 348](https://github.com/mrkkrp/tilia/pull/348). +* Foreign libraries are formatted like other components: `check` and + `inplace` take their modules, `for-editor` settles a module's extensions + from the one that holds it, and `flib:NAME` selects one. A target may name + its kind in any of the spellings `cabal` takes, as `library:`, + `foreign-library:`, `executable:`, `test-suite:` or `tst:`, in any case. + [PR 348](https://github.com/mrkkrp/tilia/pull/348). +* Packages are found in a package database, and their interfaces read, where + the database or an import directory has a path holding a space, a comma or + a character outside ASCII, which `ghc-pkg` writes quoted and escaped. + [PR 348](https://github.com/mrkkrp/tilia/pull/348). +* On Windows, an absolute entry of the `packages` field of a `cabal.project` + written with forward slashes, as `C:/proj/lib`, is looked for where it + points rather than under the working directory of its drive, and an entry + written with backslashes can hold a glob. + [PR 348](https://github.com/mrkkrp/tilia/pull/348). +* With a compiler whose interfaces are read through `ghc --show-iface`, one + outside GHC 9.10 to 9.14, a constructor named after its type, such as + `:*:`, gets its fixity rather than none. + [PR 348](https://github.com/mrkkrp/tilia/pull/348). +* A module whose quasi-quotation holds `{-# LINE` or `{-# COLUMN` as text is + formatted rather than declined as one using those pragmas. + [PR 348](https://github.com/mrkkrp/tilia/pull/348). +* Formatting a line with comments at its end takes time linear in the line's + length rather than quadratic: a line of 64,000 characters with 20 block + comments after it took 17.7 seconds to format, and takes 0.3. + [PR 348](https://github.com/mrkkrp/tilia/pull/348). +* A dependency's source that stays missing with no download to blame, such + as one of a package the compiler already has, any source under + `--no-downloads`, or one the fetch for a plan given with `--build-plan` + does not bring in, no longer makes every run ask `cabal` twice where it + keeps sources: it is asked again only after a download leaves a source + missing. The fetch for a plan given with `--build-plan` no longer runs on + every run for a source it does not bring in either. + [PR 348](https://github.com/mrkkrp/tilia/pull/348). +* A `cabal.project`, or a file it imports, that does not parse is reported + as not parsing, with what the parser said, rather than as naming no + packages. [PR 348](https://github.com/mrkkrp/tilia/pull/348). +* A byte order mark at the start of a `.tiliaignore` is skipped, as Git + skips one in a `.gitignore`, rather than being read as part of its first + pattern. [PR 348](https://github.com/mrkkrp/tilia/pull/348). +* A comment lined up with the last line of a construct at the end of a + module, such as under the last binding of a `where` clause, stays under + that line, as it does where code follows, rather than going to the margin + after an empty line. [PR 348](https://github.com/mrkkrp/tilia/pull/348). +* A comment written before the closing bracket of a tuple section, as in + `(x, {- later -})`, stays inside the section rather than moving to the + front of the next declaration, where the module no longer parsed, or under + the whole declaration. [PR 348](https://github.com/mrkkrp/tilia/pull/348). +* Blank lines between implicit-parameter bindings in a `let` or a `where` + are kept, as between value bindings, rather than dropped. + [PR 348](https://github.com/mrkkrp/tilia/pull/348). +* A `case`, a `do` block or another expression that hangs after `>-` stays + on the line of the `>-`, as one after `-<` does, rather than going on a + line of its own under it. + [PR 348](https://github.com/mrkkrp/tilia/pull/348). +* `INLINABLE` pragmas keep the spelling they are written with, `INLINABLE` + or `INLINEABLE`, rather than all coming out as `INLINEABLE`. + [PR 348](https://github.com/mrkkrp/tilia/pull/348). +* `SPECIALISE` pragmas, `SPECIALISE INLINE` and `SPECIALISE instance` + among them, keep the spelling they are written with, `SPECIALISE` or + `SPECIALIZE`, rather than all coming out as `SPECIALIZE`. + [PR 348](https://github.com/mrkkrp/tilia/pull/348). +* An options pragma with no options, such as `{-# OPTIONS_GHC #-}`, comes + out with one space before `#-}` rather than two. + [PR 348](https://github.com/mrkkrp/tilia/pull/348). +* A `cabal` failure other than one to resolve dependencies, such as a + `cabal.project` that does not parse, is printed once rather than twice, as + `cabal` is asked again without the test suites and benchmarks only where + it could not resolve dependencies with them. + [PR 348](https://github.com/mrkkrp/tilia/pull/348). +* Whether what goes to standard error is colored is decided by whether + standard error is a terminal, rather than by whether standard output is, + and a `NO_COLOR` set to the empty string no longer turns colors off, as + no-color.org asks. [PR 348](https://github.com/mrkkrp/tilia/pull/348). +* The summary `inplace` prints is written in the locale's encoding, with + what it cannot show transliterated, as what goes to standard error is, + rather than as UTF-8 whatever the locale. The module `for-editor` prints + and the diffs `check` prints are still UTF-8. + [PR 348](https://github.com/mrkkrp/tilia/pull/348). +* A module declined for an alternative that aborts with `#error` names the + line of the `#error`, where it could name line 0 when the alternative + settled a conditional around the `#error`. + [PR 348](https://github.com/mrkkrp/tilia/pull/348). +* A missing build plan is reported once, as in + `no build plan for /p: nowhere.json does not exist`, rather than as + `no build plan for /p: no build plan at nowhere.json`, and a plan that + does not parse is named. A source file or a `.cabal` file that cannot be + read, and a CPP configuration that does not parse, name their file once + too. [PR 348](https://github.com/mrkkrp/tilia/pull/348). +* `--debug-fixity` lists a fixity a module declares for a type beside the + one it declares for a constructor of the same name, rather than the + constructor's alone. [PR 348](https://github.com/mrkkrp/tilia/pull/348). +* `--debug-fixity` says which namespace each fixity it lists is for, as in + `:. infixr 5 (term)`, and gives an operator one line where its fixity is + the same among types and among terms, as in `:- infix 8 (type & term)`. + [PR 354](https://github.com/mrkkrp/tilia/pull/354). +* A module with a line using a macro, or an `#include`, before a leading + comma is declined, since formatting moves the comma above that line, + where the preprocessor can then make code that does not parse, such as + `[1, 2, , 3 4]`. [PR 355](https://github.com/mrkkrp/tilia/pull/355). +* A braced block written on one line keeps its braces where it ends a bind + or the last argument of an application and a `;` follows, as in + `do { x <- do { a }; pure x }`, rather than coming out as + `do x <- do a; pure x`, which takes `pure x` into the inner block. The + same holds for the body of a `proc`, what follows `-<` or `>-`, the + argument of a command application, and what `static` or an `SCC` pragma + applies to. [PR 355](https://github.com/mrkkrp/tilia/pull/355). +* Declarations written on one line, as in `x = 1; y = 2`, are separated by + one semicolon rather than by `; ;`. + [PR 355](https://github.com/mrkkrp/tilia/pull/355). +* A module without CPP that holds a line marker, as in `#line 40 "M.hs"` or + `# 40 "M.hs"`, or a `#pragma` or `#!` line other than those a script + begins with, is declined, as one with `{-# LINE #-}` pragmas is, rather + than having those lines dropped. + [PR 355](https://github.com/mrkkrp/tilia/pull/355). +* An or-pattern written across lines inside parentheses keeps the + semicolons between its alternatives, rather than coming out as a + constructor applied to the rest. + [PR 355](https://github.com/mrkkrp/tilia/pull/355). +* A block comment of several lines written after the `->` or `=` that opens + a body goes after that token, on lines of its own, rather than before + it, where the token began the next line and the module no longer parsed. + [PR 355](https://github.com/mrkkrp/tilia/pull/355). +* A minus or a backslash is kept apart from an operand beginning with a + symbol character, as in `- ?x`, `- #x`, `- $(x)` and `\ -1 -> 0`, rather + than printed against it, where the two read as one operator. + [PR 355](https://github.com/mrkkrp/tilia/pull/355). +* A quotation whose body may end with a symbol character, as that of + `[d| infixl 6 +++ |]` or `[| x :: Proxy * |]` may, keeps the body apart + from its brackets, in typed quotations too, rather than coming out as + `[d|infixl 6 +++|]`, where `+++|` lexes as one operator. + [PR 355](https://github.com/mrkkrp/tilia/pull/355). +* A parenthesised command broken over several lines in an arrow `do` block + closes its bracket one step in, rather than at the column of the block, + where the module no longer parsed. + [PR 355](https://github.com/mrkkrp/tilia/pull/355). +* An export list item naming a whole module keeps the keyword `module` in a + signature, rather than coming out as `signature Prelude`. + [PR 355](https://github.com/mrkkrp/tilia/pull/355). +* In a module with CPP, an indented line opening with an `OverloadedLabels` + label named like a directive, such as `#line` or `#if`, stays as it is + written, since cpp takes a `#` for a directive only at the start of a + line, rather than being moved to the margin or having the module + declined. [PR 355](https://github.com/mrkkrp/tilia/pull/355). +* A language pragma holding a comment is kept where a pragma before it + names the same extension, rather than dropped with its comment. + [PR 355](https://github.com/mrkkrp/tilia/pull/355). +* `--check-ast` reports a language pragma holding a comment that went + missing. [PR 355](https://github.com/mrkkrp/tilia/pull/355). +* `--check-ast` reports comments of an export list that come out in + another order. [PR 355](https://github.com/mrkkrp/tilia/pull/355). +* A line comment written after a block comment on its line stays after it, + as in `w = {- e -} -- f`, rather than coming out before it, after `w =`. + [PR 355](https://github.com/mrkkrp/tilia/pull/355). +* A comment on a line of its own under a trailing block comment, before a + closing bracket, stays on its line rather than being pulled up onto the + block comment's line, so formatting with leading commas is idempotent + there. [PR 355](https://github.com/mrkkrp/tilia/pull/355). +* A block Haddock on the left field of an infix constructor, as in + `Int {- ^ x -} :+ Int`, stays on its line, so formatting is idempotent + there. [PR 355](https://github.com/mrkkrp/tilia/pull/355). +* A `-- ^` Haddock whose text begins with `$` keeps it unescaped when it + moves in front of what it documents, rather than coming out as + `-- | \$…`, which `--check-ast` refused. + [PR 355](https://github.com/mrkkrp/tilia/pull/355). +* The signature of an expression ending in a block, as in + `do { pure () } :: IO ()`, stays outside the block: the block keeps its + braces on one line, and across lines the `::` opens a line of its own at + the expression's column, rather than going after the block's last + statement, where the module no longer parsed. + [PR 355](https://github.com/mrkkrp/tilia/pull/355). +* A comment written at the end of the line after the `=` or `->` of a guard + goes after that token, as after the `=` of an equation without guards, + rather than before it. [PR 355](https://github.com/mrkkrp/tilia/pull/355). +* A comment written at the end of the line after the `->` of a function + type goes after the arrow rather than before it. + [PR 355](https://github.com/mrkkrp/tilia/pull/355). +* A block comment written after the opening bracket of an import list, on + the line of the module's name, stays inside the brackets rather than + going after the module's name. + [PR 355](https://github.com/mrkkrp/tilia/pull/355). +* A block comment written after the `=` of a data declaration, on the line + of the type's name, stays after the `=` rather than going before it. + [PR 355](https://github.com/mrkkrp/tilia/pull/355). +* In a list written with leading commas, a block comment and a line comment + written after an item stay after that item, rather than coming out after + its comma and then, on the next run, in front of the next item. + [PR 355](https://github.com/mrkkrp/tilia/pull/355). +* A block comment of several lines that code follows on its last line no + longer gets an empty line under it where the source has one under that + line. [PR 355](https://github.com/mrkkrp/tilia/pull/355). +* A module with CPP holding a line marker written with a number, as in + `# 40 "M.hs"`, or a `#!` line below its top, both of which cpp passes on + to GHC, is declined, as one without CPP is, rather than having those + lines dropped. [PR 355](https://github.com/mrkkrp/tilia/pull/355). +* A `-- ^` Haddock continued on a line written `--$`, with no space, keeps + that line as written when it moves in front of what it documents, + rather than coming out escaped as `-- \$`, which changed the + documentation. [PR 355](https://github.com/mrkkrp/tilia/pull/355). +* An associated family in a class body laid out on one line comes out with + no space before the `;` after it. + [PR 355](https://github.com/mrkkrp/tilia/pull/355). +* A string gap in the package name of an import is lined up with the + opening quote where the name moves. + [PR 355](https://github.com/mrkkrp/tilia/pull/355). +* The category of a `WARNING` pragma is kept as written rather than rebuilt + from its value. [PR 355](https://github.com/mrkkrp/tilia/pull/355). +* In a module with CPP, the directives written at the margin of a block + Haddock stay there, as they already did in other block comments, rather + than being indented with the Haddock's lines, where cpp no longer reads + them and every configuration gets both branches of the Haddock. + [Issue 116](https://github.com/mrkkrp/tilia/issues/116). +* In a module with CPP, a constraint headed by a macro the module defines, + as in `HasCallStack_ (Eq a, Show a) =>` where `HasCallStack_` stands for + `HasCallStack =>`, gets no parentheses around it, rather than ones that + closed in what the macro stands for, which cpp turned into a qualified + type or a pragma inside a context that GHC rejects. + [PR 357](https://github.com/mrkkrp/tilia/pull/357). +* Where formatting leaves a module with no lines, as one holding only empty + lines, `check` heads its hunk with `+0,0`, as `git diff` does, rather + than `+1,0`. [PR 358](https://github.com/mrkkrp/tilia/pull/358). + ## Tilia 0.1.3.0 * An empty context comes out as written in a class or a data declaration, diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -37,7 +37,8 @@ `COMPONENT` may be omitted and in that case it defaults to `all`. To be precise, the kind of component we are talking about is exactly Cabal's -notion of component: libraries, executables, test suites, and benchmarks. +notion of component: libraries, foreign libraries, executables, test +suites, and benchmarks. For example, in the case of Tilia itself the valid choices are: * `all` @@ -67,16 +68,18 @@ modules a component declares get formatted: its `exposed-modules`, `other-modules`, `signatures`, and `main-is`, in every conditional branch, found under its `hs-source-dirs` as `.hs`, `.hs-boot`, or `.hsig` files. +A `Setup.hs` next to a package's `.cabal` file is formatted too. If there is no build plan yet, or it is older than the `.cabal` and `cabal.project` files, or it says nothing about a component you asked for, Tilia has Cabal solve it with `cabal build :all --dry-run`. If the plan is fine but some dependencies have been neither downloaded nor built, it fetches them with `cabal build :all --only-download`. These commands do not -build anything, and both are one-time costs, since Cabal's package cache is -shared between projects. So do not worry if the first run in a project -prints a few lines from Cabal before Tilia starts formatting. Later runs -check the plan with a read and a `stat` per package. +build anything. A download is made once, since Cabal's package cache is +shared between projects, and a solve is made again only when the plan goes +out of date. So do not worry if the first run in a project prints a few +lines from Cabal before Tilia starts formatting. Later runs check the plan +with a read and a `stat` per package. Both of those calls also pass `--enable-tests` and `--enable-benchmarks`, because test suites and benchmarks are components Tilia formats, but they @@ -166,7 +169,9 @@ CPP is a first-class formattable object to Tilia. Any Haskell syntactically enclosed in a conditional branch will format, and it does not even need to be self-contained valid Haskell on its own, as long as every configuration -of the module is a valid Haskell module. +of the module is a valid Haskell module. A module with too many +configurations to format, or with something cpp passes on to GHC, such as a +line marker, is declined and left as it is. ## Comparison with other formatters diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -9,7 +9,6 @@ import Data.ByteString qualified as BS import Data.Choice (Choice, fromBool, isTrue) import Data.Foldable (traverse_) -import Data.Maybe (mapMaybe) import Data.Text (Text) import Data.Text.Encoding qualified as T import Data.Text.IO qualified as T @@ -34,7 +33,6 @@ import Tilia.Cabal.Target ( Component, Target, - componentInPlan, componentsOfTarget, describeTargetProblem, filesOfComponents, @@ -44,12 +42,12 @@ import Tilia.Fixity.Debug (renderFixityNotes) import Tilia.Format ( FormatError (NoProject, Unreadable), - PlanSource (..), Session, describeFormatError, fixityNotesOf, formatErrorExitCode, newSession, + planSourceFor, ) import Tilia.Palette (Color (Bad), Palette, paletteFor) import Tilia.Parser (ghcLibParserVersion) @@ -73,19 +71,19 @@ main = do traverse_ transliterateUnprintable [stdout, stderr] opts <- customExecParser (prefs (columns lineWidth)) optsParserInfo - palette <- paletteFor + out <- paletteFor stdout + err <- paletteFor stderr let cmd = optCommand opts outcomes <- case cmd of Inplace target -> do - outcomes <- formatComponents palette opts target - traverse_ writeBack outcomes - outcomes <$ printReport (inplaceReport palette outcomes) + outcomes <- traverse writeBack =<< formatComponents err opts target + outcomes <$ printReport T.putStr (inplaceReport out err outcomes) Check target -> do - outcomes <- formatComponents palette opts target - outcomes <$ printReport (checkReport palette outcomes) + outcomes <- formatComponents err opts target + outcomes <$ printReport putUtf8 (checkReport out err outcomes) ForEditor file -> do - (input, outcomes) <- formatStdin palette opts file - outcomes <$ printReport (stdinReport palette input outcomes) + (input, outcomes) <- formatStdin err opts file + outcomes <$ printReport putUtf8 (stdinReport err input outcomes) exitWith cmd outcomes -- | Format the files of the components a target asks for. @@ -104,13 +102,11 @@ files <- traverse makeRelativeToCurrentDirectory =<< filesOfComponents root components + planSource <- planSourceFor optBuildPlan (pure components) session <- newSession root - ( case optBuildPlan of - Nothing -> PlanFromCabal (mapMaybe componentInPlan components) - Just givenPlan -> GivenPlan givenPlan - ) + planSource optUseCache optDownload optCheckAst @@ -204,13 +200,18 @@ (System.Exit.exitWith (ExitFailure 1)) ForEditor _ -> pure () --- | Print a 'Report'. -printReport :: Report -> IO () -printReport report = do - BS.putStr (T.encodeUtf8 (reportOut report)) +-- | Print a 'Report', with what writes its part for standard output. +printReport :: (Text -> IO ()) -> Report -> IO () +printReport putOut report = do + putOut (reportOut report) hFlush stdout traverse_ (T.hPutStrLn stderr) (reportErr report) hFlush stderr + +-- | Write to standard output as UTF-8, whatever the locale, and with the +-- newlines as they are. +putUtf8 :: Text -> IO () +putUtf8 = BS.putStr . T.encodeUtf8 -- | Every component the target asks for, and the project they were found -- in, which is where the run's settings are read from as well. 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 @@ -148,7 +148,8 @@ [ subjectOf Nothing False "synthetic/comments" commented, subjectOf Nothing False "synthetic/imports" imported, subjectOf Nothing False "synthetic/conditionals" conditional, - subjectOf Nothing False "synthetic/nesting" nested + subjectOf Nothing False "synthetic/nesting" nested, + subjectOf Nothing False "synthetic/long-line" long ] where commented = @@ -196,6 +197,16 @@ "", "wide :: [Int]", "wide = [" <> T.intercalate ", " (numbers 5000) <> "]" + ] + long = + T.unlines + [ "module Long where", + "", + "long :: [Int]", + "long = [" + <> T.intercalate ", " (numbers 1000) + <> "]" + <> foldMap (\n -> " {- " <> n <> " -}") (numbers 20) ] deeper n e = "case x of { " <> n <> " -> (" <> e <> "); _ -> x + " <> n <> " }" 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 @@ -211,7 +211,7 @@ packageReader <- newPackageReader (plannedCompiler plan) [] resolver <- newResolverWith [FromSource] kept [] tarballs packageReader plan pure $ do - answers <- traverse (askModule resolver) modules + answers <- traverse (askModule resolver Nothing) modules length <$> evaluate (force answers) packages <- for toResolve $ \release -> do modules <- fromMaybe [] <$> packageModules (tarballOf release) diff --git a/bench/bench.record b/bench/bench.record --- a/bench/bench.record +++ b/bench/bench.record @@ -29,93 +29,94 @@ interfaces 78bbcc544104eadc # stage allocated instructions benchmark -check 262394328 561065716 Agda-2.8.0/src/full/Agda/Syntax/Translation/ConcreteToAbstract.hs +check 262394328 555231347 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 +check 241179344 427994023 aeson-2.3.1.0/src/Data/Aeson/KeyMap.hs +check 189525056 491514771 blaze-html-0.9.2.0/src/Text/Blaze/Html5/Attributes.hs +check 61117160 123909455 brittany-0.14.0.2/source/library/Language/Haskell/Brittany/Internal/Transformations/Alt.hs +check 80917320 165175283 distributed-process-0.7.8/src/Control/Distributed/Process/Node.hs +check 122847376 257559652 esqueleto-3.6.0.3/test/PostgreSQL/Test.hs +check 494145192 876441840 haxl-2.5.1.1/Haxl/Core/Monad.hs +check 208630016 436314494 idris-1.3.4/src/Idris/Elab/Term.hs +check 313497704 525197526 lifted-base-0.2.3.12/Control/Exception/Lifted.hs +check 58885096 124278628 megaparsec-9.8.1/Text/Megaparsec/Internal.hs +check 78865104 169302733 optparse-applicative-0.19.0.0/tests/test.hs +check 49900040 86256621 pandoc-3.10.2/src/Text/Pandoc/Class/PandocPure.hs +check 155279368 326065024 pandoc-3.10.2/src/Text/Pandoc/Readers/Markdown.hs +check 208221512 424247665 pandoc-3.10.2/src/Text/Pandoc/Writers/Powerpoint/Output.hs +check 171071104 350069884 purescript-0.15.15/src/Language/PureScript/Errors.hs +check 83717864 174927701 purescript-0.15.15/src/Language/PureScript/TypeChecker/Types.hs +check 75850352 154401932 recursion-schemes-5.2.3/src/Data/Functor/Foldable.hs +check 87843760 182442615 servant-server-0.20.3.0/src/Servant/Server/Internal.hs +check 96642800 186847776 swagger2-2.9.1/src/Data/Swagger/Internal.hs +check 100410968 185782213 text-2.1.4/tests/Tests/Properties/Folds.hs +check 59225512 125094901 time-1.16.0.1/test/main/Test/Format/ParseTime.hs +check 65691176 131935007 tls-2.4.3/Network/TLS/Extension.hs +check 316481920 699896481 unpacked-containers-0/src/Map/Internal.hs +check 429238096 806439773 vector-0.13.2.0/src/Data/Vector/Generic.hs +check 68487400 140877072 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 +format 556595184 1024297945 Agda-2.8.0/src/full/Agda/Syntax/Translation/ConcreteToAbstract.hs +format 3854465456 7712722586 QuickCheck-2.18.0.0/src/Test/QuickCheck/Arbitrary.hs +format 862511712 1567214479 ShellCheck-0.11.0/src/ShellCheck/Analytics.hs +format 295473128 517227235 aeson-2.3.1.0/src/Data/Aeson/KeyMap.hs +format 164675032 294608279 blaze-html-0.9.2.0/src/Text/Blaze/Html5/Attributes.hs +format 113853464 207448636 brittany-0.14.0.2/source/library/Language/Haskell/Brittany/Internal/Transformations/Alt.hs +format 170106856 312154128 distributed-process-0.7.8/src/Control/Distributed/Process/Node.hs +format 296607832 538709571 esqueleto-3.6.0.3/test/PostgreSQL/Test.hs +format 759369024 1508706632 haxl-2.5.1.1/Haxl/Core/Monad.hs +format 483251128 868494716 idris-1.3.4/src/Idris/Elab/Term.hs +format 1316303056 2664117713 lens-5.3.6/src/Control/Lens/Wrapped.hs +format 373374296 680947697 lifted-base-0.2.3.12/Control/Exception/Lifted.hs +format 110841232 208652611 megaparsec-9.8.1/Text/Megaparsec/Internal.hs +format 143598656 262285835 optparse-applicative-0.19.0.0/tests/test.hs +format 53015136 93114333 pandoc-3.10.2/src/Text/Pandoc/Class/PandocPure.hs +format 360710120 655868610 pandoc-3.10.2/src/Text/Pandoc/Readers/Markdown.hs +format 443773152 810435549 pandoc-3.10.2/src/Text/Pandoc/Writers/Powerpoint/Output.hs +format 356368584 653553524 purescript-0.15.15/src/Language/PureScript/Errors.hs +format 149847256 273651638 purescript-0.15.15/src/Language/PureScript/TypeChecker/Types.hs +format 122975344 214196977 recursion-schemes-5.2.3/src/Data/Functor/Foldable.hs +format 164898304 299829497 servant-server-0.20.3.0/src/Servant/Server/Internal.hs +format 167353792 307352666 swagger2-2.9.1/src/Data/Swagger/Internal.hs +format 646295808 1317931248 synthetic/comments +format 103182688 220701758 synthetic/conditionals +format 76881520 114863718 synthetic/imports +format 19981040 49830507 synthetic/long-line +format 97023824 207242378 synthetic/nesting +format 793907888 1488797446 text-2.1.4/src/Data/Text/Internal/Fusion/CaseMapping.hs +format 198569872 352095273 text-2.1.4/tests/Tests/Properties/Folds.hs +format 125558376 227176081 time-1.16.0.1/test/main/Test/Format/ParseTime.hs +format 128855712 237558926 tls-2.4.3/Network/TLS/Extension.hs +format 986781016 1895559558 unordered-containers-0.2.21/Data/HashMap/Internal.hs +format 486456840 864325592 unpacked-containers-0/src/Map/Internal.hs +format 534644928 1002665230 vector-0.13.2.0/src/Data/Vector/Generic.hs +format 132456840 239250934 xmonad-0.18.1/src/XMonad/Operations.hs +recall 5035568 9104334 aeson-2.3.1.0 +recall 2206256 4115511 conduit-1.3.6.1 +recall 1750872 2949239 free-5.2 +recall 10419728 22711949 lens-5.3.6 +recall 1827984 3292762 megaparsec-9.8.1 +recall 2163752 3809556 mtl-2.3.2 +recall 1352776 2495420 optics-0.4.2.1 +recall 1560720 3029138 pandoc-types-1.23.1.2 +recall 2341464 4133432 semigroupoids-6.0.2 +recall 3245280 5631070 servant-0.20.3.0 +recall 5115360 8248496 text-2.1.4 +recall 4017336 7192306 vector-0.13.2.0 +resolve 1716508320 2903065195 aeson-2.3.1.0 +resolve 415521608 666133331 conduit-1.3.6.1 +resolve 455618520 731997671 free-5.2 +resolve 2779443504 4747264065 lens-5.3.6 +resolve 200991232 324227373 megaparsec-9.8.1 +resolve 210145040 336012772 mtl-2.3.2 +resolve 63439952 98654952 optics-0.4.2.1 +resolve 71737424 113796838 pandoc-types-1.23.1.2 +resolve 124790624 202262598 semigroupoids-6.0.2 +resolve 199289360 317418805 servant-0.20.3.0 +resolve 1092843928 1794267358 text-2.1.4 +resolve 2278152904 3740045561 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 @@ -154,7 +154,7 @@ formatted dd8c9bc90890 Agda-2.8.0/src/full/Agda/Syntax/Parser/Monad.hs formatted 6b041886ce39 Agda-2.8.0/src/full/Agda/Syntax/Parser/StringLiterals.hs formatted d018d2c7e144 Agda-2.8.0/src/full/Agda/Syntax/Parser/Tokens.hs -formatted a0ef5d8e9313 Agda-2.8.0/src/full/Agda/Syntax/Position.hs +formatted 852250f6def7 Agda-2.8.0/src/full/Agda/Syntax/Position.hs formatted d16539c2a462 Agda-2.8.0/src/full/Agda/Syntax/Position.hs-boot formatted b1dd8bfd3111 Agda-2.8.0/src/full/Agda/Syntax/Reflected.hs formatted cddc9daac015 Agda-2.8.0/src/full/Agda/Syntax/Scope/Base.hs @@ -178,7 +178,7 @@ formatted 109612b2572f Agda-2.8.0/src/full/Agda/Termination/TermCheck.hs formatted ed0ea780ef94 Agda-2.8.0/src/full/Agda/Termination/Termination.hs formatted 9ce4d907acfa Agda-2.8.0/src/full/Agda/TheTypeChecker.hs -formatted 522c2e92c2f2 Agda-2.8.0/src/full/Agda/TypeChecking/Abstract.hs +formatted f0d75a71448d Agda-2.8.0/src/full/Agda/TypeChecking/Abstract.hs formatted e757073d2d4e Agda-2.8.0/src/full/Agda/TypeChecking/CheckInternal.hs formatted 2d6bbce1312f Agda-2.8.0/src/full/Agda/TypeChecking/CheckInternal.hs-boot formatted 32a35663e792 Agda-2.8.0/src/full/Agda/TypeChecking/CompiledClause.hs @@ -205,7 +205,7 @@ formatted 2c03c6d0d27b Agda-2.8.0/src/full/Agda/TypeChecking/DropArgs.hs formatted c4bcc3ec3efc Agda-2.8.0/src/full/Agda/TypeChecking/Empty.hs formatted 546e2690c8bd Agda-2.8.0/src/full/Agda/TypeChecking/Empty.hs-boot -formatted d796fe01f1e9 Agda-2.8.0/src/full/Agda/TypeChecking/Errors.hs +formatted d66d78d15813 Agda-2.8.0/src/full/Agda/TypeChecking/Errors.hs formatted 4d637dbd29d8 Agda-2.8.0/src/full/Agda/TypeChecking/Errors.hs-boot formatted aaf8e5a6f74a Agda-2.8.0/src/full/Agda/TypeChecking/Errors/Names.hs formatted fa9468d1b394 Agda-2.8.0/src/full/Agda/TypeChecking/EtaContract.hs @@ -236,22 +236,22 @@ formatted 9825c48e7a9c Agda-2.8.0/src/full/Agda/TypeChecking/MetaVars/Occurs.hs formatted d47e8c206217 Agda-2.8.0/src/full/Agda/TypeChecking/Modalities.hs formatted 1fd16a038ff2 Agda-2.8.0/src/full/Agda/TypeChecking/Monad.hs -formatted 4d33b706cb4f Agda-2.8.0/src/full/Agda/TypeChecking/Monad/Base.hs +formatted 0ed8f798da0a Agda-2.8.0/src/full/Agda/TypeChecking/Monad/Base.hs formatted 9ab4cf397957 Agda-2.8.0/src/full/Agda/TypeChecking/Monad/Base/Types.hs formatted 7860b2253820 Agda-2.8.0/src/full/Agda/TypeChecking/Monad/Base/Warning.hs formatted 56ab8bfd7ea3 Agda-2.8.0/src/full/Agda/TypeChecking/Monad/Benchmark.hs -formatted a0072b209daf Agda-2.8.0/src/full/Agda/TypeChecking/Monad/Builtin.hs +formatted 384a0401d298 Agda-2.8.0/src/full/Agda/TypeChecking/Monad/Builtin.hs formatted 6b2e93e4eef0 Agda-2.8.0/src/full/Agda/TypeChecking/Monad/Builtin.hs-boot formatted d3627bb3ef79 Agda-2.8.0/src/full/Agda/TypeChecking/Monad/Caching.hs formatted ceeedfc93ba5 Agda-2.8.0/src/full/Agda/TypeChecking/Monad/Closure.hs formatted c94a9adc6e79 Agda-2.8.0/src/full/Agda/TypeChecking/Monad/Constraints.hs -formatted 965403e8d54c Agda-2.8.0/src/full/Agda/TypeChecking/Monad/Context.hs +formatted 868d2a157e43 Agda-2.8.0/src/full/Agda/TypeChecking/Monad/Context.hs formatted aa421afb353b Agda-2.8.0/src/full/Agda/TypeChecking/Monad/Context.hs-boot formatted 93f76be51b99 Agda-2.8.0/src/full/Agda/TypeChecking/Monad/Debug.hs formatted 07c8440dbd10 Agda-2.8.0/src/full/Agda/TypeChecking/Monad/Debug.hs-boot formatted 2b0eabe8c79e Agda-2.8.0/src/full/Agda/TypeChecking/Monad/Env.hs formatted 46512cb4f780 Agda-2.8.0/src/full/Agda/TypeChecking/Monad/Imports.hs -formatted a4bdd532cdc1 Agda-2.8.0/src/full/Agda/TypeChecking/Monad/MetaVars.hs +formatted 7d9f46715dba Agda-2.8.0/src/full/Agda/TypeChecking/Monad/MetaVars.hs formatted 894d39f81e58 Agda-2.8.0/src/full/Agda/TypeChecking/Monad/MetaVars.hs-boot formatted a46ae335e8c2 Agda-2.8.0/src/full/Agda/TypeChecking/Monad/Modality.hs formatted bbf8f13a117e Agda-2.8.0/src/full/Agda/TypeChecking/Monad/Mutual.hs @@ -266,7 +266,7 @@ formatted ede0f3649b77 Agda-2.8.0/src/full/Agda/TypeChecking/Monad/State.hs formatted 63e1167a5c2e Agda-2.8.0/src/full/Agda/TypeChecking/Monad/Statistics.hs formatted 49a778fb5b1f Agda-2.8.0/src/full/Agda/TypeChecking/Monad/Trace.hs -formatted 38ca9a4b989f Agda-2.8.0/src/full/Agda/TypeChecking/Names.hs +formatted 9fd81672bd87 Agda-2.8.0/src/full/Agda/TypeChecking/Names.hs formatted 5519525e6548 Agda-2.8.0/src/full/Agda/TypeChecking/Opacity.hs formatted d26ddecf1923 Agda-2.8.0/src/full/Agda/TypeChecking/Opacity.hs-boot formatted ec77f6d2c4ee Agda-2.8.0/src/full/Agda/TypeChecking/Patterns/Abstract.hs @@ -277,7 +277,7 @@ formatted 2f5659c12840 Agda-2.8.0/src/full/Agda/TypeChecking/Polarity.hs-boot formatted 2901072a89fa Agda-2.8.0/src/full/Agda/TypeChecking/Positivity.hs formatted 5626959a260d Agda-2.8.0/src/full/Agda/TypeChecking/Positivity/Occurrence.hs -formatted 37a92ee30da4 Agda-2.8.0/src/full/Agda/TypeChecking/Pretty.hs +formatted fc17ec29d60f Agda-2.8.0/src/full/Agda/TypeChecking/Pretty.hs formatted 7c15c0f77e82 Agda-2.8.0/src/full/Agda/TypeChecking/Pretty.hs-boot formatted 9a154e2294df Agda-2.8.0/src/full/Agda/TypeChecking/Pretty/Call.hs formatted f5434869778b Agda-2.8.0/src/full/Agda/TypeChecking/Pretty/Call.hs-boot @@ -287,7 +287,7 @@ formatted bf4e737ce041 Agda-2.8.0/src/full/Agda/TypeChecking/Pretty/Warning.hs-boot formatted 3d893370c964 Agda-2.8.0/src/full/Agda/TypeChecking/Primitive.hs formatted 3c8fe98419dd Agda-2.8.0/src/full/Agda/TypeChecking/Primitive.hs-boot -formatted 8ed22976b92a Agda-2.8.0/src/full/Agda/TypeChecking/Primitive/Base.hs +formatted da2381c955f4 Agda-2.8.0/src/full/Agda/TypeChecking/Primitive/Base.hs formatted 449b06119ca8 Agda-2.8.0/src/full/Agda/TypeChecking/Primitive/Cubical.hs formatted 2ea530f280a4 Agda-2.8.0/src/full/Agda/TypeChecking/Primitive/Cubical/Base.hs formatted 34da472277ef Agda-2.8.0/src/full/Agda/TypeChecking/Primitive/Cubical/Base.hs-boot @@ -300,14 +300,14 @@ formatted 2d7e0d93add3 Agda-2.8.0/src/full/Agda/TypeChecking/RecordPatterns.hs formatted 2ea1183d053a Agda-2.8.0/src/full/Agda/TypeChecking/Records.hs formatted 65b1d93597cd Agda-2.8.0/src/full/Agda/TypeChecking/Records.hs-boot -formatted d796d469ac77 Agda-2.8.0/src/full/Agda/TypeChecking/Reduce.hs +formatted c04a8dcdb87f Agda-2.8.0/src/full/Agda/TypeChecking/Reduce.hs formatted 82cb10489996 Agda-2.8.0/src/full/Agda/TypeChecking/Reduce.hs-boot formatted 902d61b8794a Agda-2.8.0/src/full/Agda/TypeChecking/Reduce/Fast.hs formatted 2158647025d5 Agda-2.8.0/src/full/Agda/TypeChecking/Reduce/Fast.hs-boot formatted 8290b6f13ee3 Agda-2.8.0/src/full/Agda/TypeChecking/Reduce/Monad.hs formatted 4138b13a5df5 Agda-2.8.0/src/full/Agda/TypeChecking/Rewriting.hs formatted 0158a552c77f Agda-2.8.0/src/full/Agda/TypeChecking/Rewriting.hs-boot -formatted a5b5675ddb35 Agda-2.8.0/src/full/Agda/TypeChecking/Rewriting/Clause.hs +formatted b3f48345a2ca Agda-2.8.0/src/full/Agda/TypeChecking/Rewriting/Clause.hs formatted e53d93353f66 Agda-2.8.0/src/full/Agda/TypeChecking/Rewriting/Confluence.hs formatted ffa8c612942d Agda-2.8.0/src/full/Agda/TypeChecking/Rewriting/NonLinMatch.hs formatted cf2803dfe738 Agda-2.8.0/src/full/Agda/TypeChecking/Rewriting/NonLinPattern.hs @@ -349,11 +349,11 @@ formatted 904a4e241e74 Agda-2.8.0/src/full/Agda/TypeChecking/SizedTypes/Utils.hs formatted 0be08dcf3e01 Agda-2.8.0/src/full/Agda/TypeChecking/SizedTypes/WarshallSolver.hs formatted dace03972057 Agda-2.8.0/src/full/Agda/TypeChecking/Sort.hs -formatted 23e9f5a4dd33 Agda-2.8.0/src/full/Agda/TypeChecking/Substitute.hs -formatted 5c1090094604 Agda-2.8.0/src/full/Agda/TypeChecking/Substitute/Class.hs +formatted e672d69282fb Agda-2.8.0/src/full/Agda/TypeChecking/Substitute.hs +formatted ed6f3c6c04cb Agda-2.8.0/src/full/Agda/TypeChecking/Substitute/Class.hs formatted 2656f0d28fba Agda-2.8.0/src/full/Agda/TypeChecking/Substitute/DeBruijn.hs formatted bdddf47208eb Agda-2.8.0/src/full/Agda/TypeChecking/SyntacticEquality.hs -formatted 9403f483b826 Agda-2.8.0/src/full/Agda/TypeChecking/Telescope.hs +formatted 64e7a1aa36eb Agda-2.8.0/src/full/Agda/TypeChecking/Telescope.hs formatted d94c0d202dfc Agda-2.8.0/src/full/Agda/TypeChecking/Telescope.hs-boot formatted a311599b882a Agda-2.8.0/src/full/Agda/TypeChecking/Telescope/Path.hs formatted 065cd440ceef Agda-2.8.0/src/full/Agda/TypeChecking/Unquote.hs @@ -363,7 +363,7 @@ formatted ae5ced9ae20f Agda-2.8.0/src/full/Agda/Utils/Applicative.hs formatted 7fe48d6127fe Agda-2.8.0/src/full/Agda/Utils/AssocList.hs formatted 0f294429e9ba Agda-2.8.0/src/full/Agda/Utils/Bag.hs -formatted 3856d320f4f2 Agda-2.8.0/src/full/Agda/Utils/Benchmark.hs +formatted ede5e2261435 Agda-2.8.0/src/full/Agda/Utils/Benchmark.hs formatted 19e137bd74e4 Agda-2.8.0/src/full/Agda/Utils/BiMap.hs formatted 09925de009a1 Agda-2.8.0/src/full/Agda/Utils/BoolSet.hs formatted 66c20e52ae54 Agda-2.8.0/src/full/Agda/Utils/Boolean.hs @@ -386,7 +386,7 @@ formatted 873df66a7304 Agda-2.8.0/src/full/Agda/Utils/Graph/AdjacencyMap/Unidirectional.hs formatted 989ea83c378b Agda-2.8.0/src/full/Agda/Utils/Graph/TopSort.hs formatted db38367e7a17 Agda-2.8.0/src/full/Agda/Utils/Hash.hs -formatted 43284ef7124c Agda-2.8.0/src/full/Agda/Utils/HashTable.hs +formatted 8328694f97ac Agda-2.8.0/src/full/Agda/Utils/HashTable.hs formatted 019e9637b9b0 Agda-2.8.0/src/full/Agda/Utils/Haskell/Syntax.hs formatted e861d8cbd7ce Agda-2.8.0/src/full/Agda/Utils/IArray.hs formatted 8d53e1639c43 Agda-2.8.0/src/full/Agda/Utils/IO.hs @@ -440,14 +440,14 @@ formatted fe0ca6de293d Agda-2.8.0/src/full/Agda/Utils/Zipper.hs formatted 86e923a357db Agda-2.8.0/src/main/Main.hs formatted 61f76fd386b5 Agda-2.8.0/src/setup/Agda/Setup.hs -formatted 4fdcc92be0f4 Agda-2.8.0/src/setup/Agda/Setup/DataFiles.hs +formatted 57e71e771600 Agda-2.8.0/src/setup/Agda/Setup/DataFiles.hs formatted 7a631dd4456c Agda-2.8.0/src/setup/Agda/Setup/EmacsMode.hs formatted acb74e0db7a5 Agda-2.8.0/src/setup/Agda/Version.hs formatted 5164a4006c26 Agda-2.8.0/src/setup/Agda/VersionCommit.hs formatted 90cd663d9426 HUnit-1.6.2.0/examples/Example.hs formatted 9b1cac4b6c09 HUnit-1.6.2.0/src/Test/HUnit.hs -formatted 0971b82d0690 HUnit-1.6.2.0/src/Test/HUnit/Base.hs -formatted 259f46f80849 HUnit-1.6.2.0/src/Test/HUnit/Lang.hs +formatted e35d465aa045 HUnit-1.6.2.0/src/Test/HUnit/Base.hs +formatted cb7ff16c7dc4 HUnit-1.6.2.0/src/Test/HUnit/Lang.hs formatted f9959d10adae HUnit-1.6.2.0/src/Test/HUnit/Terminal.hs formatted c1c1d4fdc273 HUnit-1.6.2.0/src/Test/HUnit/Text.hs formatted 358e8e211fe4 HUnit-1.6.2.0/tests/HUnitTestExtended.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 f088ecc2c2e1 async-2.2.6/Control/Concurrent/Async/Internal.hs +partly-checked a1029cf51bc3 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 @@ -627,7 +627,7 @@ formatted 4db35c37a9a6 async-2.2.6/test/test-async.hs formatted 9f3238148609 attoparsec-0.14.4/Data/Attoparsec.hs formatted 7d88b33f4399 attoparsec-0.14.4/Data/Attoparsec/ByteString.hs -formatted 4ba03080e749 attoparsec-0.14.4/Data/Attoparsec/ByteString/Char8.hs +formatted 00312ec6e47a attoparsec-0.14.4/Data/Attoparsec/ByteString/Char8.hs formatted 0e47afce0362 attoparsec-0.14.4/Data/Attoparsec/ByteString/Internal.hs formatted fcc23ffbbc3d attoparsec-0.14.4/Data/Attoparsec/ByteString/Lazy.hs formatted 220f76f3ce4e attoparsec-0.14.4/Data/Attoparsec/Char8.hs @@ -636,7 +636,7 @@ formatted dbeb97f732d5 attoparsec-0.14.4/Data/Attoparsec/Internal/Types.hs formatted ea3b710a875e attoparsec-0.14.4/Data/Attoparsec/Lazy.hs formatted 3d8057d5d688 attoparsec-0.14.4/Data/Attoparsec/Number.hs -formatted 45050bdb0a87 attoparsec-0.14.4/Data/Attoparsec/Text.hs +formatted c4be73924922 attoparsec-0.14.4/Data/Attoparsec/Text.hs formatted 8419b057d5a4 attoparsec-0.14.4/Data/Attoparsec/Text/Internal.hs formatted b1c4021729a8 attoparsec-0.14.4/Data/Attoparsec/Text/Lazy.hs formatted 63d322215a87 attoparsec-0.14.4/Data/Attoparsec/Types.hs @@ -759,7 +759,7 @@ formatted 4115c76b6f3d aws-0.25.3/Aws/SimpleDb.hs formatted 0b6040677d6d aws-0.25.3/Aws/SimpleDb/Commands.hs formatted 30e4762ca046 aws-0.25.3/Aws/SimpleDb/Commands/Attributes.hs -formatted 66e68309ec36 aws-0.25.3/Aws/SimpleDb/Commands/Domain.hs +formatted 2f311cda5b86 aws-0.25.3/Aws/SimpleDb/Commands/Domain.hs formatted d6accda5efc3 aws-0.25.3/Aws/SimpleDb/Commands/Select.hs formatted 75d5726cf334 aws-0.25.3/Aws/SimpleDb/Core.hs formatted 412e7ea774c8 aws-0.25.3/Aws/Sqs.hs @@ -794,7 +794,7 @@ formatted 0328dc0c3c7c base64-bytestring-1.2.1.0/benchmarks/BM.hs formatted e856b328c01f base64-bytestring-1.2.1.0/tests/Tests.hs formatted d41a83550f57 base64-bytestring-1.2.1.0/utils/Transcode.hs -formatted f732441f45ac bifunctors-5.6.3/src/Data/Biapplicative.hs +formatted 77e2e9cc64d0 bifunctors-5.6.3/src/Data/Biapplicative.hs formatted 463448893cde bifunctors-5.6.3/src/Data/Bifunctor/Biap.hs formatted 9705f6a45db6 bifunctors-5.6.3/src/Data/Bifunctor/Biff.hs formatted 738f47d063bd bifunctors-5.6.3/src/Data/Bifunctor/Clown.hs @@ -1571,11 +1571,11 @@ formatted f520242138c3 conduit-1.3.6.1/src/Data/Conduit/Combinators/Stream.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 98597865ff40 conduit-1.3.6.1/src/Data/Conduit/Internal/Conduit.hs formatted bbfd28e5b98b conduit-1.3.6.1/src/Data/Conduit/Internal/Fusion.hs formatted 54120af8edce conduit-1.3.6.1/src/Data/Conduit/Internal/List/Stream.hs -formatted bf0df637e814 conduit-1.3.6.1/src/Data/Conduit/Internal/Pipe.hs -formatted 4a4c14b72249 conduit-1.3.6.1/src/Data/Conduit/Lift.hs +formatted 5a515cebf8f7 conduit-1.3.6.1/src/Data/Conduit/Internal/Pipe.hs +formatted 926d89b12351 conduit-1.3.6.1/src/Data/Conduit/Lift.hs formatted e698a877d8f0 conduit-1.3.6.1/src/Data/Conduit/List.hs formatted 98630a5362e8 conduit-1.3.6.1/src/Data/Streaming/FileRead.hs formatted 9860da5f427f conduit-1.3.6.1/src/Data/Streaming/Filesystem.hs @@ -1701,15 +1701,15 @@ formatted a54d3189768c cryptonite-0.30/Crypto/MAC/Poly1305.hs formatted c065c0ae8804 cryptonite-0.30/Crypto/Number/Basic.hs partly-checked 27ebb2f56bcc cryptonite-0.30/Crypto/Number/Compat.hs -formatted d8e4da3cf8c5 cryptonite-0.30/Crypto/Number/F2m.hs +formatted 629f31e714bd cryptonite-0.30/Crypto/Number/F2m.hs formatted 7b62d9f0185b cryptonite-0.30/Crypto/Number/Generate.hs formatted 53fbd1bf4d6c cryptonite-0.30/Crypto/Number/ModArithmetic.hs formatted 3887ba3c7c43 cryptonite-0.30/Crypto/Number/Nat.hs formatted 930fa05c486f cryptonite-0.30/Crypto/Number/Prime.hs -formatted 3be1d9c43e52 cryptonite-0.30/Crypto/Number/Serialize.hs +formatted 2f0cabb85d66 cryptonite-0.30/Crypto/Number/Serialize.hs formatted cfe6a456efe7 cryptonite-0.30/Crypto/Number/Serialize/Internal.hs formatted 8f181f9bc069 cryptonite-0.30/Crypto/Number/Serialize/Internal/LE.hs -formatted c21267dc7970 cryptonite-0.30/Crypto/Number/Serialize/LE.hs +formatted 63f76fd57ace cryptonite-0.30/Crypto/Number/Serialize/LE.hs formatted 306914497f38 cryptonite-0.30/Crypto/OTP.hs formatted 47ac3109be1c cryptonite-0.30/Crypto/PubKey/Curve25519.hs formatted ff1bad4fe0ae cryptonite-0.30/Crypto/PubKey/Curve448.hs @@ -1872,7 +1872,7 @@ formatted 988c01fea196 dlist-1.0/tests/ImportUnsafe.hs formatted 7878296311fe dlist-1.0/tests/Main.hs formatted 4d7411576558 dlist-1.0/tests/OverloadedStrings.hs -formatted 0c9b9888b599 dlist-1.0/tests/QuickCheckUtil.hs +formatted 2393b4a3587d dlist-1.0/tests/QuickCheckUtil.hs formatted e865ae48f11b esqueleto-3.6.0.3/Setup.hs formatted fb274a829f01 esqueleto-3.6.0.3/src/Database/Esqueleto.hs formatted 99a3554c79c4 esqueleto-3.6.0.3/src/Database/Esqueleto/Experimental.hs @@ -2196,7 +2196,7 @@ formatted 691876a14ba8 flatparse-0.5.6.1/bench/Megaparsec.hs formatted 4e5c403e7a3b flatparse-0.5.6.1/bench/Parsec.hs formatted 767291fb667b flatparse-0.5.6.1/bench/ReadInteger.hs -formatted 94b6d379ba91 flatparse-0.5.6.1/src/FlatParse/Basic.hs +formatted bcacec1d3ede flatparse-0.5.6.1/src/FlatParse/Basic.hs formatted 162dda57b01e flatparse-0.5.6.1/src/FlatParse/Basic/Addr.hs formatted e944703d9644 flatparse-0.5.6.1/src/FlatParse/Basic/Base.hs formatted 2f38d187e067 flatparse-0.5.6.1/src/FlatParse/Basic/Bytes.hs @@ -2212,9 +2212,9 @@ formatted 10cb24214eea flatparse-0.5.6.1/src/FlatParse/Common/Switch.hs formatted 412fc97e8505 flatparse-0.5.6.1/src/FlatParse/Examples/BasicLambda/Lexer.hs formatted 2c72cb96232c flatparse-0.5.6.1/src/FlatParse/Examples/BasicLambda/Parser.hs -formatted e5272a875046 flatparse-0.5.6.1/src/FlatParse/Minimal.hs +formatted 24e21b400286 flatparse-0.5.6.1/src/FlatParse/Minimal.hs formatted 3f356742f6e5 flatparse-0.5.6.1/src/FlatParse/Minimal/Internal.hs -formatted 7ecd84a0c48e flatparse-0.5.6.1/src/FlatParse/Stateful.hs +formatted 1fc3563f3fee flatparse-0.5.6.1/src/FlatParse/Stateful.hs formatted 122b007be519 flatparse-0.5.6.1/src/FlatParse/Stateful/Addr.hs formatted bc3b9c3f288a flatparse-0.5.6.1/src/FlatParse/Stateful/Base.hs formatted 944f11f97db1 flatparse-0.5.6.1/src/FlatParse/Stateful/Bytes.hs @@ -2226,7 +2226,7 @@ formatted b3d258de0403 free-5.2/examples/PerfTH.hs formatted 24418bc38fac free-5.2/examples/RetryTH.hs formatted 7641743d0c1f free-5.2/examples/ValidationForm.hs -formatted 9fcd1a6b4714 free-5.2/src/Control/Alternative/Free.hs +formatted 0fed369b08ea free-5.2/src/Control/Alternative/Free.hs formatted 6cdf81c21164 free-5.2/src/Control/Alternative/Free/Final.hs formatted 8b307bae43e5 free-5.2/src/Control/Applicative/Free.hs formatted 1593e637f12f free-5.2/src/Control/Applicative/Free/Fast.hs @@ -2468,7 +2468,7 @@ formatted 3fc4bde8aaae hledger-1.52.1/Hledger/Cli/Commands/Incomestatement.hs formatted e795242e76e2 hledger-1.52.1/Hledger/Cli/Commands/Notes.hs formatted 7868c26f6945 hledger-1.52.1/Hledger/Cli/Commands/Payees.hs -formatted 74c42e16a7cb hledger-1.52.1/Hledger/Cli/Commands/Prices.hs +formatted fe56fd581b75 hledger-1.52.1/Hledger/Cli/Commands/Prices.hs formatted 177a0e3d59ff hledger-1.52.1/Hledger/Cli/Commands/Print.hs formatted b3664f32c410 hledger-1.52.1/Hledger/Cli/Commands/Register.hs formatted fe57269eee06 hledger-1.52.1/Hledger/Cli/Commands/Rewrite.hs @@ -2751,7 +2751,7 @@ formatted 77ebc33633f8 idris-1.3.4/src/Idris/Elab/RunElab.hs formatted 711d76a30f2c idris-1.3.4/src/Idris/Elab/Term.hs formatted 43565a6d9bac idris-1.3.4/src/Idris/Elab/Transform.hs -formatted cf8cbbec4fe7 idris-1.3.4/src/Idris/Elab/Type.hs +formatted eb98b1329d21 idris-1.3.4/src/Idris/Elab/Type.hs formatted b3e66f72a9ac idris-1.3.4/src/Idris/Elab/Utils.hs formatted ac9c50ffdaf7 idris-1.3.4/src/Idris/Elab/Value.hs formatted 5ce0ed3888f3 idris-1.3.4/src/Idris/ElabDecls.hs @@ -2817,7 +2817,7 @@ formatted 1cefb44a49bc leksah-0.16.2.2/data/leksah-welcome/test/Main.hs formatted 34cb8bb8a612 leksah-0.16.2.2/main/Main.hs formatted 0d71ef1dc947 leksah-0.16.2.2/src/IDE/BufferMode.hs -formatted 0cd8482b4f61 leksah-0.16.2.2/src/IDE/Build.hs +formatted 404f52b9bd79 leksah-0.16.2.2/src/IDE/Build.hs formatted d08cdd390358 leksah-0.16.2.2/src/IDE/Command.hs formatted 311f46674981 leksah-0.16.2.2/src/IDE/Command/Print.hs formatted 3587f60b8002 leksah-0.16.2.2/src/IDE/Command/VCS.hs @@ -2834,7 +2834,7 @@ formatted b8029845c5f6 leksah-0.16.2.2/src/IDE/Core/Types.hs formatted 375889d7ec16 leksah-0.16.2.2/src/IDE/Debug.hs does-not-parse - leksah-0.16.2.2/src/IDE/Find.hs -formatted a7b49b049b8e leksah-0.16.2.2/src/IDE/GUIHistory.hs +formatted 4d3884c63c61 leksah-0.16.2.2/src/IDE/GUIHistory.hs formatted 8ac61c496a03 leksah-0.16.2.2/src/IDE/HLint.hs formatted 8ddfdb5cd7cb leksah-0.16.2.2/src/IDE/ImportTool.hs formatted c94ba55b56fd leksah-0.16.2.2/src/IDE/Keymap.hs @@ -2893,7 +2893,7 @@ 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 fb677a8ca744 lens-5.3.6/src/Control/Exception/Lens.hs +formatted 458d82357e04 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 @@ -2941,7 +2941,7 @@ formatted 6e871d8e4385 lens-5.3.6/src/Control/Lens/Review.hs formatted 5f1a95d65c20 lens-5.3.6/src/Control/Lens/Setter.hs formatted fa7936ec3040 lens-5.3.6/src/Control/Lens/TH.hs -formatted 9164ff122ee8 lens-5.3.6/src/Control/Lens/Traversal.hs +formatted 17d4f9d6b2ac lens-5.3.6/src/Control/Lens/Traversal.hs formatted 3a5cbb2c959c lens-5.3.6/src/Control/Lens/Tuple.hs formatted 181a647a9c7b lens-5.3.6/src/Control/Lens/Type.hs formatted ff8881502434 lens-5.3.6/src/Control/Lens/Unsound.hs @@ -2987,17 +2987,17 @@ formatted a554fa5629d9 lens-5.3.6/tests/hunit.hs 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 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 -formatted 9a9d09688902 lifted-base-0.2.3.12/Control/Exception/Lifted.hs -formatted 6ce3f2d36b4c lifted-base-0.2.3.12/Data/IORef/Lifted.hs +formatted 1710cd1da159 lifted-base-0.2.3.12/Control/Concurrent/Chan/Lifted.hs +formatted 9afd73e18f04 lifted-base-0.2.3.12/Control/Concurrent/Lifted.hs +formatted 61a68e35cd0d lifted-base-0.2.3.12/Control/Concurrent/MVar/Lifted.hs +formatted 9e4f63e571b9 lifted-base-0.2.3.12/Control/Concurrent/QSem/Lifted.hs +formatted db70a2e6121a lifted-base-0.2.3.12/Control/Concurrent/QSemN/Lifted.hs +formatted e977da901a85 lifted-base-0.2.3.12/Control/Concurrent/SampleVar/Lifted.hs +formatted 054d7b6af1e4 lifted-base-0.2.3.12/Control/Exception/Lifted.hs +formatted 22bce56a50cb lifted-base-0.2.3.12/Data/IORef/Lifted.hs formatted 0232c1b3e9de lifted-base-0.2.3.12/Foreign/Marshal/Utils/Lifted.hs formatted e865ae48f11b lifted-base-0.2.3.12/Setup.hs -formatted 5d96e3b3a63b lifted-base-0.2.3.12/System/Timeout/Lifted.hs +formatted 577a6034129f lifted-base-0.2.3.12/System/Timeout/Lifted.hs formatted 8186b0308f97 lifted-base-0.2.3.12/bench/bench.hs formatted 969f026a4085 lifted-base-0.2.3.12/test/test.hs formatted 0331614d7776 megaparsec-9.8.1/Text/Megaparsec.hs @@ -3025,7 +3025,7 @@ partly-checked 37206fb8e023 microlens-0.5.0.0/src/Lens/Micro.hs formatted a33fe5ffd3d9 microlens-0.5.0.0/src/Lens/Micro/Extras.hs formatted 3608b82ef46d microlens-0.5.0.0/src/Lens/Micro/FieldN.hs -partly-checked a6c752419362 microlens-0.5.0.0/src/Lens/Micro/Internal.hs +partly-checked e7bef62398e7 microlens-0.5.0.0/src/Lens/Micro/Internal.hs formatted de09492cc927 microlens-0.5.0.0/src/Lens/Micro/Type.hs formatted 9fd4d8759261 mtl-2.3.2/Control/Monad/Accum.hs formatted 1c966453ae10 mtl-2.3.2/Control/Monad/Cont.hs @@ -3238,7 +3238,7 @@ formatted 25cccdcbef5d pandoc-3.10.2/src/Text/Pandoc/Readers/Textile.hs formatted 7e7d5f748c66 pandoc-3.10.2/src/Text/Pandoc/Readers/TikiWiki.hs formatted 92e7cf81f874 pandoc-3.10.2/src/Text/Pandoc/Readers/Txt2Tags.hs -formatted 4af418633a39 pandoc-3.10.2/src/Text/Pandoc/Readers/Typst.hs +formatted 38ba4ac13251 pandoc-3.10.2/src/Text/Pandoc/Readers/Typst.hs formatted 571c0f71e243 pandoc-3.10.2/src/Text/Pandoc/Readers/Typst/Math.hs formatted 862b8ee41599 pandoc-3.10.2/src/Text/Pandoc/Readers/Typst/Parsing.hs formatted d9474be2d4dd pandoc-3.10.2/src/Text/Pandoc/Readers/Vimwiki.hs @@ -3325,7 +3325,7 @@ formatted 64258df1d09e pandoc-3.10.2/src/Text/Pandoc/Writers/Shared.hs formatted 6ff714d9bc8d pandoc-3.10.2/src/Text/Pandoc/Writers/TEI.hs formatted 01231d1cd443 pandoc-3.10.2/src/Text/Pandoc/Writers/Texinfo.hs -formatted 3a596ddb6e0a pandoc-3.10.2/src/Text/Pandoc/Writers/Textile.hs +formatted c961b91b586a pandoc-3.10.2/src/Text/Pandoc/Writers/Textile.hs formatted e65d7bf1c614 pandoc-3.10.2/src/Text/Pandoc/Writers/Txt2Tags.hs formatted ab0ca20ffb33 pandoc-3.10.2/src/Text/Pandoc/Writers/Typst.hs formatted 5753a1fc2b52 pandoc-3.10.2/src/Text/Pandoc/Writers/Vimdoc.hs @@ -3414,7 +3414,7 @@ formatted 2f99ad7040cc pandoc-types-1.23.1.2/src/Text/Pandoc/Definition.hs formatted 42a13347f367 pandoc-types-1.23.1.2/src/Text/Pandoc/Generic.hs formatted 8fad29f2adc4 pandoc-types-1.23.1.2/src/Text/Pandoc/JSON.hs -formatted 521e0dcaf505 pandoc-types-1.23.1.2/src/Text/Pandoc/Walk.hs +formatted a6d367888d28 pandoc-types-1.23.1.2/src/Text/Pandoc/Walk.hs formatted dcf10d45e788 pandoc-types-1.23.1.2/test/Data/String/QQ.hs formatted aa803b05c956 pandoc-types-1.23.1.2/test/test-pandoc-types.hs formatted 7474b7e1d4f5 parsec3-1.0.1.8/Setup.hs @@ -3530,12 +3530,12 @@ formatted e865ae48f11b pipes-4.3.16/Setup.hs formatted bc3b140ba83c pipes-4.3.16/benchmarks/Common.hs formatted e459e4d124d4 pipes-4.3.16/benchmarks/LiftBench.hs -formatted d100cca123ea pipes-4.3.16/benchmarks/PreludeBench.hs -formatted c9e4b8790a2e pipes-4.3.16/src/Pipes.hs -formatted 73ed6cfff72e pipes-4.3.16/src/Pipes/Core.hs -formatted e021398dbff3 pipes-4.3.16/src/Pipes/Internal.hs -formatted e3b36f0685b2 pipes-4.3.16/src/Pipes/Lift.hs -formatted 82bba5f85292 pipes-4.3.16/src/Pipes/Prelude.hs +formatted d96fb6cefc30 pipes-4.3.16/benchmarks/PreludeBench.hs +formatted c033c83ec4cb pipes-4.3.16/src/Pipes.hs +formatted e3dc5b339200 pipes-4.3.16/src/Pipes/Core.hs +formatted a6c6ec5a4f4c pipes-4.3.16/src/Pipes/Internal.hs +formatted b0d9eaef316b pipes-4.3.16/src/Pipes/Lift.hs +formatted b21ef8ba8f5d pipes-4.3.16/src/Pipes/Prelude.hs formatted 436224de8a77 pipes-4.3.16/src/Pipes/Tutorial.hs formatted 068bd78f1e97 pipes-4.3.16/tests/Main.hs formatted 56dca68e0a87 postgrest-9.0.1/Setup.hs @@ -3888,7 +3888,7 @@ formatted 7a6d55f211a6 raaz-0.3.11/core/Raaz/Core/Types/Endian.hs formatted a48c22bbc9bf raaz-0.3.11/core/Raaz/Core/Types/Equality.hs formatted 72aa730843b9 raaz-0.3.11/core/Raaz/Core/Types/Internal.hs -formatted 131bd6941a42 raaz-0.3.11/core/Raaz/Core/Types/Pointer.hs +formatted c7e28dcd7d70 raaz-0.3.11/core/Raaz/Core/Types/Pointer.hs formatted f9be8525b0e9 raaz-0.3.11/core/Raaz/Core/Types/Tuple.hs formatted d98d94a62e17 raaz-0.3.11/core/Raaz/Core/Util/ByteString.hs formatted aadc37085673 raaz-0.3.11/core/Raaz/Primitive/AEAD/Internal.hs @@ -4020,13 +4020,13 @@ formatted 08af947c789a retry-0.9.3.1/test/Tests/Control/Retry.hs formatted 0b770fc83ef2 retry-0.9.3.1/test/Tests/UnliftIO/Retry.hs formatted e865ae48f11b safe-exceptions-0.1.7.4/Setup.hs -formatted bfa9329aa42a safe-exceptions-0.1.7.4/src/Control/Exception/Safe.hs +formatted 71750c378530 safe-exceptions-0.1.7.4/src/Control/Exception/Safe.hs formatted d65c0e991a57 safe-exceptions-0.1.7.4/test/Control/Exception/SafeSpec.hs formatted 2fbd14b119a4 safe-exceptions-0.1.7.4/test/Spec.hs formatted e865ae48f11b scientific-0.3.8.1/Setup.hs formatted 6a2de24bbe1d scientific-0.3.8.1/bench/bench.hs formatted b51f688e4f66 scientific-0.3.8.1/src/Data/ByteString/Builder/Scientific.hs -formatted 6fcd3c78e09a scientific-0.3.8.1/src/Data/Scientific.hs +formatted 862aefb94cc9 scientific-0.3.8.1/src/Data/Scientific.hs formatted 5837fdbf8485 scientific-0.3.8.1/src/Data/Text/Lazy/Builder/Scientific.hs formatted e18e1762aa10 scientific-0.3.8.1/src/GHC/Integer/Compat.hs formatted 70da6923c6d5 scientific-0.3.8.1/src/Utils.hs @@ -4265,7 +4265,7 @@ formatted 7425a9004035 shake-0.19.9/src/Test/Errors.hs formatted b698eeb22c5b shake-0.19.9/src/Test/Existence.hs formatted 33dfd1039065 shake-0.19.9/src/Test/FileLock.hs -formatted 62fa7f2a0865 shake-0.19.9/src/Test/FilePath.hs +formatted 1dd160a81730 shake-0.19.9/src/Test/FilePath.hs formatted 19b187c8cbe6 shake-0.19.9/src/Test/FilePattern.hs formatted 7f088d1e23e6 shake-0.19.9/src/Test/Files.hs formatted f46b5feb3e77 shake-0.19.9/src/Test/Forward.hs @@ -4406,28 +4406,28 @@ formatted bd8bb4f92c76 statistics-0.16.5.0/Statistics/Distribution/Weibull.hs formatted a5d3ccd314a5 statistics-0.16.5.0/Statistics/Function.hs formatted 4ce5ca3ee348 statistics-0.16.5.0/Statistics/Internal.hs -formatted 86e8d1a0a535 statistics-0.16.5.0/Statistics/Quantile.hs +formatted 3802c4ce0920 statistics-0.16.5.0/Statistics/Quantile.hs formatted 4eb8961889ae statistics-0.16.5.0/Statistics/Regression.hs formatted 535c5c96b342 statistics-0.16.5.0/Statistics/Resampling.hs formatted 76d271403a9e statistics-0.16.5.0/Statistics/Resampling/Bootstrap.hs formatted cc05168e10be statistics-0.16.5.0/Statistics/Sample.hs formatted 24ce2ba6d88a statistics-0.16.5.0/Statistics/Sample/Histogram.hs formatted cab9e68a7e21 statistics-0.16.5.0/Statistics/Sample/Internal.hs -formatted 7333b62fa746 statistics-0.16.5.0/Statistics/Sample/KernelDensity.hs +formatted 5148550f72c0 statistics-0.16.5.0/Statistics/Sample/KernelDensity.hs formatted 57cb926959b9 statistics-0.16.5.0/Statistics/Sample/KernelDensity/Simple.hs -formatted e7d037eb7906 statistics-0.16.5.0/Statistics/Sample/Normalize.hs +formatted bae6889ac8ec statistics-0.16.5.0/Statistics/Sample/Normalize.hs formatted 1242733971ab statistics-0.16.5.0/Statistics/Sample/Powers.hs formatted 5530b1f597e3 statistics-0.16.5.0/Statistics/Test/Bartlett.hs -formatted da8b73ff5c88 statistics-0.16.5.0/Statistics/Test/ChiSquared.hs +formatted 4ba8ec52c2e3 statistics-0.16.5.0/Statistics/Test/ChiSquared.hs formatted 4990518d53f6 statistics-0.16.5.0/Statistics/Test/Internal.hs -formatted b240b0717330 statistics-0.16.5.0/Statistics/Test/KolmogorovSmirnov.hs +formatted 93bdbc32499f statistics-0.16.5.0/Statistics/Test/KolmogorovSmirnov.hs formatted 68068b68b9a0 statistics-0.16.5.0/Statistics/Test/KruskalWallis.hs -formatted 6e9db487a147 statistics-0.16.5.0/Statistics/Test/Levene.hs +formatted 958fe17b2454 statistics-0.16.5.0/Statistics/Test/Levene.hs formatted 537ff3519540 statistics-0.16.5.0/Statistics/Test/MannWhitneyU.hs -formatted 63ad198bde51 statistics-0.16.5.0/Statistics/Test/StudentT.hs +formatted 24eee9104de3 statistics-0.16.5.0/Statistics/Test/StudentT.hs formatted 8222073f1e45 statistics-0.16.5.0/Statistics/Test/Types.hs formatted f3c789b5cb44 statistics-0.16.5.0/Statistics/Test/WilcoxonT.hs -formatted 4dc98e7c6347 statistics-0.16.5.0/Statistics/Transform.hs +formatted 96689c868795 statistics-0.16.5.0/Statistics/Transform.hs formatted f4cfb5a2aebb statistics-0.16.5.0/Statistics/Types.hs formatted f071cb4c4814 statistics-0.16.5.0/Statistics/Types/Internal.hs formatted b5402a2dc355 statistics-0.16.5.0/bench-papi/Bench.hs @@ -4442,7 +4442,7 @@ formatted 9c5a618f3bf1 statistics-0.16.5.0/tests/Tests/Helpers.hs formatted fec77bb7c2ff statistics-0.16.5.0/tests/Tests/KDE.hs formatted cf822ef362eb statistics-0.16.5.0/tests/Tests/Matrix.hs -formatted 27d419347379 statistics-0.16.5.0/tests/Tests/Matrix/Types.hs +formatted 3f54ac156fe8 statistics-0.16.5.0/tests/Tests/Matrix/Types.hs formatted 5815fd5a68d5 statistics-0.16.5.0/tests/Tests/NonParametric.hs formatted 4d0172724882 statistics-0.16.5.0/tests/Tests/NonParametric/Table.hs formatted 65adfee8e313 statistics-0.16.5.0/tests/Tests/Orphanage.hs @@ -4471,7 +4471,7 @@ formatted 0f86f9b94d82 stm-2.5.3.1/testsuite/src/Stm065.hs formatted 0872066614e0 swagger2-2.9.1/Setup.hs formatted e61f805d8652 swagger2-2.9.1/examples/hackage.hs -formatted 3c1b0b04d952 swagger2-2.9.1/src/Data/HashMap/Strict/InsOrd/Compat.hs +formatted 947090f59ec4 swagger2-2.9.1/src/Data/HashMap/Strict/InsOrd/Compat.hs formatted d71d272f220f swagger2-2.9.1/src/Data/Swagger.hs formatted f496ee0d4d0c swagger2-2.9.1/src/Data/Swagger/Declare.hs formatted 5302fa19a1a8 swagger2-2.9.1/src/Data/Swagger/Internal.hs @@ -4605,7 +4605,7 @@ 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 +formatted 66ed61ee4282 text-2.1.4/src/Data/Text/Internal/Transformation.hs formatted 18ae86a38924 text-2.1.4/src/Data/Text/Internal/Unsafe.hs formatted d3b144e675ef text-2.1.4/src/Data/Text/Internal/Unsafe/Char.hs formatted 8bc67bc79968 text-2.1.4/src/Data/Text/Internal/Validate.hs @@ -4889,7 +4889,7 @@ formatted 737706872ccf unliftio-0.2.25.1/src/UnliftIO.hs formatted 713d1458fd8d unliftio-0.2.25.1/src/UnliftIO/Async.hs formatted 5463e06f3adf unliftio-0.2.25.1/src/UnliftIO/Chan.hs -formatted 189c6c89bb81 unliftio-0.2.25.1/src/UnliftIO/Concurrent.hs +formatted d9a38375e7fb unliftio-0.2.25.1/src/UnliftIO/Concurrent.hs partly-checked c708a2f3ee0e unliftio-0.2.25.1/src/UnliftIO/Directory.hs formatted 402fb486b3cf unliftio-0.2.25.1/src/UnliftIO/Environment.hs formatted c9305d3c9be9 unliftio-0.2.25.1/src/UnliftIO/Exception.hs @@ -4916,15 +4916,15 @@ formatted 258e4c04879b unliftio-0.2.25.1/test/UnliftIO/IOSpec.hs formatted 68c4411ed8f4 unliftio-0.2.25.1/test/UnliftIO/MemoizeSpec.hs formatted f878ce9da222 unliftio-0.2.25.1/test/UnliftIO/PooledAsyncSpec.hs -formatted e6cf398d7548 unordered-containers-0.2.21/Data/HashMap/Internal.hs +formatted 9e71a44bc71c unordered-containers-0.2.21/Data/HashMap/Internal.hs declined - unordered-containers-0.2.21/Data/HashMap/Internal/Array.hs formatted 7be08d5816ff unordered-containers-0.2.21/Data/HashMap/Internal/Debug.hs formatted 25f94316b17e unordered-containers-0.2.21/Data/HashMap/Internal/List.hs -formatted 24da0241d81f unordered-containers-0.2.21/Data/HashMap/Internal/Strict.hs +formatted 1951edac1020 unordered-containers-0.2.21/Data/HashMap/Internal/Strict.hs formatted a4d22b20936f unordered-containers-0.2.21/Data/HashMap/Lazy.hs formatted b51d84ac0257 unordered-containers-0.2.21/Data/HashMap/Strict.hs formatted d88b52d5dce2 unordered-containers-0.2.21/Data/HashSet.hs -formatted a238b77b05ef unordered-containers-0.2.21/Data/HashSet/Internal.hs +formatted 3bfd62a86198 unordered-containers-0.2.21/Data/HashSet/Internal.hs formatted e865ae48f11b unordered-containers-0.2.21/Setup.hs formatted 31f2eba3c570 unordered-containers-0.2.21/benchmarks/Benchmarks.hs formatted 0ed2a6102dba unordered-containers-0.2.21/benchmarks/FineGrained.hs @@ -4946,13 +4946,13 @@ formatted ba3a254765ca unpacked-containers-0/example/Main.hs formatted 941a76a7e532 unpacked-containers-0/src/Key.hsig formatted 0ab7b95772b1 unpacked-containers-0/src/Map.hs -formatted 92369d5c9642 unpacked-containers-0/src/Map/Internal.hs +formatted 406fe8b6f676 unpacked-containers-0/src/Map/Internal.hs formatted 412fdc3e3871 unpacked-containers-0/src/Map/Internal/Debug.hs formatted 88e3acab50fe unpacked-containers-0/src/Map/Lazy.hs formatted d160eb88e766 unpacked-containers-0/src/Map/Merge/Lazy.hs formatted 3401a14fe602 unpacked-containers-0/src/Map/Merge/Strict.hs formatted 1da0e231433b unpacked-containers-0/src/Map/Strict.hs -formatted f41fa99a0443 unpacked-containers-0/src/Map/Strict/Internal.hs +formatted 9e8445172242 unpacked-containers-0/src/Map/Strict/Internal.hs formatted bb6c9398369f unpacked-containers-0/src/Set.hs formatted 185a318216e6 unpacked-containers-0/src/Set/Internal.hs formatted 867c9afd504a unpacked-containers-0/utils/Internal/BitQueue.hs @@ -5026,14 +5026,14 @@ formatted 88ed51490944 vector-0.13.2.0/tests/doctests.hs formatted 5561dc5bc4a0 vector-algorithms-0.9.1.0/bench/simple/Blocks.hs formatted 8f4b8b5057e3 vector-algorithms-0.9.1.0/bench/simple/Main.hs -formatted 3e94b6538b40 vector-algorithms-0.9.1.0/src/Data/Vector/Algorithms.hs +formatted 21a195e3ab16 vector-algorithms-0.9.1.0/src/Data/Vector/Algorithms.hs formatted 553211019f78 vector-algorithms-0.9.1.0/src/Data/Vector/Algorithms/AmericanFlag.hs -formatted 5bc324a60b4f vector-algorithms-0.9.1.0/src/Data/Vector/Algorithms/Common.hs +formatted 862dcd1590b5 vector-algorithms-0.9.1.0/src/Data/Vector/Algorithms/Common.hs formatted a7c93d247f1d vector-algorithms-0.9.1.0/src/Data/Vector/Algorithms/Heap.hs formatted 385f1aecc6ac vector-algorithms-0.9.1.0/src/Data/Vector/Algorithms/Insertion.hs formatted c2cb20f40fd9 vector-algorithms-0.9.1.0/src/Data/Vector/Algorithms/Intro.hs formatted 4a50f751547a vector-algorithms-0.9.1.0/src/Data/Vector/Algorithms/Merge.hs -formatted f86bd27d6c5a vector-algorithms-0.9.1.0/src/Data/Vector/Algorithms/Optimal.hs +formatted 5d6eea29399a vector-algorithms-0.9.1.0/src/Data/Vector/Algorithms/Optimal.hs formatted b7b0f718deb2 vector-algorithms-0.9.1.0/src/Data/Vector/Algorithms/Radix.hs formatted 47f1d28b6145 vector-algorithms-0.9.1.0/src/Data/Vector/Algorithms/Search.hs formatted 0a376532e9cb vector-algorithms-0.9.1.0/src/Data/Vector/Algorithms/Tim.hs diff --git a/corpora/vendored/declaration/class/family-in-a-class-body-on-one-line-out.hs b/corpora/vendored/declaration/class/family-in-a-class-body-on-one-line-out.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/declaration/class/family-in-a-class-body-on-one-line-out.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilyDependencies #-} + +module M where + +class C a where type X a; f :: a -> X a + +class D a where type Y a = r | r -> a; g :: a -> Y a + +x = [d|class E a where type W a :: Type; h :: a|] diff --git a/corpora/vendored/declaration/class/family-in-a-class-body-on-one-line.hs b/corpora/vendored/declaration/class/family-in-a-class-body-on-one-line.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/declaration/class/family-in-a-class-body-on-one-line.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilyDependencies #-} + +module M where + +class C a where { type X a; f :: a -> X a } + +class D a where { type Y a = r | r -> a; g :: a -> Y a } + +x = [d| class E a where { type W a :: Type; h :: a } |] diff --git a/corpora/vendored/declaration/data/block-haddock-on-the-left-of-an-infix-constructor-out.hs b/corpora/vendored/declaration/data/block-haddock-on-the-left-of-an-infix-constructor-out.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/declaration/data/block-haddock-on-the-left-of-an-infix-constructor-out.hs @@ -0,0 +1,10 @@ +module Kiln.Infix where + +-- A block Haddock ends where it closes, so the constructor stays on the +-- line it is written on. +data Ratio = Integer {- ^ the numerator -} :% Integer + +data Interval + = Double {- ^ the lower bound -} + :.. + Double diff --git a/corpora/vendored/declaration/data/block-haddock-on-the-left-of-an-infix-constructor.hs b/corpora/vendored/declaration/data/block-haddock-on-the-left-of-an-infix-constructor.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/declaration/data/block-haddock-on-the-left-of-an-infix-constructor.hs @@ -0,0 +1,9 @@ +module Kiln.Infix where + +-- A block Haddock ends where it closes, so the constructor stays on the +-- line it is written on. +data Ratio = Integer {- ^ the numerator -} :% Integer + +data Interval + = Double {- ^ the lower bound -} + :.. Double diff --git a/corpora/vendored/declaration/data/comment-after-the-equals-sign-out.hs b/corpora/vendored/declaration/data/comment-after-the-equals-sign-out.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/declaration/data/comment-after-the-equals-sign-out.hs @@ -0,0 +1,16 @@ +module M where + +data Answer + = {- in the order asked -} + Yes + | No + +data Size + = {- small + ones first -} + Small + | Large + +newtype Count + = {- of answers -} + Count Int diff --git a/corpora/vendored/declaration/data/comment-after-the-equals-sign.hs b/corpora/vendored/declaration/data/comment-after-the-equals-sign.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/declaration/data/comment-after-the-equals-sign.hs @@ -0,0 +1,11 @@ +module M where + +data Answer = {- in the order asked -} + Yes | No + +data Size = {- small + ones first -} + Small | Large + +newtype Count = {- of answers -} + Count Int diff --git a/corpora/vendored/declaration/type/comment-after-an-arrow-out.hs b/corpora/vendored/declaration/type/comment-after-an-arrow-out.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/declaration/type/comment-after-an-arrow-out.hs @@ -0,0 +1,13 @@ +module M where + +f :: + Int -> + {- the count -} + Bool +g :: + Int -> -- the count + Int -> + {- the limit, + if any -} + Bool +h :: Int -> {- a -} Bool diff --git a/corpora/vendored/declaration/type/comment-after-an-arrow.hs b/corpora/vendored/declaration/type/comment-after-an-arrow.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/declaration/type/comment-after-an-arrow.hs @@ -0,0 +1,12 @@ +module M where + +f :: Int -> {- the count -} + Bool + +g :: + Int -> -- the count + Int -> {- the limit, + if any -} + Bool + +h :: Int -> {- a -} Bool diff --git a/corpora/vendored/declaration/value/blank-lines-between-implicit-parameter-bindings-out.hs b/corpora/vendored/declaration/value/blank-lines-between-implicit-parameter-bindings-out.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/declaration/value/blank-lines-between-implicit-parameter-bindings-out.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE ImplicitParams #-} + +module Render.Settings where + +render page = + let ?width = 80 + ?indent = 2 + + ?colour = False + in layout page + +preview page = layout page + where + ?width = 40 + + ?colour = True + +session = do + let ?width = 120 + + ?colour = True + run diff --git a/corpora/vendored/declaration/value/blank-lines-between-implicit-parameter-bindings.hs b/corpora/vendored/declaration/value/blank-lines-between-implicit-parameter-bindings.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/declaration/value/blank-lines-between-implicit-parameter-bindings.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE ImplicitParams #-} + +module Render.Settings where + +render page = + let ?width = 80 + ?indent = 2 + + ?colour = False + in layout page + +preview page = layout page + where + ?width = 40 + + ?colour = True + +session = do + let ?width = 120 + + ?colour = True + run diff --git a/corpora/vendored/declaration/value/block-comment-across-lines-after-a-separator-out.hs b/corpora/vendored/declaration/value/block-comment-across-lines-after-a-separator-out.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/declaration/value/block-comment-across-lines-after-a-separator-out.hs @@ -0,0 +1,18 @@ +module Ledger.Entry where + +amount entry = case entry of + Credit n -> + {- paid in, + as written -} + n + Debit n -> negate n + +signed = \n -> + {- the sign + is the caller's -} + n + +opening = + {- carried over + from last year -} + 0 diff --git a/corpora/vendored/declaration/value/block-comment-across-lines-after-a-separator.hs b/corpora/vendored/declaration/value/block-comment-across-lines-after-a-separator.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/declaration/value/block-comment-across-lines-after-a-separator.hs @@ -0,0 +1,15 @@ +module Ledger.Entry where + +amount entry = case entry of + Credit n -> {- paid in, + as written -} + n + Debit n -> negate n + +signed = \n -> {- the sign + is the caller's -} + n + +opening = {- carried over + from last year -} + 0 diff --git a/corpora/vendored/declaration/value/comment-after-a-guard-separator-out.hs b/corpora/vendored/declaration/value/comment-after-a-guard-separator-out.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/declaration/value/comment-after-a-guard-separator-out.hs @@ -0,0 +1,19 @@ +module M where + +f x + | x > 0 = + {- positive -} + 1 + | x < 0 = -- negative + 2 + | otherwise = + {- zero, + or close -} + 3 + +g x = case x of + Just y + | y > 0 -> + {- positive -} + y + _ -> 0 diff --git a/corpora/vendored/declaration/value/comment-after-a-guard-separator.hs b/corpora/vendored/declaration/value/comment-after-a-guard-separator.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/declaration/value/comment-after-a-guard-separator.hs @@ -0,0 +1,16 @@ +module M where + +f x + | x > 0 = {- positive -} + 1 + | x < 0 = -- negative + 2 + | otherwise = {- zero, + or close -} + 3 + +g x = case x of + Just y + | y > 0 -> {- positive -} + y + _ -> 0 diff --git a/corpora/vendored/declaration/value/function/arrow/case-after-an-arrow-application-out.hs b/corpora/vendored/declaration/value/function/arrow/case-after-an-arrow-application-out.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/declaration/value/function/arrow/case-after-an-arrow-application-out.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE Arrows #-} + +module Cache.Refresh where + +refresh mode = proc key -> do + fresh <- + fetch + -< case key of + Pinned k -> k + Loose k -> normalise k + stale <- + key + >- case mode of + Eager -> fetchNow + Lazy -> fetchLater + returnA -< (fresh, stale) diff --git a/corpora/vendored/declaration/value/function/arrow/case-after-an-arrow-application.hs b/corpora/vendored/declaration/value/function/arrow/case-after-an-arrow-application.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/declaration/value/function/arrow/case-after-an-arrow-application.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE Arrows #-} + +module Cache.Refresh where + +refresh mode = proc key -> do + fresh <- fetch -< case key of + Pinned k -> k + Loose k -> normalise k + stale <- key >- case mode of + Eager -> fetchNow + Lazy -> fetchLater + returnA -< (fresh, stale) diff --git a/corpora/vendored/declaration/value/function/arrow/nested-block-braces-out.hs b/corpora/vendored/declaration/value/function/arrow/nested-block-braces-out.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/declaration/value/function/arrow/nested-block-braces-out.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE Arrows #-} +{-# LANGUAGE BlockArguments #-} + +module Circuit.Feed where + +feed = do step <- pure $ proc x -> do { returnA -< x }; run step + +relay = proc x -> do y <- send -< do { encode x }; returnA -< y + +echo = proc x -> do (\y -> send -< y) do { encode x }; returnA -< x diff --git a/corpora/vendored/declaration/value/function/arrow/nested-block-braces.hs b/corpora/vendored/declaration/value/function/arrow/nested-block-braces.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/declaration/value/function/arrow/nested-block-braces.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE Arrows #-} +{-# LANGUAGE BlockArguments #-} + +module Circuit.Feed where + +feed = do { step <- pure $ proc x -> do { returnA -< x }; run step } + +relay = proc x -> do { y <- send -< do { encode x }; returnA -< y } + +echo = proc x -> do { (\y -> send -< y) do { encode x }; returnA -< x } diff --git a/corpora/vendored/declaration/value/function/arrow/parenthesised-command-in-a-block-out.hs b/corpora/vendored/declaration/value/function/arrow/parenthesised-command-in-a-block-out.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/declaration/value/function/arrow/parenthesised-command-in-a-block-out.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE Arrows #-} + +module Circuit.Gate where + +gate = proc signal -> do + ( case signal of + High -> open -< signal + Low -> shut -< signal + ) + ( case signal of + High -> count -< 1 + Low -> count -< 0 + ) + <+> (trace -< signal) + returnA -< signal diff --git a/corpora/vendored/declaration/value/function/arrow/parenthesised-command-in-a-block.hs b/corpora/vendored/declaration/value/function/arrow/parenthesised-command-in-a-block.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/declaration/value/function/arrow/parenthesised-command-in-a-block.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE Arrows #-} + +module Circuit.Gate where + +gate = proc signal -> do + (case signal of + High -> open -< signal + Low -> shut -< signal) + (case signal of + High -> count -< 1 + Low -> count -< 0) <+> (trace -< signal) + returnA -< signal diff --git a/corpora/vendored/declaration/value/function/block-before-a-signature-out.hs b/corpora/vendored/declaration/value/function/block-before-a-signature-out.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/declaration/value/function/block-before-a-signature-out.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE LambdaCase #-} + +module M where + +a = do { pure () } :: IO () + +b = (case x of { A -> y } :: T) + +c = run do { x } :: IO () + +d = x <> do { y } :: T + +e = \case { A -> y } :: T -> U + +f = + do + x + y + :: IO () + +g = + run do + x + y + :: IO () + +h = + f + x + y :: + Int diff --git a/corpora/vendored/declaration/value/function/block-before-a-signature.hs b/corpora/vendored/declaration/value/function/block-before-a-signature.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/declaration/value/function/block-before-a-signature.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE LambdaCase #-} + +module M where + +a = do { pure () } :: IO () + +b = (case x of { A -> y } :: T) + +c = run do { x } :: IO () + +d = x <> do { y } :: T + +e = \case { A -> y } :: T -> U + +f = + do + x + y + :: IO () + +g = + run do + x + y + :: IO () + +h = + f + x + y :: + Int diff --git a/corpora/vendored/declaration/value/function/nested-block-braces-out.hs b/corpora/vendored/declaration/value/function/nested-block-braces-out.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/declaration/value/function/nested-block-braces-out.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE StaticPointers #-} + +module Journal.Replay where + +replay = do entry <- do { readEntry }; apply entry + +retry lock = do withLock lock do { flush }; release lock + +warnUnless quiet = do unless quiet if loud then shout else do { warn }; finish + +restore = mdo rec { ref <- do { newRef cell }; cell <- load ref }; pure cell + +pick mode = case mode of Eager -> run do { fetch }; Lazy -> defer + +settle = let first = run do { fetch }; rest = defer in first + +profile = do {-# SCC "flush" #-} do { flush }; report + +pointer = do static do { flush }; report diff --git a/corpora/vendored/declaration/value/function/nested-block-braces.hs b/corpora/vendored/declaration/value/function/nested-block-braces.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/declaration/value/function/nested-block-braces.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE RecursiveDo #-} +{-# LANGUAGE StaticPointers #-} + +module Journal.Replay where + +replay = do { entry <- do { readEntry }; apply entry } + +retry lock = do { withLock lock do { flush }; release lock } + +warnUnless quiet = do { unless quiet if loud then shout else do { warn }; finish } + +restore = mdo { rec { ref <- do { newRef cell }; cell <- load ref }; pure cell } + +pick mode = case mode of { Eager -> run do { fetch }; Lazy -> defer } + +settle = let { first = run do { fetch }; rest = defer } in first + +profile = do { {-# SCC "flush" #-} do { flush }; report } + +pointer = do { static do { flush }; report } diff --git a/corpora/vendored/declaration/value/inlinable-spelled-as-written-out.hs b/corpora/vendored/declaration/value/inlinable-spelled-as-written-out.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/declaration/value/inlinable-spelled-as-written-out.hs @@ -0,0 +1,9 @@ +module Data.Ring (add, scale) where + +add :: (Num a) => a -> a -> a +add = (+) +{-# INLINABLE add #-} + +scale :: (Num a) => a -> a -> a +scale = (*) +{-# INLINEABLE scale #-} diff --git a/corpora/vendored/declaration/value/inlinable-spelled-as-written.hs b/corpora/vendored/declaration/value/inlinable-spelled-as-written.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/declaration/value/inlinable-spelled-as-written.hs @@ -0,0 +1,9 @@ +module Data.Ring (add, scale) where + +add :: (Num a) => a -> a -> a +add = (+) +{-# INLINABLE add #-} + +scale :: (Num a) => a -> a -> a +scale = (*) +{-# INLINEABLE scale #-} diff --git a/corpora/vendored/declaration/value/operand-beginning-with-a-symbol-out.hs b/corpora/vendored/declaration/value/operand-beginning-with-a-symbol-out.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/declaration/value/operand-beginning-with-a-symbol-out.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE NegativeLiterals #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE TemplateHaskell #-} + +-- A prefix minus or a backslash stays apart from what follows it where that +-- begins with a symbol character, as the two would read as one operator. +module Ledger.Balance where + +debit = - ?amount + +credit = - ?rate * ?amount + +refund = - #total + +drift = - ?rate interval + +offset = - $(lookupOffset) + +typedOffset = - $$(lookupOffset) + +spliced = - $offset + +parity = map (\ -1 -> 0) readings + +unboxed = \ -1# -> 0# diff --git a/corpora/vendored/declaration/value/operand-beginning-with-a-symbol.hs b/corpora/vendored/declaration/value/operand-beginning-with-a-symbol.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/declaration/value/operand-beginning-with-a-symbol.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE ImplicitParams #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE NegativeLiterals #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE TemplateHaskell #-} + +-- A prefix minus or a backslash stays apart from what follows it where that +-- begins with a symbol character, as the two would read as one operator. +module Ledger.Balance where + +debit = - ?amount + +credit = - ?rate * ?amount + +refund = - #total + +drift = - ?rate interval + +offset = - $(lookupOffset) + +typedOffset = - $$(lookupOffset) + +spliced = - $offset + +parity = map (\ -1 -> 0) readings + +unboxed = \ -1# -> 0# diff --git a/corpora/vendored/declaration/value/or-pattern-written-across-lines-out.hs b/corpora/vendored/declaration/value/or-pattern-written-across-lines-out.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/declaration/value/or-pattern-written-across-lines-out.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE OrPatterns #-} + +module Shape.Corners where + +hasCorners :: Shape -> Bool +hasCorners s = case s of + ( Square; + Triangle + ) -> True + _ -> False + +startsWithCorners :: [Shape] -> Bool +startsWithCorners + ( ( Square; + Triangle + ) + : _ + ) = True +startsWithCorners _ = False + +isFlat :: Shape -> Bool +isFlat s = case s of + Line + Point -> True + _ -> False + +isRound :: Shape -> Bool +isRound (Circle; Ellipse) = True +isRound _ = False diff --git a/corpora/vendored/declaration/value/or-pattern-written-across-lines.hs b/corpora/vendored/declaration/value/or-pattern-written-across-lines.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/declaration/value/or-pattern-written-across-lines.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE OrPatterns #-} + +module Shape.Corners where + +hasCorners :: Shape -> Bool +hasCorners s = case s of + (Square; + Triangle) -> True + _ -> False + +startsWithCorners :: [Shape] -> Bool +startsWithCorners ((Square; + Triangle) : _) = True +startsWithCorners _ = False + +isFlat :: Shape -> Bool +isFlat s = case s of + Line + Point -> True + _ -> False + +isRound :: Shape -> Bool +isRound (Circle; Ellipse) = True +isRound _ = False diff --git a/corpora/vendored/declaration/value/quotation-ending-with-a-symbol-out.hs b/corpora/vendored/declaration/value/quotation-ending-with-a-symbol-out.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/declaration/value/quotation-ending-with-a-symbol-out.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- A quotation whose body may end with a symbol character keeps a space +-- inside each bracket, as the closing one would read as part of an operator. +module Chain.Quoted where + +fixities = [d| infixl 6 +++ |] + +method = [d| class Joinable a where infixr 5 <+> |] + +local = [d| joined = x +++ y where infixl 6 +++ |] + +kinded = [| Proxy :: Proxy * |] + +typedKinded = [|| Proxy :: Proxy * ||] + +plain = [d|joined = x ++ y|] diff --git a/corpora/vendored/declaration/value/quotation-ending-with-a-symbol.hs b/corpora/vendored/declaration/value/quotation-ending-with-a-symbol.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/declaration/value/quotation-ending-with-a-symbol.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- A quotation whose body may end with a symbol character keeps a space +-- inside each bracket, as the closing one would read as part of an operator. +module Chain.Quoted where + +fixities = [d| infixl 6 +++ |] + +method = [d| class Joinable a where infixr 5 <+> |] + +local = [d| joined = x +++ y where infixl 6 +++ |] + +kinded = [| Proxy :: Proxy * |] + +typedKinded = [|| Proxy :: Proxy * ||] + +plain = [d| joined = x ++ y |] diff --git a/corpora/vendored/declaration/value/specialise-spelled-as-written-out.hs b/corpora/vendored/declaration/value/specialise-spelled-as-written-out.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/declaration/value/specialise-spelled-as-written-out.hs @@ -0,0 +1,21 @@ +module Data.Ring (add, scale, Ring (..)) where + +add :: (Num a) => a -> a -> a +add = (+) +{-# SPECIALISE add :: Int -> Int -> Int #-} +{-# SPECIALIZE add :: Double -> Double -> Double #-} + +scale :: (Num a) => a -> a -> a +scale = (*) +{-# SPECIALISE INLINE scale :: Int -> Int -> Int #-} +{-# SPECIALIZE NOINLINE scale :: Double -> Double -> Double #-} + +newtype Ring a = Ring a + +instance (Eq a) => Eq (Ring a) where + {-# SPECIALISE instance Eq (Ring Int) #-} + Ring a == Ring b = a == b + +instance (Ord a) => Ord (Ring a) where + {-# SPECIALIZE instance Ord (Ring Int) #-} + compare (Ring a) (Ring b) = compare a b diff --git a/corpora/vendored/declaration/value/specialise-spelled-as-written.hs b/corpora/vendored/declaration/value/specialise-spelled-as-written.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/declaration/value/specialise-spelled-as-written.hs @@ -0,0 +1,21 @@ +module Data.Ring (add, scale, Ring (..)) where + +add :: (Num a) => a -> a -> a +add = (+) +{-# SPECIALISE add :: Int -> Int -> Int #-} +{-# SPECIALIZE add :: Double -> Double -> Double #-} + +scale :: (Num a) => a -> a -> a +scale = (*) +{-# SPECIALISE INLINE scale :: Int -> Int -> Int #-} +{-# SPECIALIZE NOINLINE scale :: Double -> Double -> Double #-} + +newtype Ring a = Ring a + +instance (Eq a) => Eq (Ring a) where + {-# SPECIALISE instance Eq (Ring Int) #-} + Ring a == Ring b = a == b + +instance (Ord a) => Ord (Ring a) where + {-# SPECIALIZE instance Ord (Ring Int) #-} + compare (Ring a) (Ring b) = compare a b diff --git a/corpora/vendored/declaration/value/specialise-without-a-head-variable-out.hs b/corpora/vendored/declaration/value/specialise-without-a-head-variable-out.hs --- a/corpora/vendored/declaration/value/specialise-without-a-head-variable-out.hs +++ b/corpora/vendored/declaration/value/specialise-without-a-head-variable-out.hs @@ -1,4 +1,4 @@ f :: (Ord a) => a -> a f = f -{-# SPECIALIZE let x = 2 in f x #-} +{-# SPECIALISE let x = 2 in f x #-} diff --git a/corpora/vendored/import/comment-after-the-opening-bracket-out.hs b/corpora/vendored/import/comment-after-the-opening-bracket-out.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/import/comment-after-the-opening-bracket-out.hs @@ -0,0 +1,16 @@ +module M where + +import Data.List + ( {- for the order -} + sortOn, + ) +import Data.Map + ( {- the map + itself -} + Map, + fromList, + ) +import Data.Maybe hiding + ( {- not these -} + fromJust, + ) diff --git a/corpora/vendored/import/comment-after-the-opening-bracket.hs b/corpora/vendored/import/comment-after-the-opening-bracket.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/import/comment-after-the-opening-bracket.hs @@ -0,0 +1,9 @@ +module M where + +import Data.List ( {- for the order -} + sortOn ) +import Data.Map ( {- the map + itself -} Map, + fromList ) +import Data.Maybe hiding ( {- not these -} + fromJust ) diff --git a/corpora/vendored/import/package-name-with-a-string-gap-out.hs b/corpora/vendored/import/package-name-with-a-string-gap-out.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/import/package-name-with-a-string-gap-out.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE PackageImports #-} + +module M where + +import "ba\ + \se" Data.List qualified as L diff --git a/corpora/vendored/import/package-name-with-a-string-gap.hs b/corpora/vendored/import/package-name-with-a-string-gap.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/import/package-name-with-a-string-gap.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE PackageImports #-} + +module M where + +import qualified "ba\ + \se" Data.List as L diff --git a/corpora/vendored/other/block-comment-indented-with-tabs-out.hs b/corpora/vendored/other/block-comment-indented-with-tabs-out.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/block-comment-indented-with-tabs-out.hs @@ -0,0 +1,17 @@ +-- The lines of a moved block comment stay where they were against its first +-- line, a tab counting up to the next multiple of eight, as GHC counts. +module Tabs where + +underTabs :: Int +underTabs = g + where + {- a + b -} + g = 1 + +overATab :: Int +overATab = g + where + {- a + b -} + g = 1 diff --git a/corpora/vendored/other/block-comment-indented-with-tabs.hs b/corpora/vendored/other/block-comment-indented-with-tabs.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/block-comment-indented-with-tabs.hs @@ -0,0 +1,17 @@ +-- The lines of a moved block comment stay where they were against its first +-- line, a tab counting up to the next multiple of eight, as GHC counts. +module Tabs where + +underTabs :: Int +underTabs = g + where + {- a + b -} + g = 1 + +overATab :: Int +overATab = g + where + {- a + b -} + g = 1 diff --git a/corpora/vendored/other/block-comment-that-code-follows-above-an-empty-line-out.hs b/corpora/vendored/other/block-comment-that-code-follows-above-an-empty-line-out.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/block-comment-that-code-follows-above-an-empty-line-out.hs @@ -0,0 +1,17 @@ +module M where + +f x = + if x + then {- a + b -} + y + else z + +g = 1 + +data T + = T {- a + b -} + Int + +h = 2 diff --git a/corpora/vendored/other/block-comment-that-code-follows-above-an-empty-line.hs b/corpora/vendored/other/block-comment-that-code-follows-above-an-empty-line.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/block-comment-that-code-follows-above-an-empty-line.hs @@ -0,0 +1,11 @@ +module M where + +f x = if x then {- a + b -} y else z + +g = 1 + +data T = T {- a + b -} Int + +h = 2 diff --git a/corpora/vendored/other/comment-in-a-tuple-section-out.hs b/corpora/vendored/other/comment-in-a-tuple-section-out.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/comment-in-a-tuple-section-out.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE TupleSections #-} + +module Queue.Pairs where + +pending = (,Nothing {- yet -}) + +leftOnly = (Left x, {- the right comes later -}) + +rightOnly = + (,Right y + -- and the left from the caller + ) + +done = (x, y) diff --git a/corpora/vendored/other/comment-in-a-tuple-section.hs b/corpora/vendored/other/comment-in-a-tuple-section.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/comment-in-a-tuple-section.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE TupleSections #-} + +module Queue.Pairs where + +pending = (, Nothing {- yet -}) + +leftOnly = (Left x, {- the right comes later -} ) + +rightOnly = (, Right y + -- and the left from the caller + ) + +done = (x, y) diff --git a/corpora/vendored/other/comment-opening-with-a-word-like-stack-out.hs b/corpora/vendored/other/comment-opening-with-a-word-like-stack-out.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/comment-opening-with-a-word-like-stack-out.hs @@ -0,0 +1,8 @@ +-- stacks of disks, the smallest on top, +-- and never a larger disk on a smaller one +module Hanoi (moves) where + +moves :: Int -> a -> a -> a -> [(a, a)] +moves 0 _ _ _ = [] +moves n from to via = + moves (n - 1) from via to ++ [(from, to)] ++ moves (n - 1) via to from diff --git a/corpora/vendored/other/comment-opening-with-a-word-like-stack.hs b/corpora/vendored/other/comment-opening-with-a-word-like-stack.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/comment-opening-with-a-word-like-stack.hs @@ -0,0 +1,8 @@ +-- stacks of disks, the smallest on top, +-- and never a larger disk on a smaller one +module Hanoi (moves) where + +moves :: Int -> a -> a -> a -> [(a, a)] +moves 0 _ _ _ = [] +moves n from to via = + moves (n - 1) from via to ++ [(from, to)] ++ moves (n - 1) via to from diff --git a/corpora/vendored/other/comment-under-a-block-comment-before-a-closing-bracket-out.hs b/corpora/vendored/other/comment-under-a-block-comment-before-a-closing-bracket-out.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/comment-under-a-block-comment-before-a-closing-bracket-out.hs @@ -0,0 +1,20 @@ +module Garden.Beds where + +perennials = + [ sage, + thyme {- both kinds -} + -- and more next spring + ] + +annuals = + [ basil, + dill {- self-seeding -} + -- if left alone + ] + +border = + plant + ( lavender, + rosemary {- by the path -} + -- in full sun + ) diff --git a/corpora/vendored/other/comment-under-a-block-comment-before-a-closing-bracket.hs b/corpora/vendored/other/comment-under-a-block-comment-before-a-closing-bracket.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/comment-under-a-block-comment-before-a-closing-bracket.hs @@ -0,0 +1,18 @@ +module Garden.Beds where + +perennials = + [ sage, + thyme {- both kinds -} + -- and more next spring + ] + +annuals = + [ basil + , dill {- self-seeding -} + -- if left alone + ] + +border = plant + ( lavender, rosemary {- by the path -} + -- in full sun + ) diff --git a/corpora/vendored/other/comment-under-the-last-part-of-a-construct-out.hs b/corpora/vendored/other/comment-under-the-last-part-of-a-construct-out.hs --- a/corpora/vendored/other/comment-under-the-last-part-of-a-construct-out.hs +++ b/corpora/vendored/other/comment-under-the-last-part-of-a-construct-out.hs @@ -50,3 +50,10 @@ beam :: Int beam = 2 + +-- At the end of the module, where nothing follows the construct, too. +loom :: Int +loom = shuttles + where + shuttles = 2 + -- and a spare diff --git a/corpora/vendored/other/comment-under-the-last-part-of-a-construct.hs b/corpora/vendored/other/comment-under-the-last-part-of-a-construct.hs --- a/corpora/vendored/other/comment-under-the-last-part-of-a-construct.hs +++ b/corpora/vendored/other/comment-under-the-last-part-of-a-construct.hs @@ -45,3 +45,10 @@ -- on both sides beam :: Int beam = 2 + +-- At the end of the module, where nothing follows the construct, too. +loom :: Int +loom = shuttles + where + shuttles = 2 + -- and a spare diff --git a/corpora/vendored/other/commented-language-pragma-repeating-an-extension-out.hs b/corpora/vendored/other/commented-language-pragma-repeating-an-extension-out.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/commented-language-pragma-repeating-an-extension-out.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE LambdaCase -- for classify + #-} +{-# LANGUAGE TupleSections #-} + +module Kiln.Repeated where + +-- A pragma that names an extension again but holds a comment stays, with +-- the comment. +classify :: Int -> String +classify = \case + 0 -> "zero" + _ -> "other" diff --git a/corpora/vendored/other/commented-language-pragma-repeating-an-extension.hs b/corpora/vendored/other/commented-language-pragma-repeating-an-extension.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/commented-language-pragma-repeating-an-extension.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE LambdaCase -- for classify + #-} +module Kiln.Repeated where + +-- A pragma that names an extension again but holds a comment stays, with +-- the comment. +classify :: Int -> String +classify = \case + 0 -> "zero" + _ -> "other" diff --git a/corpora/vendored/other/comments-after-an-item-before-a-leading-comma-out.hs b/corpora/vendored/other/comments-after-an-item-before-a-leading-comma-out.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/comments-after-an-item-before-a-leading-comma-out.hs @@ -0,0 +1,6 @@ +module Survey.Tally + ( count, {- the total -} -- so far + reset, {- to zero -} + tally, -- by answer + ) +where diff --git a/corpora/vendored/other/comments-after-an-item-before-a-leading-comma.hs b/corpora/vendored/other/comments-after-an-item-before-a-leading-comma.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/comments-after-an-item-before-a-leading-comma.hs @@ -0,0 +1,6 @@ +module Survey.Tally + ( count {- the total -} -- so far + , reset {- to zero -} + , tally -- by answer + ) +where diff --git a/corpora/vendored/other/cpp/context-headed-by-a-macro-out.hs b/corpora/vendored/other/cpp/context-headed-by-a-macro-out.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/cpp/context-headed-by-a-macro-out.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE CPP #-} + +-- A macro may stand for a whole constraint and its arrow, or for a pragma, +-- so a context headed by one gets no parentheses that would close it in. +module M where + +import GHC.Stack (HasCallStack) + +#define CALLSTACK HasCallStack => +#define OVERLAPS {-# OVERLAPPING #-} + +assertEqual :: CALLSTACK (Eq a, Show a) => a -> a -> IO () +assertEqual expected actual = print (expected == actual) + +firstOf :: + CALLSTACK + Foldable + t => + t a -> a +firstOf = foldr const (error "empty") + +same :: (Eq a) => a -> a -> Bool +same = (==) + +class Pretty a where + pretty :: a -> String + +instance OVERLAPS (Pretty a, Pretty b) => Pretty (a, b) where + pretty (a, b) = pretty a <> pretty b diff --git a/corpora/vendored/other/cpp/context-headed-by-a-macro.hs b/corpora/vendored/other/cpp/context-headed-by-a-macro.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/cpp/context-headed-by-a-macro.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE CPP #-} + +-- A macro may stand for a whole constraint and its arrow, or for a pragma, +-- so a context headed by one gets no parentheses that would close it in. +module M where + +import GHC.Stack (HasCallStack) + +#define CALLSTACK HasCallStack => +#define OVERLAPS {-# OVERLAPPING #-} + +assertEqual :: CALLSTACK (Eq a, Show a) => a -> a -> IO () +assertEqual expected actual = print (expected == actual) + +firstOf :: CALLSTACK + Foldable t => t a -> a +firstOf = foldr const (error "empty") + +same :: Eq a => a -> a -> Bool +same = (==) + +class Pretty a where + pretty :: a -> String + +instance OVERLAPS (Pretty a, Pretty b) => Pretty (a, b) where + pretty (a, b) = pretty a <> pretty b diff --git a/corpora/vendored/other/cpp/directives-in-a-haddock-out.hs b/corpora/vendored/other/cpp/directives-in-a-haddock-out.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/cpp/directives-in-a-haddock-out.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE CPP #-} + +module M where + +class Shape a where + {- | + The area, for example: + +#if MIN_VERSION_base(4,10,0) + >>> area (Square 2) + 4.0 +#else + >>> area (Square 2.0) + 4.0 +#endif + -} + area :: a -> Double + + -- | The perimeter. + perimeter :: a -> Double diff --git a/corpora/vendored/other/cpp/directives-in-a-haddock.hs b/corpora/vendored/other/cpp/directives-in-a-haddock.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/cpp/directives-in-a-haddock.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE CPP #-} + +module M where + +class Shape a where + {- | +The area, for example: + +#if MIN_VERSION_base(4,10,0) +>>> area (Square 2) +4.0 +#else +>>> area (Square 2.0) +4.0 +#endif + -} + area :: a -> Double + + -- | The perimeter. + perimeter :: a -> Double diff --git a/corpora/vendored/other/cpp/imports-around-a-conditional-holding-a-directive.hs b/corpora/vendored/other/cpp/imports-around-a-conditional-holding-a-directive.hs --- a/corpora/vendored/other/cpp/imports-around-a-conditional-holding-a-directive.hs +++ b/corpora/vendored/other/cpp/imports-around-a-conditional-holding-a-directive.hs @@ -4,7 +4,7 @@ import System.Environment (lookupEnv) #ifdef WIDE_TERMINALS - #define DEFAULT_WIDTH 132 +#define DEFAULT_WIDTH 132 #endif import Data.Maybe (fromMaybe) diff --git a/corpora/vendored/other/cpp/labels-named-like-directives-out.hs b/corpora/vendored/other/cpp/labels-named-like-directives-out.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/cpp/labels-named-like-directives-out.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedLabels #-} + +-- | Labels named like directives, which cpp leaves alone where they do not +-- open their line. +module Record.Fields (columns, defined) where + +#if MIN_VERSION_base(4,10,0) +import GHC.OverloadedLabels (IsLabel (..)) +#endif + +columns :: [Column] +columns = + [ #line, + #if, + #else + ] + +defined :: Column -> Bool +defined = + hasValue + #define diff --git a/corpora/vendored/other/cpp/labels-named-like-directives.hs b/corpora/vendored/other/cpp/labels-named-like-directives.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/cpp/labels-named-like-directives.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedLabels #-} + +-- | Labels named like directives, which cpp leaves alone where they do not +-- open their line. +module Record.Fields (columns, defined) where + +#if MIN_VERSION_base(4,10,0) +import GHC.OverloadedLabels (IsLabel (..)) +#endif + +columns :: [Column] +columns = + [ #line, + #if, #else + ] + +defined :: Column -> Bool +defined = + hasValue + #define diff --git a/corpora/vendored/other/cpp/line-marker-passed-on-by-cpp.hs b/corpora/vendored/other/cpp/line-marker-passed-on-by-cpp.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/cpp/line-marker-passed-on-by-cpp.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE CPP #-} + +module M where + +x = 1 -- one +# 40 "Other.hs" +y = 2 -- two diff --git a/corpora/vendored/other/cpp/macro-before-a-leading-comma.hs b/corpora/vendored/other/cpp/macro-before-a-leading-comma.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/cpp/macro-before-a-leading-comma.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE CPP #-} + +module Signals (handled) where + +#define ALSO(name) , name + +handled :: [String] +handled = + [ "INT" + , "TERM" + ALSO("HUP") + , "QUIT" + ] diff --git a/corpora/vendored/other/declarations-on-one-line-out.hs b/corpora/vendored/other/declarations-on-one-line-out.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/declarations-on-one-line-out.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Grid.Sizes where + +sizes = [d|width = 80; height = 24|] + +limits = [d|maxWidth :: Int; maxWidth = 200; minWidth = 10|] diff --git a/corpora/vendored/other/declarations-on-one-line.hs b/corpora/vendored/other/declarations-on-one-line.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/declarations-on-one-line.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Grid.Sizes where + +sizes = [d| width = 80; height = 24 |] + +limits = [d| maxWidth :: Int; maxWidth = 200; minWidth = 10 |] diff --git a/corpora/vendored/other/haddock-that-documents-nothing-out.hs b/corpora/vendored/other/haddock-that-documents-nothing-out.hs --- a/corpora/vendored/other/haddock-that-documents-nothing-out.hs +++ b/corpora/vendored/other/haddock-that-documents-nothing-out.hs @@ -40,3 +40,15 @@ -> Int g = id + +-- A block one above a local binding has only its trigger escaped: the lines +-- under it are its text. +blockAbove :: Int +blockAbove = g + where + {- \| What g is, as these would write it: + + -- | One. + {- * Two. -} + -} + g = 1 diff --git a/corpora/vendored/other/haddock-that-documents-nothing.hs b/corpora/vendored/other/haddock-that-documents-nothing.hs --- a/corpora/vendored/other/haddock-that-documents-nothing.hs +++ b/corpora/vendored/other/haddock-that-documents-nothing.hs @@ -39,3 +39,15 @@ on to a second line -} -> Int g = id + +-- A block one above a local binding has only its trigger escaped: the lines +-- under it are its text. +blockAbove :: Int +blockAbove = g + where + {- | What g is, as these would write it: + + -- | One. + {- * Two. -} + -} + g = 1 diff --git a/corpora/vendored/other/line-comment-after-a-block-comment-out.hs b/corpora/vendored/other/line-comment-after-a-block-comment-out.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/line-comment-after-a-block-comment-out.hs @@ -0,0 +1,29 @@ +module Survey.Tally + ( count, {- the total -} -- so far + reset, + ) +where + +import Data.List + ( {- for the order -} -- of answers + sortOn, + ) + +count = + {- every answer -} -- once + length answers + +data Answer + = {- in the order asked -} -- on the form + Yes + | No + +verdict a = case a of + Yes -> + {- counted -} -- as one + 1 + No -> 0 + +skipped = \a -> + {- left out -} -- of the count + 0 diff --git a/corpora/vendored/other/line-comment-after-a-block-comment.hs b/corpora/vendored/other/line-comment-after-a-block-comment.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/line-comment-after-a-block-comment.hs @@ -0,0 +1,22 @@ +module Survey.Tally + ( count, {- the total -} -- so far + reset, + ) +where + +import Data.List ( {- for the order -} -- of answers + sortOn ) + +count = {- every answer -} -- once + length answers + +data Answer = {- in the order asked -} -- on the form + Yes | No + +verdict a = case a of + Yes -> {- counted -} -- as one + 1 + No -> 0 + +skipped = \a -> {- left out -} -- of the count + 0 diff --git a/corpora/vendored/other/line-markers-in-a-quasi-quotation-out.hs b/corpora/vendored/other/line-markers-in-a-quasi-quotation-out.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/line-markers-in-a-quasi-quotation-out.hs @@ -0,0 +1,16 @@ +#!/usr/bin/env runghc +{-# LANGUAGE QuasiQuotes #-} + +-- | Lines that GHC reads past elsewhere are text in a quasi-quotation, and a +-- script's first line is its own. +module Stitched.Script where + +script :: String +script = [str| +#!/bin/sh +# 40 "Template.hs" +#pragma once +|] + +after :: Int +after = 1 diff --git a/corpora/vendored/other/line-markers-in-a-quasi-quotation.hs b/corpora/vendored/other/line-markers-in-a-quasi-quotation.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/line-markers-in-a-quasi-quotation.hs @@ -0,0 +1,16 @@ +#!/usr/bin/env runghc +{-# LANGUAGE QuasiQuotes #-} + +-- | Lines that GHC reads past elsewhere are text in a quasi-quotation, and a +-- script's first line is its own. +module Stitched.Script where + +script :: String +script = [str| +#!/bin/sh +# 40 "Template.hs" +#pragma once +|] + +after :: Int +after = 1 diff --git a/corpora/vendored/other/line-markers.hs b/corpora/vendored/other/line-markers.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/line-markers.hs @@ -0,0 +1,16 @@ +-- | Code stitched together from several files, which says where each part +-- of it came from the way cpp does. +module Stitched where + +ownLine :: Int -> Int +ownLine n = n + 1 + +# 40 "Template.hs" + +fromTheTemplate :: Int -> Int +fromTheTemplate n = n + +#line 12 "Stitched.hs" + +andBackAgain :: Int -> Int +andBackAgain n = n - 1 diff --git a/corpora/vendored/other/moved-haddock-beginning-with-a-dollar-out.hs b/corpora/vendored/other/moved-haddock-beginning-with-a-dollar-out.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/moved-haddock-beginning-with-a-dollar-out.hs @@ -0,0 +1,12 @@ +module Kiln.Price where + +-- A dollar that a Haddock moved in front of what it documents begins with +-- stays as written. +charge :: + -- | $1 for each unit + Int -> + {- | $5 at least, + $10 at most -} + Int -> + Int +charge = const diff --git a/corpora/vendored/other/moved-haddock-beginning-with-a-dollar.hs b/corpora/vendored/other/moved-haddock-beginning-with-a-dollar.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/moved-haddock-beginning-with-a-dollar.hs @@ -0,0 +1,10 @@ +module Kiln.Price where + +-- A dollar that a Haddock moved in front of what it documents begins with +-- stays as written. +charge :: + Int -- ^ $1 for each unit + -> Int {- ^ $5 at least, + $10 at most -} + -> Int +charge = const diff --git a/corpora/vendored/other/moved-haddock-continued-with-a-dollar-out.hs b/corpora/vendored/other/moved-haddock-continued-with-a-dollar-out.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/moved-haddock-continued-with-a-dollar-out.hs @@ -0,0 +1,14 @@ +module M where + +f :: + -- | the price, + --$5 at most + Int -> + Int +f = id + +data T + = -- | the price, + --$5 at most + T + Int diff --git a/corpora/vendored/other/moved-haddock-continued-with-a-dollar.hs b/corpora/vendored/other/moved-haddock-continued-with-a-dollar.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/moved-haddock-continued-with-a-dollar.hs @@ -0,0 +1,11 @@ +module M where + +f :: + Int -> -- ^ the price, + --$5 at most + Int +f = id + +data T = T + Int -- ^ the price, + --$5 at most diff --git a/corpora/vendored/other/options-pragma-with-no-options-out.hs b/corpora/vendored/other/options-pragma-with-no-options-out.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/options-pragma-with-no-options-out.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC #-} + +module Kiln.Fire where + +fire :: Int +fire = 1 diff --git a/corpora/vendored/other/options-pragma-with-no-options.hs b/corpora/vendored/other/options-pragma-with-no-options.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/options-pragma-with-no-options.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC #-} + +module Kiln.Fire where + +fire :: Int +fire = 1 diff --git a/corpora/vendored/other/position-pragma-in-a-quasi-quotation-out.hs b/corpora/vendored/other/position-pragma-in-a-quasi-quotation-out.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/position-pragma-in-a-quasi-quotation-out.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE QuasiQuotes #-} + +-- | A position pragma in a quasi-quotation is text, and moves nothing. +module Woven.Template where + +template :: String +template = [str| +{-# LINE 40 "Template.hs" #-} +|] + +after :: Int +after = 1 diff --git a/corpora/vendored/other/position-pragma-in-a-quasi-quotation.hs b/corpora/vendored/other/position-pragma-in-a-quasi-quotation.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/position-pragma-in-a-quasi-quotation.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE QuasiQuotes #-} + +-- | A position pragma in a quasi-quotation is text, and moves nothing. +module Woven.Template where + +template :: String +template = [str| +{-# LINE 40 "Template.hs" #-} +|] + +after :: Int +after = 1 diff --git a/corpora/vendored/other/stack-script-header-over-a-comment-out.hs b/corpora/vendored/other/stack-script-header-over-a-comment-out.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/stack-script-header-over-a-comment-out.hs @@ -0,0 +1,11 @@ +#!/usr/bin/env stack +-- stack script --snapshot lts-22.21 --package text + +-- Print each line of the input with its words in reverse order. +module Main (main) where + +import qualified Data.Text as T +import qualified Data.Text.IO as T + +main :: IO () +main = T.interact (T.unlines . map (T.unwords . reverse . T.words) . T.lines) diff --git a/corpora/vendored/other/stack-script-header-over-a-comment.hs b/corpora/vendored/other/stack-script-header-over-a-comment.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/stack-script-header-over-a-comment.hs @@ -0,0 +1,10 @@ +#!/usr/bin/env stack +-- stack script --snapshot lts-22.21 --package text +-- Print each line of the input with its words in reverse order. +module Main (main) where + +import qualified Data.Text as T +import qualified Data.Text.IO as T + +main :: IO () +main = T.interact (T.unlines . map (T.unwords . reverse . T.words) . T.lines) diff --git a/corpora/vendored/other/warning-category-as-written-out.hs b/corpora/vendored/other/warning-category-as-written-out.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/warning-category-as-written-out.hs @@ -0,0 +1,9 @@ +module M where + +{-# WARNING in "x-p\&artial" f "Partial" #-} +f :: Int -> Int +f = id + +{-# WARNING in "x-unsafe" g "Unsafe" #-} +g :: Int -> Int +g = id diff --git a/corpora/vendored/other/warning-category-as-written.hs b/corpora/vendored/other/warning-category-as-written.hs new file mode 100644 --- /dev/null +++ b/corpora/vendored/other/warning-category-as-written.hs @@ -0,0 +1,9 @@ +module M where + +{-# WARNING in "x-p\&artial" f "Partial" #-} +f :: Int -> Int +f = id + +{-# WARNING in "x-unsafe" g "Unsafe" #-} +g :: Int -> Int +g = id diff --git a/corpora/vendored/signature/module-in-the-export-list-out.hsig b/corpora/vendored/signature/module-in-the-export-list-out.hsig new file mode 100644 --- /dev/null +++ b/corpora/vendored/signature/module-in-the-export-list-out.hsig @@ -0,0 +1,7 @@ +signature Codec (Codec, module Data.Text) where + +import Data.Text + +data Codec + +encode :: Codec -> Text diff --git a/corpora/vendored/signature/module-in-the-export-list.hsig b/corpora/vendored/signature/module-in-the-export-list.hsig new file mode 100644 --- /dev/null +++ b/corpora/vendored/signature/module-in-the-export-list.hsig @@ -0,0 +1,7 @@ +signature Codec (Codec, module Data.Text) where + +import Data.Text + +data Codec + +encode :: Codec -> Text 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 @@ -18,6 +18,7 @@ Kind (..), packageOf, packageComponents, + packageBranches, addedSources, sourceExtensions, isDeclaredModule, @@ -54,6 +55,7 @@ CondTree (..), ConfVar (..), Executable (..), + ForeignLib (..), GenericPackageDescription (..), Library (..), PackageDescription (..), @@ -88,7 +90,7 @@ import Tilia.Cabal.Project (cabalFilesIn, startingDirectory) import Tilia.Pragma (Defaults, defaultsOf, lookupEdition, nameSwitch) import Tilia.Process (readProgramOutput) -import Tilia.Utils (attempted, pathUnder, quietly, tshow) +import Tilia.Utils (pathUnder, quietly, readBytes, tshow) -- | Why a file's extensions could not be settled. data PackageProblem @@ -261,7 +263,7 @@ -- | Read and parse a @.cabal@ file, or say why it cannot be. readPackageDescription :: FilePath -> IO (Either PackageProblem GenericPackageDescription) readPackageDescription cabalFile = - attempted (BS.readFile cabalFile) >>= \case + readBytes cabalFile >>= \case Left why -> pure (Left (PackageUnreadable cabalFile why)) Right bytes -> pure (parsePackageDescription cabalFile bytes) @@ -351,7 +353,7 @@ -- | The kinds of component a @.cabal@ file can declare, and the setup -- script beside it. -data Kind = Lib | Exe | Test | Bench | Setup +data Kind = Lib | FLib | Exe | Test | Bench | Setup deriving (Eq, Ord, Show) -- | Every component of a package, in the order declared: its kind, its @@ -361,6 +363,7 @@ concat [ [(Lib, packageOf described, libraryBranches t) | t <- toList (condLibrary described)], [(Lib, nameOf n, libraryBranches t) | (n, t) <- condSubLibraries described], + [(FLib, nameOf n, foreignLibBranches t) | (n, t) <- condForeignLibs 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] @@ -373,14 +376,20 @@ 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)] -declaredModules described = - [ (T.intercalate "." (fmap T.pack (splitDirectories sub <> [name])), joined d (joined sub name)) - | branch <- packageBranches described, - (d, section) <- addedSources branch, - (sub, name) <- sectionModules section +-- | Each source directory the branches given name, with every module they +-- declare there and where it would be written under it, without an +-- extension. +declaredModules :: [BranchSections] -> [(FilePath, [(Text, FilePath)])] +declaredModules branches = + [ ( d, + [ ( T.intercalate "." (fmap T.pack (splitDirectories sub <> [name])), + joined sub name + ) + | (sub, name) <- sectionModules section + ] + ) + | branch <- branches, + (d, section) <- addedSources branch ] -- | Every directory any branch of a package names for its files, and then @@ -442,6 +451,10 @@ libraryBranches :: CondTree ConfVar Library -> [BranchSections] libraryBranches = branchesOf $ \l -> declaring (libBuildInfo l) (exposedModules l <> signatures l) [] + +-- | Every branch of a foreign library. +foreignLibBranches :: CondTree ConfVar ForeignLib -> [BranchSections] +foreignLibBranches = branchesOf $ \f -> declaring (foreignLibBuildInfo f) [] [] -- | Every branch of an executable. executableBranches :: CondTree ConfVar Executable -> [BranchSections] 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 @@ -34,12 +34,13 @@ Futility (..), undiscoveredFutility, futilityFor, + CabalFailure (..), prepareWith, loadPlan, ) where -import Control.Monad (filterM, join, void) +import Control.Monad (filterM, join) import Data.Aeson ( FromJSON (..), Value, @@ -50,6 +51,8 @@ (.:?), ) import Data.Aeson.Types (parseMaybe) +import Data.Bifunctor (first) +import Data.ByteString qualified as BS import Data.Choice (Choice, isFalse) import Data.Containers.ListUtils (nubOrdOn) import Data.Foldable (toList, traverse_) @@ -82,10 +85,10 @@ import System.Environment (lookupEnv) import System.Exit (ExitCode (..)) import System.FilePath (isRelative, takeDirectory, ()) -import System.IO (hClose, hFlush, stderr) +import System.IO (Handle, hClose, hFlush, stderr) import System.Info qualified import System.Process - ( StdStream (CreatePipe, Inherit, UseHandle), + ( StdStream (CreatePipe, UseHandle), createProcess, cwd, proc, @@ -95,11 +98,11 @@ waitForProcess, ) import Tilia.Cabal.Package (readPackageDescription) -import Tilia.Cabal.Project (cabalFilesIn) +import Tilia.Cabal.Project (cabalFilesIn, projectConfigFiles) import Tilia.Cpp.Macros (Macros (..)) import Tilia.Fixity.Cache import Tilia.Fixity.PackageDb -import Tilia.Process (readProgramOutput) +import Tilia.Process (readProgramOutputIn) import Tilia.Utils (quietly, sha256Of) ---------------------------------------------------------------------------- @@ -302,8 +305,10 @@ decodePlan :: FilePath -> IO (Either Text BuildPlan) decodePlan path = doesFileExist path >>= \case - False -> pure (Left ("no build plan at " <> T.pack path)) - True -> either (Left . T.pack) Right <$> eitherDecodeFileStrict path + False -> pure (Left (T.pack path <> " does not exist")) + True -> first unparsed <$> eitherDecodeFileStrict path + where + unparsed why = T.pack path <> " does not parse: " <> T.pack why -- | Find where @cabal@ unpacked each @source-repository-package@. checkedOutIn :: FilePath -> BuildPlan -> IO BuildPlan @@ -427,7 +432,8 @@ data PlanComponent = PlanComponent { -- | The package it belongs to. pcPackage :: Text, - -- | @lib@, @exe:name@, @test:name@, @bench:name@. + -- | @lib@ for the main library, or else the kind and the name, as in + -- @lib:name@, @flib:name@, @exe:name@, @test:name@ or @bench:name@. pcName :: Text } deriving (Eq, Ord, Show) @@ -492,14 +498,15 @@ (_ : _, _) -> pure (PlanStale newer) ([], _ : _) -> pure (PlanNarrow missing) ([], []) -> - sourcesShortOf cache plan >>= \case + sourcesShortOf cache projectDir plan >>= \case [] -> pure Ready ps -> pure (SourcesMissing (fmap ppName ps)) -- | The packages the plan expects to fetch whose sources are not here. -sourcesShortOf :: Cache -> BuildPlan -> IO [PlanPackage] -sourcesShortOf cache plan = do - tarballs <- filter (isFetchable . fst) <$> plannedTarballs cache plan +sourcesShortOf :: Cache -> FilePath -> BuildPlan -> IO [PlanPackage] +sourcesShortOf cache projectDir plan = do + tarballs <- + filter (isFetchable . fst) <$> plannedTarballs cache projectDir plan absent <- fmap fst <$> filterM (fmap not . doesFileExist . snd) tarballs if null absent then pure [] @@ -507,6 +514,19 @@ installed <- getInstalledPackages cache pure (filter (not . builtAlready installed) absent) +-- | The packages a fetch left the plan short of, with @cabal@ asked again +-- where it keeps what it downloads if there are any. +-- +-- A fetch leaving a source missing where @cabal@ last said is what a moved +-- package cache looks like, and the only thing taken for one. +shortAfterFetch :: Cache -> FilePath -> BuildPlan -> IO [PlanPackage] +shortAfterFetch cache projectDir plan = + sourcesShortOf cache projectDir plan >>= \case + [] -> pure [] + _ -> do + forgetPackageCache cache projectDir + sourcesShortOf cache projectDir plan + -- | Has the compiler got this package already? builtAlready :: [InstalledPackage] -> PlanPackage -> Bool builtAlready installed p = any matches installed @@ -519,13 +539,10 @@ filesNewerThanPlan plan projectDir solved = quietly [] $ do written <- getModificationTime (planPathFor projectDir) let planTime = maybe written (max written) solved - atRoot <- quietly [] (listDirectory projectDir) + configs <- traverse (projectConfigFiles . (projectDir )) projectFiles atRootPackage <- cabalFilesIn projectDir inPackages <- concat <$> traverse cabalFilesIn (localDirs plan) - let candidates = - [projectDir f | f <- atRoot, f `elem` projectFiles] - <> atRootPackage - <> inPackages + let candidates = fmap fst (concat configs) <> atRootPackage <> inPackages newer <- traverse (isNewerThan planTime) candidates pure [f | Just f <- newer] where @@ -581,6 +598,13 @@ Left _ -> pure fallback Right plan -> use =<< openCache caching =<< tokenForBuildPlan plan +-- | Why a run of @cabal@ failed, as said to the user. +data CabalFailure + = -- | No plan satisfies what it was asked about. + Unsolvable Text + | -- | Anything else. + CabalFailed Text + -- | Do whatever is missing, given a way to run @cabal@ and a memory of what -- earlier attempts came to. prepareWith :: @@ -589,7 +613,7 @@ -- | Whether to download what is missing. Choice "download" -> -- | Run @cabal@ with these arguments. - ([String] -> IO (Either Text ())) -> + ([String] -> IO (Either CabalFailure ())) -> -- | What earlier attempts came to. Futility -> -- | The components the run is about to format. @@ -610,10 +634,14 @@ False -> solveThenFetch where wholeProject = ["--enable-tests", "--enable-benchmarks"] - tryWholeProject args = - cabal (args <> wholeProject) >>= \case - Right () -> pure (Right ()) - Left _ -> cabal args + tryWholeProject args = do + attempt <- cabal (args <> wholeProject) + first said <$> case attempt of + Left (Unsolvable _) -> cabal args + _ -> pure attempt + said = \case + Unsolvable why -> why + CabalFailed why -> why fetch short | isFalse downloading = pure (Right ()) | otherwise = do @@ -624,14 +652,16 @@ tryWholeProject ["build", ":all", "--only-download"] >>= \case Left err -> pure (Left err) Right () -> - withPlan ((Right () <$) . rememberFutileFetch futility) - fetchWhatIsShort = withPlan fetch - withPlan use = + withPlan + shortAfterFetch + ((Right () <$) . rememberFutileFetch futility) + fetchWhatIsShort = withPlan sourcesShortOf fetch + withPlan shortOf use = readBuildPlan (planPathFor projectDir) >>= \case Left _ -> pure (Right ()) Right plan -> do cache <- openCache caching =<< tokenForBuildPlan plan - use . fmap ppName =<< sourcesShortOf cache plan + use . fmap ppName =<< shortOf cache projectDir plan solveThenFetch = do started <- getCurrentTime tryWholeProject ["build", ":all", "--dry-run"] >>= \case @@ -644,31 +674,50 @@ _ -> pure (Right ()) -- | Run @cabal@ in a project directory, letting it speak for itself. -runCabal :: FilePath -> [String] -> IO (Either Text ()) -runCabal projectDir args = quietly (Left "could not run cabal") $ do - hFlush stderr - -- A duplicate because 'createProcess' closes the handle it is given once - -- the child has it, and closing the real standard error would leave - -- nothing to report the failure on. - passed <- hDuplicate stderr - -- A pipe closed at once rather than our standard input, which in an - -- editor's process carries what the editor says to it. - (toChild, _, _, running) <- - createProcess - (proc "cabal" args) - { cwd = Just projectDir, - std_in = CreatePipe, - std_out = UseHandle passed, - std_err = Inherit - } - traverse_ hClose toChild - code <- waitForProcess running - pure $ case code of - ExitSuccess -> Right () - _ -> Left ("cabal " <> T.unwords (fmap T.pack args) <> " failed; see above") +runCabal :: FilePath -> [String] -> IO (Either CabalFailure ()) +runCabal projectDir args = + quietly (Left (CabalFailed "could not run cabal")) $ do + hFlush stderr + -- A duplicate because 'createProcess' closes the handle it is given + -- once the child has it, and closing the real standard error would + -- leave nothing to report the failure on. + passed <- hDuplicate stderr + -- A pipe closed at once rather than our standard input, which in an + -- editor's process carries what the editor says to it. + (toChild, _, fromChild, running) <- + createProcess + (proc "cabal" args) + { cwd = Just projectDir, + std_in = CreatePipe, + std_out = UseHandle passed, + std_err = CreatePipe + } + traverse_ hClose toChild + complaints <- foldMap passedOn fromChild + code <- waitForProcess running + pure $ case code of + ExitSuccess -> Right () + _ + | "Could not resolve dependencies" `BS.isInfixOf` complaints -> + Left (Unsolvable failed) + | otherwise -> Left (CabalFailed failed) + where + failed = "cabal " <> T.unwords (fmap T.pack args) <> " failed; see above" +-- | Copy what comes out of a handle to standard error as it comes, and hand +-- all of it back once it ends. +passedOn :: Handle -> IO BS.ByteString +passedOn h = go [] + where + go chunks = + BS.hGetSome h 4096 >>= \chunk -> + if BS.null chunk + then pure (BS.concat (reverse chunks)) + else BS.hPut stderr chunk >> go (chunk : chunks) + -- | Fetch the sources of a trusted plan's dependencies that are neither --- installed nor fetched already, at the versions the plan names. +-- installed nor fetched already, at the versions the plan names, unless a +-- fetch has already failed to bring them in. fetchUninstalled :: -- | Whether to use the cache. Choice "useCache" -> @@ -679,13 +728,19 @@ IO () fetchUninstalled caching projectDir plan = do cache <- openCache caching =<< tokenForBuildPlan plan - sourcesShortOf cache plan >>= \case + refused <- cachedFutileFetch cache + short <- sourcesShortOf cache projectDir plan + case [p | p <- short, ppName p `notElem` refused] of [] -> pure () - short -> - void . runCabal projectDir $ - "fetch" - : "--no-dependencies" - : [T.unpack (ppName p <> "-" <> ppVersion p) | p <- short] + wanted -> + runCabal projectDir ("fetch" : "--no-dependencies" : fmap named wanted) + >>= \case + Left _ -> pure () + Right () -> + storeFutileFetch cache . fmap ppName + =<< shortAfterFetch cache projectDir plan + where + named p = T.unpack (ppName p <> "-" <> ppVersion p) -- | Get a plan that is safe to use, doing whatever @cabal@ work is needed. loadPlan :: @@ -718,25 +773,22 @@ _ -> 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 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) - [t | t@(p, _) <- tarballs, isFetchable p, ppName p `notElem` refused] - if null absent then pure tarballs else asked - Nothing -> asked +-- where that would be under the package cache @cabal@ last named for the +-- project, or names now where it has named none. +plannedTarballs :: + -- | Where what @cabal@ said is remembered. + Cache -> + -- | The project the plan is for. + FilePath -> + -- | The plan. + BuildPlan -> + IO [(PlanPackage, FilePath)] +plannedTarballs cache projectDir plan = + maybe asked under =<< cachedPackageCache cache projectDir where asked = do - cacheRoot <- packageCacheRoot - storePackageCache cache cacheRoot + cacheRoot <- packageCacheRoot projectDir + storePackageCache cache projectDir cacheRoot under cacheRoot under cacheRoot = do repos <- quietly [] (Data.List.sort <$> listDirectory cacheRoot) @@ -748,11 +800,12 @@ CheckedOut _ -> True _ -> False --- | Where @cabal@ keeps downloaded package sources, one directory per --- repository it downloads from. -packageCacheRoot :: IO FilePath -packageCacheRoot = - readProgramOutput +-- | Where @cabal@ keeps the package sources it downloads for the project in +-- the directory given, one directory per repository it downloads from. +packageCacheRoot :: FilePath -> IO FilePath +packageCacheRoot projectDir = + readProgramOutputIn + projectDir "cabal" ["path", "--remote-repo-cache", "--output-format=json"] >>= \case 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 @@ -9,12 +9,28 @@ findProjectRoot, startingDirectory, cabalFilesIn, + projectConfigFiles, ) where import Control.Monad (filterM) +import Data.Bifunctor (first) +import Data.ByteString qualified as BS +import Data.Either (fromRight) import Data.List (isSuffixOf, sort) import Data.Maybe (listToMaybe) +import Data.Set qualified as Set +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.Encoding qualified as T +import Distribution.Fields.Field + ( Field (..), + FieldLine (..), + Name (..), + fieldUniverse, + ) +import Distribution.Fields.Parser (readFields) +import Distribution.Parsec.Position (Position) import System.Directory ( canonicalizePath, doesDirectoryExist, @@ -22,7 +38,7 @@ listDirectory, ) import System.FilePath (takeDirectory, takeFileName, ()) -import Tilia.Utils (quietly) +import Tilia.Utils (quietly, tshow) -- | A project, and what marked it out. data ProjectRoot = ProjectRoot @@ -84,3 +100,29 @@ filterM doesFileExist (fmap (directory ) (sort (filter (".cabal" `isSuffixOf`) entries))) + +-- | A project configuration file and the files it imports, directly or +-- through one another, each once, with its fields or why they do not +-- parse. +-- +-- A file that cannot be read, such as an import from a URL, is passed over. +projectConfigFiles :: FilePath -> IO [(FilePath, Either Text [Field Position])] +projectConfigFiles = go Set.empty . pure + where + go _ [] = pure [] + go seen (given : rest) = do + file <- quietly given (canonicalizePath given) + contents <- quietly Nothing (Just <$> BS.readFile file) + case contents of + Just bytes | Set.notMember file seen -> do + let fields = first tshow (readFields bytes) + ((file, fields) :) + <$> go + (Set.insert file seen) + (importsOf file (fromRight [] fields) <> rest) + _ -> go seen rest + importsOf file fields = + [ takeDirectory file T.unpack (T.decodeUtf8Lenient value) + | Field (Name _ "import") [FieldLine _ value] <- + concatMap fieldUniverse fields + ] 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 @@ -19,10 +19,8 @@ where import Control.Monad (filterM) -import Data.ByteString qualified as BS -import Data.ByteString.Char8 qualified as BS8 -import Data.Char (toLower) -import Data.List (isPrefixOf, isSuffixOf, sort) +import Data.Bifunctor (first) +import Data.List (isPrefixOf, isSuffixOf, sort, tails) import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map import Data.Set (Set) @@ -31,12 +29,13 @@ import Data.Text qualified as T import Data.Text.Encoding qualified as T import Distribution.Fields.Field (Field (..), FieldLine (..), Name (..)) -import Distribution.Fields.Parser (readFields) import Distribution.PackageDescription (GenericPackageDescription (..)) +import Distribution.Parsec.Position (Position) import System.Directory (canonicalizePath, doesFileExist, listDirectory) import System.FilePath ( dropTrailingPathSeparator, normalise, + splitDirectories, takeDirectory, (), ) @@ -54,7 +53,13 @@ setupScript, ) import Tilia.Cabal.Plan (PlanComponent (..)) -import Tilia.Cabal.Project (Marker (..), ProjectRoot (..), cabalFilesIn, markerFile) +import Tilia.Cabal.Project + ( Marker (..), + ProjectRoot (..), + cabalFilesIn, + markerFile, + projectConfigFiles, + ) import Tilia.Ignore (withoutIgnored) import Tilia.Utils (fieldWords, quietly, tshow) @@ -82,11 +87,17 @@ "unrecognised target " <> tshow written <> ": expected all, a package or component name, or one of\ - \ lib:, exe:, test:, bench: followed by a name" - kindNamed = \case + \ lib:, flib:, exe:, test:, bench: followed by a name" + kindNamed k = case T.toLower k of "lib" -> Just Lib + "library" -> Just Lib + "flib" -> Just FLib + "foreign-library" -> Just FLib "exe" -> Just Exe + "executable" -> Just Exe + "tst" -> Just Test "test" -> Just Test + "test-suite" -> Just Test "bench" -> Just Bench "benchmark" -> Just Bench _ -> Nothing @@ -139,6 +150,8 @@ data TargetProblem = -- | A @cabal.project@ naming packages, none of which could be found. NoPackages FilePath + | -- | A project configuration file that does not parse, and why. + ProjectMalformed FilePath Text | -- | A @.cabal@ file that could not be read or parsed, and why. UnreadablePackage PackageProblem | -- | A target naming no component the project holds. @@ -150,6 +163,8 @@ describeTargetProblem = \case NoPackages file -> T.pack file <> " names no packages that exist" + ProjectMalformed file why -> + T.pack file <> " does not parse:" <> foldMap ("\n " <>) (T.lines why) UnreadablePackage problem -> describePackageProblem problem NoSuchTarget asked available -> "no component matches " @@ -162,11 +177,12 @@ ProjectRoot -> Target -> IO (Either TargetProblem [Component]) -componentsOfTarget root target = do - files <- packageFilesOf root - if null files - then pure (Left (NoPackages (prPath root markerFile (prMarker root)))) - else +componentsOfTarget root target = + packageFilesOf root >>= \case + Left problem -> pure (Left problem) + Right [] -> + pure (Left (NoPackages (prPath root markerFile (prMarker root)))) + Right files -> traverse componentsInCabalFile files >>= \case results | (problem : _) <- [p | Left p <- results] -> pure (Left problem) @@ -213,6 +229,7 @@ spellKind :: Kind -> Text spellKind = \case Lib -> "lib" + FLib -> "flib" Exe -> "exe" Test -> "test" Bench -> "bench" @@ -252,31 +269,32 @@ asDirectory :: FilePath -> FilePath asDirectory = dropTrailingPathSeparator . normalise --- | The @.cabal@ files the project is made of. +-- | The @.cabal@ files the project is made of, or which of its +-- configuration files does not parse. -- -- A @cabal.project@ names them, possibly through globs; anything else means -- the marker found by the walk upwards is itself the only package. -packageFilesOf :: ProjectRoot -> IO [FilePath] +packageFilesOf :: ProjectRoot -> IO (Either TargetProblem [FilePath]) packageFilesOf root = case prMarker root of - PackageFile named -> pure [prPath root named] + PackageFile named -> pure (Right [prPath root named]) ProjectFile -> do - contents <- - quietly BS.empty (BS.readFile (prPath root "cabal.project")) - found <- - traverse - (packageToCabalFile (prPath root)) - (packagesInCabalProjectContents contents) - pure (Set.toList (Set.fromList (concat found))) + configs <- projectConfigFiles (prPath root "cabal.project") + case traverse (uncurry (first . ProjectMalformed)) configs of + Left problem -> pure (Left problem) + Right parsed -> do + found <- + traverse + (packageToCabalFile (prPath root)) + (concatMap packagesInProjectConfig parsed) + pure (Right (Set.toList (Set.fromList (concat found)))) --- | The entries of a @cabal.project@'s @packages@ field. -packagesInCabalProjectContents :: BS.ByteString -> [Text] -packagesInCabalProjectContents contents = case readFields contents of - Left _ -> [] - Right fields -> concatMap entries (packagesIn fields) +-- | The entries of a project configuration file's @packages@ fields. +packagesInProjectConfig :: [Field Position] -> [Text] +packagesInProjectConfig = concatMap entries . packagesIn where packagesIn = concatMap $ \case Field (Name _ name) ls - | BS8.map toLower name `elem` ["packages", "optional-packages"] -> + | name `elem` ["packages", "optional-packages"] -> [T.unwords [T.decodeUtf8Lenient value | FieldLine _ value <- ls]] | otherwise -> [] Section _ _ inner -> packagesIn inner @@ -285,33 +303,35 @@ -- | Turn one entry of a @packages@ field into the @.cabal@ files it names. packageToCabalFile :: FilePath -> Text -> IO [FilePath] packageToCabalFile root entry = do - paths <- - packageGlobToCabalFiles - (if "/" `T.isPrefixOf` written then "/" else root) - (fmap T.unpack (T.split (== '/') written)) + paths <- packageGlobToCabalFiles root (splitDirectories (T.unpack entry)) concat <$> traverse asPackage paths where - written = T.strip entry asPackage path | ".cabal" `isSuffixOf` path = do there <- quietly False (doesFileExist path) pure [path | there] | otherwise = cabalFilesIn path --- | Resolve a path whose components may contain @*@. +-- | Resolve a path whose components may contain @*@, or be @**@, which +-- stands for any number of directories. packageGlobToCabalFiles :: FilePath -> [String] -> IO [FilePath] packageGlobToCabalFiles here = \case [] -> pure [here] - ("" : rest) -> packageGlobToCabalFiles here rest ("." : rest) -> packageGlobToCabalFiles here rest + components@("**" : rest) -> + (<>) + <$> packageGlobToCabalFiles here rest + <*> entriesMatching (const True) components (component : rest) - | '*' `elem` component -> do - entries <- quietly [] (listDirectory here) - concat - <$> traverse - (\e -> packageGlobToCabalFiles (here e) rest) - (sort (filter (globMatching component) entries)) + | '*' `elem` component -> entriesMatching (globMatching component) rest | otherwise -> packageGlobToCabalFiles (here component) rest + where + entriesMatching matching rest = do + entries <- quietly [] (listDirectory here) + concat + <$> traverse + (\e -> packageGlobToCabalFiles (here e) rest) + (sort (filter matching entries)) -- | Does a name match a pattern with @*@ in it? globMatching :: String -> String -> Bool @@ -319,7 +339,7 @@ (before, []) -> before == name (before, _ : after) -> before `isPrefixOf` name - && after `isSuffixOf` drop (length before) name + && any (globMatching after) (tails (drop (length before) name)) -- | Every component one @.cabal@ file declares. componentsInCabalFile :: FilePath -> IO (Either TargetProblem [Component]) diff --git a/src/Tilia/Comments.hs b/src/Tilia/Comments.hs --- a/src/Tilia/Comments.hs +++ b/src/Tilia/Comments.hs @@ -122,7 +122,6 @@ GHC.ITlineComment t _ -> Just (commentAt ls s LineComment (T.pack t)) GHC.ITblockComment t _ -> Just (commentAt ls s BlockComment (T.pack t)) GHC.ITdocComment _ _ -> Just (commentAt ls s DocComment (sliceSpan (lineTexts ls) s)) - GHC.ITdocOptions t _ -> Just (commentAt ls s LineComment (T.pack t)) _ -> Nothing where s = spanOfReal spn @@ -132,14 +131,14 @@ commentAt ls spn style raw = Comment { commentSpan = spn, - commentBody = normalizeBody startColumn style raw, + commentBody = normalizeBody (spanStartColumn spn) style raw, commentStyle = style, commentAbove = above, commentCodeBeforeStopsAt = codeBeforeStopsAt, commentFirstInBrackets = any ((`T.elem` "([{") . snd) (T.unsnoc before'), commentFollowed = followed, commentGapAbove = above == BlankLine, - commentGapBelow = blankAt (spanEndLine spn + 1) ls, + commentGapBelow = not followed && blankAt (spanEndLine spn + 1) ls, commentNextLine = nextLine } where @@ -181,25 +180,28 @@ BlockComment -> c { commentBody = - normalizeBody startColumn BlockComment (sliceSpan (lineTexts ls) s) + normalizeBody + (spanStartColumn s) + BlockComment + (sliceSpan (lineTexts ls) s) } _ -> c where s = commentSpan c - startColumn = - maybe 0 (`offsetOf` spanStartColumn s) (lineAt (spanStartLine s) ls) -- | Apply the normalizations, in the only order that works: dedent before -- stripping, since a line of nothing but spaces has to still count as -- indented when the common indentation is measured. normalizeBody :: Int -> CommentStyle -> Text -> NonEmpty Text -normalizeBody startColumn style raw = +normalizeBody column style raw = case NE.nonEmpty (T.lines raw) of Nothing -> spaceAfterDashes style raw :| [] Just (first' :| rest) -> fmap T.stripEnd (spaceAfterDashes style first' :| fmap dedent rest) where - dedent l = T.drop (min startColumn (T.length (T.takeWhile isSpace l))) l + dedent l = + let n = offsetOf (T.takeWhile isSpace l) column + in T.replicate (columnOf l n - column) " " <> T.drop n l -- | @--foo@ becomes @-- foo@; @----@ and @-- foo@ are left alone. -- @@ -285,6 +287,7 @@ -- | The line whose trailing comment a comment with the line to itself -- carries on, by being lined up under that line or that comment, or under -- comments that carry it on in turn, and the column that comment begins at. +-- A trailing comment that closes itself is carried on by none. carriedOnFrom :: [Comment] -> Comment -> Maybe (Int, Int) carriedOnFrom cs = \c -> if commentTrailing c || commentFollowed c @@ -301,6 +304,7 @@ | c <- cs, commentTrailing c, not (commentFollowed c), + not (closesItself c), let s = commentSpan c ] ownLineComments = @@ -350,7 +354,8 @@ escapeTrigger c = case commentStyle c of DocComment -> c - { commentBody = fmap escape (commentBody c), + { commentBody = case commentBody c of + opening :| rest -> escape opening :| rest, commentStyle = if bracketed c then BlockComment else LineComment } _ -> 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,6 +9,7 @@ ( attachComments, attachScopedComments, Margin (..), + commentText, ) where @@ -25,7 +26,7 @@ import Tilia.Comments import Tilia.Comments.Place import Tilia.Doc.Combinators -import Tilia.Doc.Internal (Doc (..), Spill (..), foldChildren) +import Tilia.Doc.Internal (Doc (..), foldChildren) import Tilia.Span -- | Attach comments to a 'Doc'. @@ -97,10 +98,10 @@ where placeOne opensTheRun c = commentDoc c $ - closeLine + DCloseLine <> includeWhen (opensTheRun || commentGapAbove c) blankLine <> commentText margin c - <> closeLine + <> DCloseLine -- | The spans of every 'DLocated' in the document, and of every 'DFence', -- in that order. @@ -239,12 +240,12 @@ InPlace -> case position of Before -> includeUnless glued space <> body <> includeUnless atTheEnd space _ -> space <> body - EndsTheLine -> space <> body <> closeLine <> gapBelow - HeldBack spill -> holdBack spill (renderComment c) + EndsTheLine -> space <> body <> DCloseLine <> gapBelow + HeldBack spill -> DHoldBack spill (renderComment c) OnItsOwnLines -> - closeLineUnlessAfterOpener (commentGapAbove c) + DCloseLineUnlessAfterOpener (commentGapAbove c) <> body - <> closeLine + <> DCloseLine <> gapBelow where glued = commentTrailing c && (not atTheEnd || commentFirstInBrackets c) @@ -272,17 +273,3 @@ note | marginComment margin c = cppMarginNote | otherwise = id - --- | Put this text at the end of the line this position falls on. -holdBack :: Spill -> Text -> Doc -holdBack = DHoldBack - --- | End the current line and leave a mark so that a line break that follows --- it immediately (if any) will have no effect. -closeLine :: Doc -closeLine = DCloseLine - --- | 'closeLine', with an empty line under it if told to, unless the line --- ends with an opening bracket, a bar or an equals sign. -closeLineUnlessAfterOpener :: Bool -> Doc -closeLineUnlessAfterOpener = DCloseLineUnlessAfterOpener diff --git a/src/Tilia/Comments/Place.hs b/src/Tilia/Comments/Place.hs --- a/src/Tilia/Comments/Place.hs +++ b/src/Tilia/Comments/Place.hs @@ -133,7 +133,7 @@ wider a b = if endPoint a >= endPoint b then a else b against c - | Just placed@(_, After _) <- asCommentBefore = Just placed + | Just placed <- asCommentBefore = Just placed | commentTrailing c, Just r <- trailed = Just (r, After SpillAtIndentation) @@ -146,7 +146,7 @@ here = commentSpan c asCommentBefore = against =<< (`Map.lookup` commentsByEndPoint) =<< stopsAt trailed - | writtenAgainst || not (commentFollowed c) = + | writtenAgainst || endsItsLine c = linedUpUnder <|> endingOn (spanStartLine here) | otherwise = Nothing linedUpUnder = do @@ -167,11 +167,13 @@ fencedOff r = outside (Map.lookup here enclosingRegions) - || (printedInPlace && outside (Map.lookup here enclosingFences)) + || (not heldBack && outside (Map.lookup here enclosingFences)) where outside = maybe False (\(from, to) -> not (from <= startPoint r && endPoint r <= to)) - printedInPlace = shapeOf (After SpillAtIndentation) c == InPlace + heldBack = case shapeOf (After SpillAtIndentation) c of + HeldBack _ -> True + _ -> False next = snd <$> Map.lookupGE (endPoint here) regionsByStartPoint @@ -187,12 +189,15 @@ under | Just (top, bottom) <- IntMap.lookup (spanStartLine here) runs, - Just (line, column) <- commentNextLine bottom, - column /= spanStartColumn here, - any ((<= (line, column)) . startPoint) next = + all (beginsUnder (commentNextLine bottom)) next = lineOfCode top | otherwise = Nothing + beginsUnder below r = case below of + Just (line, column) -> + column /= spanStartColumn here && startPoint r <= (line, column) + Nothing -> False + lineOfCode top = do r <- nearest (Down . startPoint) (filter linedUp onThatLine) guard (any (larger r) onThatLine) @@ -221,6 +226,20 @@ larger r o = startPoint o < startPoint r && endPoint o == lineEnd commentsByEndPoint = Map.fromList [(endPoint (commentSpan c), c) | c <- comments] + + endsItsLine c = + not (commentFollowed c) + || maybe + False + endsItsLine + (Map.lookup (endPoint (commentSpan c)) commentsByStopPoint) + + commentsByStopPoint = + Map.fromList + [ ((spanStartLine (commentSpan c), n), c) + | c <- comments, + Just n <- [commentCodeBeforeStopsAt c] + ] runs = IntMap.fromList diff --git a/src/Tilia/Cpp.hs b/src/Tilia/Cpp.hs --- a/src/Tilia/Cpp.hs +++ b/src/Tilia/Cpp.hs @@ -5,7 +5,7 @@ -- -- Each configuration is printed on its own and the documents are merged. -- Working out what the configurations are is "Tilia.Cpp.Directives", whose --- vocabulary this module re-exports so that callers need only one import. +-- vocabulary this module re-exports. module Tilia.Cpp ( -- * Formatting formatWithCpp, @@ -510,7 +510,8 @@ <$> formatAllConfigs formatter (readingOf r t) else pure Nothing docs <- - except (traverse (complete (fmap (fmap fst) found)) (zip [0 ..] texts)) + except . traverse (complete (fmap (fmap fst) found)) $ + zip [0 ..] (fmap snd answers) let settledIn i | Just _ <- lookup i found = settledBy !! i | otherwise = foldMap ((settledBy !!) . fst) (listToMaybe found) @@ -545,11 +546,8 @@ . unconditionalErrors $ t --- | Preserve an error-only alternative without asking the Haskell parser to --- parse its missing expression or declaration. A successful sibling supplies --- the surrounding syntax, with the nodes wholly inside the conditional taken --- out; the @#error@ is put back into the space they leave with every other --- directive. More complicated aborting alternatives are left unsupported. +-- | The document of a configuration whose varied lines hold nothing but an +-- @#error@: a sibling's, with what it printed from those lines taken out. errorBranch :: Varied -> Text -> Doc -> Maybe Doc errorBranch (Varied ranges) source reference = foldl step (Just reference) ranges where 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 @@ -148,6 +148,9 @@ | -- | A line using a macro written inside a quasi-quote or a multi-line -- string, its line, and what is written on it. MacroInQuotedText Int Text + | -- | A line using a macro or an @#include@ written before a leading + -- comma, its line, and what is written on it. + BeforeLeadingComma Int Text | -- | A branch holding something that a conditional around it, asking the -- same question, rules out, and the line of the directive opening it. RuledOutBranch Int @@ -178,6 +181,11 @@ "the #" <> k <> " at line " <> tshow n <> " is inside a quasi-quote or a multi-line string" MacroInQuotedText n t -> t <> " at line " <> tshow n <> " is inside a quasi-quote or a multi-line string" + BeforeLeadingComma n t -> + t + <> " at line " + <> tshow n + <> " comes before a leading comma, which formatting moves above it" RuledOutBranch n -> "the branch at line " <> tshow n @@ -384,13 +392,8 @@ | gs <- forest ] --- | Read both spellings under the same CPP choices. --- --- Sorting or deduplicating the resulting source text separately loses the --- association with the guards: formatting can change that order or make two --- formerly different strings identical. Cover every branch of either --- spelling, including its ancestors. 'Nothing' denotes a configuration --- deliberately rejected by @#error@. +-- | Each configuration either module has, as the one and the other read in +-- it, with 'Nothing' where an @#error@ rules it out. correspondingBranches :: -- | Before. Text -> 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 @@ -15,6 +15,7 @@ import Control.Applicative ((<|>)) import Control.Monad (foldM) +import Data.Char (isSpace) import Data.List (sortOn, unsnoc) import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map @@ -61,7 +62,7 @@ unwrap, wrap, ) -import Tilia.Source (Lines, Written (..), blankAt, lineAt, linesOf) +import Tilia.Source (Lines, Written (..), blankAt, lineAt, lineTexts, linesOf) import Tilia.Span (Span (..), mkSpan, startPoint) -- | What the configurations of a module had besides their code. @@ -418,6 +419,9 @@ putDirective :: Lines -> Doc -> Directive -> Either CppError Doc putDirective written doc d | quotedAt doc (dLine d) = Left (DirectiveInQuotedText (dLine d) (dKeyword d)) + | dKeyword d == "include", + commaUnder written (dLastLine d) = + Left (BeforeLeadingComma (dLine d) ("#" <> dText d)) | otherwise = Right (placeAt (const False) (Just written) (dLine d) body id doc) where body = @@ -429,11 +433,22 @@ putMacroLine :: Lines -> Doc -> (Int, Text) -> Either CppError Doc putMacroLine written doc (n, t) | quotedAt doc n = Left (MacroInQuotedText n t) + | commaUnder written n = Left (BeforeLeadingComma n t) | otherwise = Right (placeAt (const False) (Just written) n body indent doc) where body = DLocated (mkSpan (n, 1) (n, 1)) (DCloseLine <> DText t <> DCloseLine) <> includeWhen (blankAt (n + 1) written) blankLine + +-- | Does the code under a line open with a comma, which the printer puts at +-- the end of the item above the line instead? +commaUnder :: Lines -> Int -> Bool +commaUnder written n = case dropWhile passed (drop n (lineTexts written)) of + l : _ -> T.isPrefixOf "," (T.stripStart l) + [] -> False + where + passed l = + T.all isSpace l || isDirective l || T.isPrefixOf "--" (T.stripStart l) -- | Is this line inside something the document reproduces verbatim, such -- as a quasi-quotation, where a line cannot be put back? diff --git a/src/Tilia/Diff.hs b/src/Tilia/Diff.hs --- a/src/Tilia/Diff.hs +++ b/src/Tilia/Diff.hs @@ -14,8 +14,8 @@ import Control.Monad.ST (ST, runST) import Data.Array.ST (STUArray, newArray, readArray, writeArray) import Data.Array.Unboxed (Array, UArray, listArray, (!)) +import Data.List (unfoldr) import Data.Map.Strict qualified as Map -import Data.Maybe (fromMaybe) import Data.Text (Text) import Data.Text qualified as T import Tilia.Palette (Color (..), Palette, paint) @@ -57,7 +57,8 @@ before = "a/" <> T.pack path after = "b/" <> T.pack path --- | One line of the comparison, with the number it has on each side. +-- | One line of the comparison, with the number it has on each side, and +-- with the newline it ends in, if it ends in one. data Line = Line !Mark !Int !Int !Text -- | A unified diff, with whatever heading the caller wants. @@ -72,14 +73,8 @@ -- | After. Text -> Text -unified palette above (beforeName, afterName) before after - | null hunks, - before /= after = - "(the two differ only in how they end their lines)" - | null hunks = - "(the two are identical as text, so the difference is in something\ - \ the text does not show)" - | otherwise = T.intercalate "\n" (above <> heading <> body) +unified palette above (beforeName, afterName) before after = + T.intercalate "\n" (above <> heading <> body) where heading = [ paint palette (Header Gone) ("--- " <> beforeName), @@ -88,7 +83,7 @@ body = concatMap render hunks - render range = hunkHeading range : fmap line (slice range) + render range = hunkHeading range : concatMap line (slice range) hunkHeading range = paint palette Meta $ @@ -99,13 +94,18 @@ <> " @@" where span' which n = case slice range of - (l : _) -> tshow (which l) <> "," <> tshow n - [] -> "0,0" + l : _ | n > 0 -> tshow (which l) <> "," <> tshow n + _ -> "0,0" - line (Line mark _ _ text) = case mark of - Context -> paint palette Kept (" " <> text) - Removed -> paint palette Gone ("-" <> text) - Added -> paint palette New ("+" <> text) + line (Line mark _ _ text) = case T.stripSuffix "\n" text of + Just ended -> [marked ended] + Nothing -> + [marked text, paint palette Meta "\\ No newline at end of file"] + where + marked = case mark of + Context -> paint palette Kept . (" " <>) + Removed -> paint palette Gone . ("-" <>) + Added -> paint palette New . ("+" <>) slice (from, to) = take (to - from + 1) (drop from lines') @@ -118,8 +118,12 @@ changed = [i | (i, Line m _ _ _) <- zip [0 ..] lines', m /= Context] total = length lines' lines' = tag (split before) (split after) - split = fmap withoutReturn . T.splitOn "\n" - withoutReturn l = fromMaybe l (T.stripSuffix "\r" l) + split = unfoldr $ \t -> + if T.null t + then Nothing + else + let (l, rest) = T.breakOn "\n" t + in Just (l <> T.take 1 rest, T.drop 1 rest) -- | How many unchanged lines to show either side of a change. margin :: Int 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 @@ -685,7 +685,7 @@ KeepWhitespace -> id -- | Assemble the final text: one trailing newline, no blank lines at the --- end, no trailing whitespace anywhere. +-- end, and trailing whitespace only where a verbatim line keeps it. finish :: Out -> Text finish out = case dropWhile (T.null . lineBody) (outLines (breakLine 0 out)) of diff --git a/src/Tilia/Editor.hs b/src/Tilia/Editor.hs --- a/src/Tilia/Editor.hs +++ b/src/Tilia/Editor.hs @@ -11,21 +11,20 @@ where import Data.Choice (Choice) -import Data.Maybe (mapMaybe) +import Data.Either (fromRight) import Data.Text (Text) import Tilia.Cabal.Project (ProjectRoot (..), findProjectRoot) import Tilia.Cabal.Target ( Target (Everything), - componentInPlan, componentsOfTarget, ) import Tilia.Format ( Compiled (..), FormatError (NoProject), - PlanSource (..), Session, compiledSession, newSession, + planSourceFor, sessionRoot, ) import Tilia.Ignore (isIgnoredInProject) @@ -61,11 +60,8 @@ findProjectRoot file >>= \case Nothing -> pure (Left (NoProject file)) Just root -> do - planSource <- case givenPlan of - Just plan -> pure (GivenPlan plan) - Nothing -> - PlanFromCabal . either (const []) (mapMaybe componentInPlan) - <$> componentsOfTarget root Everything + planSource <- + planSourceFor givenPlan (fromRight [] <$> componentsOfTarget root Everything) newSession root planSource diff --git a/src/Tilia/Equivalence.hs b/src/Tilia/Equivalence.hs --- a/src/Tilia/Equivalence.hs +++ b/src/Tilia/Equivalence.hs @@ -58,6 +58,7 @@ Pragma (..), asOrdinary, carriedOnFrom, + carriesOn, commentPragma, commentTrailing, triggerEscaped, @@ -67,7 +68,7 @@ import Tilia.Pragma (languageNames, pragmaFlags) import Tilia.Pragma.Ghc (InForce (..), inForceAfter) import Tilia.Source (comments, sourceLines) -import Tilia.Span (Span (..)) +import Tilia.Span (Span (..), covers) import Tilia.Span.Ghc (spanOf, spansOf) import Tilia.Utils (tshow) @@ -431,8 +432,10 @@ -- Except in the header, where the order says nothing. The pragmas are -- sorted and so are the imports, and a comment written against either -- travels with it, so the two streams are put in a settled order there --- before being compared. What is still asked of that stretch is that the --- same comments come out of it. +-- before being compared, with the pragmas of the header that hold a +-- comment. What is still asked of that stretch is that the same comments +-- come out of it, and those inside the export list, which nothing sorts, +-- in order. -- -- Documentation comments are counted rather than compared. The printer may -- legitimately rewrite one—a @-- ^ x@ that moves in front of what it @@ -476,19 +479,27 @@ <> tshow docsAfter | otherwise = diverge (belowHeader moduleBefore before) (belowHeader moduleAfter after) + <|> diverge (settled headerCommentsBefore) (settled headerCommentsAfter) <|> diverge - (settled (withinHeader moduleBefore before)) - (settled (withinHeader moduleAfter after)) + (exported moduleBefore headerCommentsBefore) + (exported moduleAfter headerCommentsAfter) where moduleBefore = pmModule parsedBefore moduleAfter = pmModule parsedAfter before = asRead parsedBefore after = asRead parsedAfter + headerCommentsBefore = withinHeader parsedBefore before + headerCommentsAfter = withinHeader parsedAfter after asRead m = concatMap (asOrdinary (sourceLines (pmSource m))) (comments (pmSource m)) belowHeader m cs = filter (not . inHeader m cs) (ordinary cs) - withinHeader m cs = filter (inHeader m cs) (ordinary cs) + withinHeader m cs = + filter (inHeader (pmModule m) cs) (ordinary cs) + <> filter commented (takeWhile (pragmaWritten m . commentSpan) cs) + pragmaWritten = writtenInHeader . pmHeaderEnd + exported m = + filter (\c -> any (`covers` commentSpan c) (spanOf =<< hsmodExports m)) settled = sortOn bodyKey inHeader m cs = case lastRearrangedLine m cs of @@ -515,6 +526,7 @@ ordinary = filter (\c -> not (isDocumentation c) && isNothing (commentPragma c)) + commented = maybe False pragmaCommented . commentPragma diverge [] [] = Nothing diverge (b : _) [] = Just ("lost " <> quoted b) @@ -607,12 +619,14 @@ <> foldMap spanOf (hsmodExports m) carriedPast lastLine = maybe lastLine (spanEndLine . commentSpan . snd) . unsnoc $ - takeWhile - (maybe False ((<= lastLine) . fst) . carriedOnFrom (remarks <> run)) - run + takeWhile (\c -> any (carries c) (carriedOn c)) run where remarks = [c | c <- cs, spanEndLine (commentSpan c) == lastLine] run = following (lastLine + 1) cs + carriedOn = carriedOnFrom (remarks <> run) + carries c (line, remark) = + line <= lastLine && carriesOn remark (commentSpan c) next + next = spanOf =<< listToMaybe (hsmodDecls m) following n = \case c : more | spanStartLine (commentSpan c) < n -> following n more diff --git a/src/Tilia/Fixity.hs b/src/Tilia/Fixity.hs --- a/src/Tilia/Fixity.hs +++ b/src/Tilia/Fixity.hs @@ -16,7 +16,6 @@ -- * Module declarations declaredFixities, - moduleName, -- * Module exports ExportItem (..), @@ -32,6 +31,7 @@ certainlyBrings, decides, Namespace (..), + typeOperatorNamespace, Fixities, Certain (..), ModuleChain (..), @@ -45,6 +45,7 @@ Provenance (..), Resolution (..), lookupFixity, + fixityInScope, -- * What could not be answered Unknown (..), @@ -78,7 +79,7 @@ import Data.List.NonEmpty qualified as NE import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map -import Data.Maybe (mapMaybe) +import Data.Maybe (listToMaybe, mapMaybe) import Data.Set (Set) import Data.Set qualified as Set import Data.Text (Text) @@ -87,7 +88,7 @@ import GHC.Generics (Generic) import GHC.Hs hiding (Fixity, OpName) import GHC.Types.Fixity qualified as GHC -import GHC.Types.Name.Occurrence (occNameString) +import GHC.Types.Name.Occurrence (isDataOcc, occNameString) import GHC.Types.Name.Reader (RdrName (..), rdrNameOcc) import GHC.Types.SrcLoc (GenLocated (..), unLoc) import Tilia.Gathered (Gathered (..)) @@ -196,7 +197,7 @@ ForD _ f -> [opName (unLoc (fd_name f))] TyClD _ d@DataDecl{} -> fmap snd (membersOf d) TyClD _ ClassDecl{tcdSigs} -> concatMap (signedNames . unLoc) tcdSigs - _ -> [] + d -> concatMap (constructorsOf . snd) (dataInstances d) -- | The members of the type or class a declaration declares, by -- namespace: a data type's constructors and record fields, a class's @@ -206,13 +207,29 @@ -- its own—@:|@ is a constructor and @infixr 5@ all the same. membersOf :: TyClDecl GhcPs -> [(Namespace, OpName)] membersOf = \case - DataDecl{tcdDataDefn} -> - fmap (InTerms,) (concatMap (fromCon . unLoc) (consOf (dd_cons tcdDataDefn))) + DataDecl{tcdDataDefn} -> fmap (InTerms,) (constructorsOf tcdDataDefn) ClassDecl{tcdSigs, tcdATs} -> fmap (InTerms,) (concatMap (signedNames . unLoc) tcdSigs) <> [(InTypes, opName (unLoc (fdLName (unLoc f)))) | f <- tcdATs] _ -> [] + +-- | The data instances a declaration makes, each with its family: its own, +-- or those of a class instance. +dataInstances :: HsDecl GhcPs -> [(OpName, HsDataDefn GhcPs)] +dataInstances = \case + InstD _ (DataFamInstD _ d) -> [instanceOf d] + InstD _ (ClsInstD _ ClsInstDecl{cid_datafam_insts}) -> + fmap (instanceOf . unLoc) cid_datafam_insts + _ -> [] where + instanceOf :: DataFamInstDecl GhcPs -> (OpName, HsDataDefn GhcPs) + instanceOf (DataFamInstDecl FamEqn{feqn_tycon, feqn_rhs}) = + (opName (unLoc feqn_tycon), feqn_rhs) + +-- | The constructors and record fields a data definition declares. +constructorsOf :: HsDataDefn GhcPs -> [OpName] +constructorsOf = concatMap (fromCon . unLoc) . consOf . dd_cons + where consOf :: DataDefnCons (LConDecl GhcPs) -> [LConDecl GhcPs] consOf = toList @@ -299,8 +316,9 @@ IEVar _ n _ -> [as (ExportName InTerms) n] IEThingAbs _ n _ -> [as (ExportName InTypes) n] IEThingAll _ n _ -> [as ExportAll n] - IEThingWith _ n _ ns _ -> - [as ExportSome n (fmap (opName . ieWrappedName . unLoc) ns)] + IEThingWith _ n wildcard ns _ -> + [as ExportAll n | IEWildcard _ <- [wildcard]] + <> [as ExportSome n (fmap (opName . ieWrappedName . unLoc) ns)] IEModuleContents _ m -> [ExportModule (T.pack (moduleNameString (unLoc m)))] _ -> [] as item n = @@ -313,7 +331,8 @@ Qual m _ -> Just (T.pack (moduleNameString m)) _ -> Nothing --- | The members of each type or class a module declares. +-- | The members of each type or class a module declares, and of each data +-- family it gives instances of. declaredMembers :: HsModule GhcPs -> Map OpName (Set (Namespace, OpName)) declaredMembers = Map.fromListWith Set.union . concatMap (fromDecl . unLoc) . hsmodDecls @@ -321,7 +340,10 @@ fromDecl = \case TyClD _ d@DataDecl{tcdLName} -> [entry tcdLName d] TyClD _ d@ClassDecl{tcdLName} -> [entry tcdLName d] - _ -> [] + d -> + [ (family, Set.fromList (fmap (InTerms,) (constructorsOf defn))) + | (family, defn) <- dataInstances d + ] entry name d = (opName (unLoc name), Set.fromList (membersOf d)) -- | The members a module's export list offers with each name. @@ -333,9 +355,12 @@ declared = Map.map (Set.map snd) (declaredMembers hsModule) fromIE = \case IEThingAbs _ n _ -> [(nameOf n, Set.empty)] - IEThingAll _ n _ -> [(nameOf n, kids) | Just kids <- [Map.lookup (nameOf n) declared]] - IEThingWith _ n _ ns _ -> [(nameOf n, Set.fromList (fmap nameOf ns))] + IEThingAll _ n _ -> whole n + IEThingWith _ n wildcard ns _ -> + (nameOf n, Set.fromList (fmap nameOf ns)) + : concat [whole n | IEWildcard _ <- [wildcard]] _ -> [] + whole n = [(nameOf n, kids) | Just kids <- [Map.lookup (nameOf n) declared]] nameOf = opName . ieWrappedName . unLoc ---------------------------------------------------------------------------- @@ -740,6 +765,9 @@ Just missing -> Unresolved missing -- | What the scope itself has for a use, and the namespace it came from. +-- +-- A use among types is taken for a promoted constructor only where no type +-- of its name may be in scope, as GHC prefers the type. fixityInScope :: -- | The scope. Scope -> @@ -756,14 +784,21 @@ | Just fixity <- Map.lookup op builtInSyntax = Just (namespace, (fixity, BuiltIn)) | otherwise = - case mapMaybe found (namespace : promotedFrom namespace) of - (answer : _) -> Just answer - [] -> Nothing + listToMaybe . mapMaybe found $ + namespace : [n | n <- promotedFrom namespace, unclaimed] where found n = (n,) <$> case qualifier of Nothing -> Map.lookup op (reachUnqualified (reachIn n scope)) Just q -> Map.lookup (q, op) (reachQualified (reachIn n scope)) + unclaimed = + Set.notMember (qualifier, op) (reachDecided (reachIn namespace scope)) + && null + [ () + | (i, established) <- scopeUnsettled scope, + maySupply (establishedMembers established) qualifier op i, + _ <- unsettledThrough established (namespace, op) + ] -- | The operators the language gives a fixity, rather than a declaration -- anywhere: @:@ alone. @@ -776,6 +811,13 @@ InTypes -> [InTerms] InTerms -> [] +-- | The namespace an operator written in a type is in: among terms for a +-- promoted constructor written with its tick, among types otherwise. +typeOperatorNamespace :: RdrName -> Namespace +typeOperatorNamespace n + | isDataOcc (rdrNameOcc n) = InTerms + | otherwise = InTypes + -- | The unread imports that could have declared this operator. unreadThatMightDeclare :: -- | The scope. @@ -828,7 +870,8 @@ -- nothing is regrouped around it. operatorsUsed :: Gathered -> [(Namespace, (Maybe Text, OpName))] operatorsUsed found = - fmap (named InTerms) inExpressions <> fmap (named InTypes) inTypes + fmap (named InTerms) inExpressions + <> [named (typeOperatorNamespace n) n | n <- inTypes] where captured = capturedUses found inExpressions = 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 @@ -27,6 +27,7 @@ import Data.Text.Encoding qualified as T import Distribution.PackageDescription (GenericPackageDescription) import GHC.Generics (Generic) +import System.FilePath.Posix qualified as Posix import Tilia.Cabal.Package (packageSourceDirs) import Tilia.Fixity.Cabal (entryPosixPath, ownCabalFile) import Tilia.Utils (quietly) @@ -67,15 +68,15 @@ where dirs = maybe [] packageSourceDirs (archiveCabal archive) pick ending = - inArchive ending . T.decodeUtf8Lenient . snd - <$> listToMaybe (under sfx matching <> matching) - where - sfx = "/" <> pathOfModule modName <> ending - matching = [f | f <- archiveFiles archive, sfx `isSuffixOf` fst f] - under sfx matching = [f | d <- dirs, f <- matching, inDir sfx d (fst f)] - inDir sfx d path - | d == "." = takeWhile (/= '/') path <> sfx == path - | otherwise = ("/" <> d <> sfx) `isSuffixOf` path + inArchive ending . T.decodeUtf8Lenient + <$> listToMaybe + [ content + | d <- dirs, + let file = + Posix.normalise (d <> "/" <> pathOfModule modName <> ending), + (path, content) <- archiveFiles archive, + drop 1 (dropWhile (/= '/') path) == file + ] -- | 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 @@ -21,7 +21,11 @@ import Data.List (isSuffixOf) import Data.Text (Text) import Distribution.PackageDescription (GenericPackageDescription) -import Tilia.Cabal.Package (declaredModules, parsePackageDescription) +import Tilia.Cabal.Package + ( declaredModules, + packageBranches, + parsePackageDescription, + ) import Tilia.Utils (quietly) -- | The modules a package holds, read from the @.cabal@ file in its @@ -32,7 +36,7 @@ packageModules tarball = quietly Nothing $ do bytes <- BL.readFile tarball evaluate . force $ - fmap fst . declaredModules + fmap fst . concatMap snd . declaredModules . packageBranches <$> cabalFileInArchive (Tar.read (GZip.decompress bytes)) -- | The first @.cabal@ file at the top level of an archive. 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 @@ -25,10 +25,13 @@ storeSolveTime, cachedPackageCache, storePackageCache, + forgetPackageCache, ) where +import Control.Exception (bracketOnError) import Control.Monad (join) +import Data.ByteString qualified as BS import Data.Choice (Choice, isFalse) import Data.Foldable (toList, traverse_) import Data.List.NonEmpty (NonEmpty) @@ -39,6 +42,7 @@ import Data.Set qualified as Set import Data.Text (Text) import Data.Text qualified as T +import Data.Text.Encoding qualified as T import Data.Time (UTCTime) import Data.Time.Format (defaultTimeLocale, formatTime) import Data.Time.Format.ISO8601 (iso8601ParseM, iso8601Show) @@ -47,12 +51,14 @@ createDirectoryIfMissing, getModificationTime, getXdgDirectory, + removeFile, renameFile, ) -import System.FilePath (takeDirectory, ()) +import System.FilePath (takeDirectory, takeFileName, ()) +import System.IO (hClose, openBinaryTempFile) import Tilia.Fixity import Tilia.Fixity.PackageDb (Installed (..), InstalledPackage (..)) -import Tilia.Utils (quietly, readUtf8File, tshow, writeUtf8File) +import Tilia.Utils (quietly, readUtf8File, sha256Of, tshow) -- | Where cached answers are kept together with a token unique to this -- build plan and environment, or nowhere, in which case nothing is @@ -453,16 +459,34 @@ storeSolveTime cache = writeAtomically (at cache (solveTimeFile cache)) . T.pack . iso8601Show --- | Where @cabal@ last said it keeps the sources it downloads. -cachedPackageCache :: Cache -> IO (Maybe FilePath) -cachedPackageCache cache = - readIfPresent (at cache (packageCacheFile cache)) (T.unpack . T.strip) +-- | Where @cabal@ last said it keeps the sources it downloads for the +-- project in the directory given. +cachedPackageCache :: Cache -> FilePath -> IO (Maybe FilePath) +cachedPackageCache cache projectDir = + readIfPresent + (at cache (packageCacheFile cache projectDir)) + (T.unpack . T.strip) --- | Remember where @cabal@ keeps the sources it downloads. -storePackageCache :: Cache -> FilePath -> IO () -storePackageCache cache = - writeAtomically (at cache (packageCacheFile cache)) . T.pack +-- | Remember where @cabal@ keeps the sources it downloads for a project. +storePackageCache :: + -- | Where to remember it. + Cache -> + -- | The project's directory. + FilePath -> + -- | Where @cabal@ keeps the sources. + FilePath -> + IO () +storePackageCache cache projectDir = + writeAtomically (at cache (packageCacheFile cache projectDir)) . T.pack +-- | Forget where @cabal@ said it keeps the sources it downloads for a +-- project. +forgetPackageCache :: Cache -> FilePath -> IO () +forgetPackageCache cache projectDir = + traverse_ + (quietly () . removeFile) + (at cache (packageCacheFile cache projectDir)) + -- | Render a fixity declaration as fields. renderFixity :: ((Namespace, OpName), Fixity) -> [Text] renderFixity ((namespace, OpName op), Fixity direction precedence) = @@ -571,9 +595,12 @@ solveTimeFile :: Cache -> [Text] solveTimeFile cache = ["solve-times", tokenOf cache] --- | The path of the directory @cabal@ downloads sources into. -packageCacheFile :: Cache -> [Text] -packageCacheFile cache = ["package-cache", tokenOf cache] +-- | The path of the directory @cabal@ downloads a project's sources into. +packageCacheFile :: Cache -> FilePath -> [Text] +packageCacheFile cache projectDir = + [ "package-cache", + tokenOf cache <> "-" <> T.take 16 (sha256Of (T.pack projectDir)) + ] -- | The token a cache is kept under. tokenOf :: Cache -> Text @@ -591,13 +618,19 @@ Nothing -> pure Nothing Just path -> fmap parse <$> readUtf8File path --- | Write via a temporary file and a rename, making the directory if need --- be. +-- | Write via a temporary file of this write's own and a rename, making +-- the directory if need be. writeAtomically :: Maybe FilePath -> Text -> IO () writeAtomically place contents = case place of Nothing -> pure () Just path -> quietly () $ do - createDirectoryIfMissing True (takeDirectory path) - let temporary = path <> ".tmp" - writeUtf8File temporary contents - renameFile temporary path + let directory = takeDirectory path + createDirectoryIfMissing True directory + bracketOnError + (openBinaryTempFile directory (takeFileName path <> ".tmp")) + (\(temporary, h) -> hClose h >> removeFile temporary) + ( \(temporary, h) -> do + BS.hPut h (T.encodeUtf8 contents) + hClose h + 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 @@ -24,15 +24,18 @@ Fixity (..), Import (..), ModuleChain (..), + Namespace (..), OpName (..), Provenance (..), Resolution (..), Scope (..), disagreement, + fixityInScope, lookupFixity, moduleImports, operatorSpelling, operatorsUsed, + reachIn, reachUnqualified, spellDisagreement, spellFixity, @@ -47,10 +50,11 @@ data FixityNotes = FixityNotes { -- | What each import brought, in the order the module writes them. notedImports :: [ImportNote], - -- | Resolutions per operator. - notedOperators :: [OperatorNote], - -- | What operators the module declares. - notedDeclarations :: [(Text, Fixity)] + -- | Resolutions per operator, with the namespaces each holds in. + notedOperators :: [(Namespaces, OperatorNote)], + -- | What operators the module declares, with the namespaces each + -- declaration is in. + notedDeclarations :: [(Namespaces, (Text, Fixity))] } deriving (Eq, Show) @@ -84,6 +88,10 @@ } deriving (Eq, Show) +-- | The namespaces an entry holds in. +data Namespaces = One Namespace | Both + deriving (Eq, Show) + -- | Record everything that decided one module's fixities. fixityNotes :: -- | Whether @ImplicitPrelude@ is on, so that the Prelude is listed among @@ -102,7 +110,7 @@ pure FixityNotes { notedImports = importNotes, - notedOperators = fmap aboutOperator used, + notedOperators = used, notedDeclarations = here } where @@ -130,29 +138,38 @@ } used = - Map.elems - ( Map.fromList - [ ((namespace, uncurry operatorSpelling u), (namespace, u)) - | (namespace, u) <- concatMap (operatorsUsed . pmGathered) configurations - ] - ) + joined . Map.elems $ + Map.fromList + [ ((noteSpelling note, answering), (One answering, note)) + | (answering, note) <- + fmap aboutOperator (concatMap (operatorsUsed . pmGathered) configurations) + ] here = - [ (op, fixity) - | (OpName op, (fixity, DeclaredHere)) <- Map.toList declaredHere - ] - declaredHere = - Map.union - (reachUnqualified (scopeInTerms scope)) - (reachUnqualified (scopeInTypes scope)) + joined . Map.elems $ + Map.fromList + [ ((op, namespace), (One namespace, (op, fixity))) + | namespace <- [InTypes, InTerms], + (OpName op, (fixity, DeclaredHere)) <- + Map.toList (reachUnqualified (reachIn namespace scope)) + ] aboutOperator (namespace, (qualifier, op)) = - OperatorNote - { noteSpelling = operatorSpelling qualifier op, - noteResolution = lookupFixity scope namespace qualifier op, - noteDisagreement = disagreement scope namespace qualifier op - } + ( maybe namespace fst (fixityInScope scope namespace qualifier op), + OperatorNote + { noteSpelling = operatorSpelling qualifier op, + noteResolution = lookupFixity scope namespace qualifier op, + noteDisagreement = disagreement scope namespace qualifier op + } + ) +-- | Join adjacent entries that differ only in their namespaces. +joined :: (Eq a) => [(Namespaces, a)] -> [(Namespaces, a)] +joined = \case + (_, a) : (_, b) : rest | a == b -> (Both, a) : joined rest + entry : rest -> entry : joined rest + [] -> [] + -- | Set out all the 'FixityNotes' per file. renderFixityNotes :: Palette -> Map FilePath FixityNotes -> [Text] renderFixityNotes palette notes = @@ -202,16 +219,30 @@ (False, Just alias) -> " as " <> named alias (False, Nothing) -> "" - fromOwn (op, fixity) = operator op <> " " <> spellFixity fixity + fromOwn (namespaces, (op, fixity)) = + operator op <> " " <> spellFixity fixity <> " " <> spellNamespaces namespaces - fromOperator o = + fromOperator (namespaces, o) = operator (noteSpelling o) <> " " <> case noteResolution o of Resolved fixity provenance -> - spellFixity fixity <> ", " <> from provenance <> ambiguously o + spellFixity fixity + <> " " + <> spellNamespaces namespaces + <> ", " + <> from provenance + <> ambiguously o Unresolved missing -> - "unknown: may be declared in " <> spellUnreadIn palette missing + "unknown " + <> spellNamespaces namespaces + <> ": may be declared in " + <> spellUnreadIn palette missing + + spellNamespaces = \case + One InTypes -> "(type)" + One InTerms -> "(term)" + Both -> "(type & term)" from = \case DeclaredHere -> "declared in this module" 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 @@ -139,7 +139,12 @@ ("interface" : m : _) -> m == modName _ -> False sectionsNamed name = [body | (heading, body) <- sections out, heading == name] - fixities = Map.fromList (concatMap declared (sectionsNamed "fixities")) + fixities = + Map.fromListWith + (flip (<>)) + [ (op, [fixity]) + | (op, fixity) <- concatMap declared (sectionsNamed "fixities") + ] declared = mapMaybe fixityEntry . T.splitOn "," ownExports section = Set.fromList @@ -173,14 +178,19 @@ name <- take 1 (dropWhile (`elem` (["family", "role", "instance"] :: [Text])) rest) ] --- | Sort declared fixities into the namespaces they govern. -namespaced :: Set OpName -> Map OpName Fixity -> Fixities +-- | Sort declared fixities into the namespaces they govern: of two for one +-- name, GHC lists the term's first. +namespaced :: Set OpName -> Map OpName [Fixity] -> Fixities namespaced types declared = Map.fromList [ ((namespace, op), fixity) - | (op, fixity) <- Map.toList declared, - namespace <- if Set.member op types then [InTypes] else [InTerms] + | (op, fixities) <- Map.toList declared, + (namespace, fixity) <- zip (governed op fixities) fixities ] + where + governed op = \case + [_, _] -> [InTerms, InTypes] + _ -> [if Set.member op types then InTypes else InTerms] -- | Split the output into sections. sections :: Text -> [(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,11 +13,14 @@ where import Control.Monad (filterM) -import Data.List (nub) +import Data.List (nub, stripPrefix) import Data.Map.Strict qualified as Map -import Data.Maybe (mapMaybe) +import Data.Maybe (fromMaybe, mapMaybe) import Data.Text (Text) import Data.Text qualified as T +import Distribution.Compat.Newtype (unpack') +import Distribution.FieldGrammar.Newtypes (FSep (..), FilePathNT (..), alaList') +import Distribution.Parsec (Parsec, simpleParsec) import System.Directory (doesDirectoryExist, findExecutable) import System.FilePath (()) import Tilia.Process (readProgramOutput) @@ -81,16 +84,18 @@ -- | The databases a set of records came out of. databasesIn :: [Map.Map Text Text] -> [FilePath] databasesIn fields = - nub - [ T.unpack (unquote root) "package.conf.d" - | f <- fields, - Just root <- [Map.lookup "pkgroot" f] - ] + nub [root "package.conf.d" | Just root <- fmap packageRoot fields] --- | Strip the quotes a path is written in when it has none needing them. -unquote :: Text -> Text -unquote = T.dropAround (== '"') . T.strip +-- | Where a record's database keeps what @${pkgroot}@ stands for. +packageRoot :: Map.Map Text Text -> Maybe FilePath +packageRoot = fmap getFilePathNT . parsedField "pkgroot" +-- | A record's field, read as Cabal-syntax reads it, which is how +-- @ghc-pkg@ writes it. +parsedField :: (Parsec a) => Text -> Map.Map Text Text -> Maybe a +parsedField key fields = + simpleParsec . T.unpack . T.strip =<< Map.lookup key fields + -- | Split @ghc-pkg dump@ output into its records. records :: Text -> [Text] records = fmap T.unlines . go . T.lines @@ -117,15 +122,13 @@ ipImportDirs = maybe [] - (fmap (T.unpack . rooted fields . unquote) . T.words) - (Map.lookup "import-dirs" fields) + (fmap rooted . unpack' (alaList' FSep FilePathNT)) + (parsedField "import-dirs" fields) } - --- | Put the package's root where its registration only left a variable. -rooted :: Map.Map Text Text -> Text -> Text -rooted fields path = case Map.lookup "pkgroot" fields of - Nothing -> path - Just root -> T.replace "${pkgroot}" (unquote root) path + where + rooted path = + fromMaybe path ((<>) <$> root <*> stripPrefix "${pkgroot}" path) + root = packageRoot fields -- | The modules an @exposed-modules@ field names that the package holds. moduleNames :: Text -> [Text] diff --git a/src/Tilia/Fixity/Plan.hs b/src/Tilia/Fixity/Plan.hs --- a/src/Tilia/Fixity/Plan.hs +++ b/src/Tilia/Fixity/Plan.hs @@ -27,7 +27,7 @@ import Control.Monad (filterM, join) import Data.Choice (Choice, fromBool, pattern Do) import Data.Containers.ListUtils (nubOrd) -import Data.Foldable (toList) +import Data.Foldable (asum, toList) import Data.List.NonEmpty (NonEmpty ((:|))) import Data.List.NonEmpty qualified as NE import Data.Map.Strict (Map) @@ -37,15 +37,18 @@ import Data.Set qualified as Set import Data.Text (Text) import Data.Text qualified as T +import Data.Traversable (for) import GHC.Hs (HsModule) import GHC.Hs.Extension (GhcPs) import GHC.LanguageExtensions.Type (Extension (ImplicitPrelude)) -import System.Directory (doesFileExist) +import System.Directory (canonicalizePath, doesFileExist) import System.FilePath (()) import Tilia.Cabal.Package - ( PackageReader, + ( Kind (Lib), + PackageReader, declaredModules, newPackageReader, + packageComponents, packageExtensions, readPackageDescription, ) @@ -63,7 +66,16 @@ import Tilia.Memo (Flights, memoized, newFlights, newMemo) import Tilia.Parser import Tilia.Pragma (Defaults, effectiveExtensions) -import Tilia.Utils (byteOrderMark, inParallel, quietly, readUtf8File, sha256Of, sha256OfFile, tshow) +import Tilia.Utils + ( byteOrderMark, + inParallel, + pathUnder, + quietly, + readUtf8File, + sha256Of, + sha256OfFile, + tshow, + ) ---------------------------------------------------------------------------- -- Resolving @@ -82,11 +94,13 @@ -- | What can be asked about a module, once a plan says where to look. newtype Resolver = Resolver - { -- | What reading a module established about the names it exports. - askModule :: Text -> IO Established + { -- | What reading a module established about the names it exports, as + -- the file at the canonical path given, where it is one of the + -- project's own, imports it. + askModule :: Maybe FilePath -> Text -> IO Established } --- | Build a new 'Resolver'. +-- | Build a new 'Resolver' for the project in the current directory. -- -- Answers are remembered on disk between runs by "Tilia.Fixity.Cache", so a -- package is decompressed and parsed once per machine rather than once per @@ -97,7 +111,12 @@ IO Resolver newResolver plan = do packageReader <- newPackageReader (plannedCompiler plan) [] - newResolverVia (Do #useCache) [FromInterface, FromSource] packageReader plan + newResolverVia + (Do #useCache) + [FromInterface, FromSource] + packageReader + "." + plan -- | 'newResolver', restricted to the routes given. newResolverVia :: @@ -107,14 +126,16 @@ [Route] -> -- | What the package of each of the project's own modules puts in force. PackageReader -> + -- | The project the plan is for. + FilePath -> -- | The build plan to use. BuildPlan -> IO Resolver -newResolverVia caching routes packageReader plan = do +newResolverVia caching routes packageReader projectDir plan = do cache <- openCache caching =<< tokenForBuildPlan plan tarballs <- if FromSource `elem` routes - then plannedTarballs cache plan + then plannedTarballs cache projectDir plan else pure [] installed <- getInstalledPackages cache newResolverWith routes cache installed tarballs packageReader plan @@ -138,7 +159,7 @@ newResolverWith routes cache installed tarballs packageReader plan = do index <- buildModuleIndex cache installed tarballs let interfaces = interfaceIndex installed - local <- localModules plan + importable <- localModules plan flights <- newFlights answersRead <- newMemo extensionsRead <- newMemo @@ -154,7 +175,7 @@ Workings { wkRoutes = routes, wkCache = cache, - wkLocal = local, + wkImportable = importable, wkIndex = index, wkInterfaces = interfaces, wkInterfaceOf = interfaceOf, @@ -169,13 +190,16 @@ } -- The stand-in is what 'withReexports' makes of a module it is in the -- middle of reading. - reach visiting modName - | modName `Set.member` visiting = pure mempty + reach visiting local modName + | key `Set.member` visiting = pure mempty | otherwise = - memoized flights answersRead mempty modName $ - resolveModule workings visiting modName - summariesOf modName text = - extensionsOf modName >>= \case + memoized flights answersRead mempty key $ + resolveModule workings (Set.insert key visiting) found modName + where + found = local modName + key = maybe modName T.pack found + summariesOf found modName text = + extensionsOf found modName >>= \case Nothing -> pure Nothing Just extensions -> do let summarized = @@ -184,7 +208,7 @@ stamp = digestOf . T.intercalate "\n" $ [tshow extensions, macrosRead, text] - case digestOf . T.pack <$> Map.lookup modName local of + case digestOf . T.pack <$> found of Nothing -> summarized Just key -> join @@ -193,8 +217,8 @@ (storeSummaries cache key stamp) (Just <$> summarized) macrosRead = tshow (macrosOf plan) - extensionsOf modName - | Just path <- Map.lookup modName local = + extensionsOf found modName + | Just path <- found = either (const Nothing) Just <$> packageReader path | Just (package, tarball) <- Map.lookup modName index = memoized flights extensionsRead Nothing package $ @@ -203,7 +227,7 @@ archiveOf tarball = memoized flights archivesRead Nothing (T.pack tarball) (readArchive tarball) moduleInArchive tarball modName = (moduleIn modName =<<) <$> archiveOf tarball - pure Resolver{askModule = reach Set.empty} + pure Resolver{askModule = reach Set.empty . importable} -- | A module's interface, read once, with the primops' fixities standing -- in for that of @GHC.Prim@, which has no file. @@ -234,7 +258,7 @@ (either (const Nothing) Just . fromHiFile modName =<<) <$> given modName pure Resolver - { askModule = \modName -> + { askModule = \_ modName -> memoized flights answersRead unreadable modName $ fromInterface interfaceOf modName } @@ -249,6 +273,9 @@ scopeFor :: -- | What can be asked about the modules it imports. Resolver -> + -- | The canonical path of the module, where it is one of the project's + -- own. + Maybe FilePath -> -- | Whether @ImplicitPrelude@ is on, which the module's own pragmas -- and its package's @default-extensions@ decide between them. Choice "implicitPrelude" -> @@ -257,11 +284,12 @@ NonEmpty (HsModule GhcPs) -> -- | Everything that module can see, and what it could not find out. IO Scope -scopeFor resolver implicitPrelude configurations = do +scopeFor resolver importer implicitPrelude configurations = do let imports = moduleImports implicitPrelude configurations + asked = askModule resolver importer answers <- inParallel - (\m -> (m,) <$> askModule resolver m) + (\m -> (m,) <$> asked m) (fmap importModule imports) let table = Map.fromList answers pure $ @@ -280,9 +308,10 @@ wkRoutes :: [Route], -- | Where to remember answers between runs. wkCache :: Cache, - -- | The modules of the project's own packages, which are read straight - -- from disk rather than out of an archive. - wkLocal :: Map Text FilePath, + -- | Where each module the file at the canonical path given, where it is + -- one of the project's own, imports from a directory rather than an + -- archive is. See 'localModules'. + wkImportable :: Maybe FilePath -> Text -> Maybe FilePath, -- | Which package holds each module, and the tarball to find it in; the -- package is the cache key, which carries the hash the tarball was -- verified against. @@ -291,13 +320,23 @@ wkInterfaces :: Map Text (Text, FilePath), -- | A module's interface, read at most once a run. wkInterfaceOf :: Text -> IO (Maybe Interface), - -- | How to reach another module. Tied back on itself by + -- | How to reach another module, given where each module the one + -- importing it imports from a directory is. Tied back on itself by -- 'newResolverWith', so that the memo it keeps covers the recursive -- calls too. - wkReach :: Set Text -> Text -> IO Established, - -- | What each configuration of a module says, given its text, worked - -- out once a run. - wkSummariesOf :: Text -> Text -> IO (Maybe (NonEmpty ModuleSummary)), + wkReach :: + Set Text -> + (Text -> Maybe FilePath) -> + Text -> + IO Established, + -- | What each configuration of a module says, given where it is if it + -- is one of the project's own, its name and its text, worked out once a + -- run. + wkSummariesOf :: + Maybe FilePath -> + Text -> + Text -> + IO (Maybe (NonEmpty ModuleSummary)), -- | What a tarball holds for a module, each tarball read once a run. wkModuleInArchive :: FilePath -> Text -> IO (Maybe InArchive), -- | The modules @cabal@ writes itself, which are therefore in no @@ -313,8 +352,12 @@ resolveModule :: -- | Where to look, and how to get back to the resolver. Workings -> - -- | Modules currently being resolved further up the call chain. + -- | Modules currently being resolved further up the call chain, this one + -- among them, each by its path if it is one of the project's own and by + -- its name otherwise. Set Text -> + -- | Where the module is, if it is one of the project's own. + Maybe FilePath -> -- | The module to resolve. Text -> IO Established @@ -322,7 +365,7 @@ Workings { wkRoutes, wkCache, - wkLocal, + wkImportable, wkIndex, wkInterfaces, wkInterfaceOf, @@ -333,22 +376,23 @@ wkReexported } visiting + found modName - | Just path <- Map.lookup modName wkLocal, + | Just path <- found, writtenForHsc path = pure mempty - | Just path <- Map.lookup modName wkLocal = + | Just path <- found = readUtf8File path >>= \case Nothing -> pure unreadable Just source -> - fromSummaries (wkReach visiting') modName - =<< wkSummariesOf modName (snd (byteOrderMark source)) + fromSummaries (wkReach visiting (wkImportable found)) modName + =<< wkSummariesOf found modName (snd (byteOrderMark source)) | Just original <- Map.lookup modName wkReexported, Map.notMember modName wkInterfaces = - wkReach visiting' original + wkReach visiting fromDependency original | otherwise = answered <$> firstAnswer (fmap taking wkRoutes) where - visiting' = Set.insert modName visiting + fromDependency = wkImportable Nothing taking = \case FromInterface -> viaInterface @@ -377,8 +421,8 @@ throughCache package $ fromSource wkModuleInArchive - wkSummariesOf - (wkReach visiting') + (wkSummariesOf Nothing) + (wkReach visiting fromDependency) tarball modName @@ -568,9 +612,10 @@ -- | One answer from every configuration of a module that counts. -- --- A module may declare a fixity in one configuration and a different one in --- another. Which of them holds depends on how the module is compiled, which --- is not ours to decide, so disagreement leaves the name unsettled. +-- A module may declare a fixity in one configuration and a different one, or +-- none, which is infixl 9, in another. Which of them holds depends on how the +-- module is compiled, which is not ours to decide, so disagreement leaves +-- the name unsettled. -- Agreement across the ones that count is an answer, and a stronger one -- than the blanked text could give. -- @@ -604,7 +649,17 @@ declared = Map.unionsWith (<>) - [Map.map pure (establishedFixities a) | a <- toList counted] + [ Map.map pure (Map.union (establishedFixities a) (defaulted a)) + | a <- toList counted + ] + defaulted a = + Map.fromSet + (const defaultFixity) + ( Set.filter + (null . unsettledThrough a) + (Set.intersection fixed (certainNames (establishedCertain a))) + ) + fixed = foldMap (Map.keysSet . establishedFixities) counted sole (fixity :| rest) = if all (== fixity) rest then Just fixity else Nothing disagreed = inhabited (Map.keysSet (Map.filter (isNothing . sole) declared)) @@ -618,26 +673,56 @@ (certainMembers b) } --- | Where each module that lives in a directory rather than an archive is. -localModules :: BuildPlan -> IO (Map Text FilePath) -localModules plan = - Map.unions <$> traverse forPackage (nubOrd (concatMap directoryOf (bpPackages plan))) +-- | Where each module the file at the canonical path given, where it is one +-- of the project's own, imports from a directory rather than an archive is. +-- +-- A module of the component with the source directory nearest above the +-- file comes before any library's, as GHC looks in a component's own +-- source directories before the packages it depends on. Components whose +-- directories are as near count together. +localModules :: BuildPlan -> IO (Maybe FilePath -> Text -> Maybe FilePath) +localModules plan = do + components <- + concat + <$> traverse forPackage (nubOrd (concatMap directoryOf (bpPackages plan))) + let libraries = Map.unions [modules | (Lib, _, modules) <- components] + pure $ \importer -> + let covering = + [ (length rest, modules) + | Just file <- [importer], + (_, dirs, modules) <- components, + Just rest <- fmap (`pathUnder` file) dirs + ] + holding = + [modules | (n, modules) <- covering, all ((n <=) . fst) covering] + in \modName -> + asum (fmap (Map.lookup modName) holding) + <|> Map.lookup modName libraries where directoryOf p = case ppSource p of LocalPackage dir -> [dir] CheckedOut dir -> [dir] _ -> [] - forPackage dir = quietly Map.empty $ do + forPackage dir = quietly [] $ do cabalFilesIn dir >>= \case - [] -> pure Map.empty + [] -> pure [] (cabalFile : _) -> readPackageDescription cabalFile >>= \case - Left _ -> pure Map.empty + Left _ -> pure [] Right described -> - Map.fromListWith (\_ first' -> first') . concat - <$> traverse (locate dir) (declaredModules described) - locate dir (m, unwritten) = do - found <- filterM doesFileExist [dir unwritten <> e | e <- moduleEndings] + traverse (component dir) (packageComponents described) + component dir (kind, _, branches) = do + placed <- for (declaredModules branches) $ \(d, modules) -> do + root <- canonicalizePath (dir d) + (root,) . concat <$> traverse (locate root) modules + pure + ( kind, + fmap fst placed, + Map.fromListWith (\_ first' -> first') (concatMap snd placed) + ) + locate root (m, unwritten) = do + found <- + filterM doesFileExist [root unwritten <> e | e <- moduleEndings] pure [(m, path) | path <- take 1 found] -- | What a module exports, out of what it declares and what its imports @@ -742,6 +827,11 @@ (certainMembersOf answers qualifier parent) (Map.lookup parent declared) ) + <> Set.fromList + [ (InTerms, kid) + | kid <- kids, + Set.member (InTerms, kid) (summaryNames summary) + ] ) ExportModule m -> (if Just m == summaryName summary || m == modName then own else mempty) diff --git a/src/Tilia/Format.hs b/src/Tilia/Format.hs --- a/src/Tilia/Format.hs +++ b/src/Tilia/Format.hs @@ -12,6 +12,7 @@ Session, sessionRoot, PlanSource (..), + planSourceFor, newSession, Compiled (..), compiledSession, @@ -26,16 +27,19 @@ import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE) import Data.Choice (Choice, fromBool, isTrue) +import Data.Either (fromRight) import Data.Foldable (traverse_) import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef) 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.Version (Version, versionBranch) import GHC.Driver.Session (OnOff (..)) import GHC.LanguageExtensions.Type (Extension (ImplicitPrelude)) +import System.Directory (canonicalizePath) import Tilia.Cabal.Package ( PackageProblem (..), PackageReader, @@ -52,7 +56,7 @@ versionMacros, ) import Tilia.Cabal.Project (ProjectRoot (..), findProjectRoot) -import Tilia.Cabal.Target (packageFilesOf) +import Tilia.Cabal.Target (Component, componentInPlan, packageFilesOf) import Tilia.Cpp ( CppError (..), correspondingBranches, @@ -106,7 +110,8 @@ NoPackage FilePath PackageProblem | -- | The file is not Haskell we can parse. NotParsed ParseError - | -- | The file carries @{-# LINE #-}@ or @{-# COLUMN #-}@ pragmas. + | -- | The file carries @{-# LINE #-}@ or @{-# COLUMN #-}@ pragmas, or lines + -- GHC's lexer reads past, such as @#line@ ones. PositionPragmas FilePath | -- | The file uses the preprocessor in a way we cannot handle. CppUnsupported FilePath CppError @@ -115,6 +120,8 @@ UnknownFixity FilePath [((Maybe Text, OpName), Unknown)] | -- | The file could not be read at all. Unreadable FilePath Text + | -- | The file could not be written back once formatted. + Unwritable FilePath Text | -- | Formatting the file changed its AST. NotEquivalent FilePath Text | -- | Formatting is not idempotent. @@ -138,11 +145,14 @@ PositionPragmas path -> "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 + <> ": it uses {-# LINE #-} or {-# COLUMN #-} pragmas or #line, #pragma" + <> " or #! lines, and no reformatting can leave those true" + CppUnsupported path why -> case why of + ConfigurationNotParsed{} -> + "will not format " <> located (describeCppError why) + _ -> "will not format " <> file path <> ": " <> describeCppError why Unreadable path why -> "cannot read " <> file path <> ": " <> why + Unwritable path why -> "cannot write " <> file path <> ": " <> why NotEquivalent path why -> "formatting " <> file path <> " changed the program: " <> why NotIdempotent path why -> @@ -190,12 +200,14 @@ NotEquivalent{} -> 17 NotIdempotent{} -> 18 Threw{} -> 19 + Unwritable{} -> 20 CppUnsupported _ why -> case why of MalformedConditional{} -> 9 TooManyConfigurations -> 10 ConfigurationNotParsed{} -> 11 DirectiveInQuotedText{} -> 12 MacroInQuotedText{} -> 12 + BeforeLeadingComma{} -> 12 RuledOutBranch{} -> 13 AbortingAlternative{} -> 14 @@ -208,6 +220,7 @@ NotParsed{} -> False NoPackage{} -> False Unreadable{} -> False + Unwritable{} -> False NotEquivalent{} -> False NotIdempotent{} -> False Threw{} -> False @@ -242,6 +255,13 @@ -- Cabal to solve it. GivenPlan FilePath +-- | Where a session's build plan comes from: the plan file given, if any, +-- or else Cabal, solving for the components the action finds. +planSourceFor :: Maybe FilePath -> IO [Component] -> IO PlanSource +planSourceFor givenPlan components = case givenPlan of + Just plan -> pure (GivenPlan plan) + Nothing -> PlanFromCabal . mapMaybe componentInPlan <$> components + -- | Settle everything that does not depend on the file being formatted. newSession :: -- | The project. @@ -273,9 +293,9 @@ then [FromInterface, FromSource] <$ liftIO (fetchUninstalled caching root plan) else pure [FromInterface] pure (plan, routes) - packages <- liftIO (packageFilesOf project) + packages <- liftIO (fromRight [] <$> packageFilesOf project) packageReader <- liftIO (newPackageReader (plannedCompiler plan) packages) - resolver <- liftIO (newResolverVia caching routes packageReader plan) + resolver <- liftIO (newResolverVia caching routes packageReader root plan) notes <- if isTrue debugFixity then Just <$> liftIO (newIORef Map.empty) @@ -358,9 +378,8 @@ -- | Result. IO (Either FormatError Text) formatSource session path source = runExceptT $ do - when (movesPositions source) $ - throwE (PositionPragmas path) package <- orElse (NoPackage path) =<< liftIO (sessionPackage session path) + importer <- liftIO (canonicalizePath path) let resolver = sessionResolver session config = ParserConfig package extensionsAndCpp text = @@ -369,14 +388,20 @@ renderConfigFor extensions parsed = do let implicitPrelude = fromBool (Set.member ImplicitPrelude extensions) - scope <- liftIO (scopeFor resolver implicitPrelude (fmap pmModule parsed)) + scope <- + liftIO $ + scopeFor + resolver + (Just importer) + implicitPrelude + (fmap pmModule parsed) liftIO $ case sessionFixityNotes session of Nothing -> pure () Just ref -> do told <- fixityNotes implicitPrelude - (askModule resolver) + (askModule resolver (Just importer)) scope parsed atomicModifyIORef' ref (\m -> (Map.insertWith (\_ old -> old) path told m, ())) @@ -406,7 +431,9 @@ ( printDoc (renderModule render parsed), Just parsed ) - let inForce@(_, cpp) = extensionsAndCpp source + let inForce@(extensions, cpp) = extensionsAndCpp source + when (movesPositions (Set.toList extensions) source) $ + throwE (PositionPragmas path) (formatted, tree) <- formatting inForce Nothing source printedTree <- if isTrue (sessionCheckAst session) diff --git a/src/Tilia/Ignore.hs b/src/Tilia/Ignore.hs --- a/src/Tilia/Ignore.hs +++ b/src/Tilia/Ignore.hs @@ -35,7 +35,7 @@ import Data.Text.Encoding qualified as T import System.Directory (canonicalizePath, doesFileExist) import System.FilePath (joinPath, ()) -import Tilia.Utils (pathUnder, quietly) +import Tilia.Utils (byteOrderMark, pathUnder, quietly) -- | The patterns of one ignore file, in the order they are written. newtype IgnoreFile = IgnoreFile [Pattern] @@ -70,12 +70,15 @@ | -- | A bracket expression, whether it is negated, and what it holds. Bracket Bool [Char -> Bool] --- | Read an ignore file. +-- | Read an ignore file, past the byte order mark it may begin with, as Git +-- does. parseIgnoreFile :: Text -> IgnoreFile parseIgnoreFile = IgnoreFile . mapMaybe (parsePattern . T.unpack . withoutReturn) . T.lines + . snd + . byteOrderMark where withoutReturn = T.dropWhileEnd (== '\r') diff --git a/src/Tilia/Palette.hs b/src/Tilia/Palette.hs --- a/src/Tilia/Palette.hs +++ b/src/Tilia/Palette.hs @@ -11,22 +11,22 @@ ) where -import Data.Maybe (isJust) import Data.Text (Text) import System.Environment (lookupEnv) -import System.IO (hIsTerminalDevice, stdout) +import System.IO (Handle, hIsTerminalDevice) -- | Whether to color the output. data Palette = Colors | Plain deriving (Eq, Show) --- | Color output when there is somebody there to see it. -paletteFor :: IO Palette -paletteFor = do +-- | Color what goes to a handle when there is somebody there to see it, +-- unless a @NO_COLOR@ that is not empty says otherwise. +paletteFor :: Handle -> IO Palette +paletteFor h = do refused <- lookupEnv "NO_COLOR" - terminal <- hIsTerminalDevice stdout + terminal <- hIsTerminalDevice h pure $ - if terminal && not (isJust refused) + if terminal && maybe True null refused then Colors else Plain diff --git a/src/Tilia/Parser.hs b/src/Tilia/Parser.hs --- a/src/Tilia/Parser.hs +++ b/src/Tilia/Parser.hs @@ -218,7 +218,6 @@ GHC.ITlineComment _ _ -> True GHC.ITblockComment _ _ -> True GHC.ITdocComment _ _ -> True - GHC.ITdocOptions _ _ -> True _ -> False -- | Is this token a quasi-quotation? diff --git a/src/Tilia/Pragma.hs b/src/Tilia/Pragma.hs --- a/src/Tilia/Pragma.hs +++ b/src/Tilia/Pragma.hs @@ -11,7 +11,6 @@ lookupEdition, nameSwitch, flagSwitches, - optionFlags, pragmaFlags, languageNames, withoutSkippedComments, @@ -19,11 +18,12 @@ ) where -import Control.Monad ((<=<)) -import Data.Char (isAlphaNum, isSpace) +import Control.Monad (guard, (<=<)) +import Data.Char (isAlphaNum, isDigit, isLower, isSpace, isUpper) +import Data.List (unsnoc) import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map -import Data.Maybe (mapMaybe, maybeToList) +import Data.Maybe (fromMaybe, mapMaybe, maybeToList) import Data.Set qualified as Set import Data.Text (Text) import Data.Text qualified as T @@ -34,12 +34,23 @@ import GHC.Types.SrcLoc (mkRealSrcLoc, unLoc) import Tilia.Utils (tshow) --- | Recognize @{-# LINE #-}@ and @{-# COLUMN #-}@ pragmas. -movesPositions :: Text -> Bool -movesPositions = any positional . pragmaBodies +-- | Recognize @{-# LINE #-}@ and @{-# COLUMN #-}@ pragmas in a module with +-- these extensions in force, and the lines GHC's lexer reads past at the +-- start of a line, but for the @#!@ lines a script begins with. +-- +-- Those are the line markers cpp writes, such as @# 40 "M.hs"@, which move +-- positions as a @LINE@ pragma does, and @#pragma@ and @#!@ lines, which +-- leave nothing behind for formatting to print. With CPP on, @#line@ and +-- @#pragma@ lines are directives, which formatting keeps. +movesPositions :: [Extension] -> Text -> Bool +movesPositions extensions = + or . scanPragmas positional (pastCode extensions) . T.cons '\n' . script where positional body = T.toUpper (T.takeWhile (/= ' ') body) `elem` ["LINE", "COLUMN"] + script t + | "#!" `T.isPrefixOf` t = script (T.drop 1 (T.dropWhile (/= '\n') t)) + | otherwise = t -- | What a component puts in force before the pragmas of a module: its -- @default-language@ and its @default-extensions@. @@ -206,16 +217,40 @@ 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 = scanPragmas past +-- | Carry on past the code of a module with these extensions in force, over +-- its strings, characters and quasi-quotations, up to a line that GHC's +-- lexer reads past and formatting would lose. +pastCode :: [Extension] -> (Text -> [Bool]) -> Text -> [Bool] +pastCode extensions = past where past go t = case T.uncons t of + Just ('\n', after) | readPast after -> [True] Just ('"', after) -> go (skipString after) Just ('\'', after) -> go (skipCharacter after) - _ -> go (skipCode t) + _ + | QuasiQuotes `elem` extensions, + Just body <- quasiQuotation t -> + go (T.drop 2 (snd (T.breakOn "|]" body))) + | otherwise -> go (skipCode t) + withoutCpp = Cpp `notElem` extensions + readPast l = case T.uncons l of + Just ('#', rest) -> + (withoutCpp && any (`T.isPrefixOf` rest) ["line", "pragma"]) + || "!" `T.isPrefixOf` rest + || T.any isDigit (T.take 1 (fromMaybe rest (T.stripPrefix " " rest))) + Just (' ', rest) -> "#!" `T.isPrefixOf` rest + _ -> False + + quasiQuotation t = do + (quoter, rest) <- T.span inQuoter <$> T.stripPrefix "[" t + (modules, name) <- unsnoc (T.splitOn "." quoter) + guard (all (begins isUpper) modules && begins varStart name) + T.stripPrefix "|" rest + inQuoter c = inName c || c == '.' + begins p = maybe False (p . fst) . T.uncons + varStart c = isLower c || c == '_' + skipString = inString . T.dropWhile (\c -> c /= '"' && c /= '\\') inString t @@ -233,14 +268,15 @@ 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 == '\'' + opens c = + c == '{' || c == '-' || c == '"' || c == '\'' || c == '[' || c == '\n' 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 +headerPragmaBodies = scanPragmas id past where past go t = case T.uncons t of Just (c, _) @@ -248,17 +284,18 @@ | 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 +-- | What the given function makes of 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 other given function does. +scanPragmas :: (Text -> a) -> ((Text -> [a]) -> Text -> [a]) -> Text -> [a] +scanPragmas pragma 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 (withoutSkippedComments inner)) + pragma (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) diff --git a/src/Tilia/Process.hs b/src/Tilia/Process.hs --- a/src/Tilia/Process.hs +++ b/src/Tilia/Process.hs @@ -3,6 +3,7 @@ -- | Running a program and reading its output. module Tilia.Process ( readProgramOutput, + readProgramOutputIn, ) where @@ -15,6 +16,7 @@ import System.IO (Handle, hClose, hSetBinaryMode) import System.Process ( StdStream (CreatePipe), + cwd, proc, std_err, std_in, @@ -31,7 +33,11 @@ -- -- Line endings come back as newlines however the program wrote them. readProgramOutput :: FilePath -> [String] -> IO (Maybe Text) -readProgramOutput program args = quietly Nothing $ +readProgramOutput = readProgramOutputIn "." + +-- | 'readProgramOutput', with the program run in the directory given. +readProgramOutputIn :: FilePath -> FilePath -> [String] -> IO (Maybe Text) +readProgramOutputIn dir program args = quietly Nothing $ withCreateProcess spec $ \toChild fromChild childErrors running -> do traverse_ hClose toChild waitForErrors <- forked (drain childErrors) @@ -43,7 +49,8 @@ where spec = (proc program args) - { std_in = CreatePipe, + { cwd = Just dir, + std_in = CreatePipe, std_out = CreatePipe, std_err = CreatePipe } diff --git a/src/Tilia/Render.hs b/src/Tilia/Render.hs --- a/src/Tilia/Render.hs +++ b/src/Tilia/Render.hs @@ -92,7 +92,7 @@ (pmGathered parsed) (comments (pmSource parsed)) plain = heldOff haddocks loose' - (stackHeader, rest) = takeStackHeader (pmHeaderEnd parsed) plain + (stackHeader, rest) = takeStackHeader (pmPrologue parsed) plain (pragmas, uncovered) = takeHeaderPragmas (pmSource parsed) (pmHeaderEnd parsed) rest held = heldOffModuleDoc hsMod haddocks pragmas uncovered opening = importsOpening (sourceLines (pmSource parsed)) held hsMod 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 @@ -240,8 +240,7 @@ space <> indent ( fold resultSig - <> space - <> foldMap (at_ ctx (injectivityAnn ctx)) fdInjectivityAnn + <> foldMap ((space <>) . at_ ctx (injectivityAnn ctx)) fdInjectivityAnn ) resultSig = familyResultSig ctx fdResultSig 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 @@ -90,7 +90,7 @@ -- | The uses of an operator a local binding captures, by where the -- operator is written, with their fixities. ctxCaptured :: Map Span Fixity, - -- | The comments that take whole lines, by starting position. + -- | The comments that end their line, by starting position. ctxLineComments :: Map (Int, Int) Comment, -- | The column of the trailing comment each comment that carries one on -- begins at, by where that comment begins. @@ -375,7 +375,7 @@ n >= spanEndLine s || maybe False from (quoteEndingFrom n (ctxSource ctx)) --- | Does a comment that takes whole lines begin inside this span? +-- | Does a comment that ends its line begin inside this span? holdsLineComment :: Ctx -> Span -> Bool holdsLineComment ctx s = case Map.lookupGE (startPoint s) (ctxLineComments ctx) of 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 @@ -122,7 +122,10 @@ (fmap (at_ ctx (conDecl ctx (Isn't #singleRecCon))) cons) | otherwise -> layoutFrom ctx (spanOf tyCon <> spansOf cons) . indent $ - beforeEquals <> txt "=" <> space <> alternatives + beforeEquals + <> txt "=" + <> space + <> fenceWithin ctx (fmap endOf equalsSpan <> spansOf cons) alternatives where singleRecCon = case cons of [L _ ConDeclH98{con_args = RecCon{}}] -> True @@ -133,6 +136,8 @@ ConDeclGADT{..} -> spansOf (NE.toList con_names) ConDeclH98{..} -> spanOf con_name + equalsSpan = spanOf (andd_equal dd_ext) + lineHaddocks = any (printsWholeLineDocs ctx . visibleDocs . unLoc) cons beforeEquals @@ -280,7 +285,7 @@ | otherwise = conDeclField ctx x <> case cdf_doc x of - Just d -> space <> haddock ctx Caret Closed d + Just d -> space <> haddockInline ctx Caret d Nothing -> breakOrSpace rightDoc x = case cdf_doc x of Just d -> hardBreak <> haddock ctx Pipe Closed d 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 @@ -56,19 +56,17 @@ -- | Render a declaration run while applying the requested 'Grouping'. declRun :: Grouping -> Ctx -> FamilyStyle -> [LHsDecl GhcPs] -> Doc declRun grouping ctx style ds = - items NoBrace $ case groups of - [] -> [] - (firstGroup : rest) -> - render firstGroup <> concat (zipWith withGap groups rest) + items + NoBrace + [ includeWhen gap breakOrSpace <> at_ ctx (hsDecl ctx style) d + | (previous, current) <- zip (Nothing : fmap Just groups) groups, + let gaps = any (`separate` current) previous : repeat False, + (gap, d) <- zip gaps (NE.toList current) + ] where isSignatureFile = ctxSourceType ctx == SignatureSource groups = groupDecls ctx isSignatureFile ds - render = NE.toList . fmap (at_ ctx (hsDecl ctx style)) - withGap previous current - | separate previous current = breakOrSpace : render current - | otherwise = render current - separate previous current = not (remarkUnder ctx ended began || underHeading) && case grouping of Disregard -> True @@ -83,8 +81,8 @@ isHeading (unLoc (NE.last previous)) && commentRightUnder ctx ended began - isDocumented = any (isDocNext . unLoc) - isDocNext = \case + isDocumented = any (isDocComment . unLoc) + isDocComment = \case DocD _ (DocCommentNext _) -> True DocD _ (DocCommentPrev _) -> True _ -> False @@ -154,7 +152,6 @@ | FamilyDeclaration | TypeSynonym | PragmaDeclaration - | DocumentsNext | DocumentsPrevious | Unremarkable deriving (Eq, Show) @@ -182,7 +179,6 @@ TyClD _ (SynDecl _ (L _ n) _ _ _) -> (TypeSynonym, [n]) TyClD _ (FamDecl _ (FamilyDecl _ _ _ (L _ n) _ _ _ _)) -> (FamilyDeclaration, [n]) KindSigD _ (StandaloneKindSig _ (L _ n) _) -> (KindSignature, [n]) - DocD _ (DocCommentNext _) -> (DocumentsNext, []) DocD _ (DocCommentPrev _) -> (DocumentsPrevious, []) _ -> (Unremarkable, []) @@ -190,7 +186,6 @@ -- them? relatedDecls :: LHsDecl GhcPs -> LHsDecl GhcPs -> Bool relatedDecls a b = case (kindA, kindB) of - (DocumentsNext, _) -> True (_, DocumentsPrevious) -> True pair | pair `elem` relatedKinds -> shareAName namesA namesB _ -> False 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 @@ -17,6 +17,7 @@ import Control.Applicative ((<|>)) import Data.Choice (Choice, fromBool, isTrue, pattern Is, pattern Isn't) +import Data.Data (Data) import Data.Generics.Schemes (listify) import Data.List (unsnoc) import Data.List.NonEmpty (NonEmpty (..)) @@ -85,6 +86,7 @@ NegApp _ e _ -> txt "-" <> includeWhen (isLiteral e) (negativeLiteralGap ctx) + <> includeWhen (startsWithSymbol e) space <> hsExpr ctx e HsPar _ e -> layoutWithin ctx here (spanOf e) $ @@ -156,11 +158,14 @@ HsProjection{..} -> parens (txt "." <> dotFields ctx proj_flds) ExprWithTySig _ x HsWC{hswc_body} -> align $ - hsExpr ctx x - <> joinedBy "::" + hsExprIn ctx (withBracing MayBrace plainSite) x + <> ( if endsWithBlock (unLoc x) + then breakOrSpace <> txt "::" <> space + else joinedBy "::" + ) <> indent (hsSigType ctx hswc_body) ArithSeq _ _ range -> arithSeq ctx here (closingFor site) range - HsTypedBracket (bracketAnn, _) e -> quoted here opener "||]" (hsExpr ctx e) + HsTypedBracket (bracketAnn, _) e -> quoted here opener "||]" e (hsExpr ctx e) where opener = case bracketAnn of BracketNoE{} -> "[||" @@ -172,15 +177,21 @@ txt "proc" <> layoutFrom ctx (spanOf p) (breakOrSpace <> indent (hsPat ctx p) <> breakOrSpace) <> txt "->" - <> attachBody (CmdTopBody ctx plainSite e) - HsStatic _ e -> txt "static" <> breakOrSpace <> indent (hsExpr ctx e) + <> attachBody + (CmdTopBody ctx (withBracing (siteBracing site) plainSite) e) + HsStatic _ e -> + txt "static" + <> breakOrSpace + <> indent (hsExprIn ctx (withBracing (siteBracing site) plainSite) e) HsPragE _ prag x -> case prag of HsPragSCC _ n -> txt "{-# SCC " <> writtenString n <> txt " #-}" <> breakOrSpace - <> nest (if siteInBlock site then 1 else 0) (hsExpr ctx x) + <> nest + (if siteInBlock site then 1 else 0) + (hsExprIn ctx (withBracing (siteBracing site) plainSite) x) HsEmbTy _ HsWC{hswc_body} -> txt "type" <> space <> hsType ctx hswc_body HsHole holeKind -> case holeKind of HoleVar n -> name ctx n @@ -213,20 +224,36 @@ HsOverLit{} -> True _ -> False +-- | Does this expression begin with a symbol character, which an operator +-- written right before it would take into its name? +startsWithSymbol :: LHsExpr GhcPs -> Bool +startsWithSymbol e = case unLoc e of + HsIPVar{} -> True + HsOverLabel{} -> True + HsLam{} -> True + HsUntypedSplice _ HsUntypedSpliceExpr{} -> True + HsTypedSplice{} -> True + HsApp _ f _ -> startsWithSymbol f + HsAppType _ f _ -> startsWithSymbol f + RecordUpd{rupd_expr} -> startsWithSymbol rupd_expr + HsGetField{gf_expr} -> startsWithSymbol gf_expr + _ -> False + -- | A function applied to arguments. application :: Ctx -> Site -> LHsExpr GhcPs -> LHsExpr GhcPs -> Doc application ctx site f x = case placement of Normal -> mayBraceWhenFlat (siteBracing site) headAndInit - <> indent (breakOrSpace <> hsExpr ctx lastArg) + <> indent (breakOrSpace <> lastArgDoc) Hanging -> layoutFrom ctx initSpan (headAndInit MayBrace) - <> attach Hanging (hsExpr ctx lastArg) + <> attach Hanging lastArgDoc where (func, args) = gatherArgs f (x :| []) initArgs = NE.init args lastArg = NE.last args + lastArgDoc = hsExprIn ctx (withBracing (siteBracing site) plainSite) lastArg initSpan = spanOf f <> (startOf <$> spanOf lastArg) placement | maybe False (writtenOnOneLine ctx) initSpan = exprHangs (unLoc lastArg) @@ -253,9 +280,9 @@ tuple :: Ctx -> Maybe Span -> ClosingIndent -> Boxity -> [HsTupArg GhcPs] -> Doc tuple ctx here closing boxity args | any isMissing args = flat (brackets' (sepBy comma (fmap arg args))) - | otherwise = brackets' (insideBrackets here (commaSep (fmap arg args))) + | otherwise = brackets' (commaSep (fmap arg args)) where - brackets' = boxityBrackets boxity closing + brackets' = boxityBrackets boxity closing . insideBrackets here isMissing = \case Missing _ -> True _ -> False @@ -460,7 +487,7 @@ (fmap endOf (spanOf p) <> spanOf f) (attach placement (printBody bound)) where - bound = mkBody plainSite f + bound = bodyIn mkBody (siteBracing site) f placement | sameLine (spanOf p) (spanOf f) = bodyPlacement bound | otherwise = Normal @@ -695,7 +722,10 @@ at_ ctx (either (valDecl ctx b) (knotSig (ctxKnot ctx) ctx)) item HsValBinds _ _ -> error "Tilia: renamer-only local bindings" HsIPBinds ann (IPBinds _ xs) -> - anchored ann (items bracing (fmap (at_ ctx implicitBind) xs)) + anchored ann . items bracing $ + keepBlanks + (separatedByBlank ctx) + [(spanOf x, at ctx x implicitBind) | x <- xs] EmptyLocalBinds _ -> mempty where implicitBind (IPBind _ (L _ n) e) = @@ -741,7 +771,8 @@ <> breakOrSpace <> indent ( txt (arrowText arrow rightToLeft) - <> attach (exprHangs (unLoc input)) (hsExpr ctx writtenSecond) + <> attachBody + (bodyIn (ExprBody ctx) (siteBracing site) writtenSecond) ) HsCmdArrForm _ form Prefix cmds -> bananaWith (closingFor site) $ @@ -761,9 +792,9 @@ HsCmdApp _ cmd e -> hsCmd ctx site{siteApplicand = True} cmd <> breakOrSpace - <> indent (hsExpr ctx e) + <> indent (hsExprIn ctx (withBracing (siteBracing site) plainSite) e) HsCmdLam _ variant' mg -> lambda ctx site variant' (CmdBody ctx) mg - HsCmdPar _ c -> parens (hsCmd ctx plainSite c) + HsCmdPar _ c -> parensWith (closingFor site) (hsCmd ctx plainSite c) HsCmdCase anns e mg -> caseOf ctx site (CmdBody ctx) anns e mg HsCmdIf anns _ c t e -> ifThenElse ctx (bodyIn (CmdBody ctx) (siteBracing site)) anns c t e @@ -962,12 +993,16 @@ rendered = fmap (hsPat ctx) pats lambdaGap p = includeWhen (needsGap (unLoc p)) space - needsGap = \case + needsGap p = case p of LazyPat{} -> True BangPat{} -> True SplicePat{} -> True InvisPat{} -> True + NPat{} -> negative + LitPat{} -> negative _ -> False + where + negative = T.isPrefixOf "-" (showGhc p) endOfPats = case pats of [] -> case style of @@ -1067,9 +1102,13 @@ _ -> maybe id located (spanOf lgrhs) . layoutFrom ctx (grhsSpan grhs) $ fenceWithin ctx headSpan guardHead - <> nest - (if parentPlacement == Normal then 1 else 0) - (attach placement (printBody bound)) + <> fenceWithin + ctx + (fmap endOf separatorSpan <> spanOf body) + ( nest + (if parentPlacement == Normal then 1 else 0) + (attach placement (printBody bound)) + ) where GRHS EpAnn{anns = GrhsAnn{ga_vbar, ga_sep}} guards body = grhs guardHead = @@ -1176,48 +1215,51 @@ -- | A Template Haskell quotation. quotation :: Ctx -> Maybe Span -> HsQuote GhcPs -> Doc quotation ctx here = \case - ExpBr (bracketAnn, _) e -> quotedAs (flavour bracketAnn) (hsExpr ctx e) + ExpBr (bracketAnn, _) e -> quotedAs (flavour bracketAnn) e (hsExpr ctx e) where flavour = \case BracketNoE{} -> "" BracketHasE{} -> "e" - PatBr _ p -> quotedAs "p" (hsPat ctx p) - DecBrL _ decls -> - quotedAs "d" (starGuard decls (knotDecls (ctxKnot ctx) ctx decls)) + PatBr _ p -> quotedAs "p" p (hsPat ctx p) + DecBrL _ decls -> quotedAs "d" decls (knotDecls (ctxKnot ctx) ctx decls) DecBrG _ _ -> error "Tilia: DecBrG is produced by the renamer" - TypBr _ ty -> quotedAs "t" (starGuard ty (hsType ctx ty)) + TypBr _ ty -> quotedAs "t" ty (hsType ctx ty) VarBr _ isSingle n -> txt (if isSingle then "'" else "''") <> name ctx n where + quotedAs :: (Data a) => Text -> a -> Doc -> Doc quotedAs flavour = quoted here ("[" <> flavour <> "|") "|]" - starGuard x body - | risky = space <> body <> space - | otherwise = body - where - risky = - any isStar (listify (const True :: HsType GhcPs -> Bool) x) - || any isAbstract (listify (const True :: FamilyInfo GhcPs -> Bool) x) - isStar = \case - HsStarTy{} -> True - _ -> False - isAbstract = \case - ClosedTypeFamily Nothing -> True - _ -> False --- | The body of a quotation between its brackets, indented where it breaks. +-- | The body of a quotation between its brackets, indented where it breaks, +-- and spaced from them where it may end with a symbol character. quoted :: + (Data a) => -- | Where the quotation is written. Maybe Span -> -- | The opening bracket. Text -> -- | The closing bracket. Text -> + -- | What is quoted. + a -> -- | The body. Doc -> Doc -quoted here opener closer body = +quoted here opener closer x body = txt opener - <> breakOrNothing - <> indent (insideBrackets here body <> breakOrNothing <> txt closer) + <> gap + <> indent (insideBrackets here body <> gap <> txt closer) + where + gap = if risky then breakOrSpace else breakOrNothing + risky = + any isStar (listify (const True :: HsType GhcPs -> Bool) x) + || any isAbstract (listify (const True :: FamilyInfo GhcPs -> Bool) x) + || not (null (listify (const True :: FixitySig GhcPs -> Bool) x)) + isStar = \case + HsStarTy{} -> True + _ -> False + isAbstract = \case + ClosedTypeFamily Nothing -> True + _ -> False -- | An item of a block: the last one keeps the block's bracing, and any -- other may brace itself when the block is flat. @@ -1288,6 +1330,19 @@ exprHangs (unLoc y) | otherwise -> exprHangs (unLoc x) _ -> Normal + +-- | Does this expression end with a layout block, which takes in what is +-- printed after it on its last line? +endsWithBlock :: HsExpr GhcPs -> Bool +endsWithBlock = \case + HsDo _ (DoExpr _) _ -> True + HsDo _ (MDoExpr _) _ -> True + HsCase{} -> True + HsLam _ LamCase _ -> True + HsLam _ LamCases _ -> True + HsApp _ _ y -> endsWithBlock (unLoc y) + OpApp _ _ _ y -> endsWithBlock (unLoc y) + _ -> False -- | Does this command absorb the line break that introduces it? cmdHangs :: HsCmd GhcPs -> Placement 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 @@ -19,15 +19,18 @@ import Data.Generics.Schemes (listify) import Data.List (dropWhileEnd) import Data.List.NonEmpty qualified as NE -import Data.Maybe (fromMaybe, mapMaybe) +import Data.Maybe (fromMaybe, isJust, mapMaybe) import Data.Text (Text) import Data.Text qualified as T import GHC.Hs +import GHC.LanguageExtensions.Type (Extension (Cpp)) import GHC.Types.SrcLoc (GenLocated (..), getLoc, unLoc) import Tilia.Comments (Comment (..), afterOpener, bracketed, singleLine, triggerOn) +import Tilia.Comments.Attach (Margin (..), commentText) import Tilia.Doc.Combinators import Tilia.Gathered (Gathered (..)) import Tilia.Render.Context +import Tilia.Source (directiveOnLine) import Tilia.Span import Tilia.Span.Ghc @@ -75,9 +78,7 @@ docBody ctx style doc@(L l str) = case reusableText ctx style doc of Just c -> - ( maybe id located (spanOfSrcSpan l) - $ align - $ verbatimLines AtIndent TrimWhitespace (NE.toList (commentBody c)), + ( maybe id located (spanOfSrcSpan l) (commentText margin c), selfClosing c ) Nothing @@ -85,6 +86,8 @@ | blockForm -> (writtenAt rebuiltBlock, False) | otherwise -> (writtenAt rebuilt, False) where + margin = Margin directive (const False) + directive t = extensionOn ctx Cpp && isJust (directiveOnLine t) writtenAt = fenceWithin ctx (spanOfSrcSpan l) emptyBlock = txt (blockOpener style) <> space <> txt "-}" rebuilt = @@ -94,10 +97,10 @@ Nothing -> 0 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 "--") - <> space - <> txt t + line' isFirst t + | isFirst = txt (opener style) <> space <> txt t + | "$" `T.isPrefixOf` t = txt "--" <> txt t + | otherwise = txt "--" <> space <> txt t rebuiltBlock = align $ txt (blockOpener style) @@ -221,7 +224,7 @@ [Text] docLines blockForm str | null body = [] - | otherwise = fmap guardDollar (dedent (fmap unpad body)) + | otherwise = dedent (fmap unpad body) where body = dropWhileEnd T.null @@ -244,6 +247,3 @@ [] -> 0 ns -> minimum ns indentation = T.length . T.takeWhile (== ' ') - guardDollar t - | "$" `T.isPrefixOf` t = T.cons '\\' t - | otherwise = t 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 @@ -32,6 +32,7 @@ import Tilia.Render.Declaration (decls) import Tilia.Render.Haddock import Tilia.Render.Layout +import Tilia.Render.Literal (writtenString) import Tilia.Render.Name import Tilia.Render.Pragma (warningTxt) import Tilia.Source (Source, directivePresentOnLine, sourceLines) @@ -118,20 +119,22 @@ "OPTIONS_HADDOCK" -> Just OptionsHaddockOrder _ -> Nothing --- | Take the Stack script header off the front of a comment stream. +-- | Take the Stack script header off the front of a comment stream: the +-- comment whose first word is @stack@ at the margin of the first line, or +-- of the line under the @#!@ line, which Stack reads its options from. takeStackHeader :: - -- | Where the header ends. - Maybe Span -> + -- | The lines above the module that the parser never sees. + [Text] -> -- | The comment stream. [Comment] -> (Doc, [Comment]) -takeStackHeader headerEnd = \case +takeStackHeader prologue = \case (c : cs) | isStackHeader c -> (reproduce c <> blankLine, cs) cs -> (mempty, cs) where isStackHeader c = - writtenInHeader headerEnd (commentSpan c) - && T.isPrefixOf "stack" (T.stripStart (T.drop 2 (NE.head (commentBody c)))) + startPoint (commentSpan c) == (if null prologue then 1 else 2, 1) + && take 1 (T.words (T.drop 2 (NE.head (commentBody c)))) == ["stack"] reproduce c = verbatimLines AtMargin TrimWhitespace (NE.toList (commentBody c)) @@ -161,7 +164,8 @@ key p = (hpRun p, orderOf p, hpBody p) orderOf p = pragmaOrder (hpName p) (hpBody p) dedupe = fmap NE.head . NE.groupBy repeated - repeated a b = hpName a == "LANGUAGE" && key a == key b + repeated a b = + hpName a == "LANGUAGE" && isNothing (hpWritten b) && key a == key b split p | hpName p == "LANGUAGE", isNothing (hpWritten p) = @@ -173,7 +177,10 @@ render p = located (hpSpan p) (written p) <> hardBreak written p = case hpWritten p of Nothing -> - txt "{-# " <> txt (hpName p) <> space <> txt (hpBody p) <> txt " #-}" + txt "{-# " + <> txt (hpName p) + <> includeUnless (T.null (hpBody 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 @@ -320,7 +327,9 @@ let (before, after) = splitAt n' rendered in before <> [keywordAt ctx (spanOf dots) ".."] <> after IEModuleContents (warning, _) m -> - exportWarning warning <> at ctx m (moduleHeadName ctx) <> comma' + exportWarning warning + <> at ctx m (\n -> txt "module" <> space <> outputable n) + <> comma' 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 @@ -395,7 +404,7 @@ isQualified = isImportDeclQualified ideclQualified packageQualifier = case ideclPkgQual of NoRawPkgQual -> mempty - RawPkgQual literal -> outputable literal + RawPkgQual literal -> writtenString literal levelBefore = case ideclLevelSpec of LevelStylePre l -> declLevel l _ -> mempty @@ -411,7 +420,10 @@ in layoutWithin ctx listSpan parensSpan $ hidden <> breakOrSpace - <> parens (insideBrackets listSpan (importExportItems ctx xs)) + <> fenceWithin + ctx + parensSpan + (parens (insideBrackets listSpan (importExportItems ctx xs))) -- | The keyword an import's level is written with. declLevel :: ImportDeclLevel -> Doc 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 @@ -37,28 +37,28 @@ -- | A pattern whose outermost bracket closes where it is told to. hsPatClosing :: Ctx -> ClosingIndent -> LPat GhcPs -> Doc -hsPatClosing ctx = hsPatIn ctx (Isn't #inAsPat) +hsPatClosing ctx = hsPatIn ctx (Isn't #inParens) -- | A pattern that knows where it stands. hsPatIn :: -- | The context. Ctx -> - -- | Is this inside an as-pattern? - Choice "inAsPat" -> + -- | Is this inside parentheses? + Choice "inParens" -> -- | Where its outermost bracket closes. ClosingIndent -> -- | The pattern. LPat GhcPs -> Doc -hsPatIn ctx inAsPat closing l = - at ctx l (patBody ctx inAsPat closing (spanOf l)) +hsPatIn ctx inParens closing l = + at ctx l (patBody ctx inParens closing (spanOf l)) -- | Every shape a pattern can take. patBody :: -- | The context. Ctx -> - -- | Is this inside an as-pattern? - Choice "inAsPat" -> + -- | Is this inside parentheses? + Choice "inParens" -> -- | Where its outermost bracket closes. ClosingIndent -> -- | Where the pattern was written. @@ -66,13 +66,15 @@ -- | The pattern. Pat GhcPs -> Doc -patBody ctx inAsPat closing here = \case +patBody ctx inParens closing here = \case WildPat _ -> txt "_" VarPat _ n -> name ctx n LazyPat _ p -> txt "~" <> recur p - AsPat _ n p -> - name ctx n <> txt "@" <> hsPatIn ctx (Is #inAsPat) Indented p - ParPat _ p -> parensWith closing (insideBrackets here (recur p)) + AsPat _ n p -> name ctx n <> txt "@" <> recur p + ParPat _ p -> + parensWith + closing + (insideBrackets here (hsPatIn ctx (Is #inParens) Indented p)) BangPat _ p -> txt "!" <> recur p ListPat _ ps -> bracketsWith closing (insideBrackets here (commaSep (fmap recur ps))) @@ -82,9 +84,9 @@ closing (insideBrackets here (commaSep (fmap (align . recur) ps))) OrPat _ ps -> - itemsSepBy (fromBool (isTrue inAsPat)) NoBrace (fmap recur (NE.toList ps)) + itemsSepBy (fromBool (isTrue inParens)) NoBrace (fmap recur (NE.toList ps)) SumPat _ p tag arity -> unboxedSum closing tag arity (recur p) - ConPat _ con details -> conPattern ctx inAsPat here con details + ConPat _ con details -> conPattern ctx inParens here con details ViewPat _ e p -> align $ knotExpr (ctxKnot ctx) ctx plainSite e @@ -105,14 +107,14 @@ EmbTyPat _ (HsTP _ ty) -> txt "type" <> space <> hsType ctx ty InvisPat _ (HsTP _ ty) -> txt "@" <> hsType ctx ty where - recur = hsPatIn ctx inAsPat Indented + recur = hsPatIn ctx inParens Indented -- | A constructor pattern, in whichever of its three forms. conPattern :: -- | The context. Ctx -> - -- | Is this inside an as-pattern? - Choice "inAsPat" -> + -- | Is this inside parentheses? + Choice "inParens" -> -- | Where the pattern was written. Maybe Span -> -- | The constructor. @@ -120,7 +122,7 @@ -- | What it was applied to. HsConPatDetails GhcPs -> Doc -conPattern ctx inAsPat here con = \case +conPattern ctx inParens here con = \case PrefixCon args -> align $ name ctx con @@ -135,7 +137,7 @@ recur l <> attachOperator Normal (spanOf l) (spanOf con) (spanOf r) (name ctx con) (recur r) where - recur = hsPatIn ctx inAsPat Indented + recur = hsPatIn ctx inParens Indented field = either wildcard (at_ ctx (patFieldBind ctx)) wildcard l = at ctx l (const (txt "..")) visibleFields dotdot fields = case dotdot of 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 @@ -9,6 +9,7 @@ pragma, activation, inlineSpec, + spelledAsWritten, overlapMode, warnDecls, warningTxt, @@ -18,6 +19,7 @@ import Data.Char (toUpper) import Data.List (isInfixOf) import Data.Text (Text) +import Data.Text qualified as T import GHC.Data.FastString (unpackFS) import GHC.Hs import GHC.Types.Basic hiding (overlapMode) @@ -26,7 +28,7 @@ import GHC.Unit.Module.Warnings import Tilia.Doc.Combinators import Tilia.Render.Context -import Tilia.Render.Literal (writtenString) +import Tilia.Render.Literal (stringLiteral, writtenString) import Tilia.Render.Name -- | Wrap a body in pragma braces. @@ -48,15 +50,23 @@ ActiveAfter _ n -> txt "[" <> outputable n <> txt "]" FinalActive -> error "Tilia: FinalActive is not expected in parsed source" --- | Which flavour of inlining was asked for. +-- | Which flavour of inlining was asked for, @INLINABLE@ spelled as written. inlineSpec :: InlineSpec -> Doc inlineSpec = \case Inline _ -> txt "INLINE" - Inlinable _ -> txt "INLINEABLE" + Inlinable src -> txt (spelledAsWritten "INLINABLE" "INLINEABLE" src) NoInline _ -> txt "NOINLINE" Opaque _ -> txt "OPAQUE" NoUserInlinePrag -> mempty +-- | Whichever of two spellings of a pragma's name its source text uses, the +-- first where it has none. +spelledAsWritten :: Text -> Text -> SourceText -> Text +spelledAsWritten usual other = \case + SourceText s + | T.unpack other `isInfixOf` fmap toUpper (unpackFS s) -> other + _ -> usual + -- | The overlap pragma of an instance. overlapMode :: Ctx -> Maybe (LocatedP OverlapMode) -> Maybe Doc overlapMode ctx mode = do @@ -117,7 +127,9 @@ where said = fmap (fmap hsDocString) named (unLoc -> InWarningCategory{..}) = - txt ("in \"" <> showGhc (unLoc iwc_wc) <> "\"") <> space + txt "in" <> space <> written iwc_st iwc_wc <> space + written (SourceText s) _ = stringLiteral s + written NoSourceText wc = txt ("\"" <> showGhc (unLoc wc) <> "\"") -- | One message is written bare; several go in a list. literalList :: [LocatedE StringLiteral] -> Doc 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 @@ -50,8 +50,10 @@ SpecSig _ n types prag -> specialiseSig ctx Nothing (noLocA (HsVar NoExtField n)) types prag SpecSigE _ binders e prag -> specialiseSigE ctx binders e prag - SpecInstSig _ sigType -> - pragma "SPECIALIZE instance" (indent (hsSigType ctx sigType)) + SpecInstSig (_, src) sigType -> + pragma + (spelledAsWritten "SPECIALIZE" "SPECIALISE" src <> " instance") + (indent (hsSigType ctx sigType)) MinimalSig _ formula -> at ctx formula (pragma "MINIMAL" . indent . booleanFormula ctx) CompleteMatchSig _ names ty -> completeSig ctx names ty @@ -134,7 +136,7 @@ ConLike -> txt "CONLIKE" FunLike -> mempty --- | A @SPECIALIZE@ pragma. +-- | A @SPECIALIZE@ pragma, spelled as written. specialiseSig :: Ctx -> Maybe (RuleBndrs GhcPs) -> @@ -144,7 +146,7 @@ Doc specialiseSig ctx binders target types InlinePragma{..} = pragmaBrackets $ - txt "SPECIALIZE" + txt (spelledAsWritten "SPECIALIZE" "SPECIALISE" inl_src) <> space <> inlineSpec inl_inline <> space 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 @@ -33,20 +33,23 @@ import Data.Choice (Choice, fromBool, isTrue) import Data.List.NonEmpty (NonEmpty (..)) +import Data.Set qualified as Set import Data.Text qualified as T import GHC.Hs -import GHC.Types.Name.Occurrence (isTvOcc) -import GHC.Types.Name.Reader (RdrName, rdrNameOcc) +import GHC.LanguageExtensions.Type (Extension (Cpp)) +import GHC.Types.Name.Occurrence (isTvOcc, occNameString) +import GHC.Types.Name.Reader (RdrName, isUnqual, rdrNameOcc) import GHC.Types.SourceText import GHC.Types.SrcLoc (GenLocated (..), getLoc, unLoc) import GHC.Types.Var (Specificity (..)) import Tilia.Doc.Combinators -import Tilia.Fixity (Namespace (..)) +import Tilia.Fixity (typeOperatorNamespace) import Tilia.Render.Context import Tilia.Render.Haddock import Tilia.Render.Literal (stringLiteral) import Tilia.Render.Name import Tilia.Render.Operator +import Tilia.Source (definedMacros, sourceLines) import Tilia.Span import Tilia.Span.Ghc @@ -97,7 +100,9 @@ <> space <> txt "->" <> betweenArgs - <> case unLoc y of + <> fenceWithin ctx (fmap endOf (arrowSpan multAnn) <> spanOf y) result + where + result = case unLoc y of HsFunTy{} -> recur (unLoc y) _ -> at ctx y recur HsListTy _ t -> @@ -153,7 +158,7 @@ split t = case unLoc t of HsOpTy _ _ l o r -> Just (l, o, r) _ -> Nothing - fixity o = operatorFixity ctx InTypes (unLoc o) + fixity o = operatorFixity ctx (typeOperatorNamespace (unLoc o)) (unLoc o) -- | Print a chain of type operators once precedence has regrouped it. renderChain :: Ctx -> OpChain (LHsType GhcPs) (LocatedN RdrName) -> Doc @@ -264,11 +269,21 @@ -- | A class context, as it appears before a @=>@. context :: Ctx -> LHsContext GhcPs -> Doc -context ctx = at_ ctx (contextOf loneVariable (hsType ctx) . fmap unbracket) +context ctx = at_ ctx (contextOf bare (hsType ctx) . fmap unbracket) where - loneVariable t = case unLoc t of - HsTyVar _ _ (L _ n) -> isTvOcc (rdrNameOcc n) + bare t = case unLoc t of + HsTyVar _ _ (L _ n) | isTvOcc (rdrNameOcc n) -> True + _ -> headedByMacro t + headedByMacro t = case unLoc t of + HsTyVar _ _ (L _ n) -> macro n + HsAppTy _ f _ -> headedByMacro f _ -> False + macro n = + extensionOn ctx Cpp + && isUnqual n + && Set.member + (T.pack (occNameString (rdrNameOcc n))) + (definedMacros (sourceLines (ctxSource ctx))) unbracket t = case unLoc t of HsParTy _ inner -> unbracket inner _ -> t @@ -280,16 +295,16 @@ -- | A context over anything that can stand as a constraint. contextOf :: - -- | Is this constraint nothing but a variable? + -- | Can this constraint, when it is the only one, go without parentheses? (a -> Bool) -> -- | How to print one. (a -> Doc) -> -- | The constraints. [a] -> Doc -contextOf lone render = \case +contextOf bare render = \case [] -> txt "()" - [x] | lone x -> render x + [x] | bare x -> render x xs -> parens (commaSep (fmap (align . render) xs)) -- | The flags a type variable binder may carry. @@ -363,6 +378,18 @@ close = case visibility of Invisible -> txt "." Visible -> space <> txt "->" + +-- | Where the arrow of a function type is written. +arrowSpan :: HsMultAnnOf mult GhcPs -> Maybe Span +arrowSpan = \case + HsUnannotated a -> arrow a + HsLinearAnn (EpPct1 _ a) -> arrow a + HsLinearAnn (EpLolly t) -> spanOf t + HsExplicitMult (_, a) _ -> arrow a + where + arrow = \case + EpArrow t -> spanOf t + _ -> Nothing -- | The @forall@ that opens a type. forallTelescope :: Ctx -> HsForAllTelescope GhcPs -> Doc diff --git a/src/Tilia/Run.hs b/src/Tilia/Run.hs --- a/src/Tilia/Run.hs +++ b/src/Tilia/Run.hs @@ -26,7 +26,6 @@ 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) @@ -34,7 +33,7 @@ import System.FilePath (takeExtension) import Tilia.Diff (diffInFull) import Tilia.Format - ( FormatError (Threw, Unreadable), + ( FormatError (Threw, Unreadable, Unwritable), Session, describeFormatError, formatErrorExitCode, @@ -49,6 +48,7 @@ byteOrderMark, inParallel, indent, + readBytes, tshow, wrappedUnder, writeUtf8File, @@ -136,7 +136,7 @@ -- | Read a source file as UTF-8. readAsUtf8 :: FilePath -> IO (Either Text Text) readAsUtf8 path = - attempted (BS.readFile path) >>= \case + readBytes path >>= \case Left why -> pure (Left why) Right bytes -> pure (asUtf8 bytes) @@ -153,11 +153,14 @@ where after = setNewlineStyle (getNewlineStyle before) formatted --- | Put a formatted file back, and only if it changed. -writeBack :: (FilePath, Outcome) -> IO () +-- | Put a formatted file back, and only if it changed, counting it as failed +-- where it cannot be written. +writeBack :: (FilePath, Outcome) -> IO (FilePath, Outcome) writeBack (path, outcome) = case outcome of - Changed _ after -> writeUtf8File path after - _ -> pure () + Changed _ after -> + (path,) . either (Failed . Unwritable path) (const outcome) + <$> attempted (writeUtf8File path after) + _ -> pure (path, outcome) ---------------------------------------------------------------------------- -- Report @@ -172,30 +175,46 @@ deriving (Eq, Show) -- | The summary an @inplace@ run prints. -inplaceReport :: Palette -> [(FilePath, Outcome)] -> Report -inplaceReport palette outcomes = +inplaceReport :: + -- | The palette of standard output. + Palette -> + -- | The palette of standard error. + Palette -> + -- | Every file of the run, and what became of it. + [(FilePath, Outcome)] -> Report - { reportOut = T.unlines (tally palette ("✓", Good) "Formatted" (not . skipped) outcomes), - reportErr = asides palette outcomes +inplaceReport out err outcomes = + Report + { reportOut = + T.unlines (tally out ("✓", Good) "Formatted" (not . skipped) outcomes), + reportErr = asides err outcomes } where skipped o = declined o || failed o -- | The diffs a @check@ run prints, and what it could not or would not do. -checkReport :: Palette -> [(FilePath, Outcome)] -> Report -checkReport palette outcomes = +checkReport :: + -- | The palette of standard output. + Palette -> + -- | The palette of standard error. + Palette -> + -- | Every file of the run, and what became of it. + [(FilePath, Outcome)] -> Report +checkReport out err outcomes = + Report { reportOut = T.unlines - [ diffInFull palette path before after + [ diffInFull out path before after | (path, Changed before after) <- outcomes ], - reportErr = asides palette outcomes + reportErr = asides err outcomes } -- | The module a @for-editor@ run prints, formatted or as it was read where -- it was declined, and why it was not formatted. stdinReport :: + -- | The palette of standard error. Palette -> -- | The module as it was read. Text -> diff --git a/src/Tilia/Source.hs b/src/Tilia/Source.hs --- a/src/Tilia/Source.hs +++ b/src/Tilia/Source.hs @@ -18,6 +18,7 @@ offsetOf, directivePresentOnLine, directiveOnLine, + definedMacros, -- * Its comments comments, 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 @@ -17,6 +17,7 @@ contentColumn, directivePresentOnLine, directiveOnLine, + definedMacros, conditionalKeywords, opensGroup, continuesGroup, @@ -30,8 +31,11 @@ import Data.IntSet (IntSet) import Data.IntSet qualified as IntSet import Data.Maybe (isJust) +import Data.Set (Set) +import Data.Set qualified as Set import Data.Text (Text) import Data.Text qualified as T +import Tilia.Cpp.Macros (isNameChar) -- | The text of a module as its author wrote it. -- @@ -46,7 +50,10 @@ { -- | Every line of the module as written. lnWritten :: !(IntMap Text), -- | The ones this configuration does not contain. - lnDropped :: !IntSet + lnDropped :: !IntSet, + -- | The names the module defines with @#define@, in whichever + -- configuration. + lnMacros :: Set Text } -- | Read the lines of a module, every one of which it has. @@ -54,7 +61,13 @@ linesOf (Written text) = Lines { lnWritten = IntMap.fromList (zip [1 ..] (T.lines text)), - lnDropped = IntSet.empty + lnDropped = IntSet.empty, + lnMacros = + Set.fromList + [ T.takeWhile isNameChar (T.stripStart rest) + | Just ("define", body) <- fmap directiveOnLine (T.lines text), + Just rest <- [T.stripPrefix "define" body] + ] } -- | Drop the given ranges from the 'Lines'. @@ -93,12 +106,11 @@ -- 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) +offsetOf line column = T.foldr walk (\i !_ -> i) line 0 1 where - walk i c - | c >= column = i - | i >= T.length line = i + (column - c) - | otherwise = walk (i + 1) (afterChar (T.index line i) c) + walk ch next i c + | c < column = next (i + 1) (afterChar ch c) + | otherwise = i -- | The compiler's column for the character at this offset. columnOf :: Text -> Int -> Int @@ -119,9 +131,17 @@ directivePresentOnLine :: Int -> Lines -> Bool directivePresentOnLine n ls = isJust (directiveOnLine =<< lineAt n ls) +-- | The names the module defines with @#define@, in whichever configuration. +definedMacros :: Lines -> Set Text +definedMacros = lnMacros + -- | The keyword a directive line opens with, and everything after its @#@. +-- +-- The @#@ is the first character of the line: cpp, in the traditional mode +-- GHC runs it in, passes a line indented further on to GHC, which may read +-- an OverloadedLabels label there. directiveOnLine :: Text -> Maybe (Text, Text) -directiveOnLine l = case T.uncons (T.stripStart l) of +directiveOnLine l = case T.uncons l of Just ('#', rest) | keyword `elem` directiveKeywords -> Just (keyword, body) where diff --git a/src/Tilia/Utils.hs b/src/Tilia/Utils.hs --- a/src/Tilia/Utils.hs +++ b/src/Tilia/Utils.hs @@ -5,6 +5,7 @@ module Tilia.Utils ( quietly, attempted, + readBytes, readUtf8File, writeUtf8File, fieldWords, @@ -42,6 +43,7 @@ displayException, fromException, throwIO, + try, ) import Control.Monad (replicateM, (>=>)) import Crypto.Hash.SHA256 qualified as SHA256 @@ -57,6 +59,7 @@ import Data.Text.Encoding qualified as T import System.Directory (doesFileExist) import System.FilePath (equalFilePath, normalise, splitDirectories) +import System.IO.Error (ioeGetErrorString) -- | 'show' a value and take the result as 'Text'. tshow :: (Show a) => a -> Text @@ -75,6 +78,12 @@ if there then Just . T.decodeUtf8Lenient <$> BS.readFile path else pure Nothing + +-- | Read a file's bytes, or say why they could not be read without naming +-- the file, which whoever reports it names already. +readBytes :: FilePath -> IO (Either Text BS.ByteString) +readBytes path = + either (Left . T.pack . ioeGetErrorString) Right <$> try (BS.readFile path) -- | Write a file as UTF-8. writeUtf8File :: FilePath -> Text -> IO () 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 @@ -18,20 +18,26 @@ ( PackageProblem (..), newPackageReader, parsePackageDescription, + readPackageDescription, ) 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" $ + describe "a .cabal file" $ do 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 + it "is said to be unreadable without being named again" $ + withSystemTempDirectory "tilia-gone" $ \root -> do + let cabalFile = root "t.cabal" + fmap (const ()) <$> readPackageDescription cabalFile + `shouldReturn` Left (PackageUnreadable cabalFile "does not exist") + describe "the component a file belongs to" $ do it "is the one whose source directory holds it" $ inPackage twoComponents ["src", "test"] $ \root -> do @@ -73,6 +79,13 @@ driver <- asked (root "tests" "Doctests.hs") (has BangPatterns unit, has BangPatterns driver) `shouldBe` (True, False) + it "is a foreign library where its source directory holds the file" $ + inPackage withForeignLibrary ["src", "flib"] $ \root -> do + library <- asked (root "src" "M.hs") + flib <- asked (root "flib" "F.hs") + (has OverloadedStrings library, has OverloadedStrings flib) + `shouldBe` (False, True) + it "inherits settings in conditional source directories" $ inPackage conditionalLibrary ["src", "new"] $ \root -> (has BangPatterns <$> asked (root "new" "M.hs")) @@ -241,6 +254,27 @@ " default-extensions: OverloadedStrings" ] +-- | A library, and a foreign library with settings of its own. +withForeignLibrary :: Text +withForeignLibrary = + T.unlines + [ "cabal-version: 2.4", + "name: demo", + "version: 0", + "", + "library", + " exposed-modules: M", + " hs-source-dirs: src", + " default-language: Haskell2010", + "", + "foreign-library demo", + " type: native-shared", + " other-modules: F", + " hs-source-dirs: flib", + " default-language: Haskell2010", + " default-extensions: OverloadedStrings" + ] + -- | A library that names no @hs-source-dirs@, so its modules sit beside the -- @.cabal@ file. besideTheCabalFile :: Text @@ -425,8 +459,7 @@ -- | Write a @.cabal@ file and the given directories, and hand back the root. inPackage :: Text -> [FilePath] -> (FilePath -> IO a) -> IO a inPackage contents dirs use = - withSystemTempDirectory "tilia-package" $ \root -> do - writeUtf8File (root "demo.cabal") contents + withFiles [("demo.cabal", contents)] $ \root -> do mapM_ (createDirectoryIfMissing True . (root )) (sort dirs) use root 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,7 +7,7 @@ import Data.List (isSuffixOf, sort) import Data.Text (Text) import Data.Text qualified as T -import System.FilePath (takeFileName, ()) +import System.FilePath (isPathSeparator, takeFileName, ()) import Test.Hspec import Tilia.Cabal.Plan (PlanComponent (..)) import Tilia.Cabal.Project (Marker (..), ProjectRoot (..), findProjectRoot) @@ -26,12 +26,19 @@ it "takes each kind of component" $ do parseTarget "lib:tilia" `shouldBe` Right (Qualified Nothing Lib "tilia") + parseTarget "flib:tilia" `shouldBe` Right (Qualified Nothing FLib "tilia") parseTarget "exe:tilia" `shouldBe` Right (Qualified Nothing Exe "tilia") parseTarget "test:tests" `shouldBe` Right (Qualified Nothing Test "tests") parseTarget "bench:speed" `shouldBe` Right (Qualified Nothing Bench "speed") - it "takes benchmark as a spelling of bench" $ + it "takes every spelling of a kind cabal takes, in any case" $ do + parseTarget "library:tilia" `shouldBe` Right (Qualified Nothing Lib "tilia") + parseTarget "foreign-library:tilia" `shouldBe` Right (Qualified Nothing FLib "tilia") + parseTarget "executable:tilia" `shouldBe` Right (Qualified Nothing Exe "tilia") + parseTarget "tst:tests" `shouldBe` Right (Qualified Nothing Test "tests") + parseTarget "test-suite:tests" `shouldBe` Right (Qualified Nothing Test "tests") parseTarget "benchmark:speed" `shouldBe` Right (Qualified Nothing Bench "speed") + parseTarget "LIB:tilia" `shouldBe` Right (Qualified Nothing Lib "tilia") it "takes a package in front of the kind" $ parseTarget "tilia:lib:tilia" `shouldBe` Right (Qualified (Just "tilia") Lib "tilia") @@ -43,13 +50,13 @@ parseTarget "" `shouldSatisfy` failed it "refuses a kind it does not know" $ - parseTarget "flib:thing" `shouldSatisfy` failed + parseTarget "doc:thing" `shouldSatisfy` failed it "refuses more colons than it can account for" $ parseTarget "a:lib:b:c" `shouldSatisfy` failed it "says what it would have accepted" $ - case parseTarget "flib:thing" of + case parseTarget "doc:thing" of Left why -> why `shouldSatisfy` T.isInfixOf "lib:" Right _ -> expectationFailure "should not have parsed" @@ -143,15 +150,16 @@ files <- filesOfComponents project cs fmap takeFileName files `shouldBe` ["L.hs"] - it "reads a package an absolute entry names" + it "reads a package an absolute entry names with forward slashes" $ withProject [ ("proj/cabal.project", ""), ("lib/lib.cabal", package "lib" "src") ] $ \root -> do + let entry = T.map forward (T.pack (prPath root "lib")) writeUtf8File (prPath root "proj" "cabal.project") - ("packages: " <> T.pack (prPath root "lib") <> "\n") + ("packages: " <> entry <> "\n") componentsOfTarget (ProjectRoot (prPath root "proj") ProjectFile) Everything >>= \case Left problem -> expectationFailure (T.unpack (describeTargetProblem problem)) @@ -178,6 +186,32 @@ Left problem -> expectationFailure (T.unpack (describeTargetProblem problem)) Right cs -> sort (fmap componentPackage cs) `shouldBe` ["one", "two"] + it "expands a component with more than one star in it" + $ withProject + [ ("cabal.project", "packages: pkgs/*-*\n"), + ("pkgs/one-a/one.cabal", package "one" "src"), + ("pkgs/two-b/two.cabal", package "two" "src"), + ("pkgs/three/three.cabal", package "three" "src") + ] + $ \root -> + componentsOfTarget root Everything >>= \case + Left problem -> expectationFailure (T.unpack (describeTargetProblem problem)) + Right cs -> sort (fmap componentPackage cs) `shouldBe` ["one", "two"] + + it "expands a double star to any depth, none included" + $ withProject + [ ("cabal.project", "packages: pkgs/**/*.cabal\n"), + ("pkgs/one.cabal", package "one" "src"), + ("pkgs/a/two.cabal", package "two" "src"), + ("pkgs/a/b/three.cabal", package "three" "src"), + ("other/four.cabal", package "four" "src") + ] + $ \root -> + componentsOfTarget root Everything >>= \case + Left problem -> expectationFailure (T.unpack (describeTargetProblem problem)) + Right cs -> + sort (fmap componentPackage cs) `shouldBe` ["one", "three", "two"] + it "passes over a package a comment has taken out" $ withProject [ ("cabal.project", "packages:\n one\n -- two\n"), @@ -221,6 +255,32 @@ Left problem -> expectationFailure (T.unpack (describeTargetProblem problem)) Right cs -> fmap componentPackage cs `shouldBe` ["one"] + it "reads the packages the files it imports name, as cabal does" + $ withProject + [ ("cabal.project", "packages: one\nimport: config/more.config\n"), + ("config/more.config", "packages: two\nimport: last.config\n"), + ("config/last.config", "packages: three\n"), + ("one/one.cabal", package "one" "src"), + ("two/two.cabal", package "two" "src"), + ("three/three.cabal", package "three" "src") + ] + $ \root -> + componentsOfTarget root Everything >>= \case + Left problem -> expectationFailure (T.unpack (describeTargetProblem problem)) + Right cs -> + sort (fmap componentPackage cs) `shouldBe` ["one", "three", "two"] + + it "reads a file imported in a cycle once" + $ withProject + [ ("cabal.project", "packages: one\nimport: more.config\n"), + ("more.config", "import: ./cabal.project\n"), + ("one/one.cabal", package "one" "src") + ] + $ \root -> + componentsOfTarget root Everything >>= \case + Left problem -> expectationFailure (T.unpack (describeTargetProblem problem)) + Right cs -> fmap componentPackage cs `shouldBe` ["one"] + it "looks in every source directory a component names" $ withProject [ ("only.cabal", packageWith "only" ["src", "gen"] ["A", "B"]), @@ -445,6 +505,20 @@ filesFor (Called "only") `shouldReturn` ["Setup.hs", "A.hs"] filesFor (Qualified Nothing Lib "only") `shouldReturn` ["A.hs"] + it "finds the modules of a foreign library, and names it as a plan does" + $ withProject + [ ("only.cabal", withForeignLibrary), + ("src/A.hs", "module A where\n"), + ("flib/F.hs", "module F where\n") + ] + $ \root -> + componentsOfTarget root (Qualified Nothing FLib "foreign") >>= \case + Left problem -> expectationFailure (T.unpack (describeTargetProblem problem)) + Right cs -> do + files <- filesOfComponents root cs + fmap takeFileName files `shouldBe` ["F.hs"] + fmap (fmap pcName . componentInPlan) cs `shouldBe` [Just "flib:foreign"] + it "names each library the way a plan does" $ withProject [("both.cabal", withSubLibrary)] $ \root -> componentsOfTarget root Everything >>= \case @@ -469,6 +543,28 @@ Right cs -> expectationFailure ("found " <> show (length cs) <> " components") Left problem -> describeTargetProblem problem `shouldSatisfy` T.isInfixOf "no packages" + it "says what the parser said of a cabal.project that will not parse" $ + withProject [("cabal.project", "packages: one\nfoo bar: baz\n")] $ \root -> + componentsOfTarget root Everything >>= \case + Right cs -> expectationFailure ("found " <> show (length cs) <> " components") + Left problem -> do + let said = describeTargetProblem problem + said `shouldSatisfy` T.isInfixOf "cabal.project does not parse:" + said `shouldSatisfy` T.isInfixOf "line 2, column 5" + + it "says so when a file it imports will not parse" + $ withProject + [ ("cabal.project", "packages: one\nimport: more.config\n"), + ("more.config", "foo bar: baz\n"), + ("one/one.cabal", package "one" "src") + ] + $ \root -> + componentsOfTarget root Everything >>= \case + Right cs -> expectationFailure ("found " <> show (length cs) <> " components") + Left problem -> + describeTargetProblem problem + `shouldSatisfy` T.isInfixOf "more.config does not parse:" + it "includes optional packages that exist, ignoring absent ones" $ withProject [ ("cabal.project", "packages: main\noptional-packages: optional absent\n"), @@ -493,6 +589,10 @@ ---------------------------------------------------------------------------- -- Helpers +-- | Turn a path separator into a forward slash, which every system takes. +forward :: Char -> Char +forward c = if isPathSeparator c then '/' else c + failed :: Either Text Target -> Bool failed = \case Left _ -> True @@ -572,6 +672,26 @@ "", "library inner", " hs-source-dirs: inner", + " default-language: Haskell2010" + ] + +-- | A package with a library and a foreign library. +withForeignLibrary :: Text +withForeignLibrary = + T.unlines + [ "cabal-version: 2.4", + "name: only", + "version: 0.1.0.0", + "", + "library", + " hs-source-dirs: src", + " exposed-modules: A", + " default-language: Haskell2010", + "", + "foreign-library foreign", + " type: native-shared", + " hs-source-dirs: flib", + " other-modules: F", " default-language: Haskell2010" ] diff --git a/tests/Tilia/Comments/PlaceSpec.hs b/tests/Tilia/Comments/PlaceSpec.hs --- a/tests/Tilia/Comments/PlaceSpec.hs +++ b/tests/Tilia/Comments/PlaceSpec.hs @@ -134,10 +134,10 @@ ("{- c -}", Just (After SpillAtIndentation, fName)) ] - it "goes its own way where that comment goes before what follows" $ - placedIn [xOnLineTwo] [] "{- a -} -- b\nx = 1\n" - `shouldBe` [ ("{- a -}", Just (Before, xOnLineTwo)), - ("-- b", Just (Before, xOnLineTwo)) + it "goes before what follows where that comment does" $ + placedIn [foo, oneOnLineTwo] [mkSpan (1, 6) (2, 4)] "foo = {- a -} -- b\n 1\n" + `shouldBe` [ ("{- a -}", Just (Before, oneOnLineTwo)), + ("-- b", Just (Before, oneOnLineTwo)) ] describe "a comment with nothing written against it" $ do @@ -244,9 +244,9 @@ fBody = mkSpan (1, 21) (1, 22) fBodyPastThree = mkSpan (1, 29) (1, 30) --- | The @x@ on the second line. -xOnLineTwo :: Span -xOnLineTwo = mkSpan (2, 1) (2, 2) +-- | The @1@ on the second line of @foo = {- a -} -- b@. +oneOnLineTwo :: Span +oneOnLineTwo = mkSpan (2, 3) (2, 4) ---------------------------------------------------------------------------- -- The snippets that take more than one line diff --git a/tests/Tilia/Corpus.hs b/tests/Tilia/Corpus.hs --- a/tests/Tilia/Corpus.hs +++ b/tests/Tilia/Corpus.hs @@ -126,10 +126,13 @@ expectUnreadable = [], expectDeclined = [ "other" "position-pragmas.hs", + "other" "line-markers.hs", "other" "cpp" "unbalanced.hs", "other" "cpp" "define-in-a-quasiquote.hs", "other" "cpp" "macro-standing-for-a-bracket.hs", - "other" "cpp" "branch-opening-a-bracket-it-does-not-close.hs" + "other" "cpp" "macro-before-a-leading-comma.hs", + "other" "cpp" "branch-opening-a-bracket-it-does-not-close.hs", + "other" "cpp" "line-marker-passed-on-by-cpp.hs" ] }, corpusInPackages = False @@ -196,6 +199,7 @@ ghcDeclined = [ "driver" "T17786.hs", "ghci.debugger" "HappyTest.hs", + "overloadedrecflds" "should_run" "overloadedlabelsrun04.hs", "parser" "should_compile" "ColumnPragma.hs", "parser" "should_compile" "T7118.hs", "perf" "compiler" "T20261.hs", @@ -394,7 +398,8 @@ "other" "cpp" "separation-2a.hs", "other" "cpp" "separation-2b.hs", "other" "cpp" "shifted.hs", - "other" "cpp" "simple-import.hs" + "other" "cpp" "simple-import.hs", + "declaration" "signature" "specialize" "specialize-2.hs" ] <> ormoluRecordBraces diff --git a/tests/Tilia/CorpusSpec.hs b/tests/Tilia/CorpusSpec.hs --- a/tests/Tilia/CorpusSpec.hs +++ b/tests/Tilia/CorpusSpec.hs @@ -16,6 +16,7 @@ import Data.Text.Encoding (decodeUtf8') import System.Directory (createDirectoryIfMissing) import System.FilePath (replaceExtension, ()) +import System.IO (stdout) import System.IO.Temp (withSystemTempDirectory) import Test.Hspec hiding (Example, after, before, example) import Tilia.Corpus @@ -69,7 +70,7 @@ it "is available" . expectationFailure $ "corpus not on this machine and could not be fetched: " <> T.unpack problem Right examples -> do - palette <- runIO paletteFor + palette <- runIO (paletteFor stdout) case corpusExpectations corpus of Listed lists -> againstLists lists (check palette) examples -- Plain, so that what a record says does not depend on whether the @@ -273,7 +274,9 @@ where wasNotDeclined = "the corpus says this should be declined, and it was not" unlisted what = - "this " <> what <> ", and the corpus does not list it under expectSkip" + "this " + <> what + <> ", and the corpus does not list it under expectUnreadable" check :: Palette -> Example -> IO Result check palette example = do @@ -322,7 +325,7 @@ -- more input or output. checkPure :: Palette -> FilePath -> Maybe Defaults -> Text -> Maybe Text -> Result checkPure palette path package source expected - | movesPositions source = + | movesPositions inForce source = Result Declined "a pragma that moves positions, which we do not rewrite" noDigest | usesCpp inForce source = checkCpp palette path package source expected | otherwise = case parseModule config path source of diff --git a/tests/Tilia/CppSpec.hs b/tests/Tilia/CppSpec.hs --- a/tests/Tilia/CppSpec.hs +++ b/tests/Tilia/CppSpec.hs @@ -280,21 +280,32 @@ formatCpp includeInQuasiquote `shouldBe` Left "the #include at line 7 is inside a quasi-quote or a multi-line string" + it "refuses an #include before a leading comma" $ + formatCpp includeBeforeLeadingComma + `shouldBe` Left "#include \"colors.h\" at line 5 comes before a leading comma, which formatting moves above it" + it "refuses an alternative aborting with #error that it cannot format" $ formatCpp abortingAlternative `shouldBe` Left "the alternative that the #error at line 7 aborts cannot be formatted without parsing it" + it "names the line of an #error that settling a conditional leaves unguarded" $ + formatCpp abortingWhereSettled + `shouldBe` Left "the alternative that the #error at line 10 aborts cannot be formatted without parsing it" + it "refuses a branch that a conditional around it asking the same question rules out" $ formatCpp ruledOut `shouldBe` Left "the branch at line 6 is ruled out by a conditional around it that asks the same question" describe "telling a directive line from code" $ do it "reads the keyword and everything after the hash" $ - directiveOnLine " # if FOO" `shouldBe` Just ("if", "if FOO") + directiveOnLine "# if FOO" `shouldBe` Just ("if", "if FOO") it "does not take a label at the start of a line for a directive" $ directiveOnLine " #field" `shouldBe` Nothing + it "does not take an indented line for one, as cpp does not" $ + directiveOnLine " #if FOO" `shouldBe` Nothing + ---------------------------------------------------------------------------- -- The modules the question is asked of @@ -646,6 +657,20 @@ "|]" ] +-- | An @#include@ standing for items of a list, written above the comma +-- that separates them from the next. +includeBeforeLeadingComma :: Text +includeBeforeLeadingComma = + T.unlines + [ "module M where", + "", + "colors =", + " [ \"red\"", + "#include \"colors.h\"", + " , \"blue\"", + " ]" + ] + -- | An alternative that aborts with @#error@ and leaves an expression -- unfinished, in a module whose conditionals cannot be varied one at a -- time. @@ -663,6 +688,25 @@ " + 2", "#if A", "g = 1", + "#endif" + ] + +-- | An alternative that aborts with @#error@ once what it answers settles +-- the conditional around the @#error@, which another alternative leaves +-- open. +abortingWhereSettled :: Text +abortingWhereSettled = + T.unlines + [ "module M where", + "", + "f =", + "#ifdef A", + " 1 +", + "#else", + " 2", + "#endif", + "#if defined(A) || defined(B)", + "#error \"b\"", "#endif" ] diff --git a/tests/Tilia/DiffSpec.hs b/tests/Tilia/DiffSpec.hs --- a/tests/Tilia/DiffSpec.hs +++ b/tests/Tilia/DiffSpec.hs @@ -55,6 +55,35 @@ " h" ] + it "ends a hunk at the last line, with nothing after it" $ + diff Plain ("x", "y") "a\nb\n" "a\nB\n" + `shouldBe` T.intercalate + "\n" + ["--- x", "+++ y", "@@ -1,2 +1,2 @@", " a", "-b", "+B"] + + it "marks a last line that no newline ends" $ + diff Plain ("x", "y") "a\nb" "a\nb\n" + `shouldBe` T.intercalate + "\n" + [ "--- x", + "+++ y", + "@@ -1,2 +1,2 @@", + " a", + "-b", + "\\ No newline at end of file", + "+b" + ] + + it "keeps the carriage returns the lines end in" $ + diff Plain ("x", "y") "a\r\nb\nc\r\n" "a\r\nb\r\nc\r\n" + `shouldBe` T.intercalate + "\n" + ["--- x", "+++ y", "@@ -1,3 +1,3 @@", " a\r", "-b", "+b\r", " c\r"] + + it "starts a side with no lines at 0, as git does" $ + diff Plain ("x", "y") "\n\n" "" + `shouldBe` T.intercalate "\n" ["--- x", "+++ y", "@@ -1,2 +0,0 @@", "-", "-"] + it "keeps changes far apart in hunks of their own" $ length (filter (T.isPrefixOf "@@") (T.lines (diff Plain ("x", "y") far (T.replace "k" "K" (T.replace "b" "B" far))))) `shouldBe` 2 diff --git a/tests/Tilia/EquivalenceSpec.hs b/tests/Tilia/EquivalenceSpec.hs --- a/tests/Tilia/EquivalenceSpec.hs +++ b/tests/Tilia/EquivalenceSpec.hs @@ -121,10 +121,22 @@ Nothing -> expectationFailure "let the pragma through" Just why -> why `shouldSatisfy` T.isInfixOf "invented the pragma" + it "notices a pragma holding a comment that went missing" $ + differsBecause + "{-# LANGUAGE LambdaCase #-}\n{-# LANGUAGE LambdaCase -- for f\n #-}\nmodule M where\n" + "{-# LANGUAGE LambdaCase #-}\nmodule M where\n" + "-- for f" + it "does not mind the order of what stands above the module header" $ "{-# LANGUAGE LambdaCase #-}\n{-# LANGUAGE TupleSections #-}\nmodule M where\nf = 1\n" `keepsTheCommentsOf` "{-# LANGUAGE TupleSections #-}\n{-# LANGUAGE LambdaCase #-}\nmodule M where\nf = 1\n" + it "notices comments inside the export list coming out in another order" $ + differsBecause + "module M\n ( a, {- e -} -- f\n b,\n )\nwhere\n" + "module M\n ( a, -- f\n {- e -} b,\n )\nwhere\n" + "`{- e -}` became `-- f`" + it "does not mind a comment that moved with the import it belongs to" $ "module M where\n\n-- about Set\nimport Data.Set\n\n-- about Map\nimport Data.Map\n" `keepsTheCommentsOf` "module M where\n\n-- about Map\nimport Data.Map\n\n-- about Set\nimport Data.Set\n" @@ -136,6 +148,14 @@ it "notices a comment carried on under the last import going missing" $ "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" + + it "does not mind a comment under the last import going with the code after it" $ + "module M where\nimport Data.List -- a remark\n-- about f\nf = 1\n" + `keepsTheCommentsOf` "module M where\n\nimport Data.List -- a remark\n\n-- about f\nf = 1\n" + + it "does not mind a comment under the module line going with the code after it" $ + "module M (f) where -- a remark\n-- about f\nf = 1\n" + `keepsTheCommentsOf` "module M (f) where -- a remark\n\n-- about f\nf = 1\n" describe "what the header puts in force" $ do it "does not mind language pragmas sorted where that changes nothing" $ 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 @@ -7,6 +7,7 @@ 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 qualified as BS import Data.ByteString.Lazy qualified as BL import Data.Text (Text) import Data.Text qualified as T @@ -19,10 +20,12 @@ import Tilia.Cabal.Package ( declaredModules, describePackageProblem, + packageBranches, packageExtensions, packageSourceDirs, parsePackageDescription, ) +import Tilia.Fixity.Archive (Archive (..), InArchive (..), moduleIn) import Tilia.Fixity.Cabal import Tilia.Pragma (effectiveExtensions) @@ -186,6 +189,29 @@ it "offers it when nothing names anything" $ sourceDirs "library\n build-depends: base\n" `shouldBe` ["."] + describe "a module's file in an archive" $ do + it "is found under a source directory" $ + textOf "src" "Foo.Parser" [("t-0/src/Foo/Parser.hs", "found")] + `shouldBe` Just "found" + + it "is found in the package directory" $ + textOf "." "Parser" [("t-0/Parser.hs", "found")] + `shouldBe` Just "found" + + it "is found under a source directory however it is spelled" $ + fmap + (\dir -> textOf dir "Parser" [("t-0/src/Parser.hs", "found")]) + ["src/", "./src"] + `shouldBe` [Just "found", Just "found"] + + it "is not a file of that name below a source directory" $ + textOf "src" "Parser" [("t-0/src/Foo/Parser.hs", "module Foo.Parser")] + `shouldBe` Nothing + + it "is not a file under a directory of that name further down" $ + textOf "src" "Parser" [("t-0/vendor/src/Parser.hs", "vendored")] + `shouldBe` Nothing + describe "what the package puts in force" $ do it "reads an extension the .cabal turns on" $ extensions "library\n default-extensions: LambdaCase\n" @@ -283,6 +309,17 @@ extensions :: Text -> [Extension] extensions = (`effectiveExtensions` "") . packageExtensions . described +-- | The text an archive of these files gives for a module, where its +-- @.cabal@ file names this source directory. +textOf :: FilePath -> Text -> [(FilePath, BS.ByteString)] -> Maybe Text +textOf dir modName files = + case moduleIn modName (Archive (Just cabal) files) of + Just (Haskell text) -> Just text + _ -> Nothing + where + cabal = + described ("library\n hs-source-dirs: " <> T.pack dir <> "\n") + -- | What a @.cabal@ file holding the fields given describes. described :: Text -> GenericPackageDescription described fields = @@ -295,7 +332,7 @@ -- | The names of the modules a package declares. modulesOf :: GenericPackageDescription -> [Text] -modulesOf = fmap fst . declaredModules +modulesOf = fmap fst . concatMap snd . declaredModules . packageBranches -- | A tar entry at the given path, holding the given text. entryFor :: FilePath -> Text -> Tar.Entry 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 @@ -5,11 +5,14 @@ -- | The on-disk cache of what was read out of a package. module Tilia.Fixity.CacheSpec (spec) where +import Control.Monad (replicateM, replicateM_) import Data.Choice (pattern Do, pattern Don't) +import Data.Foldable (traverse_) import Data.List.NonEmpty (NonEmpty (..)) import Data.Map.Strict qualified as Map import Data.Set qualified as Set import Data.Text (Text) +import Data.Text qualified as T import System.Directory (getModificationTime, listDirectory, setModificationTime) import System.FilePath (()) import System.IO.Temp (withSystemTempDirectory) @@ -18,6 +21,7 @@ import Tilia.Fixity.Cache import Tilia.Fixity.PackageDb (Installed (..), InstalledPackage (..)) import Tilia.TestUtils (underAsciiLocale, withEnvironment) +import Tilia.Utils (inParallel) spec :: Spec spec = do @@ -25,7 +29,7 @@ database describe "a cache not to be used" $ it "remembers nothing, and nothing is made on disk for it" $ - withIsolatedDirectory $ \dir -> do + withSystemTempDirectory "tilia-cache" $ \dir -> do cache <- withEnvironment [("XDG_CACHE_HOME", dir)] $ openCache (Don't #useCache) (PlanToken "plan") @@ -146,6 +150,23 @@ cachedEstablished cache "thing-1.0" "M" `shouldReturn` Just (declaring [((InTerms, OpName "!"), Fixity RightAssoc 3)]) + it "gives back no half of an answer two writers store at once" $ \cache -> do + let answers = + [ declaring + [ ((InTerms, OpName (T.replicate n "+")), Fixity LeftAssoc k) + | n <- [1 .. 200] + ] + | k <- [1, 2] + ] + store = storeEstablished cache "thing-1.0" "M" + storing established = [] <$ replicateM_ 200 (store established) + recalling = replicateM 200 (cachedEstablished cache "thing-1.0" "M") + traverse_ store answers + recalled' <- + concat + <$> inParallel id (fmap storing answers <> [recalling, recalling]) + filter (`notElem` fmap Just answers) recalled' `shouldBe` [] + it "round-trips the members of each name, a name without members among them" $ \cache -> do let established = mempty @@ -240,6 +261,12 @@ storeSummaries cache "m" "stamp" (Just (crowded :| [])) cachedSummaries cache "n" "stamp" `shouldReturn` Nothing + describe "where cabal keeps downloaded sources" $ + it "keeps projects apart under one plan" $ \cache -> do + storePackageCache cache "/one" "/one/packages" + cachedPackageCache cache "/another" `shouldReturn` Nothing + cachedPackageCache cache "/one" `shouldReturn` Just "/one/packages" + describe "module names with dots" $ it "files a deeply qualified module without confusion" $ \cache -> do storeEstablished cache "thing-1.0" "A.B.C.D" (declaring [((InTerms, OpName "%"), Fixity NoAssoc 5)]) @@ -339,7 +366,7 @@ cachedInstalled cache `shouldReturn` Nothing it "gives back nothing to a token it was not written under" $ \_ -> - withIsolatedDirectory $ \dir -> + withSystemTempDirectory "tilia-cache" $ \dir -> withDatabase $ \db -> do before' <- open dir (PlanToken "one") storeInstalled before' (Installed [containers] [db]) @@ -347,7 +374,7 @@ cachedInstalled after' `shouldReturn` Nothing it "gives it back under the token it was written under" $ \_ -> - withIsolatedDirectory $ \dir -> + withSystemTempDirectory "tilia-cache" $ \dir -> withDatabase $ \db -> do before' <- open dir (PlanToken "one") storeInstalled before' (Installed [containers] [db]) @@ -355,7 +382,7 @@ cachedInstalled again `shouldReturn` Just [containers] it "keeps one token's answer when another writes its own" $ \_ -> - withIsolatedDirectory $ \dir -> + withSystemTempDirectory "tilia-cache" $ \dir -> withDatabase $ \db -> do one <- open dir (PlanToken "one") storeInstalled one (Installed [containers] [db]) @@ -422,7 +449,7 @@ -- | What an answer that leaves names unsettled is tied to, and what it is -- not. tokens :: Spec -tokens = around withIsolatedDirectory $ do +tokens = around (withSystemTempDirectory "tilia-cache") $ do it "does not offer an unread answer written under another token" $ \dir -> do before' <- open dir (PlanToken "one") storeEstablished before' "thing-1.0" "M" unreadable @@ -465,10 +492,7 @@ -- or into the developer's real cache. withIsolatedCache :: (Cache -> IO ()) -> IO () withIsolatedCache action = - withIsolatedDirectory (\dir -> open dir (PlanToken "plan") >>= action) - -withIsolatedDirectory :: (FilePath -> IO ()) -> IO () -withIsolatedDirectory = withSystemTempDirectory "tilia-cache" + withSystemTempDirectory "tilia-cache" (\dir -> open dir (PlanToken "plan") >>= action) -- | Open a cache in a given directory, under a given token. open :: FilePath -> PlanToken -> IO Cache 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 @@ -50,20 +50,21 @@ notesFor [("Prelude", Just []), ("Data.Map", Just [("!", infixl' 9)])] "import Data.Map\nf m = m ! 1\n" - >>= (`shouldContain'` "· ! infixl 9, declared in Data.Map") + >>= (`shouldContain'` "· ! infixl 9 (term), declared in Data.Map") it "says when the module declared it itself" $ notesFor [("Prelude", Just [])] "infixr 5 <+>\nf a b = a <+> b\n" - >>= (`shouldContain'` "· <+> infixr 5, declared in this module") + >>= (`shouldContain'` "· <+> infixr 5 (term), declared in this module") it "says when nothing in scope declares it and everything was read" $ notesFor [("Prelude", Just [])] "f a b = a b\n" - >>= (`mentions` " infixl 9, the Report's default") + >>= (`mentions` " infixl 9 (term), the Report's default") it "says which unread module the answer might have been in" $ notesFor [("Prelude", Just [])] "import Criterion.Main\nf a b = a b\n" >>= ( `shouldContain'` - "· unknown: may be declared in Criterion.Main, which this run could not read" + "· unknown (term): may be declared in Criterion.Main, \ + \which this run could not read" ) it "counts the unread modules when there is more than one" $ @@ -78,7 +79,7 @@ notesFor [("Prelude", Just []), ("Data.Map", Just [("!", infixl' 9)])] "import qualified Data.Map as M\nf m = m M.! 1\n" - >>= (`shouldContain'` "· M.! infixl 9, declared in Data.Map") + >>= (`shouldContain'` "· M.! infixl 9 (term), declared in Data.Map") it "says when two imports disagree about one" $ notesFor @@ -107,6 +108,34 @@ told <- notesFor [("Prelude", Just [])] "f a b c = a b c a\n" length (filter (T.isInfixOf "") told) `shouldBe` 1 + it "gives an operator a line per namespace where they differ" $ do + told <- + notesFor + [("Prelude", Just [])] + "data a :. b = a :. b\ninfixr 5 data :.\ninfixl 4 type :.\n\ + \type T = Int :. Int\nx = 1 :. 2\n" + told `shouldContain'` "· :. infixl 4 (type), declared in this module" + told `shouldContain'` "· :. infixr 5 (term), declared in this module" + + it "gives an operator one line where both namespaces agree" $ do + told <- + notesFor + [("Prelude", Just [])] + "data a :- b = a :- b\ninfix 8 :-\ntype T = Int :- Int\nx = 1 :- 2\n" + filter (T.isInfixOf "declared in this module") (fmap T.stripStart told) + `shouldBe` ["· :- infix 8 (type & term), declared in this module"] + + it "names the namespace a constructor written among types answers from" $ do + let answerOf m = + mempty + { establishedFixities = + Map.fromList + [((InTerms, OpName ":>"), Fixity RightAssoc 5) | m == "Ops"] + } + told <- notesAgainst answerOf "import Ops\ntype T = Int :> Int\nx = 1 :> 2\n" + filter (T.isInfixOf ":>") (fmap T.stripStart told) + `shouldBe` ["· :> infixr 5 (term), declared in Ops"] + describe "how far reading an import got" $ do it "names the module that stopped it rather than the import above it" $ throughHspec @@ -166,7 +195,21 @@ it "lists what the module declares for itself" $ notesFor [("Prelude", Just [])] "infixr 5 <+>\nf a b = a <+> b\n" - >>= (`shouldContain'` "· <+> infixr 5") + >>= (`shouldContain'` "· <+> infixr 5 (type & term)") + + it "lists what it declares for a type beside a constructor of its name" $ do + told <- + notesFor + [("Prelude", Just [])] + "data a :. b = a :. b\ninfixr 5 data :.\ninfixl 4 type :.\n" + told `shouldContain'` "· :. infixr 5 (term)" + told `shouldContain'` "· :. infixl 4 (type)" + + it "lists once what it declares for both at once" $ do + told <- + notesFor [("Prelude", Just [])] "data a :- b = a :- b\ninfix 8 :-\n" + filter (T.isInfixOf ":-") (fmap T.stripStart told) + `shouldBe` ["· :- infix 8 (type & term)"] ---------------------------------------------------------------------------- -- Helpers 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 @@ -25,7 +25,7 @@ import Data.Text.Encoding qualified as T import GHC.Hs (HsModule) import GHC.Hs.Extension (GhcPs) -import System.Directory (doesFileExist) +import System.Directory (canonicalizePath, doesFileExist) import Test.Hspec import Tilia.BootFixities (bootFixities) import Tilia.Cabal.Plan @@ -70,7 +70,7 @@ runIO $ filterM (fmap not . doesFileExist . snd) . filter ((`Set.member` readFromSourcePackages) . ppName . fst) - =<< plannedTarballs noCache plan + =<< plannedTarballs noCache "." plan describe "the tree this project is built against" $ do it "is a real dependency tree and not an empty plan" $ length dependencies `shouldSatisfy` (>= 30) @@ -145,8 +145,12 @@ [path | (path, Nothing) <- own] `shouldBe` [] it "resolves every module they import" $ do - answers <- traverse (\m -> (m,) <$> resolve m) (importedByOwn own) - [m | (m, Nothing) <- answers] `shouldBe` [] + answers <- + traverse + (\(path, m) -> (m,) <$> askModule resolver (Just path) m) + (importedByOwn own) + [m | (m, answer) <- answers, not (settlesEverything answer)] + `shouldBe` [] it "settles every operator they use" $ do unsettled <- traverse (unsettledIn resolver) [(path, m) | (path, Just m) <- own] @@ -256,14 +260,15 @@ ---------------------------------------------------------------------------- -- This project --- | Every Haskell file this project is made of, parsed. +-- | Every Haskell file this project is made of, by its canonical path, +-- parsed. -- -- 'Nothing' where one did not parse, which is a failure of its own rather -- than something to skip over quietly. ownModules :: IO [(FilePath, Maybe (HsModule GhcPs))] ownModules = do paths <- concat <$> traverse haskellFilesIn ["src", "app", "tests"] - traverse parsed paths + traverse parsed =<< traverse canonicalizePath paths where parsed path = do source <- T.decodeUtf8Lenient <$> BS.readFile path @@ -276,18 +281,20 @@ -- | What a module exports, where reading it settles every name. fixitiesThrough :: Resolver -> Text -> IO (Maybe Fixities) -fixitiesThrough resolver modName = settled <$> askModule resolver modName +fixitiesThrough resolver modName = + settled <$> askModule resolver Nothing modName where settled established | settlesEverything established = Just (establishedFixities established) | otherwise = Nothing --- | Every module this project's own source imports. -importedByOwn :: [(FilePath, Maybe (HsModule GhcPs))] -> [Text] +-- | Every module this project's own source imports, with each file +-- importing it. +importedByOwn :: [(FilePath, Maybe (HsModule GhcPs))] -> [(FilePath, Text)] importedByOwn own = Set.toList . Set.fromList $ - [ importModule i - | (_, Just hsModule) <- own, + [ (path, importModule i) + | (path, Just hsModule) <- own, i <- moduleImports (Is #implicitPrelude) (pure hsModule), not ("Paths_" `T.isPrefixOf` importModule i) ] @@ -304,7 +311,7 @@ (FilePath, HsModule GhcPs) -> IO [String] unsettledIn resolver (path, hsModule) = do - scope <- scopeFor resolver (Is #implicitPrelude) (pure hsModule) + scope <- scopeFor resolver (Just path) (Is #implicitPrelude) (pure hsModule) pure [ path <> ": " <> T.unpack (operatorSpelling qualifier op) <> " " <> show why | ((qualifier, op), why) <- unknownOperators scope (pure (gathered hsModule)) 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 @@ -140,6 +140,24 @@ declaresIn "exports:\n !\nfixities infixl 9 !\nab12\n data Other a b where\n (!) :: Int\n" `shouldBe` [((InTerms, OpName "!"), Fixity LeftAssoc 9)] + it "gives a type and a constructor of one name each its own" $ + declaresIn + "exports:\n :.{:.}\n\ + \fixities infixr 5 :., infixl 4 :.\n\ + \b4c8\n type (:.) :: * -> * -> *\n data (:.) a b = a :. b\n" + `shouldBe` [ ((InTypes, OpName ":."), Fixity LeftAssoc 4), + ((InTerms, OpName ":."), Fixity RightAssoc 5) + ] + + it "gives one fixity for a type and a constructor of one name to both" $ + declaresIn + "exports:\n :-{:-}\n\ + \fixities infix 8 :-, infix 8 :-\n\ + \eeee\n type (:-) :: * -> * -> *\n data (:-) a b = a :- b\n" + `shouldBe` [ ((InTypes, OpName ":-"), Fixity NoAssoc 8), + ((InTerms, OpName ":-"), Fixity NoAssoc 8) + ] + describe "the members of a name" $ do it "takes the members an entry wears in braces" $ members "exports:\n GHC.Internal.Base.NonEmpty{GHC.Internal.Base.:|}\n" diff --git a/tests/Tilia/Fixity/PackageDbSpec.hs b/tests/Tilia/Fixity/PackageDbSpec.hs --- a/tests/Tilia/Fixity/PackageDbSpec.hs +++ b/tests/Tilia/Fixity/PackageDbSpec.hs @@ -27,6 +27,28 @@ dirsOf [("import-dirs", "${pkgroot}/../lib/base-4.20.2.0")] `shouldBe` Just ["${pkgroot}/../lib/base-4.20.2.0"] + it "reads the package root as ghc-pkg writes it, escapes and all" $ + dirsOf + [ ("pkgroot", "\"/opt/J\\243zef, \\\"q\\\"/lib\""), + ("import-dirs", "${pkgroot}/base") + ] + `shouldBe` Just ["/opt/Józef, \"q\"/lib/base"] + + it "reads a directory ghc-pkg quotes, as it does one with a space" $ + dirsOf + [ ("pkgroot", "\"/opt/lib\""), + ( "import-dirs", + " \"${pkgroot}/a b\" ${pkgroot}/plain \"${pkgroot}/c,d\" \ + \\"/with space/\\233\"" + ) + ] + `shouldBe` Just + [ "/opt/lib/a b", + "/opt/lib/plain", + "/opt/lib/c,d", + "/with space/é" + ] + it "roots every directory a package names" $ dirsOf [ ("pkgroot", "/opt/ghc/lib"), 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 @@ -27,13 +27,15 @@ import Data.List qualified import Data.List.NonEmpty (NonEmpty ((:|))) import Data.Map.Strict qualified as Map +import Data.Maybe (listToMaybe) import Data.Set qualified as Set import Data.Text (Text) import Data.Text qualified as T import Data.Text.Encoding qualified as T import Data.Time (addUTCTime, getCurrentTime) import System.Directory - ( createDirectoryIfMissing, + ( canonicalizePath, + createDirectoryIfMissing, doesFileExist, getPermissions, setModificationTime, @@ -53,7 +55,6 @@ import Tilia.Fixity.Cache ( PlanToken (..), openCache, - storeFutileFetch, storePackageCache, ) import Tilia.Fixity.HiFile (HiExport (..), HiFile (..), HiName (..)) @@ -87,6 +88,7 @@ askedAtOnce givenInterfaces readBefore + namedAlike gitDependencies repositories packageCache @@ -168,7 +170,7 @@ -- | 'Plan.prepareWith', with the cache in use as it is by default. prepareWith :: - ([String] -> IO (Either Text ())) -> + ([String] -> IO (Either CabalFailure ())) -> Futility -> [PlanComponent] -> FilePath -> @@ -262,10 +264,29 @@ it "does not go on to fetch when the solve fails" $ withTempProject Nothing $ \dir -> do steps <- newIORef [] - let cabal args = record steps args >> pure (Left "cabal said no") + let cabal args = Left (Unsolvable "cabal said no") <$ record steps args prepareWith cabal undiscoveredFutility [] dir PlanMissing `shouldReturn` Left "cabal said no" readIORef steps `shouldReturn` [solving, narrowSolve] + it "asks about less only where the whole project will not solve" $ + withTempProject Nothing $ \dir -> do + steps <- newIORef [] + let cabal args = Left (CabalFailed "cabal said no") <$ record steps args + prepareWith cabal undiscoveredFutility [] dir PlanMissing + `shouldReturn` Left "cabal said no" + readIORef steps `shouldReturn` [solving] + + it "hears from cabal that the whole project will not solve" $ + withTempProject Nothing $ \dir -> do + let unsolvable = complaining "Could not resolve dependencies:" + fst <$> runsCabalWith unsolvable (loading dir) + `shouldReturn` ["build", "build"] + + it "hears from cabal that it failed otherwise" $ + withTempProject Nothing $ \dir -> do + let unparsed = complaining "Error parsing project file" + fst <$> runsCabalWith unparsed (loading dir) `shouldReturn` ["build"] + it "asks about the test suites and the benchmarks, not the library alone" $ withTempProject Nothing $ \dir -> do steps <- newIORef [] @@ -283,7 +304,7 @@ let cabal args = do record steps args if wholeProject `Data.List.isSuffixOf` args - then pure (Left "a test suite will not solve") + then pure (Left (Unsolvable "a test suite will not solve")) else do when (args == narrowSolve) (writePlan dir wantingATarball) pure (Right ()) @@ -310,6 +331,16 @@ setModificationTime (dir "thing.cabal") later checkReadiness [] dir `shouldReturn` PlanStale [dir "thing.cabal"] + it "takes a change to a file the project imports as making the plan stale" $ + withOwnPlan $ \dir -> do + writeUtf8File (dir "cabal.project") "import: config/more.config\n" + createDirectoryIfMissing True (dir "config") + writeUtf8File (dir "config" "more.config") "" + earlier <- addUTCTime (-90) <$> getCurrentTime + setModificationTime (dir "cabal.project") earlier + imported <- canonicalizePath (dir "config" "more.config") + checkReadiness [] dir `shouldReturn` PlanStale [imported] + describe "a plan narrower than the run" $ do it "notices a component the plan says nothing about" $ withTempProject (Just twoComponents) $ \dir -> @@ -589,7 +620,7 @@ it "declares nothing, where it is one of the project's own" $ withFakeProject [("src/Cursed.hsc", cursed)] $ \rs -> do - askModule rs "Cursed" `shouldReturn` mempty + askModule rs Nothing "Cursed" `shouldReturn` mempty it "declares nothing, where it comes out of a tarball" $ withFakeArchive [("Cursed.hsc", cursed)] $ @@ -653,8 +684,16 @@ case said of Nothing -> expectationFailure "no cabal on the path to ask" Just reported -> - packageCacheRoot `shouldReturn` T.unpack (T.strip reported) + packageCacheRoot "." `shouldReturn` T.unpack (T.strip reported) + it "is the one the project's own configuration names" $ + withSystemTempDirectory "tilia-own-cache" $ \dir -> do + writeUtf8File (dir "cabal.project") . T.pack $ + "packages: .\nremote-repo-cache: " <> (dir "packages") <> "\n" + writeUtf8File (dir "thing.cabal") $ + "cabal-version: 3.0\nname: thing\nversion: 1.0\n\nlibrary\n" + packageCacheRoot dir `shouldReturn` (dir "packages") + describe "and where it is guessed, for a cabal too old to ask" $ do it "is what CABAL_DIR says, above all else" $ withSystemTempDirectory "tilia-cabal-dir" $ \dir -> @@ -677,49 +716,83 @@ 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 _ -> - asked `shouldBe` ["path"] - - it "is not asked again for a tarball fetching did not bring in" $ - withRemembered False ["thing"] $ \_ asked _ -> + it "is not asked again where a tarball of the plan is not there" $ + withRemembered False $ \_ asked _ -> asked `shouldBe` [] + it "is asked again where a fetch leaves a tarball of the plan missing" $ + afterFetching (\_ -> pure ()) `shouldReturn` ["path"] + + it "is not asked again where a fetch brings the plan's tarballs in" $ + afterFetching + ( \root -> do + let at = root "hackage.haskell.org/tilia-phantom/9.9.9" + createDirectoryIfMissing True at + writeUtf8File (at "tilia-phantom-9.9.9.tar.gz") "not really" + ) + `shouldReturn` [] + -- | 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 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. +-- tarball or not, 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 refused act = +withRemembered holding act = withSystemTempDirectory "tilia-remembered" $ \root -> do let at = root "hackage.haskell.org" "thing" "1.0" when holding $ do createDirectoryIfMissing True at 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 -> + withTempProject (Just (fromRepository hackage)) $ \dir -> do + storePackageCache cache dir root readBuildPlan (planPathFor dir) >>= \case Left why -> expectationFailure (T.unpack why) Right plan -> do - (asked, found) <- runsCabal (plannedTarballs cache plan) + (asked, found) <- runsCabal (plannedTarballs cache dir plan) act root asked (fmap snd found) where hackage = "{\"type\":\"secure-repo\",\"uri\":\"https://hackage.haskell.org/\"}" +-- | The commands the stand-in for @cabal@ is given while a project short of +-- a tarball fetches it, the package cache remembered to be a directory of +-- its own, which the fetch does what is given to. +afterFetching :: (FilePath -> IO ()) -> IO [String] +afterFetching fetched = + withSystemTempDirectory "tilia-remembered" $ \root -> + withEnvironment [("XDG_CACHE_HOME", root "cache")] $ + withTempProject (Just wantingATarball) $ \dir -> do + Right plan <- readBuildPlan (planPathFor dir) + cache <- openCache (Do #useCache) =<< tokenForBuildPlan plan + storePackageCache cache dir root + let cabal args = Right () <$ when (args == fetching) (fetched root) + short = SourcesMissing ["tilia-phantom"] + fst <$> runsCabal (prepareWith cabal undiscoveredFutility [] dir short) + -- | A plan handed over to be taken as it is. givenPlans :: Spec givenPlans = describe "a plan trusted as up to date" $ do + it "says which plan is not there, once" $ + withGivenPlan [] $ \project _ -> + readGivenPlan project "nowhere.json" + `shouldReturn` Left "nowhere.json does not exist" + + it "says which plan does not parse" $ + withGivenPlan [] $ \project _ -> do + let planFile = project "bad.json" + unparsed = T.pack planFile <> " does not parse: " + writeUtf8File planFile "{\"compiler-id\": 3}" + readGivenPlan project planFile >>= \case + Left why -> why `shouldSatisfy` T.isPrefixOf unparsed + Right _ -> expectationFailure "a plan that does not parse was read" + it "finds a local package it names relatively under the project" $ withGivenPlan [] $ \project planFile -> readGivenPlan project planFile >>= \case @@ -744,6 +817,12 @@ filter (== "fetch") . fst <$> runsCabal (fetchingFor project planFile) `shouldReturn` ["fetch"] + it "does not fetch again what fetching did not bring in" $ + withGivenPlan [unavailable] $ \project planFile -> do + let succeeding = fmap fst . runsCabalWith "exit 0" . fetchingFor project + succeeding planFile `shouldReturn` ["path", "fetch", "path"] + succeeding planFile `shouldReturn` [] + it "runs no cabal where it reads interfaces alone, whatever it is asked" $ withGivenPlan [unavailable] $ \project planFile -> fst @@ -780,7 +859,12 @@ -- | The @cabal@ commands something runs, as told by a stand-in put first -- on the path that fails, and what it came to. runsCabal :: IO a -> IO ([String], a) -runsCabal act +runsCabal = runsCabalWith "exit 1" + +-- | 'runsCabal', with the stand-in going on to run the shell commands +-- given. +runsCabalWith :: String -> IO a -> IO ([String], a) +runsCabalWith script act | System.Info.os == "mingw32" = expectationFailure "the stand-in for cabal is a shell script, which does not run on Windows" >> (,) [] <$> act @@ -788,7 +872,12 @@ withSystemTempDirectory "tilia-cabal" $ \bin -> do let stand = bin "cabal" commandLog = bin "commands" - writeFile stand ("#!/bin/sh\necho \"$1\" >> '" <> commandLog <> "'\nexit 1\n") + writeFile stand $ + "#!/bin/sh\necho \"$1\" >> '" + <> commandLog + <> "'\n" + <> script + <> "\n" setPermissions stand . setOwnerExecutable True =<< getPermissions stand path <- maybe "" (searchPathSeparator :) <$> lookupEnv "PATH" answer <- withEnvironment [("PATH", bin <> path)] act @@ -833,12 +922,11 @@ writeUtf8File (planPathFor dir) planText readBuildPlan (planPathFor dir) >>= \case Left why -> expectationFailure (T.unpack why) - Right plan -> - openCache (Don't #useCache) (PlanToken "") - >>= (`plannedTarballs` plan) - >>= \case - [(_, found)] -> act found - other -> expectationFailure (show (fmap snd other)) + Right plan -> do + cache <- openCache (Don't #useCache) (PlanToken "") + plannedTarballs cache dir plan >>= \case + [(_, found)] -> act found + other -> expectationFailure (show (fmap snd other)) where put cabalDir (repo, held, version) = do let at = @@ -1133,6 +1221,78 @@ ] localDirsOf plan = [dir | LocalPackage dir <- fmap ppSource (bpPackages plan)] +-- | A module another component of the package names alike, as GHC finds it +-- for each of them. +namedAlike :: Spec +namedAlike = describe "a module another component names alike" $ do + it "is the one of the component importing it" $ + withFakePlan components $ \plan -> do + fixityFrom plan ("tests" "Main.hs") "Utils" "<+>" + `shouldReturn` Just (Fixity RightAssoc 5) + fixityFrom plan "Lib.hs" "Utils" "<+>" + `shouldReturn` Just (Fixity LeftAssoc 6) + + it "is a dependency's for a component that does not hold it" $ + withFakePlan components $ \plan -> + fixityFrom plan "Lib.hs" "Data.Function" "&" + `shouldReturn` Just (Fixity LeftAssoc 1) + + it "is the one of a component sharing the importer's directory" $ + withFakePlan components $ \plan -> + fixityFrom plan ("app" "Other.hs") "Data.Function" "&" + `shouldReturn` Just (Fixity RightAssoc 0) + where + fixityFrom plan file modName op = do + rs <- newResolver plan + importer <- + traverse + canonicalizePath + [dir file | LocalPackage dir <- fmap ppSource (bpPackages plan)] + Map.lookup (InTerms, OpName op) . establishedFixities + <$> askModule rs (listToMaybe importer) modName + components = + [ ( "fake.cabal", + T.unlines + [ "cabal-version: 2.4", + "name: fake", + "version: 0.1.0.0", + "library", + " exposed-modules: Lib, Utils", + " default-language: Haskell2010", + "test-suite tests", + " type: exitcode-stdio-1.0", + " main-is: Main.hs", + " other-modules: Utils", + " hs-source-dirs: tests", + " default-language: Haskell2010", + "executable other", + " main-is: Other.hs", + " hs-source-dirs: app", + " default-language: Haskell2010", + "executable app", + " main-is: Main.hs", + " other-modules: Data.Function", + " hs-source-dirs: app", + " default-language: Haskell2010" + ] + ), + ("Lib.hs", "module Lib () where\nimport Utils ()\n"), + ("Utils.hs", utils "infixl 6"), + ("tests/Main.hs", "module Main (main) where\nimport Utils ()\n"), + ("tests/Utils.hs", utils "infixr 5"), + ( "app/Data/Function.hs", + "module Data.Function ((&)) where\ninfixr 0 &\n\ + \(&) :: a -> (a -> b) -> b\nx & f = f x\n" + ) + ] + utils fixity = + T.unlines + [ "module Utils ((<+>)) where", + fixity <> " <+>", + "(<+>) :: Int -> Int -> Int", + "a <+> b = a + b" + ] + -- | How many modules the ring has. ringSize :: Int ringSize = 8 @@ -1162,7 +1322,8 @@ -- | What a module exports, where reading it settles every name. fixitiesOf :: Resolver -> Text -> IO (Maybe Fixities) -fixitiesOf resolver modName = settled <$> askModule resolver modName +fixitiesOf resolver modName = + settled <$> askModule resolver Nothing modName where settled established | settlesEverything established = Just (establishedFixities established) @@ -1170,11 +1331,13 @@ -- | The members of each of a module's names. membersIn :: Resolver -> Text -> IO (Map.Map OpName (Set.Set OpName)) -membersIn resolver modName = establishedMembers <$> askModule resolver modName +membersIn resolver modName = + establishedMembers <$> askModule resolver Nothing modName -- | Every name a module certainly brings in. certainNamesOf :: Resolver -> Text -> IO (Set.Set (Namespace, OpName)) -certainNamesOf resolver modName = certainNames . establishedCertain <$> askModule resolver modName +certainNamesOf resolver modName = + certainNames . establishedCertain <$> askModule resolver Nothing modName -- | A module of the kind @hsc2hs@ takes, declaring an operator nothing can -- get at. @@ -1430,10 +1593,51 @@ ) ] $ \rs -> do - answer <- askModule rs "Disagree" + answer <- askModule rs Nothing "Disagree" unsettledThrough answer (InTerms, OpName "<+>") `shouldBe` [[]] unsettledThrough answer (InTerms, OpName "sort") `shouldBe` [] + it "leaves unsettled what one configuration declares and another does not" + $ withFakeProject + [ ( "src/Partly.hs", + T.unlines + [ "{-# LANGUAGE CPP #-}", + "module Partly ((<+>)) where", + "#ifdef FAST", + "infixr 5 <+>", + "#endif", + "(<+>) :: Int -> Int -> Int", + "a <+> b = a + b" + ] + ) + ] + $ \rs -> do + answer <- askModule rs Nothing "Partly" + unsettledThrough answer (InTerms, OpName "<+>") `shouldBe` [[]] + + it "keeps the fixity of a name only one configuration exports" + $ withFakeProject + [ ( "src/Partly.hs", + T.unlines + [ "{-# LANGUAGE CPP #-}", + "#ifdef FAST", + "module Partly ((<+>), f) where", + "#else", + "module Partly (f) where", + "#endif", + "infixr 5 <+>", + "(<+>) :: Int -> Int -> Int", + "a <+> b = a + b", + "f :: Int", + "f = 1" + ] + ) + ] + $ \rs -> + fixitiesOf rs "Partly" + `shouldReturn` Just + (Map.singleton (InTerms, OpName "<+>") (Fixity RightAssoc 5)) + it "settles what an import it can read decides, though no configuration reads every import" $ withFakeProject [ ( "src/Bothbad.hs", @@ -1461,7 +1665,7 @@ describe "what a package module brings in" $ it "names what it hands on" $ do - answer <- askModule resolver "Prettyprinter" + answer <- askModule resolver Nothing "Prettyprinter" certainNames (establishedCertain answer) `shouldSatisfy` Set.member (InTerms, OpName "<+>") describe "the members of each of a module's names" $ do @@ -1515,7 +1719,7 @@ ] $ \rs -> do let m = parsed "module M where\nimport Facade (T (..))\n" - scope <- scopeFor rs (Is #implicitPrelude) (pure (pmModule m)) + scope <- scopeFor rs Nothing (Is #implicitPrelude) (pure (pmModule m)) lookupFixity scope InTerms Nothing (OpName ":|") `shouldBe` Resolved (Fixity RightAssoc 5) (DeclaredIn "Facade") @@ -1547,7 +1751,7 @@ it "is what it hands on from where reading gave up" $ withFakeProject [("src/Opaque.hs", opaqueSource)] $ \rs -> do - answer <- askModule rs "Opaque" + answer <- askModule rs Nothing "Opaque" establishedUnsettled answer `shouldBe` Map.singleton ["No.Such.Module"] (Set.singleton (InTerms, OpName "<+>")) establishedUntold answer `shouldBe` Set.empty @@ -1562,24 +1766,25 @@ ] ) ] - $ \rs -> settlesEverything <$> askModule rs "Wide" `shouldReturn` True + $ \rs -> + settlesEverything <$> askModule rs Nothing "Wide" `shouldReturn` True it "is everything for a module it cannot find at all" $ withFakeProject [("src/Opaque.hs", opaqueSource)] $ - \rs -> askModule rs "No.Such.Module" `shouldReturn` unreadable + \rs -> askModule rs Nothing "No.Such.Module" `shouldReturn` unreadable it "is everything it does not certainly bring in, when what it hands on whole cannot be read" $ withFakeProject [("src/Facade.hs", "module Facade (module No.Such.Module) where\nimport No.Such.Module\n")] $ \rs -> do - answer <- askModule rs "Facade" + answer <- askModule rs Nothing "Facade" establishedUntold answer `shouldBe` Set.singleton ["No.Such.Module"] it "is the type and its members, when a type it hands on is beyond us" $ withFakeProject [("src/Facade.hs", "module Facade (T (..)) where\nimport No.Such.Module\n")] $ \rs -> do - answer <- askModule rs "Facade" + answer <- askModule rs Nothing "Facade" unsettledThrough answer (InTypes, OpName "T") `shouldBe` [["No.Such.Module"]] unsettledThrough answer (InTerms, OpName ":|") `shouldBe` [["No.Such.Module"]] @@ -1588,11 +1793,11 @@ [ ("src/Ping.hs", "module Ping (module Pong) where\nimport Pong\n"), ("src/Pong.hs", "module Pong (module Ping) where\nimport Ping\n") ] - $ \rs -> askModule rs "Ping" `shouldReturn` mempty + $ \rs -> askModule rs Nothing "Ping" `shouldReturn` mempty it "is everything for a module whose source will not parse" $ withFakeProject [("src/Bad.hs", "module Bad ((<+>)) where\nf = (((\n")] $ - \rs -> askModule rs "Bad" `shouldReturn` unreadable + \rs -> askModule rs Nothing "Bad" `shouldReturn` unreadable it "is what any configuration leaves unsettled, where none settles every name" $ withFakeProject @@ -1609,7 +1814,7 @@ ) ] $ \rs -> do - answer <- askModule rs "Both" + answer <- askModule rs Nothing "Both" establishedUnsettled answer `shouldBe` Map.singleton ["No.Such.Module"] (Set.fromList [(InTerms, OpName "<+>"), (InTerms, OpName "")]) @@ -1617,7 +1822,7 @@ withFakeProject [("src/Opaque.hs", opaqueSource)] $ \rs -> do let m = parsed "module M where\nimport Opaque\n" - scope <- scopeFor rs (Is #implicitPrelude) (pure (pmModule m)) + scope <- scopeFor rs Nothing (Is #implicitPrelude) (pure (pmModule m)) lookupFixity scope InTerms Nothing (OpName "") `shouldBe` Resolved defaultFixity ReportDefault @@ -1625,24 +1830,30 @@ withFakeProject [("src/Opaque.hs", opaqueSource)] $ \rs -> do let m = parsed "module M where\nimport Opaque\n" - scope <- scopeFor rs (Is #implicitPrelude) (pure (pmModule m)) + scope <- scopeFor rs Nothing (Is #implicitPrelude) (pure (pmModule m)) lookupFixity scope InTerms Nothing (OpName "<+>") `shouldBe` Unresolved (ModuleChain ("Opaque" :| ["No.Such.Module"]) :| []) it "names the module that stopped it rather than the import above it" $ withFakeProject [("src/Opaque.hs", opaqueSource)] $ - \rs -> Map.keys . establishedUnsettled <$> askModule rs "Opaque" `shouldReturn` [["No.Such.Module"]] + \rs -> + Map.keys . establishedUnsettled <$> askModule rs Nothing "Opaque" + `shouldReturn` [["No.Such.Module"]] it "follows the reasons down more than one module" $ withFakeProject [ ("src/Near.hs", "module Near ((<+>)) where\nimport Middle\n"), ("src/Middle.hs", "module Middle ((<+>)) where\nimport No.Such.Module\n") ] - $ \rs -> Map.keys . establishedUnsettled <$> askModule rs "Near" `shouldReturn` [["Middle", "No.Such.Module"]] + $ \rs -> + Map.keys . establishedUnsettled <$> askModule rs Nothing "Near" + `shouldReturn` [["Middle", "No.Such.Module"]] it "has nothing to say about a module that could be read" $ withFakeProject [("src/Opaque.hs", opaqueSource)] $ - \rs -> settlesEverything <$> askModule rs "Prelude" `shouldReturn` True + \rs -> + settlesEverything <$> askModule rs Nothing "Prelude" + `shouldReturn` True describe "what a module brings in" $ do it "is every name its interface exports" $ do @@ -1700,6 +1911,41 @@ certainNamesOf rs "Own" `shouldReturn` (Set.fromList [(InTypes, OpName "T"), (InTerms, OpName "C")]) + it "keeps the fixity of a data instance's constructor, with its family" + $ withFakeProject + [ ( "src/Own.hs", + T.unlines + [ "{-# LANGUAGE TypeFamilies #-}", + "module Own (F (..)) where", + "data family F a", + "infixr 5 :+", + "data instance F Int = Int :+ Int" + ] + ) + ] + $ \rs -> + fixitiesOf rs "Own" + `shouldReturn` Just + (Map.singleton (InTerms, OpName ":+") (Fixity RightAssoc 5)) + + it "keeps the fixity of a pattern synonym it bundles with a type" $ + withFakeProject [("src/Own.hs", bundling "T (E, (:<))")] $ + \rs -> + fixitiesOf rs "Own" + `shouldReturn` Just + (Map.singleton (InTerms, OpName ":<") (Fixity RightAssoc 5)) + + it "keeps the constructors of a type exported as T (.., P)" $ + withFakeProject [("src/Own.hs", bundling "T (.., (:<))")] $ + \rs -> + fixitiesOf rs "Own" + `shouldReturn` Just + ( Map.fromList + [ ((InTerms, OpName ":+"), Fixity RightAssoc 4), + ((InTerms, OpName ":<"), Fixity RightAssoc 5) + ] + ) + it "takes the members of a type it hands on from the module the type came from" $ withFakeProject [ ("src/Inner.hs", "module Inner where\ndata T = C | D\n"), @@ -1753,7 +1999,7 @@ ] $ \rs -> do let m = parsed "module C (w) where\nimport A\nimport B\nw :: Int\nw = 1 `clampTo` 2\n" - scope <- scopeFor rs (Is #implicitPrelude) (pure (pmModule m)) + scope <- scopeFor rs Nothing (Is #implicitPrelude) (pure (pmModule m)) lookupFixity scope InTerms Nothing (OpName "clampTo") `shouldBe` Resolved defaultFixity ReportDefault @@ -1764,7 +2010,7 @@ ] $ \rs -> do let m = parsed "module C (w) where\nimport A\nimport B\nw = 1 :+: 2\n" - scope <- scopeFor rs (Is #implicitPrelude) (pure (pmModule m)) + scope <- scopeFor rs Nothing (Is #implicitPrelude) (pure (pmModule m)) lookupFixity scope InTerms Nothing (OpName ":+:") `shouldBe` Unresolved (unreadOnly "A") @@ -1776,7 +2022,7 @@ ] $ \rs -> do let m = parsed "module C (w) where\nimport Core\nimport Tree (Tree (..))\nw = Leaf `Node` Leaf `Node` Leaf\n" - scope <- scopeFor rs (Is #implicitPrelude) (pure (pmModule m)) + scope <- scopeFor rs Nothing (Is #implicitPrelude) (pure (pmModule m)) lookupFixity scope InTerms Nothing (OpName "Node") `shouldBe` Resolved defaultFixity ReportDefault @@ -1788,7 +2034,7 @@ ] $ \rs -> do let m = parsed "module C (w) where\nimport Core\nimport Tree (Tree)\nw = Leaf `Node` Leaf `Node` Leaf\n" - scope <- scopeFor rs (Is #implicitPrelude) (pure (pmModule m)) + scope <- scopeFor rs Nothing (Is #implicitPrelude) (pure (pmModule m)) lookupFixity scope InTerms Nothing (OpName "Node") `shouldBe` Unresolved (ModuleChain ("Core" :| ["A"]) :| []) @@ -1799,7 +2045,7 @@ ] $ \rs -> do let m = parsed "module C (w) where\nimport Ops (T (..))\nimport Other\nw = 1 <+> 2\n" - scope <- scopeFor rs (Is #implicitPrelude) (pure (pmModule m)) + scope <- scopeFor rs Nothing (Is #implicitPrelude) (pure (pmModule m)) lookupFixity scope InTerms Nothing (OpName "<+>") `shouldBe` Resolved (Fixity LeftAssoc 6) (DeclaredIn "Other") @@ -1946,10 +2192,19 @@ writePlan :: FilePath -> Text -> IO () 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. +-- | A project whose @.cabal@ file changed after its plan was written. withChangedPackage :: (FilePath -> IO a) -> IO a withChangedPackage act = + withOwnPlan $ \dir -> do + now <- getCurrentTime + writeUtf8File (dir "thing.cabal") "" + setModificationTime (dir "thing.cabal") (addUTCTime (-30) now) + act dir + +-- | An empty project under a plan of its own, written a minute ago, so +-- that what it leaves in the cache is its own. +withOwnPlan :: (FilePath -> IO a) -> IO a +withOwnPlan act = withTempProject Nothing $ \dir -> do writePlan dir $ "{\"compiler-id\":\"ghc-0.0\",\"install-plan\":\ @@ -1959,8 +2214,6 @@ \\"pkg-src\":{\"type\":\"local\",\"path\":\"/nowhere\"}}]}" now <- getCurrentTime setModificationTime (planPathFor dir) (addUTCTime (-60) now) - writeUtf8File (dir "thing.cabal") "" - setModificationTime (dir "thing.cabal") (addUTCTime (-30) now) act dir -- | A plan naming one package that no package cache can have a tarball @@ -2040,9 +2293,19 @@ record steps args = modifyIORef' steps (<> [args]) -- | A @cabal@ that does nothing and says it went well. -obliging :: IORef [[String]] -> [String] -> IO (Either Text ()) +obliging :: IORef [[String]] -> [String] -> IO (Either CabalFailure ()) obliging steps args = record steps args >> pure (Right ()) +-- | Load the plan of a project as a run does, with the real way of running +-- @cabal@. +loading :: FilePath -> IO (Either Text BuildPlan) +loading = loadPlan (Do #useCache) (Do #download) [] + +-- | What a stand-in for @cabal@ runs to fail, saying what is given on its +-- standard error. +complaining :: String -> String +complaining complaint = "echo '" <> complaint <> "' >&2; exit 1" + -- | Run an assertion on a module's fixities, failing where the module could -- not be resolved at all. needs :: @@ -2062,7 +2325,11 @@ (Scope -> Expectation) -> Expectation endToEnd resolver source assertion = - scopeFor resolver (Is #implicitPrelude) (pure (pmModule (parsed source))) + scopeFor + resolver + Nothing + (Is #implicitPrelude) + (pure (pmModule (parsed source))) >>= assertion -- | Check one expected fixity, returning a description of any mismatch. @@ -2124,6 +2391,20 @@ "f = 1" ] +-- | A module bundling the pattern synonym @:<@ with its type @T@, which has +-- the constructor @:+@, in the export given. +bundling :: Text -> Text +bundling export = + T.unlines + [ "{-# LANGUAGE PatternSynonyms #-}", + "module Own (" <> export <> ") where", + "infixr 4 :+", + "data T = E | Int :+ T", + "infixr 5 :<", + "pattern (:<) :: Int -> T -> T", + "pattern x :< xs = x :+ xs" + ] + -- | A project of made-up modules, with a build plan written by hand. -- -- The plan names one local package and nothing else, which is enough for a @@ -2150,7 +2431,9 @@ " hs-source-dirs: src", " default-language: Haskell2010" ] - traverse_ (\(path, text) -> writeUtf8File (dir path) text) sources + for_ sources $ \(path, text) -> do + createDirectoryIfMissing True (takeDirectory (dir path)) + writeUtf8File (dir path) text writeUtf8File (dir "plan.json") $ "{\"compiler-id\":\"ghc-0.0\",\"install-plan\":\ \[{\"pkg-name\":\"fake\",\"pkg-version\":\"0.1.0.0\",\ diff --git a/tests/Tilia/FixitySpec.hs b/tests/Tilia/FixitySpec.hs --- a/tests/Tilia/FixitySpec.hs +++ b/tests/Tilia/FixitySpec.hs @@ -73,6 +73,12 @@ declaredWithNamespaces "module M where\ninfixl 6 <+>\na <+> b = a\n" `shouldBe` [((InTerms, OpName "<+>"), Fixity LeftAssoc 6)] + it "gives a data instance constructor's fixity to terms" $ + declaredWithNamespaces + "{-# LANGUAGE TypeFamilies #-}\nmodule M where\ninfixr 5 :>\n\ + \data family F a\ndata instance F Int = Int :> Int\n" + `shouldBe` [((InTerms, OpName ":>"), Fixity RightAssoc 5)] + it "gives a pattern synonym's fixity to terms" $ declaredWithNamespaces "{-# LANGUAGE PatternSynonyms #-}\nmodule M where\ninfixl 5 :>\npattern x :> y = (x, y)\n" @@ -127,6 +133,33 @@ lookupFixity (scopeOfBoth "import Terms\n") InTypes Nothing (OpName ":>") `shouldBe` Resolved (Fixity LeftAssoc 5) (DeclaredIn "Terms") + it "takes none for a type a read import brings in" $ + lookupFixity + ( scopeBringing + [("Readable", [(InTypes, ":>")])] + "import Readable\nimport Terms\n" + ) + InTypes + Nothing + (OpName ":>") + `shouldBe` Resolved defaultFixity ReportDefault + + it "takes none for a type the module declares" $ + lookupFixity + (scopeOfBoth "import Terms\ntype a :> b = Either a b\n") + InTypes + Nothing + (OpName ":>") + `shouldBe` Resolved defaultFixity ReportDefault + + it "takes none where an unread import may bring a type in" $ + lookupFixity + (scopeOfBoth "import Terms\nimport Opaque\n") + InTypes + Nothing + (OpName ":>") + `shouldBe` Unresolved (unreadOnly "Opaque") + it "does not take a type's fixity for a term" $ lookupFixity (scopeOfBoth "import Types\n") InTerms Nothing (OpName ":>") `shouldBe` Resolved defaultFixity ReportDefault @@ -147,6 +180,15 @@ fmap snd (unsettledIn "module M where\nimport Terms\nimport Other.Terms\ntype T = Int :> Int\n") `shouldBe` [Ambiguous termsDisagreeing] + it "settles a constructor written with its tick among the terms alone" $ + fmap + snd + ( unsettledIn + "{-# LANGUAGE DataKinds #-}\nmodule M where\nimport Types\n\ + \import Terms\nimport Other.Terms\ntype T = 1 ':> 2\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 @@ -163,6 +205,14 @@ exportsOfSource "module M (module Data.Map) where\n" `shouldBe` Just [ExportModule "Data.Map"] + it "reads T (.., P) as T (..) and T (P) together" $ + exportsOfSource + "{-# LANGUAGE PatternSynonyms #-}\nmodule M (T (.., P)) where\n" + `shouldBe` Just + [ ExportAll Nothing (OpName "T"), + ExportSome Nothing (OpName "T") [OpName "P"] + ] + describe "which unread module an unsettled operator is blamed on" $ do it "passes over one whose export list has no such operator" $ lookupFixity (scopeKnowing [("Opaque", ["<+>"])] usesUnknown) InTerms Nothing (OpName "") @@ -465,6 +515,24 @@ declaredMembersIn "module M where\nclass C a where\n type F a\n" `shouldBe` [(OpName "C", [(InTypes, OpName "F")])] + it "takes a data instance's constructors, under its family" $ + declaredMembersIn + "{-# LANGUAGE TypeFamilies #-}\nmodule M where\n\ + \data family F a\ndata instance F Int = A | Int :| Int\n" + `shouldBe` [ ( OpName "F", + [(InTerms, OpName ":|"), (InTerms, OpName "A")] + ) + ] + + it "takes those of the data instances of a class instance" $ + declaredMembersIn + "{-# LANGUAGE TypeFamilies #-}\nmodule M where\n\ + \instance C Int where\n data F Int = A | Int :| Int\n" + `shouldBe` [ ( OpName "F", + [(InTerms, OpName ":|"), (InTerms, OpName "A")] + ) + ] + it "has nothing to say about a type synonym" $ declaredMembersIn "module M where\ntype T = Int\n" `shouldBe` [] @@ -475,6 +543,12 @@ it "hands on every member of a name exported with (..)" $ listedMembersIn "module M (T (..)) where\ndata T = A | Int :| Int\n" `shouldBe` [(OpName "T", [OpName ":|", OpName "A"])] + + it "hands on every member of a name exported with (..) and the rest" $ + listedMembersIn + "{-# LANGUAGE PatternSynonyms #-}\n\ + \module M (T (.., P)) where\ndata T = A | Int :| Int\npattern P = A\n" + `shouldBe` [(OpName "T", [OpName ":|", OpName "A", OpName "P"])] it "says nothing of the members of a type it does not declare" $ listedMembersIn "module M (T (..)) where\nimport Elsewhere\n" diff --git a/tests/Tilia/IgnoreSpec.hs b/tests/Tilia/IgnoreSpec.hs --- a/tests/Tilia/IgnoreSpec.hs +++ b/tests/Tilia/IgnoreSpec.hs @@ -72,6 +72,9 @@ it "reads lines ended with a carriage return" $ "*.hs\r\n!keep.hs\r\n" `ignores` ["a.hs"] `butNot` ["keep.hs"] + it "reads its first line past a byte order mark" $ + "\xFEFF*.hs\n" `ignores` ["a.hs"] `butNot` [] + describe "ignore files in several directories" $ do it "match from their own directories" $ nested [([], ""), (["src"], "/x/\n")] ["src/x/B.hs"] ["x/B.hs", "src/A.hs"] diff --git a/tests/Tilia/PragmaSpec.hs b/tests/Tilia/PragmaSpec.hs --- a/tests/Tilia/PragmaSpec.hs +++ b/tests/Tilia/PragmaSpec.hs @@ -39,10 +39,36 @@ ("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" - ) + ), + ( "one after a quasi-quotation", + "module M where\nx = [q|a|]\n{-# LINE 9 \"O.hs\" #-}\n" + ), + ("a line marker", "module M where\nx = 1\n# 40 \"O.hs\"\ny = x\n"), + ("one written without a space", "module M where\n#40 \"O.hs\"\n"), + ("one written as a #line", "module M where\n#line 40 \"O.hs\"\n"), + ("one on the first line", "# 1 \"M.hs\"\nmodule M where\n"), + ("one under a script's #! line", "#!/bin/runghc\n# 1 \"M.hs\"\n"), + ("one after a comment", "module M where\n-- x\n# 9 \"O.hs\"\n"), + ("a #pragma line", "module M where\n#pragma once\n"), + ("a #! line below the top", "module M where\n#!/bin/sh\n"), + ("a #! line after a space", " #!/bin/sh\nmodule M where\n") ] - (\source -> movesPositions source `shouldBe` True) + (\source -> movesPositions [QuasiQuotes] source `shouldBe` True) + it "one after a list comprehension, where quasi-quotes are off" $ + movesPositions + [] + "module M where\nxs = [x|x<-[1]]\n{-# LINE 9 \"O.hs\" #-}\n" + `shouldBe` True + + it "a line marker written with a number where CPP is on, which cpp passes on" $ + movesPositions [Cpp] "module M where\n# 9 \"O.hs\"\n" + `shouldBe` True + + it "a #! line below the top where CPP is on, which cpp passes on" $ + movesPositions [Cpp] "module M where\n#!/bin/sh\n" + `shouldBe` True + describe "says nothing of" $ do for_' [ ("a module with no pragma at all", "module M where\nx = 1\n"), @@ -60,9 +86,29 @@ ), ( "one in a string after a name ending in a prime", "module M where\nx = f'\"'\"\ny = \"{-# LINE 1 #-}\"\n" - ) + ), + ( "one in a quasi-quotation", + "module M where\nx = [q|\n{-# LINE 1 \"O.hs\" #-}\n|]\n" + ), + ( "one in a qualified quasi-quotation", + "module M where\nx = [Q.q|{-# LINE 1 \"O.hs\" #-}|]\n" + ), + ("the #! lines a script begins with", "#!/bin/sh\n#!x\n-- stack\n"), + ( "lines GHC reads past, in a quasi-quotation", + "module M where\nx = [q|\n# 9 \"O.hs\"\n#pragma once\n#!/bin/sh\n|]\n" + ), + ("a hash and a number in a block comment", "{-\n#15888 says\n-}\n"), + ("a label opening an indented line", "module M where\nf = g\n #line\n") ] - (\source -> movesPositions source `shouldBe` False) + (\source -> movesPositions [QuasiQuotes] source `shouldBe` False) + + it "a line marker where CPP is on, which cpp reads" $ + movesPositions [Cpp] "module M where\n#line 9 \"O.hs\"\n" + `shouldBe` False + + it "a #pragma line where CPP is on, which cpp reads" $ + movesPositions [Cpp] "module M where\n#pragma once\n" + `shouldBe` False describe "the extensions in force" $ do it "keeps what the package puts in force" $ inForceUnder [ImplicitPrelude, GADTs] "module M where\n" diff --git a/tests/Tilia/RunSpec.hs b/tests/Tilia/RunSpec.hs --- a/tests/Tilia/RunSpec.hs +++ b/tests/Tilia/RunSpec.hs @@ -6,7 +6,6 @@ import Control.Concurrent (getNumCapabilities, threadDelay) import Data.ByteString qualified as BS -import Data.Either (isLeft) import Data.IORef import Data.List.NonEmpty (NonEmpty ((:|))) import Data.Text (Text) @@ -16,7 +15,8 @@ import GHC.Clock (getMonotonicTime) import System.Directory (getModificationTime) import System.FilePath (()) -import System.IO.Temp (withSystemTempDirectory) +import System.IO (Handle, IOMode (ReadWriteMode), withFile) +import System.IO.Temp (withSystemTempDirectory, withSystemTempFile) import Test.Hspec import Tilia.Cabal.Package (PackageProblem (..)) import Tilia.Cpp (CppError (..)) @@ -28,9 +28,11 @@ Unknown (..), ) import Tilia.Format (FormatError (..), formatErrorExitCode, refused) -import Tilia.Palette (Color (Bad), Palette (..)) +import Tilia.Palette (Color (Bad), Palette (..), paletteFor) +import Tilia.Parser (parseModule) import Tilia.Run -import Tilia.Utils (inParallel, lineWidth, visibleLength, wrapTo, writeUtf8File) +import Tilia.TestUtils (defaultParserConfig, withEnvironment, withFiles) +import Tilia.Utils (inParallel, lineWidth, visibleLength, wrapTo) spec :: Spec spec = do @@ -88,13 +90,14 @@ describe "the summary an inplace run prints" $ do it "counts the files it formatted, indented, by extension" $ - reportOut (inplaceReport Plain [("A.hs", Unchanged), ("B.hs", Changed "a" "b")]) + reportOut (inplaceReport Plain Plain [("A.hs", Unchanged), ("B.hs", Changed "a" "b")]) `shouldBe` " [✓] Formatted 2 .hs files\n" it "counts each extension on its own line, in a settled order" $ reportOut ( inplaceReport Plain + Plain [("C.hsig", Unchanged), ("A.hs", Unchanged), ("B.hs-boot", Unchanged)] ) `shouldBe` T.unlines @@ -104,15 +107,15 @@ ] it "says file rather than files when there is one" $ - reportOut (inplaceReport Plain [("A.hs", Unchanged)]) + reportOut (inplaceReport Plain Plain [("A.hs", Unchanged)]) `shouldBe` " [✓] Formatted 1 .hs file\n" it "counts neither a refusal nor a failure among the formatted" $ - reportOut (inplaceReport Plain [("A.hs", Unchanged), ("B.hs", decline), ("C.hs", failure)]) + reportOut (inplaceReport Plain Plain [("A.hs", Unchanged), ("B.hs", decline), ("C.hs", failure)]) `shouldBe` " [✓] Formatted 1 .hs file\n" it "says nothing at all about a run with no files" $ - inplaceReport Plain [] `shouldBe` Report "" [] + inplaceReport Plain Plain [] `shouldBe` Report "" [] describe "the files a run did not format" $ do let mixed = @@ -122,35 +125,44 @@ ] it "tallies refusals and failures apart, and puts refusals first" $ - filter (T.isInfixOf "] ") (reportErr (inplaceReport Plain mixed)) + filter (T.isInfixOf "] ") (reportErr (inplaceReport Plain Plain mixed)) `shouldBe` [ " [=] Declined 1 .hs file", " [=] Declined 1 .hs-boot file", " [✗] Failed 1 .hs file" ] it "gives a reason for every one of them" $ - length (filter opensAReason (reportErr (inplaceReport Plain mixed))) + length (filter opensAReason (reportErr (inplaceReport Plain Plain mixed))) `shouldBe` 3 it "says what a file that would not settle did" $ reportErr - (inplaceReport Plain [("A.hs", Failed (NotIdempotent "A.hs" "line 12 differs"))]) + (inplaceReport Plain Plain [("A.hs", Failed (NotIdempotent "A.hs" "line 12 differs"))]) `shouldSatisfy` any (T.isInfixOf "A.hs is not idempotent: line 12 differs") it "names the file in the reason, once" $ - reportErr (inplaceReport Plain mixed) + reportErr (inplaceReport Plain Plain mixed) `shouldSatisfy` any (T.isInfixOf "cannot read a.hs: no such file") + it "names a file once where one of its configurations does not parse" $ + case parseModule defaultParserConfig "A.hs" "x = (" of + Right _ -> expectationFailure "x = ( parsed" + Left e -> do + let said = flattened (inplaceReport Plain Plain [("A.hs", Declined why)]) + why = CppUnsupported "A.hs" (ConfigurationNotParsed [] e) + said `shouldSatisfy` T.isInfixOf "will not format A.hs:" + T.count "A.hs" said `shouldBe` 1 + it "orders the reasons by file, not by arrival" $ - reportErr (inplaceReport Plain mixed) - `shouldBe` reportErr (inplaceReport Plain (reverse mixed)) + reportErr (inplaceReport Plain Plain mixed) + `shouldBe` reportErr (inplaceReport Plain Plain (reverse mixed)) it "opens every case with a bullet" $ - filter opensAReason (reportErr (inplaceReport Plain mixed)) + filter opensAReason (reportErr (inplaceReport Plain Plain mixed)) `shouldSatisfy` all (T.isPrefixOf " · ") it "lines a wrapped case up with the text of its bullet" $ - reportErr (inplaceReport Plain [("A.hs", Failed (Unreadable "A.hs" (T.replicate 20 "and more words ")))]) + reportErr (inplaceReport Plain Plain [("A.hs", Failed (Unreadable "A.hs" (T.replicate 20 "and more words ")))]) `shouldSatisfy` \case (_tallyLine : opening : continuation : _) -> T.isPrefixOf " · " opening @@ -158,57 +170,58 @@ _ -> False it "lays an unsettled operator at the door of the run, not of the module" $ - flattened (inplaceReport Plain [("A.hs", missing "Criterion.Main")]) + flattened (inplaceReport Plain Plain [("A.hs", missing "Criterion.Main")]) `shouldSatisfy` T.isInfixOf "the fixity of <|> may be declared in Criterion.Main, which this run could not read" it "counts the modules when the answer could be in more than one" $ - flattened (inplaceReport Plain [("A.hs", missingIn ["Criterion.Main", "Test.Tasty"])]) + flattened (inplaceReport Plain Plain [("A.hs", missingIn ["Criterion.Main", "Test.Tasty"])]) `shouldSatisfy` T.isInfixOf "may be declared in Criterion.Main or Test.Tasty, neither of which this run could read" it "names the module reading stopped at, not only the import above it" $ flattened - (inplaceReport Plain [("A.hs", missingThrough [ModuleChain ("Test.Hspec" :| ["Test.QuickCheck.Property"])])]) + (inplaceReport Plain Plain [("A.hs", missingThrough [ModuleChain ("Test.Hspec" :| ["Test.QuickCheck.Property"])])]) `shouldSatisfy` T.isInfixOf "may be declared in Test.Hspec → Test.QuickCheck.Property, which this run could not read" it "gives one answer once however many operators share it" $ - flattened (inplaceReport Plain [("A.hs", missingTwice "Criterion.Main")]) + flattened (inplaceReport Plain Plain [("A.hs", missingTwice "Criterion.Main")]) `shouldSatisfy` T.isInfixOf "the fixities of <|> and <+> may be declared in Criterion.Main, which this run could not read" it "puts a comma before the and once there are three of them" $ - flattened (inplaceReport Plain [("A.hs", missingAll ["<|>", "<+>", "<*>"] "Criterion.Main")]) + flattened (inplaceReport Plain Plain [("A.hs", missingAll ["<|>", "<+>", "<*>"] "Criterion.Main")]) `shouldSatisfy` T.isInfixOf "the fixities of <|>, <+>, and <*> may be declared in" it "leaves a pair without one" $ - flattened (inplaceReport Plain [("A.hs", missingAll ["<|>", "<+>"] "Criterion.Main")]) + flattened (inplaceReport Plain Plain [("A.hs", missingAll ["<|>", "<+>"] "Criterion.Main")]) `shouldSatisfy` T.isInfixOf "the fixities of <|> and <+> may be declared in" it "counts each answer's operators rather than the file's" $ - flattened (inplaceReport Plain [("A.hs", twoAnswers)]) + flattened (inplaceReport Plain Plain [("A.hs", twoAnswers)]) `shouldSatisfy` T.isInfixOf "the fixity of <|> may be declared in Criterion.Main, which this run \ \could not read, and the fixity of <+> is infixl 6 in Left but infixr 5 \ \in Right" it "names the imports that disagree and what each brings" $ - flattened (inplaceReport Plain [("A.hs", about "<+>")]) + flattened (inplaceReport Plain Plain [("A.hs", about "<+>")]) `shouldSatisfy` T.isInfixOf "the fixity of <+> is infixl 6 in Left but infixr 5 in Right" it "gathers the imports that agree with one another" $ - flattened (inplaceReport Plain [("A.hs", disagreeing (leftSix :| [rightFive, ("Middle", Fixity LeftAssoc 6)]))]) + flattened (inplaceReport Plain Plain [("A.hs", disagreeing (leftSix :| [rightFive, ("Middle", Fixity LeftAssoc 6)]))]) `shouldSatisfy` T.isInfixOf "is infixl 6 in Left and Middle but infixr 5 in Right" it "lists three fixities the way it lists three of anything" $ - flattened (inplaceReport Plain [("A.hs", disagreeing (leftSix :| [rightFive, ("Third", Fixity NoAssoc 4)]))]) + flattened (inplaceReport Plain Plain [("A.hs", disagreeing (leftSix :| [rightFive, ("Third", Fixity NoAssoc 4)]))]) `shouldSatisfy` T.isInfixOf "is infixl 6 in Left, infixr 5 in Right, and infix 4 in Third" it "gives one disagreement once however many operators share it" $ flattened ( inplaceReport Plain + Plain [ ( "A.hs", Declined ( UnknownFixity @@ -223,27 +236,27 @@ `shouldSatisfy` T.isInfixOf "the fixities of <|> and <+> are infixl 6 in Left but infixr 5 in Right" it "keeps all of it off the stream the summary goes to" $ - reportOut (inplaceReport Plain mixed) `shouldBe` "" + reportOut (inplaceReport Plain Plain mixed) `shouldBe` "" it "says the same about them in either command" $ - reportErr (checkReport Plain mixed) `shouldBe` reportErr (inplaceReport Plain mixed) + reportErr (checkReport Plain Plain mixed) `shouldBe` reportErr (inplaceReport Plain Plain mixed) describe "what a check run prints" $ do it "shows a diff for a file that would change" $ - reportOut (checkReport Plain [("A.hs", Changed "one\n" "two\n")]) + reportOut (checkReport Plain Plain [("A.hs", Changed "one\n" "two\n")]) `shouldSatisfy` T.isInfixOf "--- a/A.hs" it "heads it the way git heads one" $ - reportOut (checkReport Plain [("A.hs", Changed "one\n" "two\n")]) + reportOut (checkReport Plain Plain [("A.hs", Changed "one\n" "two\n")]) `shouldSatisfy` T.isInfixOf "diff --git a/A.hs b/A.hs" it "shows the removal and the addition" $ do - let shown = reportOut (checkReport Plain [("A.hs", Changed "one\n" "two\n")]) + let shown = reportOut (checkReport Plain Plain [("A.hs", Changed "one\n" "two\n")]) shown `shouldSatisfy` T.isInfixOf "-one" shown `shouldSatisfy` T.isInfixOf "+two" it "says nothing on standard output about a file it did not format" $ - reportOut (checkReport Plain [("A.hs", Unchanged), ("B.hs", decline), ("C.hs", failure)]) + reportOut (checkReport Plain Plain [("A.hs", Unchanged), ("B.hs", decline), ("C.hs", failure)]) `shouldBe` "" describe "what a for-editor run prints" $ do @@ -268,54 +281,75 @@ describe "color" $ do it "leaves everything bare when there is nobody to see it" $ - reportOut (inplaceReport Plain [("A.hs", Unchanged)]) + reportOut (inplaceReport Plain Plain [("A.hs", Unchanged)]) `shouldSatisfy` (not . T.isInfixOf "\ESC") it "colors the tick and not the brackets around it" $ - reportOut (inplaceReport Colors [("A.hs", Unchanged)]) + reportOut (inplaceReport Colors Colors [("A.hs", Unchanged)]) `shouldSatisfy` T.isInfixOf "[\ESC[32m✓\ESC[0m]" it "colors the equals sign yellow" $ - reportErr (inplaceReport Colors [("A.hs", decline)]) + reportErr (inplaceReport Colors Colors [("A.hs", decline)]) `shouldSatisfy` any (T.isInfixOf "[\ESC[33m=\ESC[0m]") it "sets the extension in the summary in bold" $ - reportOut (inplaceReport Colors [("A.hs", Unchanged)]) + reportOut (inplaceReport Colors Colors [("A.hs", Unchanged)]) `shouldSatisfy` T.isInfixOf "\ESC[1m.hs\ESC[0m" it "sets the file a case is about in bold, and nothing around it" $ - reportErr (inplaceReport Colors [("src/A.hs", failureAbout "src/A.hs")]) + reportErr (inplaceReport Colors Colors [("src/A.hs", failureAbout "src/A.hs")]) `shouldSatisfy` any (T.isInfixOf "\ESC[1msrc/A.hs\ESC[0m") it "leaves the file bare when there is nobody to see it" $ - reportErr (inplaceReport Plain [("src/A.hs", failureAbout "src/A.hs")]) + reportErr (inplaceReport Plain Plain [("src/A.hs", failureAbout "src/A.hs")]) `shouldSatisfy` all (not . T.isInfixOf "\ESC") it "sets an operator a message names in cyan" $ - reportErr (inplaceReport Colors [("A.hs", about "<|>")]) + reportErr (inplaceReport Colors Colors [("A.hs", about "<|>")]) `shouldSatisfy` any (T.isInfixOf "\ESC[36m<|>\ESC[0m") it "matches an operator as a whole word and not as a fragment" $ do - let shown = T.unlines (reportErr (inplaceReport Colors [("A.hs", about ".")])) + let shown = T.unlines (reportErr (inplaceReport Colors Colors [("A.hs", about ".")])) T.count "\ESC[36m" shown `shouldBe` 1 shown `shouldSatisfy` T.isInfixOf "\ESC[1mA.hs\ESC[0m" it "leaves the operator bare when there is nobody to see it" $ - reportErr (inplaceReport Plain [("A.hs", about "<|>")]) + reportErr (inplaceReport Plain Plain [("A.hs", about "<|>")]) `shouldSatisfy` all (not . T.isInfixOf "\ESC") it "sets a module a message names in bold" $ - reportErr (inplaceReport Colors [("A.hs", missing "Criterion.Main")]) + reportErr (inplaceReport Colors Colors [("A.hs", missing "Criterion.Main")]) `shouldSatisfy` any (T.isInfixOf "\ESC[1mCriterion.Main\ESC[0m") it "colors a module even where a comma follows it" $ - reportErr (inplaceReport Colors [("A.hs", missing "Criterion.Main")]) + reportErr (inplaceReport Colors Colors [("A.hs", missing "Criterion.Main")]) `shouldSatisfy` any (T.isInfixOf "\ESC[1mCriterion.Main\ESC[0m,") it "colors the cross red" $ - reportErr (inplaceReport Colors [("A.hs", failure)]) + reportErr (inplaceReport Colors Colors [("A.hs", failure)]) `shouldSatisfy` any (T.isInfixOf "[\ESC[31m✗\ESC[0m]") + it "colors each stream with a palette of its own" $ do + let summary = inplaceReport Colors Plain [("A.hs", Unchanged), ("B.hs", decline)] + diffs = checkReport Plain Colors [("A.hs", Changed "a\n" "b\n"), ("B.hs", decline)] + reportOut summary `shouldSatisfy` T.isInfixOf "\ESC" + reportErr summary `shouldSatisfy` all (not . T.isInfixOf "\ESC") + reportOut diffs `shouldSatisfy` (not . T.isInfixOf "\ESC") + reportErr diffs `shouldSatisfy` any (T.isInfixOf "\ESC") + + it "colors what goes to a terminal, and nothing else" $ + withEnvironment [("NO_COLOR", "")] . withTerminal $ \terminal -> + withSystemTempFile "tilia-run" $ \_ file -> + ((,) <$> paletteFor terminal <*> paletteFor file) + `shouldReturn` (Colors, Plain) + + it "turns colors off for a NO_COLOR that is set, but not for an empty one" $ + withTerminal $ \terminal -> do + withEnvironment [("NO_COLOR", "1")] (paletteFor terminal) + `shouldReturn` Plain + withEnvironment [("NO_COLOR", "")] (paletteFor terminal) + `shouldReturn` Colors + describe "breaking text to fit" $ do it "keeps every line within the room given" $ fmap T.length (wrapTo 20 (T.replicate 40 "word ")) `shouldSatisfy` all (<= 20) @@ -350,11 +384,11 @@ ("another/quite/deeply/nested/one/Module.hs", failure) ] it "never prints a line wider than it allows itself" $ - fmap T.length (reportErr (inplaceReport Plain sprawling)) + fmap T.length (reportErr (inplaceReport Plain Plain sprawling)) `shouldSatisfy` all (<= lineWidth) it "does the same when the reason is enormous" $ - fmap T.length (reportErr (inplaceReport Plain [("A.hs", Failed (Unreadable "A.hs" (T.replicate 40 "and more words ")))])) + fmap T.length (reportErr (inplaceReport Plain Plain [("A.hs", Failed (Unreadable "A.hs" (T.replicate 40 "and more words ")))])) `shouldSatisfy` all (<= lineWidth) it "wraps what it says when it gives up, too" $ @@ -374,10 +408,10 @@ withBytes (BS.pack [0x6D, 0xFF, 0xFE, 0x0A]) $ \path -> readAsUtf8 path `shouldReturn` Left "it is not valid UTF-8" - it "says so when it is not there" $ + it "says so when it is not there, without naming it again" $ withSystemTempDirectory "tilia-run" $ \directory -> - (isLeft <$> readAsUtf8 (directory "gone.hs")) - `shouldReturn` True + readAsUtf8 (directory "gone.hs") + `shouldReturn` Left "does not exist" it "hands over the line endings it found, rather than the platform's" $ withBytes "module A where\r\n" $ \path -> @@ -407,9 +441,9 @@ it "counts a file whose endings disagree as one that would change" $ differs (formattingOutcome "a\r\nb\nc\r\n" "a\nb\nc\n") `shouldBe` True - it "says as much in the diff, having nothing else to show" $ - reportOut (checkReport Plain [("A.hs", formattingOutcome "a\r\nb\nc\r\n" "a\nb\nc\n")]) - `shouldSatisfy` T.isInfixOf "differ only in how they end their lines" + it "shows the line whose ending would change in the diff" $ + reportOut (checkReport Plain Plain [("A.hs", formattingOutcome "a\r\nb\nc\r\n" "a\nb\nc\n")]) + `shouldSatisfy` T.isInfixOf "\n-b\n+b\r\n" it "leaves a carriage return that is not a line ending where it is" $ written (formattingOutcome "x = \"a\\\r b\"\r\n" "y = \"a\\\r b\"\n") @@ -418,18 +452,18 @@ describe "putting a file back" $ do it "writes one that changed" $ withSource "module A where\n" $ \path -> do - writeBack (path, Changed "module A where\n" "module B where\n") + _ <- writeBack (path, Changed "module A where\n" "module B where\n") T.readFile path `shouldReturn` "module B where\n" it "writes it as UTF-8, and as the bytes it was given" $ withSource "module A where\n" $ \path -> do - writeBack (path, Changed "module A where\n" "-- ✓ über\r\n") + _ <- writeBack (path, Changed "module A where\n" "-- ✓ über\r\n") BS.readFile path `shouldReturn` T.encodeUtf8 "-- ✓ über\r\n" it "takes back exactly what it read, over a whole round trip" $ withBytes (T.encodeUtf8 "-- ü\r\nmodule A where\r\n") $ \path -> do Right asItIs <- readAsUtf8 path - writeBack (path, formattingOutcome asItIs "-- ü\nmodule B where\n") + _ <- writeBack (path, formattingOutcome asItIs "-- ü\nmodule B where\n") BS.readFile path `shouldReturn` T.encodeUtf8 "-- ü\r\nmodule B where\r\n" it "leaves one that did not alone, down to its modification time" $ @@ -441,6 +475,13 @@ it "leaves one it could not format alone" $ untouched failure + it "fails one it cannot write, and says why" $ + withSystemTempDirectory "tilia-run" $ \directory -> do + let path = directory "gone" "A.hs" + (_, outcome) <- writeBack (path, Changed "module A where\n" "x\n") + flattened (inplaceReport Plain Plain [(path, outcome)]) + `shouldSatisfy` T.isInfixOf ("cannot write " <> T.pack path) + describe "running over many files at once" $ do it "answers in the order it was asked, not the order it finished" $ do answers <- inParallel (\n -> threadDelay (1000 * (40 - n)) >> pure n) [1 .. 20 :: Int] @@ -481,11 +522,7 @@ -- | A file with the given contents, in a directory of its own. withSource :: Text -> (FilePath -> IO a) -> IO a -withSource contents act = - withSystemTempDirectory "tilia-run" $ \directory -> do - let path = directory "A.hs" - writeUtf8File path contents - act path +withSource contents act = withFiles [("A.hs", contents)] (act . ( "A.hs")) -- | The same, for a file that has to hold exactly these bytes. withBytes :: BS.ByteString -> (FilePath -> IO a) -> IO a @@ -501,13 +538,17 @@ Changed _ wouldBe -> Just wouldBe _ -> Nothing +-- | A terminal, the master side of a new pseudo-terminal. +withTerminal :: (Handle -> IO a) -> IO a +withTerminal = withFile "/dev/ptmx" ReadWriteMode + -- | Writing this outcome back should do nothing whatsoever. untouched :: Outcome -> Expectation untouched outcome = withSource "module A where\n" $ \path -> do stamped <- getModificationTime path threadDelay 10000 - writeBack (path, outcome) + _ <- writeBack (path, outcome) stampedAgain <- getModificationTime path stampedAgain `shouldBe` stamped T.readFile path `shouldReturn` "module A where\n" diff --git a/tests/Tilia/TestUtils.hs b/tests/Tilia/TestUtils.hs --- a/tests/Tilia/TestUtils.hs +++ b/tests/Tilia/TestUtils.hs @@ -54,7 +54,8 @@ doesDirectoryExist, listDirectory, ) -import System.Environment (lookupEnv, setEnv, unsetEnv) +import System.Environment (lookupEnv) +import System.Environment.Blank (setEnv, unsetEnv) import System.FilePath (takeBaseName, takeDirectory, takeExtension, ()) import System.IO (mkTextEncoding) import System.IO.Temp (withSystemTempDirectory) @@ -88,17 +89,18 @@ 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. +-- | Run something with the given variables set, to empty values too, and the +-- environment as it was afterwards however it turns out. withEnvironment :: [(String, String)] -> IO a -> IO a withEnvironment vars act = bracket set restore (const act) where set = traverse remember vars remember (key, value) = do was <- lookupEnv key - setEnv key value + setEnv key value True pure (key, was) - restore = traverse_ (\(key, was) -> maybe (unsetEnv key) (setEnv key) was) + restore = traverse_ $ \(key, was) -> + maybe (unsetEnv key) (\value -> setEnv key value True) was -- | Run something on a new temporary directory, by its canonical path, -- holding these files at their paths in it. @@ -249,7 +251,7 @@ routedResolver :: [Route] -> BuildPlan -> IO Resolver routedResolver routes plan = do packageReader <- newPackageReader (plannedCompiler plan) [] - newResolverVia (Do #useCache) routes packageReader plan + newResolverVia (Do #useCache) routes packageReader "." plan -- | Split a module on its first outermost conditional, and on every other -- one written behind the same directives, wherever in the module it sits. diff --git a/tests/Tilia/WithProjectPlan.hs b/tests/Tilia/WithProjectPlan.hs --- a/tests/Tilia/WithProjectPlan.hs +++ b/tests/Tilia/WithProjectPlan.hs @@ -82,7 +82,7 @@ absent <- filterM (fmap not . doesFileExist . snd) . filter (not . (`Set.member` unread) . ppName . fst) - =<< plannedTarballs noCache plan + =<< plannedTarballs noCache "." plan unless (null absent) $ do putStrLn ("fetching the source of " <> show (length absent) <> " package(s)") refused <- filterM (fmap isNothing . fetch . fst) absent 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.3.0 +version: 0.1.4.0 license: BSD-3-Clause license-file: LICENSE.md author: Mark Karpov