diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,35 @@ +# Changelog + +All notable changes to this project will be documented in this file. + +The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.1.0/), +and versions follow the [Haskell PVP](https://pvp.haskell.org/), as described in [CONTRIBUTING.md](CONTRIBUTING.md). + +## [0.1.0.0] - 2026-10-27 + +Initial release. + +- Immutable, lossless green trees (`Graft.Green`) with caller-defined syntax + kinds, cached UTF-8 byte lengths and child offsets, and structural sharing. + Persistent replacement, splicing, insertion and removal of a node's + children, with structured errors. Folds and traversals over trees, `Functor` + over kinds, and `NFData`, `Hashable` and `Exception` instances. +- Read-only cursors (`Graft.Cursor`): a zipper with parent, child, sibling, + ancestor and token navigation, absolute byte ranges, and lookup by offset or + range. Navigation never rebuilds the tree. +- Edits as values (`Graft.Edit`): plans of replacements, splices, insertions + and removals that all refer to the base tree and are applied together, with + conflicts rejected; the same plan as text edits to the source; and a + top-down rewrite that shares every untouched subtree. +- Builders for parsers (`Graft.Builder`, `Graft.Build`), as a pure value or in + a monad, with checkpoints for wrapping already-emitted elements. +- Typed AST views over cursors (`Graft.Ast`), written by hand per grammar. +- A line index (`Graft.LineIndex`) for line and column positions in UTF-8 + bytes or UTF-16 code units, with a separate position type for each unit. +- Byte ranges (`Graft.Range`) and the `Graft` module, which exports the types + and classes; functions are meant for qualified import, as in `Cursor.parent` + and `Edit.apply`. + +[0.1.0.0]: https://github.com/andreabedini/graft/releases/tag/v0.1.0.0 + + diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md new file mode 100644 --- /dev/null +++ b/CONTRIBUTING.md @@ -0,0 +1,156 @@ +# Contributing to Graft + +## Build and test + +```sh +cabal build all --enable-tests --enable-benchmarks --ghc-options=-Werror +cabal test all --enable-tests --enable-benchmarks --ghc-options=-Werror --test-show-details=direct +cabal haddock lib:graft +``` + +The test command repeats the build flags so that cabal doesn't reconfigure and +rebuild without `-Werror`. + +Graft is tested with GHC 9.8, 9.10, 9.12 and 9.14 (see `tested-with` in +`graft.cabal`). There are four test suites: + +- `graft-tests` checks the library against independent models. +- `graft-getting-started` builds and runs + [`examples/GettingStarted.hs`](examples/GettingStarted.hs), the program in + the README. Keep the two identical; CI compares them. +- `graft-example` builds and runs [`examples/ExactUpdate.hs`](examples/ExactUpdate.hs), + so changes to the API that break the example break the build. +- `graft-doctest` checks every `>>>` example in the Haddock documentation. It + is off by default because it needs the `doctest` package and a GHC + environment file, which cabal writes at the end of a build: + + ```sh + cabal build all -fdoctest + cabal test graft-doctest -fdoctest + ``` + + On a fresh checkout the first `cabal test` would run before the file exists, + so build first; the suite says so if the file is missing. The repository's + `cabal.project` makes cabal write the file; from a source tarball, add + `--write-ghc-environment-files=always` to the build. Examples in + `@`-blocks and `>`-blocks are not checked, so keep those short and compile + them by hand when they change. + +## How the tests work + +Each property compares the library with a model that shares none of its code. +`test/TestModel.hs` defines a plain rose tree of `String`s with no cached +lengths and its own UTF-8 width function. Generated text includes multibyte +characters, combining marks, CRLF, NUL and empty tokens, and shrinking never +produces surrogate code points. Every property runs 1,000 cases. The +replacement and navigation properties use `checkCoverage` to confirm that the +generators reach root and nested targets, nodes and tokens. + +The suites are grouped by module: + +- `test/Main.hs`: rendering, cached lengths, replacement at every path, + cursor navigation, offset lookup and covering ranges. Expectations are + stated by path, through helpers in `TestModel.hs` written with cursors and + plans. +- `test/CursorTests.hs`: random programs of moves and lookups, run on a + cursor and on the model. +- `test/EditTests.hs`: rewrites against a model driven by a generated + decision table, and edit plans against a merge written over the model's + lists and a predicate stating the conflict rules, with the patch law for + text edits and sharing checked with `StableName`. +- `test/FoldTests.hs`: `Green.foldM`, `fold`, `map` and `traverse` against the + model, and forcing and hashing. +- `test/BuilderTests.hs`: builders, checked against a separate tree model that + streams start, token and finish events, including checkpoint wrapping and the + `Build` monad. +- `test/ChildEditTests.hs`: splicing, insertion and removal, including shifted + paths and ranges and the order in which errors are reported. +- `test/AstTests.hs`: typed-view laws, fields, ancestors and edits through views. +- `test/LineIndexTests.hs`: line and column conversion against a `String` oracle. + +Most groups end with deterministic regressions for edge cases: empty nodes and +tokens, extreme indices such as `maxBound`, and shared trees whose logical length +(`2 ^ hugeDepth` bytes) is far larger than anything that could be rendered. + +## Benchmarks + +[`bench/README.md`](bench/README.md) explains how to run the benchmarks and +compare results. [`docs/performance.md`](docs/performance.md) records the +current baseline. Rerun the baseline when a change affects performance, and keep +the raw results under `bench/results//` rather than editing tables by hand. + +## Commit messages + +Keep each commit to one concern. + +Commit messages follow [Conventional Commits](https://www.conventionalcommits.org/). For example: + +``` +fix(green): fail on length overflow instead of wrapping +feat(green): map kinds with Functor and hash trees with Hashable +refactor(cursor)!: exclude the focus from ancestors +docs(cursor): state the real cost of a run of cursor edits +``` + +The allowed types are `feat`, `fix`, `perf`, `docs`, `ci`, `test`, `refactor`, `build`, `chore`, `style` and `revert`. A scope in parentheses is optional. `!` before the colon, or a `BREAKING CHANGE:` footer, marks a breaking change. The `commits` CI job checks every commit of a pull request with [git-cliff](https://git-cliff.org/), so the allowed types are the ones that the commit parsers in `cliff.toml` know. There is no local commit hook, so this CI job is the only check. + +The commit types choose the next version: + +| Commits since the last release | Next version | +|---|---| +| At least one breaking change, of any type | `B` + 1 | +| At least one `feat` | `C` + 1 | +| At least one `fix` or `perf` | `D` + 1 | +| Only `docs`, `ci`, `test`, `refactor`, `build`, `chore`, `style` | No release | + +Pull requests are merged with rebase merge. A squash merge would leave only the PR title for the release task to read. + +## Versions + +Versions follow the [Haskell PVP](https://pvp.haskell.org/) and have four components, `A.B.C.D`, for example `0.1.0.0`. `A.B` is the major version, `C` the minor version and `D` the patch version. + +- git-cliff calculates the next version from the commit types, as in the table above. This is SemVer applied to `B.C.D`. There is no special rule for versions below 1.0: a breaking change increments `B` even when it is `0`. +- Incrementing a field sets all fields to its right to `0`. +- `A` changes only by hand, when the maintainer decides that a release deserves a new number. Like a change of `B`, it makes a major release. +- Release tags are `v` followed by the version, for example `v0.1.0.0`. The first release is `0.1.0.0`. +- Every package in `cabal.project` has the version of the release. + +The `version:` fields in the `.cabal` files are the only source of the version. Only the release task, and the maintainer in a release PR, change them and `CHANGELOG.md`. + +## Making a release + +The maintainer makes releases. + +1. Make sure that `main` is green. +2. Run `mise run release-pr`. It reads the commits since the last release tag, sets the next version in every `.cabal` file, regenerates `CHANGELOG.md` with [git-cliff](https://git-cliff.org/), and opens a pull request titled `chore(release): VERSION`. If there are no releasable commits, it says so and does nothing. +3. Review the pull request. To increment `A`, change the version by hand in every `.cabal` file, and change the `CHANGELOG.md` header and the commit description to the same version. Edits to `CHANGELOG.md` are lost at the next release, which regenerates it; wording that must stay goes in `cliff.toml`. +4. When `ci-ok` passes, merge the pull request with rebase merge. +5. CI's `release` job sees the release commit on `main`. It publishes a GitHub release with the source distribution `graft-VERSION.tar.gz` and its Hackage documentation `graft-VERSION-docs.tar.gz`, their `SHA256SUMS`, and the notes from `CHANGELOG.md`. Publishing creates the tag. Then the `pages` job publishes the documentation of the release to . +6. Verify the release: + + ``` + gh release verify vVERSION + gh attestation verify ASSET --repo andreabedini/graft + ``` + +To publish a release on Hackage too, upload its source distribution and its documentation, which were built by CI, from the GitHub release: + +``` +gh release download vVERSION --repo andreabedini/graft --pattern 'PACKAGE-VERSION*.tar.gz' +cabal upload --publish PACKAGE-VERSION.tar.gz +cabal upload --publish --documentation PACKAGE-VERSION-docs.tar.gz +``` + +Releases are immutable: a published version cannot change. If a release is wrong, fix it and make a new release. If the `release` job fails before it publishes, rerun the failed jobs; the job continues the draft release. + +### Release artifacts without a release + +Every CI run, on a pull request or started by hand, uploads everything that a release would publish as one artifact, `dist`: the same files and `SHA256SUMS`, without attestations. To get them for any branch without releasing: + +``` +gh workflow run ci.yml --ref BRANCH +gh run list --workflow ci.yml --branch BRANCH --event workflow_dispatch --limit 1 +gh run download RUN_ID --name dist +``` + +The `release` job runs only on a push to `main`, so a manual run never releases. The `github-pages` artifact of a run is the documentation site, as a tar file. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2026 Andrea Bedini + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/NOTICE b/NOTICE new file mode 100644 --- /dev/null +++ b/NOTICE @@ -0,0 +1,12 @@ +Graft is an idiomatic Haskell port of the core ideas in Rowan, developed by +the rust-analyzer project: https://github.com/rust-analyzer/rowan + +The initial implementation was written in Haskell after studying Rowan's +green trees, cursor editing, builders, cache, and tests at revision +b6f1cb6494a99a2264186d110b1b170989774814 (version 0.17.0 in Cargo.toml), +retrieved on 2026-10-10. Graft is not affiliated with the Rowan project. + +Rowan is copyright Aleksey Kladov and the rust-analyzer contributors, and is +available under MIT OR Apache-2.0. Its MIT permission notice is preserved +verbatim in licenses/ROWAN-MIT. Graft's own code is MIT licensed; +see LICENSE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,139 @@ +# Graft + +Lossless, immutable concrete syntax trees for Haskell, modelled on +rust-analyzer's [Rowan](https://github.com/rust-analyzer/rowan). + +A Graft tree keeps every byte of the source: whitespace, comments and malformed +fragments are ordinary tokens. You can navigate the tree, find the syntax at a +byte offset, edit it and print it back, and everything you didn't touch comes +out exactly as it went in. That makes it a base for formatters, refactoring +and codemod tools, and language servers. You supply the lexer and +parser; Graft supplies the tree. + +Graft is experimental. The API may change before 1.0. + +## Getting started + +Add `graft` to your `build-depends`. If your Hackage index doesn't have the +release you want, take it from its tag in `cabal.project`: + +```cabal +source-repository-package + type: git + location: https://github.com/andreabedini/graft + tag: v0.1.0.0 +``` + +This program builds a tree, finds the number at byte offset 5, replaces it, +and prints the source before and after: + +```haskell +{-# LANGUAGE OverloadedStrings #-} +module Main (main) where + +import qualified Data.Text.IO as Text +import Graft +import qualified Graft.Build as Build +import qualified Graft.Cursor as Cursor +import qualified Graft.Edit as Edit +import qualified Graft.Green as Green +import qualified Graft.Range as Range + +data Kind = Root | Binding | Name | Number | Trivia + deriving (Eq, Show) + +-- A parser would emit these events; here they are written by hand. +parsed :: Either BuilderError (GreenNode Kind) +parsed = Build.exec $ Build.node Root $ do + Build.node Binding $ do + Build.token Name "x" + Build.token Trivia " = " + Build.token Number "1" + Build.token Trivia " -- keep\r\n" + +main :: IO () +main = do + tree <- either (fail . show) pure parsed + Text.putStr (Green.renderNode tree) + case Cursor.covering (Range.fromLength 5 1) (Cursor.fromGreen (Node tree)) of + Just number -> do + let edits = [Edit.replace number (Token (Green.token Number "42"))] + edited <- either (fail . show) pure (Edit.apply (Node tree) edits) + Text.putStr (Green.render edited) + Nothing -> fail "nothing at offset 5" +``` + +It prints: + +```text +x = 1 -- keep +x = 42 -- keep +``` + +The double space, the comment and the CRLF line ending survive the edit. + +`Cursor.covering` returns the innermost element that contains a range, here +the one byte at offset 5. `Cursor.tokenAt 5` would return both tokens that +touch offset 5, `" = "` and `"1"`, as an editor's caret between them touches +both. `Edit.replace` describes a change at a cursor, and `Edit.apply` makes a +list of such changes to the tree they were made on, all at once, sharing +everything the changes don't touch. `Edit.textEdits` gives the same changes +as edits to the source text, for an editor. + +## How it fits together + +- **Green trees** (`Graft.Green`) are immutable nodes and tokens tagged with + your own syntax-kind type. Each node caches its length in UTF-8 bytes and the + offset of each child, so length and child lookups don't traverse anything. + Green values have no parents or positions, so equal subtrees can be shared, + within a tree and between versions of it. `Green.foldM`, `Green.fold`, + `Green.map` and `Green.traverse` cover a whole tree. +- **Cursors** (`Graft.Cursor`) are zippers over a green tree. They know their + parent, siblings and absolute byte range, and find tokens by offset. +- **Edits** (`Graft.Edit`) are described against a tree through its cursors + and made all at once: a plan of replacements, splices, insertions and + removals, or a top-down rewrite that replaces elements as it goes. Every + decision reads the original tree, unchanged subtrees are shared with it, + and a plan also yields the edits to the source text. +- **Builders** (`Graft.Build`, `Graft.Builder`) turn a parser's start/token/finish + events into a tree, in a monad or as a pure value. Checkpoints let a parser + wrap elements it has already emitted, as an operator-precedence parser needs + to. +- **Typed views** (`Graft.Ast`) are newtypes over cursors that give your + grammar's nodes typed accessors, without building a separate AST. +- **Byte ranges** (`Graft.Range`) describe where things are. +- **Line index** (`Graft.LineIndex`) converts byte offsets to and from line and + column positions, including the UTF-16 columns used by the Language Server + Protocol. + +`Graft` exports the types and classes. The functions have short names meant +for qualified import, as in the example: `Cursor.parent`, `Green.node`, +`Range.start`. Several, such as `Green.length` and `Green.map`, clash with the +Prelude. All offsets and lengths are `TextLength`, a count of UTF-8 bytes, +never characters. + +## Learn more + +- The [API documentation](https://andreabedini.github.io/graft/) of the latest + release gives each function's contract and cost. The introductions to + `Graft.Build`, `Graft.Cursor`, `Graft.Edit`, `Graft.Ast` and + `Graft.LineIndex` each start with an example: wrapping an operand at a + checkpoint, finding a token by offset and reading its ancestors, applying a + plan and renaming every matching token in one pass, a typed view with a + field, and converting Language Server Protocol positions. +- [`examples/ExactUpdate.hs`](https://github.com/andreabedini/graft/blob/main/examples/ExactUpdate.hs) + uses typed views to change a number's value while keeping its spelling + (`001` stays `001` if the value doesn't change). +- [`docs/architecture.md`](https://github.com/andreabedini/graft/blob/main/docs/architecture.md) + explains the design, how it differs from Rowan, and what is left to do. +- [`docs/performance.md`](https://github.com/andreabedini/graft/blob/main/docs/performance.md) + records benchmark results, and + [`bench/README.md`](https://github.com/andreabedini/graft/blob/main/bench/README.md) + explains how to reproduce them. +- [`CONTRIBUTING.md`](https://github.com/andreabedini/graft/blob/main/CONTRIBUTING.md) + describes how to build and test Graft, and how releases are made. + +## License + +[MIT](https://github.com/andreabedini/graft/blob/main/LICENSE). Graft is a port of ideas from Rowan, which is MIT or Apache-2.0; +see [NOTICE](https://github.com/andreabedini/graft/blob/main/NOTICE) and [licenses/ROWAN-MIT](https://github.com/andreabedini/graft/blob/main/licenses/ROWAN-MIT). diff --git a/bench/Fixtures.hs b/bench/Fixtures.hs new file mode 100644 --- /dev/null +++ b/bench/Fixtures.hs @@ -0,0 +1,284 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} + +-- Workloads and observations shared by timing and residency runs. +module Fixtures + ( Kind (..), Prepared (..), PreparedCursor (..), Named (..), Numbered (..), Grouped (..) + , wideSource, wideTree, deepTree, chainTree, chainSource, documentTree, documentTreeAgain, documentSource + , forceElement, checked, selected, cached, cursorEnd, siblingSum + , buildTokens, buildMonadic, buildReuse, buildWrapped, editMany, snapshots, Scope (..), renameTree, renamePasses, renameVisited + , checkFixtures + ) where + +import Control.DeepSeq (NFData (..)) +import Control.Exception (evaluate) +import Control.Monad.Trans.State.Strict (modify', runState) +import Data.Hashable (Hashable (..)) +import Control.Monad (unless) +import qualified Data.List as List +import Data.Text (Text) +import qualified Data.Text as Text +import Graft +import qualified Graft.Ast as Ast +import qualified Graft.Build as Build +import qualified Graft.Builder as Builder +import qualified Graft.Cursor as Cursor +import qualified Graft.Edit as Edit +import qualified Graft.Green as Green +import qualified Graft.Range as Range + +data Kind = Root | Group | Name | Number | Trivia + deriving (Eq, Show, Enum) + +instance Hashable Kind where + hashWithSalt salt = hashWithSalt salt . fromEnum + +instance NFData Kind where + rnf kind = kind `seq` () + +-- These wrappers force fixtures before the timer starts. +newtype Prepared = Prepared { preparedTree :: GreenElement Kind } + +instance NFData Prepared where + rnf (Prepared tree) = rnf tree + +newtype PreparedCursor = PreparedCursor { preparedCursor :: Cursor Kind } + +instance NFData PreparedCursor where + rnf (PreparedCursor cursor) = rnf cursor + +forceElement :: GreenElement Kind -> () +forceElement = rnf + +newtype Named = Named (Cursor Kind) +instance AstView Named where + type AstViewKind Named = Kind + fromCursor = Ast.matchToken (== Name) Named + toCursor (Named cursor) = cursor +instance AstToken Named + +newtype Numbered = Numbered (Cursor Kind) +instance AstView Numbered where + type AstViewKind Numbered = Kind + fromCursor = Ast.matchToken (== Number) Numbered + toCursor (Numbered cursor) = cursor +instance AstToken Numbered + +newtype Grouped = Grouped (Cursor Kind) +instance AstView Grouped where + type AstViewKind Grouped = Kind + fromCursor = Ast.matchNode (== Group) Grouped + toCursor (Grouped cursor) = cursor +instance AstNode Grouped + +wideSource :: Int -> [Text] +wideSource count = [Text.pack ("名" ++ show index ++ " ") | index <- [1 .. count]] + +wideTree :: [Text] -> GreenNode Kind +wideTree = Green.node Root . wideElements + +wideElements :: [Text] -> [GreenElement Kind] +wideElements [] = [] +wideElements [text] = [Token (Green.token Number text)] +wideElements (text : rest) = Token (Green.token Name text) : wideElements rest + +deepTree :: Int -> GreenNode Kind +deepTree depth = List.foldl' (\node _ -> Green.node Group [Node node]) leaf [1 .. depth] + where leaf = Green.node Group [Token (Green.token Number "001")] + +-- A left-nested operator chain such as @((0 + 1) + 2) + 3@: both deep and +-- wide, so whole-tree traversals pay for every level on every token. +chainTree :: Int -> GreenNode Kind +chainTree count = List.foldl' step leaf [1 .. count] + where + leaf = Green.node Group [Token (Green.token Number "0")] + step left index = Green.node Group + [Node left, Token (Green.token Trivia " + "), Token (Green.token Number (Text.pack (show index)))] + +chainSource :: Int -> Text +chainSource count = Text.concat ("0" : [Text.pack (" + " ++ show index) | index <- [1 .. count]]) + +lineText :: Int -> [Text] +lineText index = [Text.pack ("名" ++ show index), " = ", "001", " -- keep", "\r\n"] + +documentSource :: Int -> Text +documentSource count = Text.concat (concatMap lineText [1 .. count]) + +documentTree :: Int -> GreenNode Kind +documentTree count = Green.node Root [Node (line index) | index <- [1 .. count]] + where + line index = Green.node Group (zipWith (\kind text -> Token (Green.token kind text)) + [Name, Trivia, Number, Trivia, Trivia] (lineText index)) + +-- The same document built again, kept apart from documentTree by the +-- optimiser, so that the two are equal but not the same object. +documentTreeAgain :: Int -> GreenNode Kind +documentTreeAgain = documentTree +{-# NOINLINE documentTreeAgain #-} + +checked :: Show err => Either err a -> a +checked = either (error . show) id + +selected :: Maybe a -> a +selected = maybe (error "benchmark fixture has no selected element") id + +cached :: GreenNode Kind -> TextLength +cached = Green.nodeLength + +cursorEnd :: Cursor Kind -> TextLength +cursorEnd = Range.end . Cursor.range + +-- A strict consumer: each adjacent sibling and range contributes to the result. +siblingSum :: Cursor Kind -> TextLength +siblingSum root = go 0 (Cursor.firstChild root) + where + go total Nothing = total + go total (Just cursor) = let next = total + cursorEnd cursor + in next `seq` go next (Cursor.nextSibling cursor) + +buildTokens :: [Text] -> GreenNode Kind +buildTokens texts = checked (Builder.finish (checked (Builder.finishNode emitted))) + where + emitted = go (Builder.startNode Root Builder.empty) texts + go builder [] = builder + go builder [text] = Builder.token Number text builder + go builder (text : rest) = let next = Builder.token Name text builder + in next `seq` go next rest + +buildMonadic :: [Text] -> GreenNode Kind +buildMonadic texts = checked (Build.exec (Build.node Root (go texts))) + where + go [] = pure () + go [text] = Build.token Number text + go (text : rest) = Build.token Name text >> go rest + +buildReuse :: GreenNode Kind -> GreenNode Kind +buildReuse node = checked (Builder.finish (checked (Builder.finishNode emitted))) + where emitted = List.foldl' (flip Builder.element) (Builder.startNode Root Builder.empty) (Green.children node) + +buildWrapped :: GreenNode Kind -> GreenNode Kind +buildWrapped node = checked (Builder.finish closed) + where + opened = Builder.startNode Root Builder.empty + marker = Builder.checkpoint opened + emitted = List.foldl' (flip Builder.element) opened (Green.children node) + wrapped = checked (Builder.startNodeAt marker Group emitted) + closed = checked (Builder.finishNode (checked (Builder.finishNode wrapped))) + +-- Each edit depends on the preceding snapshot. Distinct text prevents no-op +-- updates. Force the cache on every step without walking shared descendants. +editMany :: Int -> Path -> GreenElement Kind -> GreenElement Kind +editMany count path root = List.foldl' (editAt path) root [1 .. count] + +-- One replacement at a path, through a plan of one edit. +editAt :: Path -> GreenElement Kind -> Int -> GreenElement Kind +editAt path previous index = + let focus = checked (Cursor.at path (Cursor.fromGreen previous)) + updated = checked (Edit.apply previous [Edit.replace focus (Token (Green.token Number (Text.pack (show index))))]) + in Green.length updated `seq` updated + +-- What a renaming rewrite reads before renaming each token, as a rename that +-- checks scopes would: nothing, the ranges of its ancestors, or the ranges +-- of its ancestors that cast to Grouped. +data Scope = Everywhere | InAncestors | InGroups + +-- Rename every Name token in scope with one rewrite, as the Graft.Edit +-- example does. +renameTree :: Scope -> GreenElement Kind -> GreenElement Kind +renameTree scope = Edit.rewrite (\() cursor -> renaming scope cursor) () + +renaming :: Scope -> Cursor Kind -> Change () Kind +renaming scope cursor + | not (Cursor.isToken cursor) = Descend + | inScope && Cursor.kind cursor == Name = Replace (Token (Green.token Name "renamed")) + | otherwise = Skip + where + inScope = case scope of + Everywhere -> True + InAncestors -> ends (Cursor.ancestors cursor) > 0 + InGroups -> ends (map toCursor (Ast.ancestors cursor :: [Grouped])) > 0 + ends = List.foldl' (\total ancestor -> total + cursorEnd ancestor) 0 + +-- Every cursor the renaming rewrite visits, with its result. +renameVisited :: Scope -> GreenElement Kind -> ([Cursor Kind], GreenElement Kind) +renameVisited scope input = + let (result, visited) = runState (Edit.rewriteM step () input) [] + step () cursor = modify' (cursor :) >> pure (renaming scope cursor) + in (visited, result) + +-- The renaming rewrite repeated, each pass on the result of the previous. +renamePasses :: Int -> GreenElement Kind -> GreenElement Kind +renamePasses count input = List.foldl' pass input [1 .. count] + where + pass tree _ = let next = renameTree Everywhere tree in Green.length next `seq` next + +snapshots :: Int -> Path -> GreenElement Kind -> [GreenElement Kind] +snapshots count path root = scanl (editAt path) root [1 .. count] + +-- Independent source checks guard the workload, not timing thresholds. +checkFixtures :: IO () +checkFixtures = do + mapM_ checkWide [100, 1000, 10000] + mapM_ checkDeep [100, 1000, 10000] + mapM_ checkChain [100, 1000, 10000] + let document = Node (documentTree 1000) + before = documentSource 1000 + path = [499, 2] + cursor = checked (Cursor.at path (Cursor.fromGreen document)) + updated = editMany 100 path document + renamed = renameTree Everywhere document + expected = Text.concat [documentSource 499, Text.concat + ["名500", " = ", "100", " -- keep", "\r\n"], + Text.concat (concatMap lineText [501 .. 1000])] + assert "document source" (Green.render document == before) + assert "repeated exact edits" (Green.render updated == expected) + assert "one edit and repeated edits agree" + (checked (Edit.apply document [Edit.replace cursor (Token (Green.token Number "100"))]) == updated) + assert "original snapshot preserved" (Green.render document == before) + assert "typed groups" (length (Ast.children (Cursor.fromGreen document) :: [Grouped]) == 1000) + assert "renamed source" (Green.render renamed == Text.concat (concatMap renamedLine [1 .. 1000 :: Int])) + assert "scoped renames" (all (\scope -> renameTree scope document == renamed) [InAncestors, InGroups]) + assert "rewrite visits every element" (length (fst (renameVisited Everywhere document)) == 1 + 1000 * 6) + assert "history count" (length (snapshots 100 path document) == 101) + putStrLn "Benchmark fixtures and observations: PASS" + where + assert label valid = unless valid (error ("benchmark check failed: " ++ label)) + renamedLine index = "renamed" : drop 1 (lineText index) + checkWide count = do + let texts = wideSource count + node = wideTree texts + root = Cursor.fromGreen (Node node) + insertion = Token (Green.token Number "NEW") + inserted = checked (Green.spliceChildren (count `div` 2) (count `div` 2) [insertion] node) + _ <- evaluate (forceElement (Node node)) + assert "wide exact source" (Green.renderNode node == Text.concat texts) + assert "builder tokens" (buildTokens texts == node) + assert "builder reuse" (buildReuse node == node) + assert "monadic builder" (buildMonadic texts == node) + assert "checkpoint source" (Green.renderNode (buildWrapped node) == Text.concat texts) + assert "wide UTF-8 cache" (Green.nodeLength node == sum + [4 + fromIntegral (length (show index)) | index <- [1 .. count]]) + assert "last offset" (cursorEnd (checked (Cursor.childAt (count - 1) root)) == Green.nodeLength node) + assert "sibling observation" (siblingSum root == sum (map cursorEnd (Cursor.children root))) + assert "typed last token" (cursorEnd (toCursor (selected (Ast.token root :: Maybe Numbered))) == Green.nodeLength node) + assert "splice exact source" (Green.renderNode inserted == Text.concat + [Text.concat (take (count `div` 2) texts), "NEW", Text.concat (drop (count `div` 2) texts)]) + checkChain count = do + let node = chainTree count + root = Cursor.fromGreen (Node node) + _ <- evaluate (forceElement (Node node)) + assert "chain source" (Green.renderNode node == chainSource count) + assert "chain tokens" (length (Cursor.descendantTokens root) == 2 * count + 1) + assert "chain first offset" (fmap cursorEnd (singleToken (Cursor.tokenAt 0 root)) == Just 1) + singleToken (SingleToken cursor) = Just cursor + singleToken _ = Nothing + checkDeep depth = do + let node = deepTree depth + root = Cursor.fromGreen (Node node) + path = replicate (depth + 1) 0 + leaf = checked (Cursor.at path root) + _ <- evaluate (forceElement (Node node)) + assert "deep source" (Green.renderNode node == "001") + assert "deep path" (Cursor.path leaf == path) + assert "deep cached range" (cursorEnd leaf == 3) + assert "deep edit" (Green.render (editMany 2 path (Node node)) == "2") diff --git a/bench/Main.hs b/bench/Main.hs new file mode 100644 --- /dev/null +++ b/bench/Main.hs @@ -0,0 +1,207 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +module Main (main) where + +import Control.DeepSeq (rnf) +import Data.Functor.Identity (Identity (..)) +import Data.Hashable (hash) +import qualified Data.List as List +import qualified Data.Text as Text +import Fixtures +import Graft +import qualified Graft.Ast as Ast +import qualified Graft.Cursor as Cursor +import qualified Graft.Edit as Edit +import qualified Graft.Green as Green +import qualified Graft.Range as Range +import Residency (runResidency) +import System.Environment (getArgs) +import Test.Tasty.Bench +import Text.Read (readMaybe) + +main :: IO () +main = do + args <- getArgs + case args of + ["--check"] -> checkFixtures + ["--residency", scenario, size, edits] -> + case (readMaybe size, readMaybe edits) of + (Just documentLines, Just editCount) -> runResidency scenario documentLines editCount + _ -> error "residency size and edits must be integers" + _ -> defaultMain + [ bgroup "token" [tokenBench bytes | bytes <- [32, 4096]] + , bgroup "wide" (map wideBench [100, 1000, 10000]) + , bgroup "deep" (map deepBench [100, 1000, 10000]) + , bgroup "chain" (map chainBench [100, 1000, 10000]) + , documentBench + ] + +tokenBench :: Int -> Benchmark +tokenBench bytes = env (pure (Text.replicate bytes (Text.singleton 'a'), + Text.replicate (bytes `div` 4) (Text.singleton '🙂'))) $ \ ~(ascii, unicode) -> + bgroup (show bytes) + [ bench "ascii" $ whnf (Green.tokenLength . Green.token Name) ascii + , bench "unicode" $ whnf (Green.tokenLength . Green.token Name) unicode + ] + +wideBench :: Int -> Benchmark +wideBench size = bgroup (show size) + [ env (pure (wideSource size)) $ \texts -> bgroup "construct" + [ bench "direct" $ whnf (cached . wideTree) texts + , bench "builder-tokens" $ whnf (cached . buildTokens) texts + , bench "builder-monad" $ whnf (cached . buildMonadic) texts + ] + , env (pure (Prepared (Node (wideTree (wideSource size))))) $ \prepared -> + let tree = preparedTree prepared + node = case tree of Node value -> value; Token _ -> error "expected node" + root = Cursor.fromGreen tree + replacement = Token (Green.token Number (Text.singleton '2')) + endAt index input = cursorEnd (checked (Cursor.childAt index (Cursor.fromGreen input))) + replace index input = Green.length (checked (Edit.apply input + [Edit.replace (checked (Cursor.childAt index (Cursor.fromGreen input))) replacement])) + -- Replace every child in one rewrite, as a codemod would. + editEach input = Green.length (Edit.rewrite (\() cursor -> + if Cursor.isToken cursor then Replace replacement else Descend) () input) + -- The same change as a plan with one edit per child. + planEach input = Green.length (checked (Edit.apply input + [Edit.replace child replacement | child <- Cursor.children (Cursor.fromGreen input)])) + -- The same result from building the parent again. + editParent input = Green.length (rebuild input) + where + rebuild (Node parent) = Node (Green.node (Green.nodeKind parent) (map (const replacement) (Green.children parent))) + rebuild token = token + in bgroup "prepared" + [ bench "render" $ nf Green.render tree + , bench "hash" $ whnf hash tree + , bench "rnf" $ whnf rnf tree + , bench "builder-reuse" $ whnf (cached . buildReuse) node + , bench "builder-checkpoint" $ whnf (cached . buildWrapped) node + , bench "child-first" $ whnf (endAt 0) tree + , bench "child-middle" $ whnf (endAt (size `div` 2)) tree + , bench "child-last" $ whnf (endAt (size - 1)) tree + , bench "siblings" $ whnf (siblingSum . Cursor.fromGreen) tree + , bench "offset-first" $ whnf (offsetEnd 1 . Cursor.fromGreen) tree + , bench "offset-last" $ whnf (offsetEnd (Green.nodeLength node - 1) . Cursor.fromGreen) tree + , bench "cover-last" $ whnf (cursorEnd . selected . Cursor.covering + (Range.fromLength (Green.nodeLength node - 1) 1) . Cursor.fromGreen) tree + , bench "replace-first" $ whnf (replace 0) tree + , bench "replace-middle" $ whnf (replace (size `div` 2)) tree + , bench "replace-last" $ whnf (replace (size - 1)) tree + , bench "splice-middle" $ whnf (cached . checked . Green.spliceChildren + (size `div` 2) (size `div` 2) [replacement]) node + , bench "edit-each-child" $ whnf editEach tree + , bench "plan-each-child" $ whnf planEach tree + , bench "edit-parent-once" $ whnf editParent tree + , bench "typed-first" $ whnf (maybe 0 (cursorEnd . toCursor) . + (Ast.token :: Cursor Kind -> Maybe Named)) root + , bench "typed-last" $ whnf (maybe 0 (cursorEnd . toCursor) . + (Ast.token :: Cursor Kind -> Maybe Numbered)) root + , bench "typed-all" $ whnf (List.foldl' (\total view -> total + cursorEnd (toCursor view)) 0 . + (Ast.tokens :: Cursor Kind -> [Named])) root + ] + ] + +deepBench :: Int -> Benchmark +deepBench depth = bgroup (show depth) + [ bench "construct" $ whnf (cached . deepTree) depth + , env (pure (Prepared (Node (deepTree depth)))) $ \prepared -> + let tree = preparedTree prepared + path = replicate (depth + 1) 0 + focused input = checked (Cursor.at path (Cursor.fromGreen input)) + replacement = Token (Green.token Number (Text.singleton '2')) + in bgroup "prepared" + [ bench "render" $ nf Green.render tree + , bench "hash" $ whnf hash tree + , bench "rnf" $ whnf rnf tree + , bench "descend" $ whnf (cursorEnd . focused) tree + , bench "replace-path" $ whnf (\target -> Green.length (checked (Edit.apply tree + [Edit.replace (checked (Cursor.at target (Cursor.fromGreen tree))) replacement]))) path + , bench "offset" $ whnf (offsetEnd 1 . Cursor.fromGreen) tree + , bench "focus-and-replace" $ whnf (\input -> Green.length (checked (Edit.apply input + [Edit.replace (focused input) replacement]))) tree + ] + , env (pure (PreparedCursor (checked (Cursor.at (replicate (depth + 1) 0) + (Cursor.fromGreen (Node (deepTree depth))))))) $ \prepared -> + let root = Cursor.tree (preparedCursor prepared) + in bgroup "focused" + [ bench "replace" $ whnf (\cursor -> Green.length (checked (Edit.apply root + [Edit.replace cursor (Token (Green.token Number (Text.singleton '2')))]))) (preparedCursor prepared) + , bench "root" $ whnf (cursorEnd . Cursor.root) (preparedCursor prepared) + ] + ] + +chainBench :: Int -> Benchmark +chainBench count = env (pure (Prepared (Node (chainTree count)))) $ \prepared -> + let tree = preparedTree prepared + end = Green.length tree + in bgroup (show count) + [ bench "render" $ nf Green.render tree + , bench "hash" $ whnf hash tree + , bench "rnf" $ whnf rnf tree + , bench "tokens" $ whnf (List.foldl' (\total cursor -> total + cursorEnd cursor) 0 . Cursor.descendantTokens . Cursor.fromGreen) tree + , bench "descendants" $ whnf (length . Cursor.descendants . Cursor.fromGreen) tree + , bench "offset-first" $ whnf (offsetEnd 1 . Cursor.fromGreen) tree + , bench "offset-last" $ whnf (offsetEnd (end - 1) . Cursor.fromGreen) tree + ] + +documentBench :: Benchmark +documentBench = env (pure (Prepared (Node (documentTree 1000)))) $ \prepared -> + let tree = preparedTree prepared + path = [499, 2] + root = Cursor.fromGreen tree + in bgroup "document-1000" + [ bench "construct" $ whnf (cached . documentTree) 1000 + , bench "render" $ nf Green.render tree + , bench "hash" $ whnf hash tree + , bench "rnf" $ whnf rnf tree + , bench "count-foldM" $ whnf (runIdentity . Green.foldM countToken 0) tree + , bench "count-fold" $ whnf ((\node -> Green.fold (const 1) (const sum) node :: Int) . nodeOf) tree + , bench "map" $ whnf (Green.nodeLength . Green.map copyText . nodeOf) tree + , bench "traverse" $ whnf (Green.nodeLength . runIdentity . Green.traverse (Identity . copyText) . nodeOf) tree + , bench "tokens" $ whnf (List.foldl' (\total cursor -> total + cursorEnd cursor) 0 . Cursor.descendantTokens . Cursor.fromGreen) tree + , bench "typed-first-group" $ whnf (maybe 0 (cursorEnd . toCursor) . + (Ast.child :: Cursor Kind -> Maybe Grouped)) root + , bench "typed-all-groups" $ whnf (List.foldl' (\total view -> total + cursorEnd (toCursor view)) 0 . + (Ast.children :: Cursor Kind -> [Grouped])) root + , bench "100-edits-latest" $ whnf (Green.length . editMany 100 path) tree + , bench "100-edits-history" $ whnf (List.foldl' (\total snapshot -> total + Green.length snapshot) 0 . + snapshots 100 path) tree + , bench "rename-all" $ whnf (Green.length . renameTree Everywhere) tree + , bench "rename-all-ancestors" $ whnf (Green.length . renameTree InAncestors) tree + , bench "rename-all-groups" $ whnf (Green.length . renameTree InGroups) tree + , bgroup "apply-sparse" [bench (show count) $ whnf (Green.length . checked . Edit.apply tree . sparse root) count + | count <- [1, 10, 100, 1000]] + , bench "text-edits-1000" $ nf (checked . Edit.textEdits tree . sparse root) 1000 + , env (pure (Prepared (Node (documentTreeAgain 1000)))) $ \other -> + -- an edit whose cursor is in an equal tree built separately, so + -- that apply compares the trees instead of recognising the base + bench "apply-from-equal-tree" $ whnf (\input -> Green.length (checked (Edit.apply input + [Edit.replace (checked (Cursor.at path (Cursor.fromGreen (preparedTree other)))) renamed]))) tree + ] + where + renamed = Token (Green.token Name (Text.pack "renamed")) + -- Replace the name of every (1000 / count)-th line. + sparse root count = + [ Edit.replace (checked (Cursor.at [line, 0] root)) renamed + | line <- take count [0, 1000 `div` count ..] + ] + +offsetEnd :: TextLength -> Cursor Kind -> TextLength +offsetEnd offset root = case Cursor.tokenAt offset root of + NoToken -> error "fixture offset has no token" + SingleToken cursor -> cursorEnd cursor + BetweenTokens left right -> cursorEnd left + cursorEnd right + +-- Counts the tokens, for comparing folds with cursor walks. +countToken :: Int -> GreenElement Kind -> Identity Int +countToken count (Token _) = Identity (count + 1) +countToken count (Node _) = Identity count + +-- Copies a token's text out of its source buffer. +copyText :: GreenToken Kind -> GreenToken Kind +copyText token = Green.token (Green.tokenKind token) (Text.copy (Green.text token)) + +-- The root of a prepared tree, which is always a node. +nodeOf :: GreenElement Kind -> GreenNode Kind +nodeOf (Node node) = node +nodeOf (Token _) = error "a prepared tree is a node" diff --git a/bench/README.md b/bench/README.md new file mode 100644 --- /dev/null +++ b/bench/README.md @@ -0,0 +1,85 @@ +# Run the benchmarks + +Run these commands from the package root. The benchmark component adds +`tasty-bench` to the library's dependencies. +Python 3 runs the measurement script. Linux CPU pinning also requires `taskset`. + +Build the library and benchmarks with optimisation: + +```sh +cabal build bench:graft-bench --enable-benchmarks -O2 --ghc-options=-Werror +``` + +Check the workloads before measuring them: + +```sh +graft_bench=$(cabal list-bin bench:graft-bench --enable-benchmarks -O2) +"$graft_bench" --check +``` + +Run two passes and save the raw data in a new directory: + +```sh +python3 bench/run.py --output bench/results/"$(date +%F)" --runs 2 --timeout 3s --stdev 2 +``` + +If Linux permits CPU 2 in your process's affinity, add `--cpu 2` to pin each +measurement process. Close other CPU-intensive applications before measuring. +The script rejects an existing output directory to preserve earlier results. +It records source and executable hashes, the parent revision, compiler versions, +CPU information, and runtime options in `environment.json`. +Revision metadata is available in a jj checkout. Unpacked source distributions +record source hashes without requiring jj. + +The output contains timing CSV files, full timing logs, and `residency.csv`. +Each timing pass runs all cases sequentially with CPU time and allocation +statistics. The runtime uses a 32 MiB allocation area for these passes. +Each residency case runs in a fresh process with the default allocation area. +Residency means live heap bytes after a full garbage collection. + +Inspect or filter individual timing cases: + +```sh +"$graft_bench" --list-tests +"$graft_bench" --pattern 'wide.10000' --timeout 3s --stdev 2 +RTS -T -A32m -RTS +``` + +Compare a new run with an earlier CSV file on the same machine: + +```sh +"$graft_bench" --baseline bench/results/2026-10-17/timing-1.csv --timeout 3s --stdev 2 +RTS -T -A32m -RTS +``` + +Measure what one retained result keeps alive: + +```sh +"$graft_bench" --residency history 10000 100 +RTS -T -RTS +``` + +The arguments are a scenario, the number of document lines and the number of +edits. Lines must be positive and edits nonnegative. The scenarios are: + +- `tree`: the original document. +- `shared`: one line subtree repeated for every line. +- `latest`: only the root after the edits. +- `history`: the original and every edited root. +- `cursor`: one cursor on a middle token. +- `detached-token`: only that cursor's green token. +- `renamed-tree`: the tree after renaming every `Name` token in one rewrite. +- `renamed-cursor`: a cursor on the last token of that tree. +- `renamed-passes`: the tree after as many renaming passes as there are + edits, each rewriting the previous pass's result. +- `walk-cursors`: every cursor that one renaming rewrite visits. + +Only `latest`, `history` and `renamed-passes` use the edit count; the others +ignore it. + +The CSV reports absolute live bytes, startup live bytes, their nonnegative +difference, total allocation since startup collection, and an observed checksum. +These measurements include runtime and fixture overhead. They are not a census +of tree allocations or a measure of operating-system resident memory. + +The [baseline report](../docs/performance.md) describes the workloads, measured +results, and limitations. Rebuild and rerun the fixture checks and property suite +after changing a workload or representation. Compare repeated runs before drawing +conclusions from small timing differences. diff --git a/bench/Residency.hs b/bench/Residency.hs new file mode 100644 --- /dev/null +++ b/bench/Residency.hs @@ -0,0 +1,76 @@ +module Residency (runResidency) where + +import Control.Exception (evaluate) +import Control.Monad (unless) +import Data.IORef (newIORef, readIORef) +import qualified Data.List as List +import Fixtures +import GHC.Stats +import Graft +import qualified Graft.Cursor as Cursor +import qualified Graft.Green as Green +import System.Mem (performMajorGC) + +data Retained = Roots [GreenElement Kind] | Focus (Cursor Kind) | Visits [Cursor Kind] + +-- Force all snapshot roots, but avoid revisiting unchanged descendants for +-- every edit. Smart constructors already force their immediate cache sums. +observe :: Retained -> TextLength +observe (Roots roots) = List.foldl' (\total root -> total + Green.length root) 0 roots +observe (Focus cursor) = cursorEnd cursor +observe (Visits cursors) = List.foldl' (\total cursor -> total + cursorEnd cursor) 0 cursors + +-- Keep fixture creation out of the caller: only this result survives its GC. +{-# NOINLINE prepare #-} +prepare :: String -> Int -> Int -> IO Retained +prepare scenario size edits = do + let root = Node (documentTree size) + path = [size `div` 2, 2] + case scenario of + "shared" -> do + let line = case Green.children (documentTree 1) of + first : _ -> first + [] -> error "shared fixture has no line" + shared = Node (Green.node Root (replicate size line)) + _ <- evaluate (forceElement shared) + pure (Roots [shared]) + _ -> do + _ <- evaluate (forceElement root) + case scenario of + "tree" -> pure (Roots [root]) + "latest" -> evaluated (Roots [editMany edits path root]) + "history" -> evaluated (Roots (snapshots edits path root)) + "cursor" -> pure (Focus (checked (Cursor.at path (Cursor.fromGreen root)))) + "detached-token" -> pure (Roots [Cursor.green (checked (Cursor.at path (Cursor.fromGreen root)))]) + "renamed-tree" -> evaluated (Roots [renameTree Everywhere root]) + "renamed-cursor" -> evaluated (Focus (selected (Cursor.lastToken (Cursor.fromGreen (renameTree Everywhere root))))) + "renamed-passes" -> evaluated (Roots [renamePasses edits root]) + "walk-cursors" -> evaluated (Visits (fst (renameVisited Everywhere root))) + _ -> error ("scenario must be tree, shared, latest, history, cursor, detached-token, " + ++ "renamed-tree, renamed-cursor, renamed-passes or walk-cursors") + where + evaluated retained = evaluate (observe retained) >> pure retained + +-- One fresh process per scenario. A live IORef, read after measurement, keeps +-- precisely the requested result reachable across the full collection. +runResidency :: String -> Int -> Int -> IO () +runResidency scenario size edits = do + unless (size > 0 && edits >= 0) (error "size must be positive and edits nonnegative") + enabled <- getRTSStatsEnabled + unless enabled (error "RTS statistics are required: pass +RTS -T") + performMajorGC + before <- getRTSStats + retained <- prepare scenario size edits + _ <- evaluate (observe retained) + keep <- newIORef retained + performMajorGC + after <- getRTSStats + stillLive <- readIORef keep + checksum <- evaluate (observe stillLive) + let liveBefore = gcdetails_live_bytes (gc before) + liveAfter = gcdetails_live_bytes (gc after) + delta = if liveAfter >= liveBefore then liveAfter - liveBefore else 0 + putStrLn "Scenario,Lines,Edits,Live bytes,Baseline live bytes,Live delta bytes,Allocated bytes,Checksum" + putStrLn (concat [scenario, ",", show size, ",", show edits, ",", show liveAfter, + ",", show liveBefore, ",", show delta, ",", show (allocated_bytes after - allocated_bytes before), + ",", show checksum]) diff --git a/bench/results/2026-10-10/environment.json b/bench/results/2026-10-10/environment.json new file mode 100644 --- /dev/null +++ b/bench/results/2026-10-10/environment.json @@ -0,0 +1,65 @@ +{ + "started_at": "2026-10-10T11:31:46.617342+00:00", + "platform": "Linux-7.2.9-200.fc44.x86_64-x86_64-with-glibc2.43", + "ghc": "9.12.2", + "cabal": "3.16.1.0", + "parent_revision": "6ddf6b12e78d880ecbfb47fec1bde4f03122ddaf", + "working_copy": "0 files changed, 0 insertions(+), 0 deletions(-)", + "binary_sha256": "74c706f71ab5d66850e0be0b2070d5caf259f604f9acf0127a6a5641b601bd67", + "source_sha256": { + "graft.cabal": "3ac97c0103cd283d81befd38f6e256646e46f9ec176ca34b513c33e6e40dc75f", + "src/Graft/Ast.hs": "5eaab731210d0c476105b66877c434f3a867799a2042f175128e87463f0ce10f", + "src/Graft/Builder.hs": "8491b61dec029c921afcf147e8cf1d0ae831423f9137159525210f591663de33", + "src/Graft/Cursor.hs": "1b34e29d44a59add2ee4a6dd3d7ae6bb950c8b65520c49978d7e760e2b84c385", + "src/Graft/Edit.hs": "24a3eb1067053431b829592a257304009cd3b4e436acc4974b59ceec2c258c38", + "src/Graft/Green.hs": "29139aee364f214d5090fb68f4032312170de4952a218915e62db26ee9bd8173", + "src/Graft/Range.hs": "827cb033c8396bf633a987b38d2538bec8f349f6b7c693636d1825034ab00bae", + "src/Graft.hs": "322f31e9a12a2dce08cc34b82c19af1ce84194b965e4c25e5374db89102a4326", + "bench/Fixtures.hs": "7df516e34f607c9e228543433597e038582fcd399021cf4bd5a4933c1640f82d", + "bench/Main.hs": "edc860ba89a4ac8966599aad1374984564f022ac69940b93056f86608f69bff8", + "bench/Residency.hs": "063147535589ed6d745cd8df7a1f6f7b052061f363478037a70352d7f270dd37", + "bench/run.py": "d2457669cd3397f2e7545c08ce06f66672c8ef2ad345e9aef0904ac22ea6fce5" + }, + "cpu": 2, + "affinity": [ + 0, + 1, + 2, + 3, + 4, + 5, + 6, + 7, + 8, + 9, + 10, + 11, + 12, + 13, + 14, + 15 + ], + "lscpu": "Architecture: x86_64\nCPU op-mode(s): 32-bit, 64-bit\nAddress sizes: 52 bits physical, 57 bits virtual\nByte Order: Little Endian\nCPU(s): 16\nOn-line CPU(s) list: 0-15\nVendor ID: GenuineIntel\nModel name: Intel(R) Xeon(R) w3-2435\nCPU family: 6\nModel: 143\nThread(s) per core: 2\nCore(s) per socket: 8\nSocket(s): 1\nStepping: 8\nCPU(s) scaling MHz: 37%\nCPU max MHz: 4500.0000\nCPU min MHz: 800.0000\nBogoMIPS: 6192.00\nFlags: fpu vme de pse tsc msr pae mce cx8 apic sep mtrr pge mca cmov pat pse36 clflush dts acpi mmx fxsr sse sse2 ss ht tm pbe syscall nx pdpe1gb rdtscp lm constant_tsc art arch_perfmon pebs bts rep_good nopl xtopology nonstop_tsc cpuid aperfmperf tsc_known_freq pni pclmulqdq dtes64 monitor ds_cpl vmx smx est tm2 ssse3 sdbg fma cx16 xtpr pdcm pcid dca sse4_1 sse4_2 x2apic movbe popcnt tsc_deadline_timer aes xsave avx f16c rdrand lahf_lm abm 3dnowprefetch cpuid_fault epb cat_l3 cat_l2 cdp_l3 intel_ppin cdp_l2 ssbd mba ibrs ibpb stibp ibrs_enhanced tpr_shadow flexpriority ept vpid ept_ad fsgsbase tsc_adjust bmi1 avx2 smep bmi2 erms invpcid cqm rdt_a avx512f avx512dq rdseed adx smap avx512ifma clflushopt clwb intel_pt avx512cd sha_ni avx512bw avx512vl xsaveopt xsavec xgetbv1 xsaves cqm_llc cqm_occup_llc cqm_mbm_total cqm_mbm_local split_lock_detect user_shstk avx_vnni avx512_bf16 wbnoinvd dtherm ida arat pln pts hwp hwp_act_window hwp_epp hwp_pkg_req vnmi avx512vbmi umip pku ospke waitpkg avx512_vbmi2 gfni vaes vpclmulqdq avx512_vnni avx512_bitalg avx512_vpopcntdq la57 rdpid bus_lock_detect cldemote movdiri movdir64b enqcmd fsrm md_clear serialize tsxldtrk pconfig arch_lbr ibt amx_bf16 avx512_fp16 amx_tile amx_int8 flush_l1d arch_capabilities\nVirtualization: VT-x\nL1d cache: 384 KiB (8 instances)\nL1i cache: 256 KiB (8 instances)\nL2 cache: 16 MiB (8 instances)\nL3 cache: 22.5 MiB (1 instance)\nNUMA node(s): 1\nNUMA node0 CPU(s): 0-15\nVulnerability Gather data sampling: Not affected\nVulnerability Ghostwrite: Not affected\nVulnerability Indirect target selection: Not affected\nVulnerability Itlb multihit: Not affected\nVulnerability L1tf: Not affected\nVulnerability Mds: Not affected\nVulnerability Meltdown: Not affected\nVulnerability Mmio stale data: Not affected\nVulnerability Old microcode: Not affected\nVulnerability Reg file data sampling: Not affected\nVulnerability Retbleed: Not affected\nVulnerability Spec rstack overflow: Not affected\nVulnerability Spec store bypass: Mitigation; Speculative Store Bypass disabled via prctl\nVulnerability Spectre v1: Mitigation; usercopy/swapgs barriers and __user pointer sanitization\nVulnerability Spectre v2: Mitigation; Enhanced / Automatic IBRS; IBPB conditional; PBRSB-eIBRS SW sequence; BHI BHI_DIS_S\nVulnerability Srbds: Not affected\nVulnerability Tsa: Not affected\nVulnerability Tsx async abort: Not affected\nVulnerability Vmscape: Mitigation; IBPB before exit to userspace", + "timing_options": [ + "--stdev", + "2.0", + "--timeout", + "3s", + "--time-mode", + "cpu", + "--color", + "never", + "+RTS", + "-T", + "-A32m", + "-RTS" + ], + "runs": 2, + "residency_options": [ + "+RTS", + "-T", + "-RTS" + ], + "build_command": "cabal build bench:graft-bench --enable-benchmarks -O2 --ghc-options=-Werror", + "governor": "powersave" +} diff --git a/bench/results/2026-10-10/residency.csv b/bench/results/2026-10-10/residency.csv new file mode 100644 --- /dev/null +++ b/bench/results/2026-10-10/residency.csv @@ -0,0 +1,13 @@ +Scenario,Lines,Edits,Live bytes,Baseline live bytes,Live delta bytes,Allocated bytes,Checksum +tree,1000,0,588280,2872,585408,1557376,22893 +shared,1000,0,28864,2920,25944,67272,21000 +cursor,1000,0,632440,2920,629520,1626616,11405 +detached-token,1000,0,36232,3112,33120,1627232,3 +latest,1000,100,620264,2920,617344,5281952,22893 +history,1000,100,1857032,2944,1854088,5296400,2312085 +tree,10000,0,5844280,2872,5841408,15952288,238894 +shared,10000,0,244864,2920,241944,643272,210000 +cursor,10000,0,5996440,2920,5993520,16411096,118907 +detached-token,10000,0,36232,3112,33120,16411712,3 +latest,10000,100,5876264,2920,5873344,61911384,238894 +history,10000,100,17913032,2944,17910088,61925832,24128186 diff --git a/bench/results/2026-10-10/timing-1.csv b/bench/results/2026-10-10/timing-1.csv new file mode 100644 --- /dev/null +++ b/bench/results/2026-10-10/timing-1.csv @@ -0,0 +1,90 @@ +Name,Mean (ps),2*Stdev (ps),Allocated,Copied,Peak Memory +All.token.32.ascii,26891,802,127,0,49283072 +All.token.32.unicode,25421,3442,127,0,49283072 +All.token.4096.ascii,439580,31630,4188,0,103809024 +All.token.4096.unicode,499791,79856,4188,0,103809024 +All.wide.100.construct.direct,4194768,112028,25220,4,103809024 +All.wide.100.construct.builder-tokens,7190632,197430,40634,9,103809024 +All.wide.100.prepared.render,2142557,260464,14063,0,103809024 +All.wide.100.prepared.builder-reuse,4345912,130446,22284,2,103809024 +All.wide.100.prepared.builder-checkpoint,4424428,176066,23332,2,103809024 +All.wide.100.prepared.child-first,31970,892,223,0,103809024 +All.wide.100.prepared.child-middle,447307,45816,3813,0,103809024 +All.wide.100.prepared.child-last,881536,35244,7294,0,103809024 +All.wide.100.prepared.siblings,4364965,166882,27194,2,103809024 +All.wide.100.prepared.offset-last,5406607,607504,35102,2,103809024 +All.wide.100.prepared.cover-last,4579649,109324,31905,2,103809024 +All.wide.100.prepared.replace-first,371304,10400,1789,0,103809024 +All.wide.100.prepared.replace-middle,601595,17780,3827,0,103809024 +All.wide.100.prepared.replace-last,851638,23322,5707,0,103809024 +All.wide.100.prepared.splice-middle,593350,12670,3851,0,103809024 +All.wide.100.prepared.typed-first,48882,5106,374,0,103809024 +All.wide.100.prepared.typed-last,4847936,370796,30395,2,103809024 +All.wide.100.prepared.typed-all,5837971,884904,40701,3,103809024 +All.wide.1000.construct.direct,40813404,778894,254226,351,103809024 +All.wide.1000.construct.builder-tokens,70479045,4175658,406302,668,103809024 +All.wide.1000.prepared.render,22115764,3677772,141203,28,103809024 +All.wide.1000.prepared.builder-reuse,42970315,1579340,222299,159,103809024 +All.wide.1000.prepared.builder-checkpoint,39238976,1407068,224018,160,103809024 +All.wide.1000.prepared.child-first,31589,4322,223,0,103809024 +All.wide.1000.prepared.child-middle,4496991,476508,36086,16,103809024 +All.wide.1000.prepared.child-last,9847001,315698,71908,61,103809024 +All.wide.1000.prepared.siblings,50463144,2448040,277483,111,103809024 +All.wide.1000.prepared.offset-last,64011002,2589786,351891,141,103809024 +All.wide.1000.prepared.cover-last,53981547,1560874,314187,126,103809024 +All.wide.1000.prepared.replace-first,3834900,249796,16113,0,103809024 +All.wide.1000.prepared.replace-middle,7062038,266110,35535,10,103809024 +All.wide.1000.prepared.replace-last,10492015,158322,56091,27,103809024 +All.wide.1000.prepared.splice-middle,7436233,293214,35504,10,103809024 +All.wide.1000.prepared.typed-first,61890,1754,374,0,103809024 +All.wide.1000.prepared.typed-last,57044809,2073288,303764,122,103809024 +All.wide.1000.prepared.typed-all,81114563,3346224,407587,166,103809024 +All.wide.10000.construct.direct,518098002,19953304,2505050,36205,103809024 +All.wide.10000.construct.builder-tokens,1019694310,101964960,4056412,64748,103809024 +All.wide.10000.prepared.render,352012847,26775748,1454204,2032,103809024 +All.wide.10000.prepared.builder-reuse,731768605,22320902,2198685,14805,103809024 +All.wide.10000.prepared.builder-checkpoint,745979030,21302906,2198623,14384,103809024 +All.wide.10000.prepared.child-first,39450,7540,221,0,103809024 +All.wide.10000.prepared.child-middle,81802885,33044952,425048,1291,103809024 +All.wide.10000.prepared.child-last,217662835,4140516,882891,5913,103809024 +All.wide.10000.prepared.siblings,582136502,10822038,2790902,10176,103809024 +All.wide.10000.prepared.offset-last,729325671,136610682,3494499,12747,103809024 +All.wide.10000.prepared.cover-last,609303678,16013938,3162159,11029,103809024 +All.wide.10000.prepared.replace-first,60332715,1924160,159606,6,103809024 +All.wide.10000.prepared.replace-middle,127945746,5101816,457531,950,103809024 +All.wide.10000.prepared.replace-last,230584223,25414314,782477,2556,103809024 +All.wide.10000.prepared.splice-middle,137093444,27208872,424759,914,103809024 +All.wide.10000.prepared.typed-first,65910,15158,374,0,103809024 +All.wide.10000.prepared.typed-last,641997504,15639918,3006647,11238,103809024 +All.wide.10000.prepared.typed-all,825657290,19423914,4043838,14927,103809024 +All.deep.100.construct,1678696,89110,8739,1,103809024 +All.deep.100.prepared.render,1339475,41850,5205,0,103809024 +All.deep.100.prepared.descend,3932611,144618,20652,3,103809024 +All.deep.100.prepared.replace-path,3990043,588590,21787,3,103809024 +All.deep.100.prepared.offset,7672511,224706,44505,15,103809024 +All.deep.100.prepared.focus-and-replace,7107005,309786,40335,7,103809024 +All.deep.100.focused.replace,2531867,241598,13613,2,103809024 +All.deep.100.focused.root,337091,28324,1630,0,103809024 +All.deep.1000.construct,17587370,1321308,87902,118,103809024 +All.deep.1000.prepared.render,14947112,1636330,48032,24,103809024 +All.deep.1000.prepared.descend,42698089,4280200,206663,257,103809024 +All.deep.1000.prepared.replace-path,68006827,2318254,341739,279,103809024 +All.deep.1000.prepared.offset,85242110,5967324,437673,1422,103809024 +All.deep.1000.prepared.focus-and-replace,82667903,2962018,453654,612,103809024 +All.deep.1000.focused.replace,39503158,1255464,198480,189,103809024 +All.deep.1000.focused.root,9034700,221734,15756,0,103809024 +All.deep.10000.construct,185153987,47583434,873303,11316,103809024 +All.deep.10000.prepared.render,207133062,42708554,474693,2288,103809024 +All.deep.10000.prepared.descend,511318036,46372716,2074881,26468,103809024 +All.deep.10000.prepared.replace-path,990208097,6869514,3569741,27174,103809024 +All.deep.10000.prepared.offset,1383799484,368058448,4815710,139158,103809024 +All.deep.10000.prepared.focus-and-replace,1125283337,78359004,4642438,60788,103809024 +All.deep.10000.focused.replace,419058137,15373982,1975543,18715,103809024 +All.deep.10000.focused.root,75188360,2992156,153877,5,103809024 +All.document-1000.construct,311710227,68315562,1549430,13663,103809024 +All.document-1000.render,212551692,9247850,768652,451,103809024 +All.document-1000.tokens,618807846,60961722,3014654,1253,103809024 +All.document-1000.typed-first-group,61999,2298,369,0,103809024 +All.document-1000.typed-all-groups,74505907,1627710,407691,161,103809024 +All.document-1000.100-edits-latest,774154164,22267148,3659799,1088,103809024 +All.document-1000.100-edits-history,825623429,347887006,3683400,1084,103809024 diff --git a/bench/results/2026-10-10/timing-2.csv b/bench/results/2026-10-10/timing-2.csv new file mode 100644 --- /dev/null +++ b/bench/results/2026-10-10/timing-2.csv @@ -0,0 +1,90 @@ +Name,Mean (ps),2*Stdev (ps),Allocated,Copied,Peak Memory +All.token.32.ascii,13188,554,127,0,49283072 +All.token.32.unicode,13547,218,127,0,49283072 +All.token.4096.ascii,503125,11330,4175,0,103809024 +All.token.4096.unicode,560636,18316,4175,0,103809024 +All.wide.100.construct.direct,4370111,60542,25422,4,103809024 +All.wide.100.construct.builder-tokens,7689275,189052,40634,9,103809024 +All.wide.100.prepared.render,2351857,24972,14063,0,103809024 +All.wide.100.prepared.builder-reuse,4514548,71592,22486,2,103809024 +All.wide.100.prepared.builder-checkpoint,4670501,86212,23332,2,103809024 +All.wide.100.prepared.child-first,38402,4608,221,0,103809024 +All.wide.100.prepared.child-middle,513940,25312,3813,0,103809024 +All.wide.100.prepared.child-last,906900,35658,7294,0,103809024 +All.wide.100.prepared.siblings,5690896,1461084,27904,2,103809024 +All.wide.100.prepared.offset-last,6326730,398870,35102,2,103809024 +All.wide.100.prepared.cover-last,5593484,293520,31905,2,103809024 +All.wide.100.prepared.replace-first,395216,12646,1789,0,103809024 +All.wide.100.prepared.replace-middle,683170,65616,3827,0,103809024 +All.wide.100.prepared.replace-last,940554,23340,5732,0,103809024 +All.wide.100.prepared.splice-middle,696066,6984,3851,0,103809024 +All.wide.100.prepared.typed-first,59917,5800,374,0,103809024 +All.wide.100.prepared.typed-last,5142940,661362,30395,2,103809024 +All.wide.100.prepared.typed-all,7044156,167858,40701,3,103809024 +All.wide.1000.construct.direct,46281962,5316798,254225,347,103809024 +All.wide.1000.construct.builder-tokens,80292703,967916,406302,658,103809024 +All.wide.1000.prepared.render,25078615,1306748,141203,28,103809024 +All.wide.1000.prepared.builder-reuse,47307921,3181658,222299,159,103809024 +All.wide.1000.prepared.builder-checkpoint,47402248,1751426,216739,154,103809024 +All.wide.1000.prepared.child-first,38002,878,220,0,103809024 +All.wide.1000.prepared.child-middle,5125080,133788,35933,16,103809024 +All.wide.1000.prepared.child-last,10470394,340052,71500,61,103809024 +All.wide.1000.prepared.siblings,53622294,7762356,277481,111,103809024 +All.wide.1000.prepared.offset-last,63721339,1137496,351891,141,103809024 +All.wide.1000.prepared.cover-last,60452366,1543502,314186,125,103809024 +All.wide.1000.prepared.replace-first,3809317,145434,15755,0,103809024 +All.wide.1000.prepared.replace-middle,7486008,92560,35739,10,103809024 +All.wide.1000.prepared.replace-last,10054889,168250,55888,28,103809024 +All.wide.1000.prepared.splice-middle,7233084,263102,35504,10,103809024 +All.wide.1000.prepared.typed-first,60952,762,374,0,103809024 +All.wide.1000.prepared.typed-last,53430616,936080,303764,120,103809024 +All.wide.1000.prepared.typed-all,70769922,1441386,407587,167,103809024 +All.wide.10000.construct.direct,483299915,10707722,2505047,37458,103809024 +All.wide.10000.construct.builder-tokens,949100178,22338000,4030441,65284,103809024 +All.wide.10000.prepared.render,336977351,5949058,1454203,2052,103809024 +All.wide.10000.prepared.builder-reuse,723059071,17989208,2198685,14807,103809024 +All.wide.10000.prepared.builder-checkpoint,763621498,101824774,2224489,14792,103809024 +All.wide.10000.prepared.child-first,41403,1564,221,0,103809024 +All.wide.10000.prepared.child-middle,74976671,1391448,425048,1302,103809024 +All.wide.10000.prepared.child-last,209792302,6248080,882875,5896,103809024 +All.wide.10000.prepared.siblings,551021223,45131812,2790897,10054,103809024 +All.wide.10000.prepared.offset-last,811688944,33271740,3494499,12746,103809024 +All.wide.10000.prepared.cover-last,750446238,58625400,3175119,11448,103809024 +All.wide.10000.prepared.replace-first,50054514,1451252,153877,6,103809024 +All.wide.10000.prepared.replace-middle,121078141,2716702,457531,1003,103809024 +All.wide.10000.prepared.replace-last,215741571,4427452,782477,2556,103809024 +All.wide.10000.prepared.splice-middle,115872841,3721726,424762,947,103809024 +All.wide.10000.prepared.typed-first,62238,4618,374,0,103809024 +All.wide.10000.prepared.typed-last,576339748,5449596,3006647,11265,103809024 +All.wide.10000.prepared.typed-all,721432787,19809996,4069927,14886,103809024 +All.deep.100.construct,1514459,75072,8739,1,103809024 +All.deep.100.prepared.render,1299463,44706,5205,0,103809024 +All.deep.100.prepared.descend,3480590,54810,20955,3,103809024 +All.deep.100.prepared.replace-path,3538137,71636,21787,3,103809024 +All.deep.100.prepared.offset,7293463,279820,44506,15,103809024 +All.deep.100.prepared.focus-and-replace,6623869,212176,39421,7,103809024 +All.deep.100.focused.replace,2382991,44490,13460,2,103809024 +All.deep.100.focused.root,358372,55096,1630,0,103809024 +All.deep.1000.construct,15812836,1430058,87902,117,103809024 +All.deep.1000.prepared.render,14127560,177214,48032,24,103809024 +All.deep.1000.prepared.descend,38310733,2535628,206663,262,103809024 +All.deep.1000.prepared.replace-path,63988594,1703414,341739,279,103809024 +All.deep.1000.prepared.offset,83172440,16881524,437673,1422,103809024 +All.deep.1000.prepared.focus-and-replace,89094182,4750356,463116,615,103809024 +All.deep.1000.focused.replace,37665093,1274968,198480,187,103809024 +All.deep.1000.focused.root,8874543,151612,15756,0,103809024 +All.deep.10000.construct,165634120,12086260,873303,11308,103809024 +All.deep.10000.prepared.render,191767324,10515248,474693,2288,103809024 +All.deep.10000.prepared.descend,475162658,7840146,2074881,26470,103809024 +All.deep.10000.prepared.replace-path,795340598,19995994,3569741,27174,103809024 +All.deep.10000.prepared.offset,1236956446,13038986,4815710,139166,103809024 +All.deep.10000.prepared.focus-and-replace,1032035087,12797240,4596541,60698,103809024 +All.deep.10000.focused.replace,398447450,13595272,1936601,18111,103809024 +All.deep.10000.focused.root,185780885,1388698,153877,5,103809024 +All.document-1000.construct,272589048,3053464,1549433,13595,103809024 +All.document-1000.render,189259750,55305398,768653,451,103809024 +All.document-1000.tokens,668350410,146914566,3014654,1253,103809024 +All.document-1000.typed-first-group,62819,870,374,0,103809024 +All.document-1000.typed-all-groups,71166437,5910196,407691,160,103809024 +All.document-1000.100-edits-latest,770174032,19871488,3659800,1088,103809024 +All.document-1000.100-edits-history,773265321,24743224,3657279,1055,103809024 diff --git a/bench/results/2026-10-17/environment.json b/bench/results/2026-10-17/environment.json new file mode 100644 --- /dev/null +++ b/bench/results/2026-10-17/environment.json @@ -0,0 +1,67 @@ +{ + "started_at": "2026-10-17T11:01:58.182111+00:00", + "platform": "Linux-7.2.10-200.fc44.x86_64-x86_64-with-glibc2.43", + "ghc": "9.12.2", + "cabal": "3.18.1.0", + "parent_revision": "321036167a529a4bf2bca7f695c5e4842f39999f", + "working_copy": "0 files changed, 0 insertions(+), 0 deletions(-)", + "binary_sha256": "6a7eafdea5d15b4d95db17881be52bee110e0786e884ccc42ef8c4228fe0c04c", + "source_sha256": { + "graft.cabal": "add27375e3a9e9902b7ca07a5fceeb86573f37000dec1d72b62d6ed13174c87d", + "src/Graft/Ast.hs": "1ee1a64e697feb05b697354a76a6e5e16ad6aef92915ef2e861bf8ea60d7c939", + "src/Graft/Builder.hs": "b867b1771b5d6a51fb93cf0f3b4a7519370dc1e7192848be9868fd1704791e14", + "src/Graft/Cursor.hs": "2cfc3dd46fa82f4ad23eabd61d4025ca0cba4cb3d3dd9bb7a9d3e7ca461136ee", + "src/Graft/Edit.hs": "a86b70df27532d6410558df8973609d5d35fa3d350c976d72f5cc98506be5653", + "src/Graft/Green/Internal.hs": "afb6807a24ba756bf5a94c425a634d02fc81ac083069df4ae02da1a47ca2de06", + "src/Graft/Green.hs": "a073e55e51433ee5591a49bdae91dadb802f56b7d0e899ad463628c641f3e098", + "src/Graft/LineIndex.hs": "da2803d6e0dfe25a10f6a05f743baa83c6e5d7c3ad3cab7d038a5d3d7e22686c", + "src/Graft/Range.hs": "75fe3f8b02d10440a3ba0e3bfd0a7331eb5b12c31a2c9a273bb29fae8336f93f", + "src/Graft.hs": "527bdc16c703318225a8fea30874ce4217f3907fce5f8eb9104da797d68bf58d", + "bench/Fixtures.hs": "fe8886dc05796357fb955cbc1c0839414820ec2f7c365b99acd09cf045993a3e", + "bench/Main.hs": "6afc6d78b8db094d8dc14ff267f4773a80f75bc56bf2f9f04c1e0dedee7bf04f", + "bench/Residency.hs": "5c0e2329bed9efa4bb8b5057617ce6686e7bc25f624f6971954e86a183f0a3b5", + "bench/run.py": "f0d00b83e554b37fc0eaa9d7e0ac138e6215bf03df6d5e229454512d86c9cf12" + }, + "cpu": 2, + "affinity": [ + 0, + 1, + 2, + 3, + 4, + 5, + 6, + 7, + 8, + 9, + 10, + 11, + 12, + 13, + 14, + 15 + ], + "lscpu": "Architecture: x86_64\nCPU op-mode(s): 32-bit, 64-bit\nAddress sizes: 52 bits physical, 57 bits virtual\nByte Order: Little Endian\nCPU(s): 16\nOn-line CPU(s) list: 0-15\nVendor ID: GenuineIntel\nModel name: Intel(R) Xeon(R) w3-2435\nCPU family: 6\nModel: 143\nThread(s) per core: 2\nCore(s) per socket: 8\nSocket(s): 1\nStepping: 8\nCPU(s) scaling MHz: 24%\nCPU max MHz: 4500.0000\nCPU min MHz: 800.0000\nBogoMIPS: 6192.00\nFlags: fpu vme de pse tsc msr pae mce cx8 apic sep mtrr pge mca cmov pat pse36 clflush dts acpi mmx fxsr sse sse2 ss ht tm pbe syscall nx pdpe1gb rdtscp lm constant_tsc art arch_perfmon pebs bts rep_good nopl xtopology nonstop_tsc cpuid aperfmperf tsc_known_freq pni pclmulqdq dtes64 monitor ds_cpl vmx smx est tm2 ssse3 sdbg fma cx16 xtpr pdcm pcid dca sse4_1 sse4_2 x2apic movbe popcnt tsc_deadline_timer aes xsave avx f16c rdrand lahf_lm abm 3dnowprefetch cpuid_fault epb cat_l3 cat_l2 cdp_l3 intel_ppin cdp_l2 ssbd mba ibrs ibpb stibp ibrs_enhanced tpr_shadow flexpriority ept vpid ept_ad fsgsbase tsc_adjust bmi1 avx2 smep bmi2 erms invpcid cqm rdt_a avx512f avx512dq rdseed adx smap avx512ifma clflushopt clwb intel_pt avx512cd sha_ni avx512bw avx512vl xsaveopt xsavec xgetbv1 xsaves cqm_llc cqm_occup_llc cqm_mbm_total cqm_mbm_local split_lock_detect user_shstk avx_vnni avx512_bf16 wbnoinvd dtherm ida arat pln pts hwp hwp_act_window hwp_epp hwp_pkg_req vnmi avx512vbmi umip pku ospke waitpkg avx512_vbmi2 gfni vaes vpclmulqdq avx512_vnni avx512_bitalg avx512_vpopcntdq la57 rdpid bus_lock_detect cldemote movdiri movdir64b enqcmd fsrm md_clear serialize tsxldtrk pconfig arch_lbr ibt amx_bf16 avx512_fp16 amx_tile amx_int8 flush_l1d arch_capabilities\nVirtualization: VT-x\nL1d cache: 384 KiB (8 instances)\nL1i cache: 256 KiB (8 instances)\nL2 cache: 16 MiB (8 instances)\nL3 cache: 22.5 MiB (1 instance)\nNUMA node(s): 1\nNUMA node0 CPU(s): 0-15\nVulnerability Gather data sampling: Not affected\nVulnerability Ghostwrite: Not affected\nVulnerability Indirect target selection: Not affected\nVulnerability Itlb multihit: Not affected\nVulnerability L1tf: Not affected\nVulnerability Mds: Not affected\nVulnerability Meltdown: Not affected\nVulnerability Mmio stale data: Not affected\nVulnerability Old microcode: Not affected\nVulnerability Reg file data sampling: Not affected\nVulnerability Retbleed: Not affected\nVulnerability Spec rstack overflow: Not affected\nVulnerability Spec store bypass: Mitigation; Speculative Store Bypass disabled via prctl\nVulnerability Spectre v1: Mitigation; usercopy/swapgs barriers and __user pointer sanitization\nVulnerability Spectre v2: Mitigation; Enhanced / Automatic IBRS; IBPB conditional; PBRSB-eIBRS SW sequence; BHI BHI_DIS_S\nVulnerability Srbds: Not affected\nVulnerability Tsa: Not affected\nVulnerability Tsx async abort: Not affected\nVulnerability Vmscape: Mitigation; IBPB before exit to userspace", + "timing_options": [ + "--stdev", + "2.0", + "--timeout", + "3s", + "--time-mode", + "cpu", + "--color", + "never", + "+RTS", + "-T", + "-A32m", + "-RTS" + ], + "runs": 2, + "residency_options": [ + "+RTS", + "-T", + "-RTS" + ], + "build_command": "cabal build bench:graft-bench --enable-benchmarks -O2 --ghc-options=-Werror", + "governor": "powersave" +} diff --git a/bench/results/2026-10-17/residency.csv b/bench/results/2026-10-17/residency.csv new file mode 100644 --- /dev/null +++ b/bench/results/2026-10-17/residency.csv @@ -0,0 +1,13 @@ +Scenario,Lines,Edits,Live bytes,Baseline live bytes,Live delta bytes,Allocated bytes,Checksum +tree,1000,0,532176,2872,529304,1118192,22893 +shared,1000,0,20736,2920,17816,67320,21000 +cursor,1000,0,532320,2920,529400,1118496,11405 +detached-token,1000,0,4320,3112,1208,1119112,3 +latest,1000,100,532248,2920,529328,2025432,22893 +history,1000,100,1386064,2944,1383120,2036680,2312085 +tree,10000,0,5284176,2872,5281304,11558232,238894 +shared,10000,0,164736,2920,161816,643320,210000 +cursor,10000,0,5284320,2920,5281400,11558536,118907 +detached-token,10000,0,4320,3112,1208,11559152,3 +latest,10000,100,5284248,2920,5281328,19881472,238894 +history,10000,100,13554064,2944,13551120,19892720,24128186 diff --git a/bench/results/2026-10-17/timing-1.csv b/bench/results/2026-10-17/timing-1.csv new file mode 100644 --- /dev/null +++ b/bench/results/2026-10-17/timing-1.csv @@ -0,0 +1,108 @@ +Name,Mean (ps),2*Stdev (ps),Allocated,Copied,Peak Memory +All.token.32.ascii,1909,48,15,0,36700160 +All.token.32.unicode,1914,48,15,0,36700160 +All.token.4096.ascii,1923,50,15,0,36700160 +All.token.4096.unicode,1884,46,15,0,36700160 +All.wide.100.construct.direct,2349654,41532,15766,3,36700160 +All.wide.100.construct.builder-tokens,3209837,70250,23223,7,36700160 +All.wide.100.construct.builder-monad,3203092,58394,23041,6,36700160 +All.wide.100.prepared.render,420478,13718,617,0,36700160 +All.wide.100.prepared.builder-reuse,3479688,90822,22370,2,36700160 +All.wide.100.prepared.builder-checkpoint,3539234,85616,22441,2,36700160 +All.wide.100.prepared.child-first,2645,64,15,0,36700160 +All.wide.100.prepared.child-middle,4014,160,15,0,36700160 +All.wide.100.prepared.child-last,4022,24,15,0,36700160 +All.wide.100.prepared.siblings,2949908,88602,20996,1,36700160 +All.wide.100.prepared.offset-first,56812,772,436,0,36700160 +All.wide.100.prepared.offset-last,55728,2058,435,0,36700160 +All.wide.100.prepared.cover-last,32850,674,238,0,36700160 +All.wide.100.prepared.replace-first,119095,3048,1905,0,36700160 +All.wide.100.prepared.replace-middle,116889,3096,1905,0,36700160 +All.wide.100.prepared.replace-last,123923,5752,1916,0,36700160 +All.wide.100.prepared.splice-middle,142733,3030,1786,0,36700160 +All.wide.100.prepared.typed-first,49907,536,415,0,36700160 +All.wide.100.prepared.typed-last,3197768,103272,23277,1,36700160 +All.wide.100.prepared.typed-all,3858715,97838,30429,1,36700160 +All.wide.1000.construct.direct,20000821,388646,158816,167,39845888 +All.wide.1000.construct.builder-tokens,34206163,1331690,231025,428,39845888 +All.wide.1000.construct.builder-monad,34033983,813282,231056,426,39845888 +All.wide.1000.prepared.render,4436348,126592,6687,0,76546048 +All.wide.1000.prepared.builder-reuse,37310550,675656,220020,89,76546048 +All.wide.1000.prepared.builder-checkpoint,37758849,743826,219801,84,76546048 +All.wide.1000.prepared.child-first,2629,96,15,0,76546048 +All.wide.1000.prepared.child-middle,4020,96,15,0,76546048 +All.wide.1000.prepared.child-last,4036,84,15,0,76546048 +All.wide.1000.prepared.siblings,30077974,1005124,215704,11,76546048 +All.wide.1000.prepared.offset-first,55784,1730,436,0,76546048 +All.wide.1000.prepared.offset-last,57052,2118,435,0,76546048 +All.wide.1000.prepared.cover-last,34279,440,238,0,76546048 +All.wide.1000.prepared.replace-first,1130971,39606,16287,0,76546048 +All.wide.1000.prepared.replace-middle,1091906,60910,16287,0,76546048 +All.wide.1000.prepared.replace-last,1060605,22946,16287,0,76546048 +All.wide.1000.prepared.splice-middle,1343749,30588,16144,0,76546048 +All.wide.1000.prepared.typed-first,49283,1912,411,0,76546048 +All.wide.1000.prepared.typed-last,29651221,875642,230364,11,76546048 +All.wide.1000.prepared.typed-all,39157010,6199976,303796,15,76546048 +All.wide.10000.construct.direct,238983924,6827350,1597235,19290,76546048 +All.wide.10000.construct.builder-tokens,482898139,11692560,2295772,41284,76546048 +All.wide.10000.construct.builder-monad,487649147,17506570,2295776,41211,76546048 +All.wide.10000.prepared.render,42266924,1244778,77184,3,78643200 +All.wide.10000.prepared.builder-reuse,508932099,12608030,2168659,7482,78643200 +All.wide.10000.prepared.builder-checkpoint,514335758,19611654,2166532,7695,78643200 +All.wide.10000.prepared.child-first,2636,92,15,0,78643200 +All.wide.10000.prepared.child-middle,4013,84,15,0,78643200 +All.wide.10000.prepared.child-last,4012,86,15,0,78643200 +All.wide.10000.prepared.siblings,325806774,7141618,2133688,99,78643200 +All.wide.10000.prepared.offset-first,56388,1332,435,0,78643200 +All.wide.10000.prepared.offset-last,58408,1444,435,0,78643200 +All.wide.10000.prepared.cover-last,36411,988,238,0,78643200 +All.wide.10000.prepared.replace-first,10057104,254906,160282,7,81788928 +All.wide.10000.prepared.replace-middle,9601104,239020,160282,7,81788928 +All.wide.10000.prepared.replace-last,8976208,326926,160282,7,81788928 +All.wide.10000.prepared.splice-middle,12991006,418532,160154,6,81788928 +All.wide.10000.prepared.typed-first,46794,1486,411,0,81788928 +All.wide.10000.prepared.typed-last,318997687,13054026,2304069,105,81788928 +All.wide.10000.prepared.typed-all,403490235,11751168,2980759,145,81788928 +All.deep.100.construct,1624709,57426,12741,2,81788928 +All.deep.100.prepared.render,424527,10618,0,0,81788928 +All.deep.100.prepared.descend,2466887,83906,18204,2,81788928 +All.deep.100.prepared.replace-path,3965385,92308,27901,1,81788928 +All.deep.100.prepared.offset,3605413,101512,24671,9,81788928 +All.deep.100.prepared.focus-and-replace,4153859,98634,28792,4,81788928 +All.deep.100.focused.replace,1545785,42258,10382,2,81788928 +All.deep.100.focused.root,143128,3726,69,0,81788928 +All.deep.1000.construct,16050236,343154,126255,195,81788928 +All.deep.1000.prepared.render,5952218,228130,0,0,81788928 +All.deep.1000.prepared.descend,25372845,853846,181199,139,81788928 +All.deep.1000.prepared.replace-path,57408390,1442442,374387,395,81788928 +All.deep.1000.prepared.offset,37700813,735074,245735,869,81788928 +All.deep.1000.prepared.focus-and-replace,42879779,4061548,287811,392,81788928 +All.deep.1000.focused.replace,15937760,355728,103538,162,81788928 +All.deep.1000.focused.root,2219584,85248,0,0,81788928 +All.deep.10000.construct,166399654,6136084,1264040,18772,81788928 +All.deep.10000.prepared.render,43150094,677048,0,0,81788928 +All.deep.10000.prepared.descend,269411660,7874274,1811958,11461,81788928 +All.deep.10000.prepared.replace-path,797167615,30710142,4151179,39506,81788928 +All.deep.10000.prepared.offset,589970089,12753126,2943759,83854,81788928 +All.deep.10000.prepared.focus-and-replace,506848473,19684078,2853820,35322,81788928 +All.deep.10000.focused.replace,169510965,6013200,1004427,14234,81788928 +All.deep.10000.focused.root,22961921,1663636,0,0,81788928 +All.chain.100.tokens,12659769,429896,106848,38,81788928 +All.chain.100.descendants,12431197,439314,106848,38,81788928 +All.chain.100.offset-first,3826896,152720,30727,13,81788928 +All.chain.100.offset-last,52841,1256,436,0,81788928 +All.chain.1000.tokens,133007861,4103656,1068307,3434,81788928 +All.chain.1000.descendants,138139123,3215644,1068307,3434,81788928 +All.chain.1000.offset-first,38037412,1231920,302878,1288,81788928 +All.chain.1000.offset-last,52842,2036,435,0,81788928 +All.chain.10000.tokens,1768979337,54869488,10566446,341198,81788928 +All.chain.10000.descendants,1802800512,54006938,10566447,341411,81788928 +All.chain.10000.offset-first,571723731,20579364,3461958,116132,81788928 +All.chain.10000.offset-last,52883,1386,435,0,81788928 +All.document-1000.construct,137283972,4668608,1098537,8440,81788928 +All.document-1000.render,23595184,638992,22159,0,85983232 +All.document-1000.tokens,254259794,6572018,2080055,91,85983232 +All.document-1000.typed-first-group,33422,690,316,0,85983232 +All.document-1000.typed-all-groups,36714291,1327142,302956,11,85983232 +All.document-1000.100-edits-latest,65431094,1406096,903648,35,85983232 +All.document-1000.100-edits-history,71539545,746036,914869,36,85983232 diff --git a/bench/results/2026-10-17/timing-2.csv b/bench/results/2026-10-17/timing-2.csv new file mode 100644 --- /dev/null +++ b/bench/results/2026-10-17/timing-2.csv @@ -0,0 +1,108 @@ +Name,Mean (ps),2*Stdev (ps),Allocated,Copied,Peak Memory +All.token.32.ascii,1423,54,15,0,36700160 +All.token.32.unicode,1426,46,15,0,36700160 +All.token.4096.ascii,1423,44,15,0,36700160 +All.token.4096.unicode,1423,42,15,0,36700160 +All.wide.100.construct.direct,1818286,56094,15766,3,36700160 +All.wide.100.construct.builder-tokens,3098221,104406,22766,7,36700160 +All.wide.100.construct.builder-monad,3103501,112284,22737,6,36700160 +All.wide.100.prepared.render,414474,13218,617,0,36700160 +All.wide.100.prepared.builder-reuse,3376845,46442,22370,2,36700160 +All.wide.100.prepared.builder-checkpoint,3451876,95188,22441,2,36700160 +All.wide.100.prepared.child-first,2673,90,15,0,36700160 +All.wide.100.prepared.child-middle,3993,80,15,0,36700160 +All.wide.100.prepared.child-last,4040,158,15,0,36700160 +All.wide.100.prepared.siblings,2850688,95676,20996,1,36700160 +All.wide.100.prepared.offset-first,53812,1966,438,0,36700160 +All.wide.100.prepared.offset-last,54463,1738,435,0,36700160 +All.wide.100.prepared.cover-last,31646,1072,238,0,36700160 +All.wide.100.prepared.replace-first,112962,3710,1905,0,36700160 +All.wide.100.prepared.replace-middle,114146,2612,1905,0,36700160 +All.wide.100.prepared.replace-last,114884,3892,1905,0,36700160 +All.wide.100.prepared.splice-middle,138862,3494,1784,0,36700160 +All.wide.100.prepared.typed-first,44966,978,414,0,36700160 +All.wide.100.prepared.typed-last,2837940,91966,23277,1,36700160 +All.wide.100.prepared.typed-all,3666044,133254,30429,1,36700160 +All.wide.1000.construct.direct,19607473,721274,157908,168,39845888 +All.wide.1000.construct.builder-tokens,33451065,704626,231025,426,39845888 +All.wide.1000.construct.builder-monad,33429844,1323834,227553,414,39845888 +All.wide.1000.prepared.render,4274049,66278,6790,0,76546048 +All.wide.1000.prepared.builder-reuse,36238827,1360856,218259,107,76546048 +All.wide.1000.prepared.builder-checkpoint,36454610,695992,219801,86,76546048 +All.wide.1000.prepared.child-first,2670,92,15,0,76546048 +All.wide.1000.prepared.child-middle,3975,100,15,0,76546048 +All.wide.1000.prepared.child-last,4002,50,15,0,76546048 +All.wide.1000.prepared.siblings,28796546,604688,215704,11,76546048 +All.wide.1000.prepared.offset-first,53603,1868,435,0,76546048 +All.wide.1000.prepared.offset-last,54806,2048,435,0,76546048 +All.wide.1000.prepared.cover-last,33066,802,238,0,76546048 +All.wide.1000.prepared.replace-first,1093365,22904,16287,0,76546048 +All.wide.1000.prepared.replace-middle,1090701,25500,16261,0,76546048 +All.wide.1000.prepared.replace-last,977433,36438,16287,0,76546048 +All.wide.1000.prepared.splice-middle,1265745,23620,16118,0,76546048 +All.wide.1000.prepared.typed-first,44720,1464,411,0,76546048 +All.wide.1000.prepared.typed-last,28373080,777000,230362,12,76546048 +All.wide.1000.prepared.typed-all,36495553,739904,302986,16,76546048 +All.wide.10000.construct.direct,233189027,5483492,1597235,18821,76546048 +All.wide.10000.construct.builder-tokens,475788353,11275212,2295772,41283,76546048 +All.wide.10000.construct.builder-monad,477530998,17083212,2295777,41212,76546048 +All.wide.10000.prepared.render,41942804,1495734,77184,3,79691776 +All.wide.10000.prepared.builder-reuse,495167412,11354476,2168659,7467,79691776 +All.wide.10000.prepared.builder-checkpoint,498823486,12753644,2166529,7694,79691776 +All.wide.10000.prepared.child-first,2640,96,15,0,79691776 +All.wide.10000.prepared.child-middle,4013,94,15,0,79691776 +All.wide.10000.prepared.child-last,4015,140,15,0,79691776 +All.wide.10000.prepared.siblings,312091203,10797098,2095358,102,79691776 +All.wide.10000.prepared.offset-first,54494,1854,435,0,79691776 +All.wide.10000.prepared.offset-last,56286,1572,435,0,79691776 +All.wide.10000.prepared.cover-last,35210,762,238,0,79691776 +All.wide.10000.prepared.replace-first,9645158,367446,160281,7,80740352 +All.wide.10000.prepared.replace-middle,9520721,337284,160283,7,80740352 +All.wide.10000.prepared.replace-last,8750938,266944,160282,6,80740352 +All.wide.10000.prepared.splice-middle,12673736,341986,160154,6,80740352 +All.wide.10000.prepared.typed-first,44711,592,415,0,80740352 +All.wide.10000.prepared.typed-last,302463556,10922932,2258641,107,80740352 +All.wide.10000.prepared.typed-all,385066866,11260306,2980758,146,80740352 +All.deep.100.construct,1587704,29402,12741,2,80740352 +All.deep.100.prepared.render,434396,15318,0,0,80740352 +All.deep.100.prepared.descend,2357814,90132,18204,2,80740352 +All.deep.100.prepared.replace-path,3882543,90836,27901,1,80740352 +All.deep.100.prepared.offset,3487745,99664,24671,9,80740352 +All.deep.100.prepared.focus-and-replace,4047725,87696,28792,4,80740352 +All.deep.100.focused.replace,1551675,51314,10382,2,80740352 +All.deep.100.focused.root,142082,5250,63,0,80740352 +All.deep.1000.construct,15718770,435022,126255,200,80740352 +All.deep.1000.prepared.render,5945047,90412,0,0,80740352 +All.deep.1000.prepared.descend,24526172,763764,181199,139,80740352 +All.deep.1000.prepared.replace-path,56704525,776464,374380,325,80740352 +All.deep.1000.prepared.offset,35626540,962784,245735,859,80740352 +All.deep.1000.prepared.focus-and-replace,42273990,1683776,282138,375,80740352 +All.deep.1000.focused.replace,16005380,387332,103538,162,80740352 +All.deep.1000.focused.root,2212537,78362,0,0,80740352 +All.deep.10000.construct,163701475,5528990,1264043,18792,80740352 +All.deep.10000.prepared.render,42478740,1561774,0,0,80740352 +All.deep.10000.prepared.descend,267016801,10442860,1811958,10946,80740352 +All.deep.10000.prepared.replace-path,789545744,14391790,4151176,39506,80740352 +All.deep.10000.prepared.offset,605271110,14019994,2943759,83881,80740352 +All.deep.10000.prepared.focus-and-replace,540129094,12252506,2853825,35300,80740352 +All.deep.10000.focused.replace,170837672,6033254,1004429,14204,80740352 +All.deep.10000.focused.root,22942751,3767388,0,0,80740352 +All.chain.100.tokens,12645178,240004,108062,38,80740352 +All.chain.100.descendants,12379751,218360,108062,38,80740352 +All.chain.100.offset-first,3778100,76902,30829,13,80740352 +All.chain.100.offset-last,52564,1688,435,0,80740352 +All.chain.1000.tokens,142496339,4440236,1068307,3440,80740352 +All.chain.1000.descendants,129204531,4442348,1068307,3437,80740352 +All.chain.1000.offset-first,38935558,1164980,302878,1285,80740352 +All.chain.1000.offset-last,52663,1322,435,0,80740352 +All.chain.10000.tokens,1823844487,53519406,10566446,341229,80740352 +All.chain.10000.descendants,1775043659,62193254,10566447,341217,80740352 +All.chain.10000.offset-first,565200716,11504712,3461958,113111,80740352 +All.chain.10000.offset-last,52444,1300,435,0,80740352 +All.document-1000.construct,135652541,3367344,1098536,8515,80740352 +All.document-1000.render,23434051,336976,22159,0,85983232 +All.document-1000.tokens,252024644,6683798,2080055,91,85983232 +All.document-1000.typed-first-group,33216,734,316,0,85983232 +All.document-1000.typed-all-groups,36680940,1013028,303766,11,85983232 +All.document-1000.100-edits-latest,65031409,1186970,903648,35,85983232 +All.document-1000.100-edits-history,70862757,1723574,914869,36,85983232 diff --git a/bench/results/2026-10-17b/environment.json b/bench/results/2026-10-17b/environment.json new file mode 100644 --- /dev/null +++ b/bench/results/2026-10-17b/environment.json @@ -0,0 +1,67 @@ +{ + "started_at": "2026-10-17T11:46:47.360522+00:00", + "platform": "Linux-7.2.10-200.fc44.x86_64-x86_64-with-glibc2.43", + "ghc": "9.12.2", + "cabal": "3.18.1.0", + "parent_revision": "d6920da04cabb94c6fa1d63a74ca7ccc819be77e", + "working_copy": "0 files changed, 0 insertions(+), 0 deletions(-)", + "binary_sha256": "84d363eb6cde1153e5e7dfac7d384e5c3ff97125a39864eedd17a39475a9b08b", + "source_sha256": { + "graft.cabal": "e80d943acaee74d882a4a2857eff8d5ab8b92c48edc561e6543b6a93e7528058", + "src/Graft/Ast.hs": "b066ef7c5147429ce225b02a177569bc37488c364130306d540f44a480dc2988", + "src/Graft/Builder.hs": "3ba4227522046c2e1e96fcec63cf3090212d60ade067c27436177ead7b3afdc7", + "src/Graft/Cursor.hs": "1f537d902813a5dd29bbe28fd606a70ebe6f9f65acd949709532d38ba2014f3b", + "src/Graft/Edit.hs": "5c4811d3f925e537280b28369d756d47ebb39c7b1774fd93d5d35a7feaa177f4", + "src/Graft/Green/Internal.hs": "0c40c5fec301ee545f162fd3b002c3e479dfc214ee0af0631b4931a125112f88", + "src/Graft/Green.hs": "5ba0aa74f23dbd801a0777f8054e3aa55af03565be53e0d41a7724083feee449", + "src/Graft/LineIndex.hs": "69066a9100562fb04b49e0600c497cc90d5cbba83fbccbfa8dd3fae7e02df8a7", + "src/Graft/Range.hs": "551ac6c06b4e7a0737c63a3ada39ae4f7796118a80dc765a4cf79c69b45309fd", + "src/Graft.hs": "527bdc16c703318225a8fea30874ce4217f3907fce5f8eb9104da797d68bf58d", + "bench/Fixtures.hs": "fe8886dc05796357fb955cbc1c0839414820ec2f7c365b99acd09cf045993a3e", + "bench/Main.hs": "6afc6d78b8db094d8dc14ff267f4773a80f75bc56bf2f9f04c1e0dedee7bf04f", + "bench/Residency.hs": "5c0e2329bed9efa4bb8b5057617ce6686e7bc25f624f6971954e86a183f0a3b5", + "bench/run.py": "f0d00b83e554b37fc0eaa9d7e0ac138e6215bf03df6d5e229454512d86c9cf12" + }, + "cpu": 2, + "affinity": [ + 0, + 1, + 2, + 3, + 4, + 5, + 6, + 7, + 8, + 9, + 10, + 11, + 12, + 13, + 14, + 15 + ], + "lscpu": "Architecture: x86_64\nCPU op-mode(s): 32-bit, 64-bit\nAddress sizes: 52 bits physical, 57 bits virtual\nByte Order: Little Endian\nCPU(s): 16\nOn-line CPU(s) list: 0-15\nVendor ID: GenuineIntel\nModel name: Intel(R) Xeon(R) w3-2435\nCPU family: 6\nModel: 143\nThread(s) per core: 2\nCore(s) per socket: 8\nSocket(s): 1\nStepping: 8\nCPU(s) scaling MHz: 76%\nCPU max MHz: 4500.0000\nCPU min MHz: 800.0000\nBogoMIPS: 6192.00\nFlags: fpu vme de pse tsc msr pae mce cx8 apic sep mtrr pge mca cmov pat pse36 clflush dts acpi mmx fxsr sse sse2 ss ht tm pbe syscall nx pdpe1gb rdtscp lm constant_tsc art arch_perfmon pebs bts rep_good nopl xtopology nonstop_tsc cpuid aperfmperf tsc_known_freq pni pclmulqdq dtes64 monitor ds_cpl vmx smx est tm2 ssse3 sdbg fma cx16 xtpr pdcm pcid dca sse4_1 sse4_2 x2apic movbe popcnt tsc_deadline_timer aes xsave avx f16c rdrand lahf_lm abm 3dnowprefetch cpuid_fault epb cat_l3 cat_l2 cdp_l3 intel_ppin cdp_l2 ssbd mba ibrs ibpb stibp ibrs_enhanced tpr_shadow flexpriority ept vpid ept_ad fsgsbase tsc_adjust bmi1 avx2 smep bmi2 erms invpcid cqm rdt_a avx512f avx512dq rdseed adx smap avx512ifma clflushopt clwb intel_pt avx512cd sha_ni avx512bw avx512vl xsaveopt xsavec xgetbv1 xsaves cqm_llc cqm_occup_llc cqm_mbm_total cqm_mbm_local split_lock_detect user_shstk avx_vnni avx512_bf16 wbnoinvd dtherm ida arat pln pts hwp hwp_act_window hwp_epp hwp_pkg_req vnmi avx512vbmi umip pku ospke waitpkg avx512_vbmi2 gfni vaes vpclmulqdq avx512_vnni avx512_bitalg avx512_vpopcntdq la57 rdpid bus_lock_detect cldemote movdiri movdir64b enqcmd fsrm md_clear serialize tsxldtrk pconfig arch_lbr ibt amx_bf16 avx512_fp16 amx_tile amx_int8 flush_l1d arch_capabilities\nVirtualization: VT-x\nL1d cache: 384 KiB (8 instances)\nL1i cache: 256 KiB (8 instances)\nL2 cache: 16 MiB (8 instances)\nL3 cache: 22.5 MiB (1 instance)\nNUMA node(s): 1\nNUMA node0 CPU(s): 0-15\nVulnerability Gather data sampling: Not affected\nVulnerability Ghostwrite: Not affected\nVulnerability Indirect target selection: Not affected\nVulnerability Itlb multihit: Not affected\nVulnerability L1tf: Not affected\nVulnerability Mds: Not affected\nVulnerability Meltdown: Not affected\nVulnerability Mmio stale data: Not affected\nVulnerability Old microcode: Not affected\nVulnerability Reg file data sampling: Not affected\nVulnerability Retbleed: Not affected\nVulnerability Spec rstack overflow: Not affected\nVulnerability Spec store bypass: Mitigation; Speculative Store Bypass disabled via prctl\nVulnerability Spectre v1: Mitigation; usercopy/swapgs barriers and __user pointer sanitization\nVulnerability Spectre v2: Mitigation; Enhanced / Automatic IBRS; IBPB conditional; PBRSB-eIBRS SW sequence; BHI BHI_DIS_S\nVulnerability Srbds: Not affected\nVulnerability Tsa: Not affected\nVulnerability Tsx async abort: Not affected\nVulnerability Vmscape: Mitigation; IBPB before exit to userspace", + "timing_options": [ + "--stdev", + "2.0", + "--timeout", + "3s", + "--time-mode", + "cpu", + "--color", + "never", + "+RTS", + "-T", + "-A32m", + "-RTS" + ], + "runs": 2, + "residency_options": [ + "+RTS", + "-T", + "-RTS" + ], + "build_command": "cabal build bench:graft-bench --enable-benchmarks -O2 --ghc-options=-Werror", + "governor": "powersave" +} diff --git a/bench/results/2026-10-17b/residency.csv b/bench/results/2026-10-17b/residency.csv new file mode 100644 --- /dev/null +++ b/bench/results/2026-10-17b/residency.csv @@ -0,0 +1,13 @@ +Scenario,Lines,Edits,Live bytes,Baseline live bytes,Live delta bytes,Allocated bytes,Checksum +tree,1000,0,452176,2872,449304,1038192,22893 +shared,1000,0,20656,2920,17736,67240,21000 +cursor,1000,0,452320,2920,449400,1038496,11405 +detached-token,1000,0,4304,3112,1192,1039112,3 +latest,1000,100,452248,2920,449328,1943832,22893 +history,1000,100,1304464,2944,1301520,1955080,2312085 +tree,10000,0,4484176,2872,4481304,10758232,238894 +shared,10000,0,164656,2920,161736,643240,210000 +cursor,10000,0,4484320,2920,4481400,10758536,118907 +detached-token,10000,0,4304,3112,1192,10759152,3 +latest,10000,100,4484248,2920,4481328,19079872,238894 +history,10000,100,12752464,2944,12749520,19091120,24128186 diff --git a/bench/results/2026-10-17b/timing-1.csv b/bench/results/2026-10-17b/timing-1.csv new file mode 100644 --- /dev/null +++ b/bench/results/2026-10-17b/timing-1.csv @@ -0,0 +1,108 @@ +Name,Mean (ps),2*Stdev (ps),Allocated,Copied,Peak Memory +All.token.32.ascii,1874,40,15,0,36700160 +All.token.32.unicode,1807,38,15,0,36700160 +All.token.4096.ascii,1906,40,15,0,36700160 +All.token.4096.unicode,1752,248,15,0,36700160 +All.wide.100.construct.direct,2374702,84300,14365,2,36700160 +All.wide.100.construct.builder-tokens,1354745,254536,9012,1,36700160 +All.wide.100.construct.builder-monad,1270971,163220,9029,1,36700160 +All.wide.100.prepared.render,513364,18536,629,0,36700160 +All.wide.100.prepared.builder-reuse,2020454,44550,9791,0,36700160 +All.wide.100.prepared.builder-checkpoint,2020479,44530,10065,1,36700160 +All.wide.100.prepared.child-first,3784,102,15,0,36700160 +All.wide.100.prepared.child-middle,4997,744,15,0,36700160 +All.wide.100.prepared.child-last,5026,864,15,0,36700160 +All.wide.100.prepared.siblings,4145363,150072,21196,1,36700160 +All.wide.100.prepared.offset-first,78929,672,436,0,36700160 +All.wide.100.prepared.offset-last,77903,2096,435,0,36700160 +All.wide.100.prepared.cover-last,42671,1388,238,0,36700160 +All.wide.100.prepared.replace-first,162831,10242,1893,0,36700160 +All.wide.100.prepared.replace-middle,160225,14374,1912,0,36700160 +All.wide.100.prepared.replace-last,181300,7812,1912,0,36700160 +All.wide.100.prepared.splice-middle,200505,10860,1786,0,36700160 +All.wide.100.prepared.typed-first,72168,2650,414,0,36700160 +All.wide.100.prepared.typed-last,4371683,122104,23277,1,36700160 +All.wide.100.prepared.typed-all,5296758,667418,30429,1,36700160 +All.wide.1000.construct.direct,23871191,2307906,143115,132,40894464 +All.wide.1000.construct.builder-tokens,12446147,362032,85747,89,44040192 +All.wide.1000.construct.builder-monad,12941454,289810,87918,87,44040192 +All.wide.1000.prepared.render,4433394,436708,6790,0,76546048 +All.wide.1000.prepared.builder-reuse,18210785,443110,94889,33,76546048 +All.wide.1000.prepared.builder-checkpoint,17850612,497778,94739,33,76546048 +All.wide.1000.prepared.child-first,2755,82,15,0,76546048 +All.wide.1000.prepared.child-middle,4353,30,15,0,76546048 +All.wide.1000.prepared.child-last,4337,102,15,0,76546048 +All.wide.1000.prepared.siblings,42523030,4077108,215704,11,76546048 +All.wide.1000.prepared.offset-first,76200,2266,436,0,76546048 +All.wide.1000.prepared.offset-last,76057,2114,436,0,76546048 +All.wide.1000.prepared.cover-last,43834,3444,238,0,76546048 +All.wide.1000.prepared.replace-first,1475290,73926,16263,0,76546048 +All.wide.1000.prepared.replace-middle,1572911,109476,16287,0,76546048 +All.wide.1000.prepared.replace-last,1653024,137136,16287,0,76546048 +All.wide.1000.prepared.splice-middle,1591241,33798,16144,0,76546048 +All.wide.1000.prepared.typed-first,62015,1082,414,0,76546048 +All.wide.1000.prepared.typed-last,37580479,576312,231175,11,76546048 +All.wide.1000.prepared.typed-all,50812367,2563128,303796,15,76546048 +All.wide.10000.construct.direct,273138988,6792556,1423615,12342,76546048 +All.wide.10000.construct.builder-tokens,158202986,5689146,866745,7713,76546048 +All.wide.10000.construct.builder-monad,168304215,7919770,874573,8085,76546048 +All.wide.10000.prepared.render,44939301,1196226,77184,3,78643200 +All.wide.10000.prepared.builder-reuse,200064322,6806196,958894,2933,78643200 +All.wide.10000.prepared.builder-checkpoint,204076135,7257064,957878,2962,78643200 +All.wide.10000.prepared.child-first,2868,930,15,0,78643200 +All.wide.10000.prepared.child-middle,4264,300,15,0,78643200 +All.wide.10000.prepared.child-last,4315,142,15,0,78643200 +All.wide.10000.prepared.siblings,403459250,5542306,2133687,100,78643200 +All.wide.10000.prepared.offset-first,75034,2514,436,0,78643200 +All.wide.10000.prepared.offset-last,72066,1266,438,0,78643200 +All.wide.10000.prepared.cover-last,44443,1602,238,0,78643200 +All.wide.10000.prepared.replace-first,13008923,191928,160258,7,79691776 +All.wide.10000.prepared.replace-middle,15593068,4084056,160281,6,79691776 +All.wide.10000.prepared.replace-last,14741566,312624,160282,6,79691776 +All.wide.10000.prepared.splice-middle,18005118,450864,160155,7,79691776 +All.wide.10000.prepared.typed-first,68383,3060,415,0,79691776 +All.wide.10000.prepared.typed-last,435128569,46520836,2304075,104,79691776 +All.wide.10000.prepared.typed-all,535989769,17931954,2980758,146,79691776 +All.deep.100.construct,1898465,64702,12741,2,79691776 +All.deep.100.prepared.render,453131,192826,44,0,79691776 +All.deep.100.prepared.descend,3291987,118344,18558,2,79691776 +All.deep.100.prepared.replace-path,4512053,128906,27900,1,79691776 +All.deep.100.prepared.offset,4959053,615670,24974,9,79691776 +All.deep.100.prepared.focus-and-replace,5204197,714740,29096,4,79691776 +All.deep.100.focused.replace,1778918,91246,10611,2,79691776 +All.deep.100.focused.root,148991,8902,71,0,79691776 +All.deep.1000.construct,20592441,689544,127069,201,79691776 +All.deep.1000.prepared.render,6302265,222542,0,0,79691776 +All.deep.1000.prepared.descend,34778396,1297614,184030,142,79691776 +All.deep.1000.prepared.replace-path,67101940,1458228,374385,292,79691776 +All.deep.1000.prepared.offset,47943690,1400694,245735,859,79691776 +All.deep.1000.prepared.focus-and-replace,51159116,1417896,282142,370,79691776 +All.deep.1000.focused.replace,19361382,1926610,103946,165,79691776 +All.deep.1000.focused.root,2273531,33694,0,0,79691776 +All.deep.10000.construct,206172411,10277800,1277073,19534,79691776 +All.deep.10000.prepared.render,44416699,1423292,0,0,79691776 +All.deep.10000.prepared.descend,347183320,7941476,1811958,11473,79691776 +All.deep.10000.prepared.replace-path,872687972,10790616,4151179,39484,79691776 +All.deep.10000.prepared.offset,758152818,79476694,2944098,83815,79691776 +All.deep.10000.prepared.focus-and-replace,641935639,47874728,2853817,36062,79691776 +All.deep.10000.focused.replace,191988727,2070656,1033776,16049,79691776 +All.deep.10000.focused.root,24824556,3956640,0,0,79691776 +All.chain.100.tokens,18469066,543190,108062,38,79691776 +All.chain.100.descendants,17792721,410922,108264,38,79691776 +All.chain.100.offset-first,5547750,111842,30727,13,79691776 +All.chain.100.offset-last,78617,6346,436,0,79691776 +All.chain.1000.tokens,193822406,2903238,1068307,3441,79691776 +All.chain.1000.descendants,192324898,2259520,1074781,3419,79691776 +All.chain.1000.offset-first,51136450,1370534,302878,1286,79691776 +All.chain.1000.offset-last,76085,4422,436,0,79691776 +All.chain.10000.tokens,2330588042,124336908,10747636,339720,79691776 +All.chain.10000.descendants,2220872070,30612644,10721742,339789,79691776 +All.chain.10000.offset-first,777865226,23411438,3461958,114655,79691776 +All.chain.10000.offset-last,80890,2494,435,0,79691776 +All.document-1000.construct,183257744,2430520,1026419,6944,79691776 +All.document-1000.render,26498516,205444,22568,0,84934656 +All.document-1000.tokens,362059333,10574980,2080056,93,84934656 +All.document-1000.typed-first-group,48968,854,316,0,84934656 +All.document-1000.typed-all-groups,53524143,3645804,303766,11,84934656 +All.document-1000.100-edits-latest,103399084,3710684,898478,35,84934656 +All.document-1000.100-edits-history,92195966,1860910,913275,36,84934656 diff --git a/bench/results/2026-10-17b/timing-2.csv b/bench/results/2026-10-17b/timing-2.csv new file mode 100644 --- /dev/null +++ b/bench/results/2026-10-17b/timing-2.csv @@ -0,0 +1,108 @@ +Name,Mean (ps),2*Stdev (ps),Allocated,Copied,Peak Memory +All.token.32.ascii,1649,60,15,0,36700160 +All.token.32.unicode,1605,44,15,0,36700160 +All.token.4096.ascii,1708,88,15,0,36700160 +All.token.4096.unicode,1765,110,15,0,36700160 +All.wide.100.construct.direct,2229398,43398,14340,2,36700160 +All.wide.100.construct.builder-tokens,1137266,40246,9012,1,36700160 +All.wide.100.construct.builder-monad,1204812,41906,8801,1,36700160 +All.wide.100.prepared.render,616942,18776,629,0,36700160 +All.wide.100.prepared.builder-reuse,1824447,177808,9791,0,36700160 +All.wide.100.prepared.builder-checkpoint,1964397,55932,10016,1,36700160 +All.wide.100.prepared.child-first,3128,2248,15,0,36700160 +All.wide.100.prepared.child-middle,5000,1330,15,0,36700160 +All.wide.100.prepared.child-last,4796,140,15,0,36700160 +All.wide.100.prepared.siblings,3853157,131890,20996,1,36700160 +All.wide.100.prepared.offset-first,74877,1796,436,0,36700160 +All.wide.100.prepared.offset-last,74134,1250,436,0,36700160 +All.wide.100.prepared.cover-last,42365,4860,238,0,36700160 +All.wide.100.prepared.replace-first,153545,5522,1893,0,36700160 +All.wide.100.prepared.replace-middle,148919,8960,1916,0,36700160 +All.wide.100.prepared.replace-last,143526,3498,1905,0,36700160 +All.wide.100.prepared.splice-middle,155065,5400,1773,0,36700160 +All.wide.100.prepared.typed-first,57840,908,415,0,36700160 +All.wide.100.prepared.typed-last,3559169,82230,23277,1,36700160 +All.wide.100.prepared.typed-all,4453038,106848,30429,1,36700160 +All.wide.1000.construct.direct,22772408,2256040,143115,131,40894464 +All.wide.1000.construct.builder-tokens,12697718,789742,87965,93,44040192 +All.wide.1000.construct.builder-monad,12724223,366856,87918,87,44040192 +All.wide.1000.prepared.render,4827928,866242,6790,0,76546048 +All.wide.1000.prepared.builder-reuse,19199824,1648936,95379,34,76546048 +All.wide.1000.prepared.builder-checkpoint,17944838,433482,96449,33,76546048 +All.wide.1000.prepared.child-first,2834,110,15,0,76546048 +All.wide.1000.prepared.child-middle,4279,106,15,0,76546048 +All.wide.1000.prepared.child-last,4409,84,15,0,76546048 +All.wide.1000.prepared.siblings,38373320,1354992,215704,11,76546048 +All.wide.1000.prepared.offset-first,88116,1484,436,0,76546048 +All.wide.1000.prepared.offset-last,74713,30248,436,0,76546048 +All.wide.1000.prepared.cover-last,44653,824,238,0,76546048 +All.wide.1000.prepared.replace-first,1449762,31824,16263,0,76546048 +All.wide.1000.prepared.replace-middle,1500889,54334,16157,0,76546048 +All.wide.1000.prepared.replace-last,1489551,32424,16261,0,76546048 +All.wide.1000.prepared.splice-middle,1597822,22294,16118,0,76546048 +All.wide.1000.prepared.typed-first,62740,1918,414,0,76546048 +All.wide.1000.prepared.typed-last,37903874,880580,230364,11,76546048 +All.wide.1000.prepared.typed-all,50814338,5825476,303796,15,76546048 +All.wide.10000.construct.direct,254108104,7233688,1430997,12522,76546048 +All.wide.10000.construct.builder-tokens,175712249,42253240,874660,7824,76546048 +All.wide.10000.construct.builder-monad,159286416,37014940,874574,8044,76546048 +All.wide.10000.prepared.render,43099654,1915840,78002,3,78643200 +All.wide.10000.prepared.builder-reuse,204181272,12593142,958894,2929,78643200 +All.wide.10000.prepared.builder-checkpoint,203386061,8904642,957878,2962,78643200 +All.wide.10000.prepared.child-first,3178,422,15,0,78643200 +All.wide.10000.prepared.child-middle,4304,164,15,0,78643200 +All.wide.10000.prepared.child-last,4404,386,15,0,78643200 +All.wide.10000.prepared.siblings,453640803,60274084,2152852,98,78643200 +All.wide.10000.prepared.offset-first,78263,11692,436,0,78643200 +All.wide.10000.prepared.offset-last,82943,9244,436,0,78643200 +All.wide.10000.prepared.cover-last,48877,9488,238,0,78643200 +All.wide.10000.prepared.replace-first,14110745,460004,160257,7,79691776 +All.wide.10000.prepared.replace-middle,13181073,357826,160284,8,79691776 +All.wide.10000.prepared.replace-last,13114596,479968,160283,7,79691776 +All.wide.10000.prepared.splice-middle,16493939,375766,160153,6,79691776 +All.wide.10000.prepared.typed-first,61818,1938,411,0,79691776 +All.wide.10000.prepared.typed-last,389255112,10709836,2297584,105,79691776 +All.wide.10000.prepared.typed-all,525311111,21628150,3026118,142,79691776 +All.deep.100.construct,2197639,71950,12741,2,79691776 +All.deep.100.prepared.render,433186,8470,25,0,79691776 +All.deep.100.prepared.descend,3433622,263598,18558,2,79691776 +All.deep.100.prepared.replace-path,5143681,87020,28206,1,79691776 +All.deep.100.prepared.offset,4772412,249104,24974,9,79691776 +All.deep.100.prepared.focus-and-replace,5432446,790498,29096,4,79691776 +All.deep.100.focused.replace,1971900,63962,10535,2,79691776 +All.deep.100.focused.root,179212,37064,69,0,79691776 +All.deep.1000.construct,21763915,366926,127069,202,79691776 +All.deep.1000.prepared.render,6240277,103588,0,0,79691776 +All.deep.1000.prepared.descend,35264554,2233910,184030,142,79691776 +All.deep.1000.prepared.replace-path,67954900,1272100,376582,303,79691776 +All.deep.1000.prepared.offset,45576279,1410778,242501,859,79691776 +All.deep.1000.prepared.focus-and-replace,52270515,1991448,287008,385,79691776 +All.deep.1000.focused.replace,19305606,268788,103946,165,79691776 +All.deep.1000.focused.root,2362510,92168,0,0,79691776 +All.deep.10000.construct,223107120,14481118,1277073,19534,79691776 +All.deep.10000.prepared.render,44911101,1673682,0,0,79691776 +All.deep.10000.prepared.descend,358664105,44758574,1824900,12168,79691776 +All.deep.10000.prepared.replace-path,859743253,15984926,4151186,39531,79691776 +All.deep.10000.prepared.offset,704773010,27763774,2943757,83779,79691776 +All.deep.10000.prepared.focus-and-replace,619461198,21758414,2853830,34764,79691776 +All.deep.10000.focused.replace,210853249,6605600,1033777,15995,79691776 +All.deep.10000.focused.root,25414998,3574462,0,0,79691776 +All.chain.100.tokens,17797362,1447548,108264,38,79691776 +All.chain.100.descendants,16237164,403306,108062,38,79691776 +All.chain.100.offset-first,4976966,658632,30829,13,79691776 +All.chain.100.offset-last,75941,13846,436,0,79691776 +All.chain.1000.tokens,203717296,7468580,1068307,3442,79691776 +All.chain.1000.descendants,187361876,3019788,1068307,3431,79691776 +All.chain.1000.offset-first,54573069,1412250,302878,1304,79691776 +All.chain.1000.offset-last,81377,2680,435,0,79691776 +All.chain.10000.tokens,2194064244,106610536,10747636,339736,79691776 +All.chain.10000.descendants,2134854462,83177164,10721742,339828,79691776 +All.chain.10000.offset-first,725922001,35642588,3492108,115829,79691776 +All.chain.10000.offset-last,70842,1668,435,0,79691776 +All.document-1000.construct,170809043,22851828,1026419,6949,79691776 +All.document-1000.render,24141205,399510,22568,0,84934656 +All.document-1000.tokens,315666687,22311046,2080055,89,84934656 +All.document-1000.typed-first-group,42219,1374,316,0,84934656 +All.document-1000.typed-all-groups,47507911,605370,303766,11,84934656 +All.document-1000.100-edits-latest,96648569,3602806,898466,34,84934656 +All.document-1000.100-edits-history,92303046,785018,913275,36,84934656 diff --git a/bench/run.py b/bench/run.py new file mode 100644 --- /dev/null +++ b/bench/run.py @@ -0,0 +1,90 @@ +#!/usr/bin/env python3 +"""Run an already-built benchmark, preserving raw results and its environment.""" + +import argparse +from datetime import datetime, timezone +import hashlib +import json +import os +from pathlib import Path +import platform +import subprocess +import sys + + +def output(*command): + return subprocess.check_output(command, text=True).strip() + + +def main(): + parser = argparse.ArgumentParser(description=__doc__) + parser.add_argument("--output", type=Path, required=True) + parser.add_argument("--cpu", type=int, help="pin child processes to this Linux CPU") + parser.add_argument("--runs", type=int, default=2) + parser.add_argument("--timeout", default="3s") + parser.add_argument("--stdev", type=float, default=2) + args = parser.parse_args() + if args.runs < 1 or args.stdev <= 0: + parser.error("runs and stdev must be positive") + root = Path(__file__).resolve().parent.parent + os.chdir(root) + if args.cpu is not None: + if not hasattr(os, "sched_getaffinity") or args.cpu not in os.sched_getaffinity(0): + parser.error("requested CPU is outside this process's Linux affinity") + binary = Path(output("cabal", "list-bin", "bench:graft-bench", "--enable-benchmarks", "-O2")) + if not binary.is_file(): + parser.error("build bench:graft-bench with --enable-benchmarks -O2 first") + # Refuse to overwrite an earlier measurement. + args.output.mkdir(parents=True, exist_ok=False) + args.output = args.output.resolve() + prefix = [] if args.cpu is None else ["taskset", "-c", str(args.cpu)] + timing_options = ["--stdev", str(args.stdev), "--timeout", args.timeout, + "--time-mode", "cpu", "--color", "never", "+RTS", "-T", "-A32m", "-RTS"] + sources = [root / "graft.cabal", *sorted((root / "src").rglob("*.hs")), + *sorted((root / "bench").glob("*.hs")), root / "bench/run.py"] + has_jj = (root / ".jj").is_dir() + metadata = { + "started_at": datetime.now(timezone.utc).isoformat(), + "platform": platform.platform(), "ghc": output("ghc", "--numeric-version"), + "cabal": output("cabal", "--numeric-version"), + "parent_revision": output("jj", "--ignore-working-copy", "log", "-r", "@-", "--no-graph", + "-T", "commit_id ++ \"\\n\"") if has_jj else None, + "working_copy": output("jj", "--ignore-working-copy", "diff", "--stat") if has_jj else None, + "binary_sha256": hashlib.sha256(binary.read_bytes()).hexdigest(), + "source_sha256": {str(path.relative_to(root)): hashlib.sha256(path.read_bytes()).hexdigest() + for path in sources}, + "cpu": args.cpu, "affinity": sorted(os.sched_getaffinity(0)) + if hasattr(os, "sched_getaffinity") else None, + "lscpu": output("lscpu") if sys.platform.startswith("linux") else None, + "timing_options": timing_options, "runs": args.runs, + "residency_options": ["+RTS", "-T", "-RTS"], + "build_command": "cabal build bench:graft-bench --enable-benchmarks -O2 --ghc-options=-Werror", + } + if args.cpu is not None: + governor = Path(f"/sys/devices/system/cpu/cpu{args.cpu}/cpufreq/scaling_governor") + metadata["governor"] = governor.read_text().strip() if governor.exists() else None + (args.output / "environment.json").write_text(json.dumps(metadata, indent=2) + "\n") + subprocess.run(prefix + [str(binary), "--check"], check=True) + for run in range(1, args.runs + 1): + csv_path = args.output / f"timing-{run}.csv" + command = prefix + [str(binary), "--csv", str(csv_path)] + timing_options + print(f"Timing run {run}: {csv_path}", flush=True) + with (args.output / f"timing-{run}.log").open("w") as log: + subprocess.run(command, stdout=log, stderr=subprocess.STDOUT, check=True) + rows = [] + for size in (1000, 10000): + for edits in (0, 100): + scenarios = ("tree", "shared", "cursor", "detached-token", "renamed-tree", "renamed-cursor", "walk-cursors") if edits == 0 else ("latest", "history", "renamed-passes") + for scenario in scenarios: + command = prefix + [str(binary), "--residency", scenario, str(size), str(edits), + "+RTS", "-T", "-RTS"] + lines = output(*command).splitlines() + if not rows: + rows.append(lines[0]) + rows.append(lines[1]) + (args.output / "residency.csv").write_text("\n".join(rows) + "\n") + print(f"Benchmark results: {args.output}", flush=True) + + +if __name__ == "__main__": + main() diff --git a/docs/architecture.md b/docs/architecture.md new file mode 100644 --- /dev/null +++ b/docs/architecture.md @@ -0,0 +1,339 @@ +# Graft architecture + +This note explains how Graft is put together and why, and where it departs from +Rowan. The Haddock documentation is the reference for individual functions. + +## Scope + +Graft is the tree layer of a concrete-syntax toolchain. A concrete syntax tree +keeps the source's exact spelling, including whitespace and comments (trivia), +where an abstract syntax tree keeps only its meaning. Graft stores such trees, +navigates them, edits them persistently and prints them back. Lexing, parsing, +grammar validation and formatting policy belong to the application. + +## Modules and names + +Each module covers one concept, and its functions have short names meant for +qualified import: `Cursor.parent`, `Green.node`, `Range.start`, `Build.token`. +The same short name can appear in several modules, such as `children` in +`Graft.Green`, `Graft.Cursor` and `Graft.Ast`, each acting on its own module's +type. The `Graft` module exports only the types and classes, so that they can +be used unqualified alongside the qualified functions. + +Edits inside a tree go through `Graft.Edit`: `Graft.Green` edits the children +of a single node, a plan applies a list of edits described through cursors to +the tree they were made on, and a rewrite visits a tree top-down and replaces +elements as it goes. Cursors themselves only read. + +## Green trees + +A green token is a leaf with a syntax kind and exact `Text`. A green node has a +kind and an ordered list of children, each a node or a token. The kind is a +type parameter, so an application uses its own enumeration with no conversion +to integers. Empty nodes and tokens are valid, and the same subtree may appear +any number of times. + +Green values have no parents and no absolute positions, so a subtree can be +shared between trees and between versions of one tree. Their constructors are +hidden, and the smart constructors `Green.node` and `Green.token` establish the +cached lengths. The representation lives in `Graft.Green.Internal`, which the +package does not expose. + +All lengths and offsets are `TextLength`, a newtype over `Int` counting UTF-8 +bytes. `Text` is stored as UTF-8, so a token's byte length is read in constant +time. The newtype keeps byte offsets apart from character counts and from the +UTF-16 positions that language clients send; `Graft.LineIndex` converts between +them. + +Rendering writes every token's text in source order into one buffer sized from +the cached length. Graft never inserts separators or normalizes text: every +byte of output came from some token. Valid Unicode round-trips exactly; invalid +UTF-8 is outside the contract. + +`Green.foldM` is a strict left fold over a tree's elements in preorder, in any +monad. It loops over each node's child array by index, builds no list, and +folds a node's last child by a tail call, so a chain of single-child nodes +runs in constant stack. Rendering, `rnf` and hashing are written with it. It +has no event for leaving a node, because that would lose the tail call: an +earlier version with enter and leave events rendered the 10,000-level chain +2.4 times slower. `Cursor.walk` reports leaving, at the cost of a cursor per +element. `Green.fold` is the lazy bottom-up fold, for results shaped like the +tree; `Green.map` and `Green.traverse` rebuild a tree from new tokens and +measure every node again. + +Trivia is ordinary tokens. Rowan attaches leading and trailing trivia to tokens; +Graft doesn't, so that there is one kind of leaf and no rule about which token +owns a comment. Applications that want ownership can express it with node +structure. + +## Representation and costs + +A node stores its kind, its total length, its children in a `SmallArray`, and +the start of each child relative to the node in a `PrimArray Int`. This is the +same information Rowan keeps: the child offsets make child access constant time +and let offset lookup binary-search each level instead of scanning. A token's +kind, length and text are stored directly in the element that holds it, which +saves a box per token. Nodes keep their own box, so that a cursor can point at +a parent node without re-allocating it. + +| Operation | Cost | +| --- | --- | +| Length of a node or token | Constant | +| Child by index, first or last child, sibling, parent | Constant | +| Path or root of a cursor | Linear in the depth | +| Token or element at an offset | Logarithmic in the width of each level, times depth, plus any empty children at the offset | +| Building a node | Linear in its number of children | +| Replacing a child of one node | Linear in the parent's width: the array is copied, and the length is adjusted by the difference | +| Splicing children of one node | Linear in the parent's width plus the replacements | +| `Edit.apply` | Linear in the edits, their paths, and the widths of the nodes above them; the trees are compared when a cursor isn't from the base itself | +| `Edit.rewrite` | Linear in the elements visited, which covers rebuilding the nodes above the replacements | +| `Edit.textEdits` | As `Edit.apply`, plus rendering the replacements | +| Rendering | Linear in the elements and the output | + +No edit traverses descendants it doesn't change. Equality is structural +but returns immediately for physically identical nodes, so comparing two +versions that share most of their structure is cheap when the shared parts are +the same values. + +Graft has no node cache. Rowan's builder interns identical nodes and tokens to +save memory; Graft only shares what the application shares, for example by +emitting existing green elements into a builder. Interning remains an open +question that needs measurements from real parsers. + +## Cursors + +A cursor is a zipper: the focused element, its absolute offset, its index in +the parent, and the parent's cursor, and so on up to the root. Moving down, up +or sideways is constant time, and the cursor computes absolute ranges from the +cached child offsets. Navigation never performs transformation work: a +cursor's fields are values, and there is no edit state that an observer could +force. A cursor retains its parent chain and, through it, the whole tree, and +nothing else. Lists such as `children` and `descendants` are lazy, cost a +cursor per element consumed, and buy early exit; one step of `descendants` +can cost up to the depth, returning from a finished branch. + +Cursors are read-only. An earlier design let a cursor record edits as it +moved and build the edited nodes when they were read. The cost of an +observation then depended on which thunk it forced, the documentation had to +list which observers built an edited node, and three successive changes each +found an observer that was accidentally quadratic. Edits now live in +`Graft.Edit`, and `Cursor.tree` is the whole tree the cursor is in. + +Rowan has separate node and token cursors, and offers mutable red trees +(`clone_for_update`) so that edits are visible through every handle. Graft has +one cursor type for both and no mutation. Rowan's `ancestors` starts with the +node itself; Graft's `Cursor.ancestors` and `Ast.ancestors` start with the +parent, while `Cursor.descendants` starts with the focus. + +## Edits + +`Graft.Edit` makes changes that are described against a tree as it is and +made all at once. It has two entry points, for two workloads. + +A plan is a list of edits, each made with a cursor on the base tree: +`Edit.replace` an element, `Edit.splice` a range of a node's children, or +`Edit.insertBefore`, `Edit.insertAfter` and `Edit.remove` a child among its +siblings. `Edit.apply` makes them together. Every cursor and child position +refers to the base, so an edit never shifts another: replacing children 2 and +7 replaces those two original children, whatever happens to the lengths or the +children between them. At each node with an edit, the new children are, for +each boundary from the first to the last, the insertions at that boundary in +the order of the list, then the child, which is the elements of a splice that +starts there, or nothing if an earlier splice consumed it, or its replacement, +or the child itself, rebuilt if an edit lies below it and shared otherwise. +Apart from the order of insertions at one boundary, the result does not depend +on the order of the list. + +A plan is rejected when a replacement and any other edit apply at or below the +same element; when a splice consumes a child that another edit applies to or +below, which an insertion strictly inside the splice's range does and one at +either end does not; or when two splices of one node have ranges `[a, b)` and +`[c, d)` with `a < d` and `c < b`. Each error names the edits by their +positions in the list. Every edit's cursor must be in a tree equal to the +base. That is compatibility, not provenance: `apply` cannot tell where a +cursor came from, but equality of the whole tree guarantees that its path, +range and context mean the same thing in the base, which equality of the +target alone would not. For a cursor made from the base the comparison is a +pointer test; a cursor from an equal tree built separately is accepted after +a structural comparison, which can cost the size of the tree, and that is why +`apply` needs `Eq` on the kind. Evaluating the result to `Right` completes the +validation and every rebuilt node; replacement elements and the shared parts +of the base are as evaluated as they were given. + +`Edit.textEdits` gives the same plan as changes to the source text, with +UTF-8 byte ranges in the base's text, for `Graft.LineIndex` to convert for an +editor. It runs the same merge as `apply`, so insertions at boundaries that +share an offset, as the boundaries of an empty element do, come out in the +order of the result, and it merges edits that touch, so that no two share an +offset. Patching the original text with them renders the result of `apply`. + +A rewrite, `Edit.rewrite` or `Edit.rewriteM`, visits a tree top-down and +calls a function on each element with a cursor on the original tree and a +context passed down from the ancestors. The function answers `Replace` with a +new element, below which nothing is visited; `Descend`, which keeps the +element's form and visits its children; `DescendWith` a new context; or +`Skip`, which keeps the subtree unvisited. A node is rebuilt, once, exactly +when a child reports a replacement, by a flag carried up and never by +comparing trees, so `Replace` with the original element counts; a node with +no replacement below it is returned as it is. `rewriteM` needs a monad rather +than an applicative because the answer decides what is visited next; in +`Either` it stops at the first failure, and in `StateT` it can collect the +ranges it replaced, which are ranges in the original. It forces each rebuilt +node before returning it through the monad. A rewrite suits a traversal that +may change many elements, such as a rename that reads each token's ancestors; +a plan suits a sparse set of targets found by analysis. The two share only +the array copying underneath. + +Neither lets a later decision observe an earlier change inside one operation. +When a second change depends on the first, apply the first and work on the +result; the intermediate tree is paid for because it was asked for. The +rebuilt nodes are the only new allocation that outlives an operation: a +plan's trie, the paths, and the cursors a rewrite visits are garbage when it +returns. There is no occurrence identity across versions: Graft can't tell you +where an element of the old tree went in the new one. + +## Lookup by offset + +`TextRange` is a half-open interval of byte offsets with validated endpoints. +Offsets need not lie on character boundaries. + +`Cursor.tokenAt` treats token ranges as closed when deciding what an offset +touches. An offset inside a token returns that token. An offset on the boundary +between two tokens returns both, left first, as an editor needs at a cursor +position between two words. The start and end of the text return the first and +last token. Empty tokens are skipped by this lookup, though navigation still +visits them. + +`Cursor.covering` returns the innermost element whose range contains a query +range, descending into the first covering child at each level. An empty query +on a boundary therefore picks the leftmost candidate, including empty +elements. These rules are Graft's own and may differ from Rowan's tie-breaking. + +## Builders + +A builder holds the elements emitted so far, in reverse order, and a stack of +open nodes with the position where each started. Closing a node collects the +elements emitted since its start into a node. A checkpoint is a position in +that sequence, counted in elements; `Builder.startNodeAt` opens a node at an earlier +checkpoint, so a parser can wrap an operand after seeing the operator that +follows it. + +Checkpoints are positions, not handles, exactly as in Rowan: a checkpoint +taken inside a node that has since closed may be out of range, or may become +valid again after more elements are emitted. The builder checks only that the +position lies within the current node. + +Rowan's builder asserts on misuse. Graft's pure builder returns +`Either BuilderError` from every operation that can fail, and `Builder.finish` +checks that every node was closed and that exactly one root node remains. The +`Build` monad in `Graft.Build` threads the builder and the errors, and its +`Build.node` and `Build.nodeAt` bracket a node, so a parser that opens and +closes nodes only through them can't leave one open. `Build.save` and +`Build.restore` give backtracking parsers the persistence of the pure builder; +restoring inside a bracketed body can unbalance it, so restore at the level +where you saved. + +## Typed views + +`AstView` is the class for application-defined views. A view is usually a +newtype over a cursor. `fromCursor` casts a cursor to the view and can fail; +`toCursor` gives the cursor back. The class has the same shape as `Exception`, +with `Cursor` in the place of `SomeException`. It has an associated kind type, +which replaces Rowan's language parameter. Views add typed accessors without a +second tree, so every view keeps its exact text, trivia, range and context. + +The empty subclasses `AstNode` and `AstToken` say whether a view is of nodes or +of tokens. `Ast.child`, `Ast.children`, `Ast.parent` and `Ast.ancestors` need +an `AstNode` view; `Ast.token` and `Ast.tokens` need an `AstToken` view. Each +view therefore has two instances: the `AstView` instance with the cast, and an +empty `AstNode` or `AstToken` instance. + +The set of views is open. Graft can't know an application's kinds, and an +application can define more than one view for the same kind, or add views in a +package other than the one that defines the kind type. A type class allows +both. Within one application the kind type is an ordinary closed type, so a +cast that matches on the kind gets the usual exhaustiveness checks. + +A cast checks the element's form and kind, not the grammar. A view of an +expression with a missing operand still exists, and its accessor for that +operand returns `Nothing`. Required fields, duplicates and token spelling are +the application's to check. The classes have laws (a cast looks only at the +element, not its position; it keeps the cursor; casting a view's cursor +succeeds again; a node view rejects tokens and a token view rejects nodes) that +the type system can't enforce; `Ast.matchNode` and `Ast.matchToken` implement +the usual `fromCursor`. + +`examples/ExactUpdate.hs` uses views for a semantic update: it reads a number's +value, keeps the original token when the value is unchanged, so `001` stays +`001`, and otherwise replaces only that token. + +## Line and column positions + +`Graft.LineIndex` records where each line starts in a text and converts byte +offsets to and from zero-based lines and columns. Columns can be counted in +UTF-8 bytes or in UTF-16 code units, the Language Server Protocol's default, +and each unit has its own position type, so a column in one can't be passed +where the other is expected. +Lines end at `\n`, `\r\n` or a lone `\r`, as in that protocol, and columns past +the end of a line clamp to it. An offset or column inside a character, in +either unit, is rejected rather than rounded, so a converted offset is always a +character boundary. An index describes one text and must be rebuilt +after an edit. + +## Testing + +The tests compare the library with independent models that share none of its +code: a plain rose tree for the green layer and the cursors, a merge written +over lists and a predicate of the conflict rules for the plans, and a +generated decision table for the rewrites. A doctest suite checks the examples +in the Haddock documentation; +[CONTRIBUTING.md](../CONTRIBUTING.md) describes both. The benchmark suite +and its latest results are in [performance.md](performance.md). + +## Relation to Rowan + +Graft started from a study of Rowan at revision +`b6f1cb6494a99a2264186d110b1b170989774814` (version 0.17.0), retrieved on +10 October 2026. The sources studied were [green nodes][node] and +[tokens][token], [cursors][cursor], [AST support][ast], the [builder][builder] +and [node cache][node-cache], and Rowan's [green][green], [text][syntax-text] +and [formatting][tidy] tests. + +| Rowan | Graft | +| --- | --- | +| Reference-counted thin allocations | Ordinary values managed by the garbage collector | +| `u16` syntax kinds and a language trait | A type parameter for the application's own kind type | +| `TextSize`, a `u32` byte count | `TextLength`, a newtype over `Int` | +| Children with cached relative offsets | The same, in a `SmallArray` and a `PrimArray` | +| Leading and trailing trivia on tokens | Trivia as ordinary tokens | +| Separate node and token cursors, optionally mutable | One read-only cursor type; edits are plans and rewrites applied to a tree | +| Mutable builder that asserts on misuse | Pure builder with structured errors, and a `Build` monad | +| Node cache for interning | No interning | +| `AstNode` and `AstToken` traits, `AstChildren` iterator, `SyntaxNodePtr` | An `AstView` class with `AstNode` and `AstToken` subclasses, and lazy lists; no location pointers | + +## Open questions + +- Interning: whether a node cache pays for itself depends on duplicate rates in + real parser output. The first user, haskott (a Haskell reimplementation of + Ott), will provide the measurements. +- Location handles: an equivalent of Rowan's `SyntaxNodePtr`, which finds an + element again in a new version of the tree, needs rules for empty and nested + elements that share a range. Relocating a cursor from the base into the + result of `Edit.apply` is the same question. +- Editing sessions: an operation in which a later decision sees an earlier + edit. Not planned until a workload needs it, and then with a cost analysis + fitted to its representation, which is the test of whether it should exist. +- Trivia ownership, and how close to Rowan's API Graft should stay. +- Incremental reparsing: Graft can splice a reparsed subtree into a tree, but + has no support for deciding which subtree to reparse after a text edit. This + is a likely follow-up. + +[node]: https://github.com/rust-analyzer/rowan/blob/b6f1cb6494a99a2264186d110b1b170989774814/src/green/node.rs +[token]: https://github.com/rust-analyzer/rowan/blob/b6f1cb6494a99a2264186d110b1b170989774814/src/green/token.rs +[cursor]: https://github.com/rust-analyzer/rowan/blob/b6f1cb6494a99a2264186d110b1b170989774814/src/cursor.rs +[ast]: https://github.com/rust-analyzer/rowan/blob/b6f1cb6494a99a2264186d110b1b170989774814/src/ast.rs +[builder]: https://github.com/rust-analyzer/rowan/blob/b6f1cb6494a99a2264186d110b1b170989774814/src/green/builder.rs +[node-cache]: https://github.com/rust-analyzer/rowan/blob/b6f1cb6494a99a2264186d110b1b170989774814/src/green/node_cache.rs +[green]: https://github.com/rust-analyzer/rowan/blob/b6f1cb6494a99a2264186d110b1b170989774814/src/green.rs +[syntax-text]: https://github.com/rust-analyzer/rowan/blob/b6f1cb6494a99a2264186d110b1b170989774814/src/syntax_text.rs +[tidy]: https://github.com/rust-analyzer/rowan/blob/b6f1cb6494a99a2264186d110b1b170989774814/tests/tidy.rs diff --git a/docs/performance.md b/docs/performance.md new file mode 100644 --- /dev/null +++ b/docs/performance.md @@ -0,0 +1,352 @@ +# Graft performance + +A dated log of Graft's benchmark measurements, oldest first. The first three +entries are full runs of `bench/run.py`, whose raw results are kept under +`bench/results/`; the [run guide](../bench/README.md) explains how to +reproduce them. Later entries are before-and-after passes of the cases that a +change affected. The last section says what the numbers suggest about the +remaining costs. + +## Method + +The full runs measured these workloads ([source](../bench/Main.hs)): + +| Workload | Shape | +| --- | --- | +| Token | ASCII or emoji text of 32 or 4,096 UTF-8 bytes | +| Wide | One node with 100, 1,000 or 10,000 tokens, each with distinct Unicode text | +| Deep | 100, 1,000 or 10,000 nested single-child nodes above one `001` token | +| Chain | A left-nested operator chain `((0 + 1) + 2) + …` with 100, 1,000 or 10,000 operators, so both deep and wide | +| Document | 1,000 line nodes of five tokens each: name, spacing, number, comment, CRLF | + +The cases cover construction (directly, with the pure builder and with the +`Build` monad), rendering, child access, sibling iteration, offset and range +lookup, replacement and splicing, typed fields, whole-tree traversal and 100 +successive edits. Inputs are fully evaluated before timing, and each case +consumes its result: rendered text, a cached length, or a strict sum of visited +ranges. `bench/Fixtures.hs` checks every workload against independently built +text before measuring (`graft-bench --check`). Cases added since then are +described in the entries that use them. + +Each timing pass asks `tasty-bench` for a relative standard deviation of 2%, +with a three-second limit per case, and the suite runs twice. Times are CPU +time including garbage collection. Allocation is per operation. Separate +processes measure residency: the live heap after a full collection, minus the +live heap at startup. + +All three runs used GHC 9.12.2 with `-O2` on an Intel Xeon w3-2435 under Fedora +Linux, pinned to CPU 2 with the `powersave` governor. Other activity on the +machine was not controlled. + +| Run | Code measured | Results | +| --- | --- | --- | +| 2026-10-10 | List children, before the 2026-10-17 changes | [timing 1](../bench/results/2026-10-10/timing-1.csv), [timing 2](../bench/results/2026-10-10/timing-2.csv), [residency](../bench/results/2026-10-10/residency.csv), [environment](../bench/results/2026-10-10/environment.json) | +| 2026-10-17 | Array children, cursor edits, single-buffer rendering | [timing 1](../bench/results/2026-10-17/timing-1.csv), [timing 2](../bench/results/2026-10-17/timing-2.csv), [residency](../bench/results/2026-10-17/residency.csv), [environment](../bench/results/2026-10-17/environment.json) | +| 2026-10-17b | As above, plus a single-pass builder and unpacked tokens | [timing 1](../bench/results/2026-10-17b/timing-1.csv), [timing 2](../bench/results/2026-10-17b/timing-2.csv), [residency](../bench/results/2026-10-17b/residency.csv), [environment](../bench/results/2026-10-17b/environment.json) | + +Each environment record includes SHA-256 hashes of the sources and the +executable. The 2026-10-17 run measured the commit "perf: render without +per-node closures and climb to the root strictly", and 2026-10-17b measured +"docs: plainer Haddock with examples in every module". + +The 2026-10-17b run took place while the machine was busy with other work +(a load average of about 6.6), and 38 and 40 of its 107 cases missed the +requested precision, with up to 72% spread. Its timings are therefore not +used in the tables below, except where noted; its residency figures are, since +live heap doesn't depend on load. + +The tables give the smaller and larger mean of the two passes, so a range is +not a confidence interval. In 2026-10-17, 6 of 107 cases in the first pass and +1 in the second ended at the time limit before reaching the requested +precision, with at most 16% spread (twice the standard deviation over the +mean). The 2026-10-10 run missed in 43 and 29 of its 89 cases, with up to 42%. +Treat differences of less than about 20% as noise. + +## Results + +Times are in microseconds. + +### Wide node, 10,000 children + +| Case | 2026-10-10 | 2026-10-17 | +| --- | ---: | ---: | +| First child | 0.039–0.041 | 0.003 | +| Last child | 210–218 | 0.004 | +| Offset lookup, last token | 729–812 | 0.056–0.058 | +| Offset lookup, first token | — | 0.054–0.056 | +| Covering range, last token | 609–750 | 0.035–0.036 | +| Replace first child | 50.1–60.3 | 9.6–10.1 | +| Replace last child | 216–231 | 8.8–9.0 | +| Splice in the middle | 116–137 | 12.7–13.0 | +| Iterate all siblings | 551–582 | 312–326 | +| Last typed token | 576–642 | 302–319 | +| Render | 337–352 | 41.9–42.3 | +| Construct directly | 483–518 | 233–239 | +| Construct with the builder | 949–1,020 | 476–483 | +| Construct with `Build` | — | 478–488 | + +Child access and lookups are now independent of width. Replacement still +copies the parent's child array, so it is linear in the width, but it no +longer re-sums every child's length. Rendering copies each token once into a +buffer sized from the cached length. + +### Deep and chain trees, 10,000 levels + +| Case | 2026-10-10 | 2026-10-17 | +| --- | ---: | ---: | +| Deep: construct | 166–185 | 164–166 | +| Deep: descend to the leaf | 475–511 | 267–269 | +| Deep: render three bytes | 192–207 | 42.5–43.2 | +| Deep: offset lookup | 1,237–1,384 | 590–605 | +| Deep: replace at a path (descend, replace, rebuild) | 795–990 | 790–797 | +| Deep: replace through a prepared cursor | 398–419 | 170–171 | +| Deep: prepared cursor to root | 75.2–186 | 22.9–23.0 | +| Chain: all tokens | — | 1,769–1,824 | +| Chain: offset lookup, first token | — | 565–572 | + +Deep cases are bounded by depth, which the array representation doesn't +change. Construction allocates more per level than before (1.2 MiB rather than +0.8 MiB), because each node now holds two small arrays. + +The chain workload is new. Before the 2026-10-17 changes, whole-tree +traversal was quadratic in depth. A separate measurement of the 2026-10-10 code +took 346 ms and allocated 1.8 GB to visit every token of a 4,000-operator +chain; the 10,000-operator chain now takes 1.8 ms. + +### Document, 1,000 lines + +| Case | 2026-10-10 | 2026-10-17 | +| --- | ---: | ---: | +| Construct | 273–312 | 136–137 | +| Render 22,893 bytes | 189–213 | 23.4–23.6 | +| All token ranges | 619–668 | 252–254 | +| All typed line nodes | 71.2–74.5 | 36.7 | +| 100 successive edits | 770–774 | 65.0–65.4 | + +### Retained memory + +Live heap in MiB after a full collection, minus startup. Edited cases apply 100 +edits to the middle line. + +| Retained result | 2026-10-10, 1,000 lines | 2026-10-17, 1,000 lines | 2026-10-10, 10,000 lines | 2026-10-17, 10,000 lines | +| --- | ---: | ---: | ---: | ---: | +| Original tree | 0.558 | 0.505 | 5.571 | 5.037 | +| One line subtree, reused for every line | 0.025 | 0.017 | 0.231 | 0.154 | +| Latest edited tree | 0.589 | 0.505 | 5.601 | 5.037 | +| All 101 versions | 1.768 | 1.319 | 17.080 | 12.923 | +| A cursor on one middle token | 0.600 | 0.505 | 5.716 | 5.037 | +| Only that cursor's green token | 0.032 | 0.001 | 0.032 | 0.001 | + +A document of 10,000 lines (238,894 bytes of source, 50,000 tokens) takes about +105 bytes of heap per token, or 22 per source byte. Keeping every version costs +less than before because an edit copies one child array per ancestor instead of +rebuilding list prefixes. A cursor keeps its whole tree alive. Building and +editing the 10,000-line document allocates 19 MiB in total, down from 59 MiB. + +### Later changes (2026-10-17b) + +Two changes followed the 2026-10-17 run: + +- **Unpacked tokens.** A token's fields are stored directly in the `Token` + constructor, saving a box per token. The heap figures for 10,000 lines become: + + | Retained result | 2026-10-17 | 2026-10-17b | + | --- | ---: | ---: | + | Original tree | 5.037 | 4.274 | + | Latest edited tree | 5.037 | 4.274 | + | All 101 versions | 12.923 | 12.159 | + + That is about 90 bytes per token, or 19 per source byte. An interleaved + comparison of the two builds on the same machine found the timings within + noise, except that offset lookup became about 10 ns slower. Unpacking nodes + as well saved only a further 3% of heap and made replacements about 45% + slower, because cursors had to re-allocate the parent node on every + descent, so nodes stay boxed. +- **Single-pass `Builder.finishNode`.** Closing a node now fills the node while walking + the pending elements, instead of splitting the list first and copying it. + Even on the busy machine, building 10,000 tokens took 158–176 µs, against + 476–483 µs in the 2026-10-17 run. + +### Recorded edits (2026-10-19) + +Cursor edits are now recorded in the ancestors and built when read, instead +of copying the parent on every move away from an edit. These are single +passes of the affected cases on one machine, before and after the change, +with GHC 9.12.2, `--stdev 3` and a 32 MiB allocation area, not runs of +`bench/run.py`. `rename-all` renames each of the 1,000 `Name` tokens of the +1,000-line document through one cursor, as the `Graft.Cursor` example does; +`rename-all-ancestors` also reads the ranges of every token's ancestors, as a +rename that checks scopes would. `edit-each-child` replaces every child of the +wide node through one cursor. + +| Case | Before | After | +| --- | ---: | ---: | +| `rename-all`, 1,000 lines | 1.96 ms, 17 MB allocated | 540 µs, 2.5 MB | +| `rename-all-ancestors`, 1,000 lines | 8.25 ms, 80 MB | 738 µs, 3.1 MB | +| `edit-each-child`, 100 children | 22.8 µs | 15.5 µs | +| `edit-each-child`, 1,000 children | 1.61 ms, 16 MB | 210 µs, 1.0 MB | +| `edit-each-child`, 10,000 children | 149 ms, 1.5 GB | 2.78 ms, 11 MB | +| One replacement at depth 10,000, then the tree | 189 µs, 1.0 MB | 222 µs, 1.0 MB | +| 100 single edits of the document, each followed by the tree | 101 µs | 99.4 µs | +| Iterate all siblings, 10,000 children | 320 µs | 293 µs | +| Child by index from a fresh cursor | 3.6–6.3 ns | 39–53 ns | +| Prepared cursor at depth 10,000 to the root | 23.2 µs | 64.6 µs | + +Before, each step away from an edited child copied the parent's child array, +so a run of edits was quadratic in the width, and every climb from below an +edit that was then thrown away, such as `Cursor.ancestors` on each token, +copied the ancestors again. Single edits cost the same as before. A cursor is +now larger, so taking one child of a fresh cursor, which GHC used to reduce to +almost nothing, allocates, and walking up a very deep cursor is slower. + +| Retained result, 1,000 lines | Before | After | +| --- | ---: | ---: | +| The tree after renaming every `Name` | 0.428 MB, 18.8 MB allocated | 0.428 MB, 3.7 MB allocated | +| The cursor on the last token after renaming | 0.429 MB | 0.765 MB | +| The last cursor after 10 renaming passes through one chain of cursors | 0.429 MB | 0.902 MB | +| The last cursor after 100 passes | 0.429 MB | 0.902 MB | +| Every cursor that one renaming walk visits | 17.3 MB | 1.81 MB | + +At 10,000 lines the renamed tree takes 4.24 MB before and 4.28 MB after, +with 908 MB and 37 MB allocated, the cursor 4.24 MB before and 7.64 MB +after, and every visited cursor 893 MB before and 18.7 MB after. A cursor +keeps the version of each edited node from before the edits, but repeated +passes don't accumulate older versions: the residency after 10 and 100 +passes is the same. Keeping every cursor of a walk costs far less than +before, when each cursor that had left an edited line held its own copy of +the document's child array. + +### Typed casts on edited cursors (2026-10-26) + +A typed walk that edits as it goes was still quadratic after the previous +change. `Ast.matchNode` and `Ast.matchToken` told nodes from tokens by +matching on `Cursor.green`, which builds a node that has been edited through +the cursor. So `Ast.parent` or `Ast.ancestors` on each token of a renaming +walk rebuilt every edited ancestor after each edit, at a cost proportional to +its width. The casts now use `Cursor.kind` and the new `Cursor.isToken`, +which build nothing. + +`rename-all-groups` renames every `Name` in the 1,000-line document and, +before each rename, reads the ranges of the token's ancestors that cast to a +typed view of line (`Group`) nodes. As in the previous entry, these are single +passes on one machine with GHC 9.12.2, `--stdev 3` and a 32 MiB allocation +area, not runs of `bench/run.py`. + +| Case | Before | After | +| --- | ---: | ---: | +| `rename-all-groups`, 1,000 lines | 13.5 ms, 65 MB allocated | 669 µs, 3.5 MB | + +The typed walk now costs the same as `rename-all-ancestors`, which reads +every ancestor through `Cursor.ancestors`: 658 µs and 3.5 MB in the same run. + +### Read-only cursors and edit plans (2026-10-27) + +Cursors lost their edits and shrank to four fields, and `Graft.Edit` took +over editing: `apply` makes a plan of edits against the tree they refer to, +and `rewrite` visits a tree top-down and replaces as it goes +([architecture](architecture.md)). The cases that edit were rewritten over +the new API, so the "before" and "after" columns time the same task done +the way each design does it: `edit-each-child` was a cursor walk and is a +rewrite; `replace-*`, `replace-path`, the focused `replace` and the 100 +document edits were `Cursor.replace` and `Cursor.tree` and are plans of one +edit; `rename-all*` renamed through one cursor and are rewrites that read +the same things before each rename. New cases: `plan-each-child`, the same +change as `edit-each-child` as a plan with one edit per child; +`apply-sparse-k`, a plan replacing the name of `k` lines spread over the +document, and `text-edits-1000` for its largest plan; and +`apply-from-equal-tree`, one edit whose cursor is in an equal document built +separately, so that `apply` compares the trees instead of recognising the +base. + +Both columns are single passes on one machine in one sitting, with GHC +9.12.2, `-O2`, `--stdev 3`, a 32 MiB allocation area and the process pinned +to CPU 2, not runs of `bench/run.py`; the "before" build is the `main` +revision `7a36b16`. The plan cases were timed a second time after two fixes +that the first pass prompted: `apply` had laid out every untouched child of +a rebuilt node through lists, at 470 bytes and 80 ns per child, and now +copies the untouched runs of the child array as blocks, shifts their offsets +and measures only the new elements, reusing the offsets when no patch +changes the layout. Times are in microseconds. + +| Case | Before | After | +| --- | ---: | ---: | +| Wide, 10,000: child by index from a fresh cursor | 0.038–0.042 | 0.030 | +| Wide, 10,000: iterate all siblings | 273 | 48.6 | +| Wide, 10,000: all typed tokens | 464 | 405 | +| Wide, 10,000: replace the first, middle, last child | 13.6, 13.3, 10.5 | 17.5, 15.3, 13.5 | +| Wide, 100 / 1,000 / 10,000: `edit-each-child` | 17.2 / 167 / 2,272 | 4.79 / 47.1 / 590 | +| Wide, 10,000: `plan-each-child` | — | 3,281 | +| Wide, 10,000: `edit-parent-once` | 349 | 347 | +| Deep, 10,000: descend to the leaf | 357 | 243 | +| Deep, 10,000: prepared cursor to the root | 46.1 | 30.9 | +| Deep, 10,000: replace at a path | 550 | 2,036 | +| Deep, 10,000: replace through a prepared cursor | 223 | 1,824 | +| Chain, 10,000: all tokens | 2,133 | 1,879 | +| Document: all token ranges | 328 | 281 | +| Document: all typed line nodes | 47.8 | 39.4 | +| Document: 100 successive edits, latest / all versions | 84.3 / 90.4 | 113 / 109 | +| Document: `rename-all` / `-ancestors` / `-groups` | 595 / 807 / 964 | 300 / 504 / 454 | +| Document: `apply-sparse` 1 / 10 / 100 / 1,000 | — | 1.86 / 5.64 / 38.4 / 411 | +| Document: `text-edits-1000` | — | 507 | +| Document: `apply-from-equal-tree` | — | 97.5 | + +Allocation moved with the times: `rename-all` from 3.05 MB to 1.57 MB, +`edit-each-child` at 10,000 from 11.3 MB to 2.88 MB, a replacement in the +wide node from 160 KB to 161 KB, and the 100 document edits from 0.93 MB to +1.06 MB. + +| Retained result, 1,000 lines | Before | After | +| --- | ---: | ---: | +| The original tree | 0.449 MB | 0.449 MB | +| A cursor on a middle token | 0.450 MB | 0.449 MB | +| The tree after renaming every `Name` | 0.425 MB | 0.377 MB | +| A cursor on that tree's last token (before: the cursor that renamed) | 0.738 MB | 0.378 MB | +| The same after 10 and after 100 renaming passes | 0.899 MB | 0.377 MB | +| Every cursor a renaming walk visits (before: tokens; after: every element) | 1.78 MB | 0.929 MB | + +At 10,000 lines the renamed tree takes 4.27 MB before and 3.76 MB after, and +the cursor 7.39 MB before and 3.76 MB after. A cursor now retains the tree it +is in and nothing else. The renamed tree is smaller after because the +rewrite's replacement token is one shared value where the walk built one per +token; that is the fixture, not the library. + +What the pass found: + +- Navigation is faster and smaller across the board, as the four-field + cursor predicted: a fresh child costs what it did before 2026-10-19, + sibling iteration over 10,000 children is five times faster, and deep + descents and typed walks gained 15–30%. +- A rewrite does the renaming walk in half the time and half the allocation + of the editing cursor, and a dense change through a rewrite is five times + faster than the same change as a plan with one edit per child, which pays + for a trie entry and a path per edit. That is the division of labour the + design intended. +- A plan of one edit costs a fixed 0.3 µs more than the old cursor edit for + resolving the cursor, building the trie and validating, and the same array + copy after that. On the 1,000-line document that is 1.9 µs per edit + against 0.84. Through a 10,000-level chain it is 2.0 ms against 0.55: each + level costs a trie node, a layout and a one-child patch where the cursor + copied one child. A plan of a single edit could walk the cursor's parent + chain instead of building a trie; this log notes it as the candidate if a + real tree is that deep. +- Comparing an equal tree built separately costs 97 µs on the 1,000-line + document, fifty times the edit it validates. The pointer test is what + makes the normal case cheap, and it is an optimisation, not a bound. + +## What the numbers suggest + +- Memory per token is the largest remaining cost. Each token occupies an array + slot, an offset and a `Token` holding its text, and nothing deduplicates + identical tokens such as `;` or a single space. A node cache + like Rowan's could share them. Its value depends on duplicate rates in real + parser output, which haven't been measured. +- Edits in very wide nodes copy the whole child array. A chunked or + finger-tree child list would make them logarithmic, at a cost to access and + memory in the common case. +- A plan of one edit on a very deep path pays per level for machinery that a + single edit doesn't need; walking the cursor's parent chain would remove + it. +- Traversals through cursors allocate a cursor per occurrence. `Green.foldM` + avoids that when positions aren't needed; this log doesn't yet record it. + +These results describe Graft alone and make no comparison with Rowan. diff --git a/examples/ExactUpdate.hs b/examples/ExactUpdate.hs new file mode 100644 --- /dev/null +++ b/examples/ExactUpdate.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} + +-- Run with: cabal run graft-example +-- The tree is written out by hand; Graft has no lexer or parser. +module Main (main) where + +import qualified Data.Text as Text +import qualified Data.Text.IO as TextIO +import Graft +import qualified Graft.Ast as Ast +import qualified Graft.Cursor as Cursor +import qualified Graft.Edit as Edit +import qualified Graft.Green as Green +import Text.Read (readMaybe) + +data Kind = Root | Expr | Name | Number | Trivia deriving (Eq, Show) + +-- In a library, export the view types but not their constructors, so that +-- views are made only by casting. +newtype Expression = Expression (Cursor Kind) +instance AstView Expression where + type AstViewKind Expression = Kind + fromCursor = Ast.matchNode (== Expr) Expression + toCursor (Expression cursor) = cursor +instance AstNode Expression + +newtype NumberLiteral = NumberLiteral (Cursor Kind) +instance AstView NumberLiteral where + type AstViewKind NumberLiteral = Kind + fromCursor = Ast.matchToken (== Number) NumberLiteral + toCursor (NumberLiteral cursor) = cursor +instance AstToken NumberLiteral + +expressionNumber :: Expression -> Maybe NumberLiteral +expressionNumber = Ast.token . toCursor + +-- Graft doesn't interpret token text: reading the value and choosing a new +-- spelling are up to the application. A Number token can still hold text +-- that doesn't parse as a number. +numberValue :: NumberLiteral -> Maybe Integer +numberValue = readMaybe . Text.unpack . Green.render . Cursor.green . toCursor + +setNumberValue :: Integer -> NumberLiteral -> Maybe (GreenElement Kind) +setNumberValue value literal = do + oldValue <- numberValue literal + let focus = toCursor literal + tree = Cursor.tree focus + if oldValue == value + then pure tree -- Same value: keep the spelling, such as 001. + else either (const Nothing) Just $ + Edit.apply tree [Edit.replace focus (Token (Green.token Number (Text.pack (show value))))] + +updateValue :: Integer -> GreenElement Kind -> Maybe (GreenElement Kind) +updateValue value root = do + expression <- Ast.child (Cursor.fromGreen root) + literal <- expressionNumber expression + setNumberValue value literal + +original :: GreenElement Kind +original = Node (Green.node Root + [ Token (Green.token Name "x") + , Token (Green.token Trivia " = ") + , Node (Green.node Expr [Token (Green.token Number "001")]) + , Token (Green.token Trivia " -- keep\r\n") + ]) + +main :: IO () +main = mapM_ display [Just original, updateValue 1 original, updateValue 2 original] + where + display Nothing = fail "Missing expression, missing number, or invalid numeric text" + display (Just root) = TextIO.putStr (Green.render root) diff --git a/examples/GettingStarted.hs b/examples/GettingStarted.hs new file mode 100644 --- /dev/null +++ b/examples/GettingStarted.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main (main) where + +import qualified Data.Text.IO as Text +import Graft +import qualified Graft.Build as Build +import qualified Graft.Cursor as Cursor +import qualified Graft.Edit as Edit +import qualified Graft.Green as Green +import qualified Graft.Range as Range + +data Kind = Root | Binding | Name | Number | Trivia + deriving (Eq, Show) + +-- A parser would emit these events; here they are written by hand. +parsed :: Either BuilderError (GreenNode Kind) +parsed = Build.exec $ Build.node Root $ do + Build.node Binding $ do + Build.token Name "x" + Build.token Trivia " = " + Build.token Number "1" + Build.token Trivia " -- keep\r\n" + +main :: IO () +main = do + tree <- either (fail . show) pure parsed + Text.putStr (Green.renderNode tree) + case Cursor.covering (Range.fromLength 5 1) (Cursor.fromGreen (Node tree)) of + Just number -> do + let edits = [Edit.replace number (Token (Green.token Number "42"))] + edited <- either (fail . show) pure (Edit.apply (Node tree) edits) + Text.putStr (Green.render edited) + Nothing -> fail "nothing at offset 5" diff --git a/graft.cabal b/graft.cabal new file mode 100644 --- /dev/null +++ b/graft.cabal @@ -0,0 +1,138 @@ +cabal-version: 3.0 +name: graft +version: 0.1.0.0 +synopsis: Immutable, lossless concrete syntax trees +description: + Lossless, immutable concrete syntax trees, modelled on rust-analyzer's + Rowan. Green trees keep every byte of the source, cache UTF-8 lengths and + share subtrees. Cursors navigate them and find syntax by byte offset; plans + and rewrites edit them persistently, sharing what they don't change. + Builders turn parser events into trees, and typed views give a grammar's + nodes typed accessors without a separate AST. Lexing and parsing are left + to the application. +category: Language +license: MIT +license-files: LICENSE licenses/ROWAN-MIT +copyright: 2026 Andrea Bedini +author: Andrea Bedini +maintainer: andrea@bedini.au +homepage: https://github.com/andreabedini/graft +bug-reports: https://github.com/andreabedini/graft/issues +build-type: Simple +tested-with: GHC ==9.8.4 || ==9.10.3 || ==9.12.2 || ==9.14.1 +extra-source-files: + bench/run.py + bench/results/**/*.csv + bench/results/**/*.json +extra-doc-files: + README.md + CHANGELOG.md + CONTRIBUTING.md + NOTICE + docs/architecture.md + docs/performance.md + bench/README.md + +source-repository head + type: git + location: https://github.com/andreabedini/graft.git + +flag doctest + description: Build the doctest suite, which checks the Haddock examples. + default: False + manual: True + +common warnings + ghc-options: -Wall + +library + import: warnings + exposed-modules: Graft Graft.Green Graft.Range Graft.Cursor Graft.Edit Graft.Builder Graft.Build Graft.Ast Graft.LineIndex + other-modules: Graft.Green.Internal + build-depends: + base >=4.19 && <4.23, + containers >=0.6.8 && <0.9, + deepseq >=1.5 && <1.6, + hashable >=1.4 && <1.6, + primitive >=0.8 && <0.10, + text >=2.0 && <2.2 + hs-source-dirs: src + default-language: Haskell2010 + +benchmark graft-bench + import: warnings + type: exitcode-stdio-1.0 + main-is: Main.hs + other-modules: Fixtures Residency + hs-source-dirs: bench + build-depends: + base >=4.19 && <4.23, + deepseq >=1.5 && <1.6, + graft, + hashable >=1.4 && <1.6, + tasty-bench >=0.3.5 && <0.6, + text >=2.0 && <2.2, + transformers >=0.6.1 && <0.7 + ghc-options: -rtsopts -with-rtsopts=-T -fproc-alignment=64 + default-language: Haskell2010 + +test-suite graft-tests + import: warnings + type: exitcode-stdio-1.0 + main-is: Main.hs + other-modules: AstTests BuilderTests ChildEditTests CursorTests EditTests FoldTests LineIndexTests TestModel + hs-source-dirs: test + build-depends: + base >=4.19 && <4.23, + bytestring >=0.11 && <0.13, + containers >=0.6.8 && <0.9, + deepseq >=1.5 && <1.6, + graft, + hashable >=1.4 && <1.6, + QuickCheck >=2.14 && <2.20, + text >=2.0 && <2.2, + transformers >=0.6.1 && <0.7 + default-language: Haskell2010 + +-- The program in the README's Getting started section, built and run so that +-- it tracks the API. CI checks that the README shows this file unchanged. +test-suite graft-getting-started + import: warnings + type: exitcode-stdio-1.0 + main-is: GettingStarted.hs + hs-source-dirs: examples + build-depends: + base >=4.19 && <4.23, + graft, + text >=2.0 && <2.2 + default-language: Haskell2010 + +-- The exact-preserving update example linked from the README and the +-- architecture note, built and run so that it tracks the API. +test-suite graft-example + import: warnings + type: exitcode-stdio-1.0 + main-is: ExactUpdate.hs + hs-source-dirs: examples + build-depends: + base >=4.19 && <4.23, + graft, + text >=2.0 && <2.2 + default-language: Haskell2010 + +-- Checks the examples in the Haddock documentation. Enable it with +-- -fdoctest; see CONTRIBUTING.md. +test-suite graft-doctest + import: warnings + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: test/doctest + if !flag(doctest) + buildable: False + build-depends: + base >=4.19 && <4.23, + directory >=1.3 && <1.4, + doctest >=0.22 && <0.26, + graft + ghc-options: -threaded + default-language: Haskell2010 diff --git a/licenses/ROWAN-MIT b/licenses/ROWAN-MIT new file mode 100644 --- /dev/null +++ b/licenses/ROWAN-MIT @@ -0,0 +1,23 @@ +Permission is hereby granted, free of charge, to any +person obtaining a copy of this software and associated +documentation files (the "Software"), to deal in the +Software without restriction, including without +limitation the rights to use, copy, modify, merge, +publish, distribute, sublicense, and/or sell copies of +the Software, and to permit persons to whom the Software +is furnished to do so, subject to the following +conditions: + +The above copyright notice and this permission notice +shall be included in all copies or substantial portions +of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF +ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED +TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A +PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT +SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION +OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR +IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +DEALINGS IN THE SOFTWARE. diff --git a/src/Graft.hs b/src/Graft.hs new file mode 100644 --- /dev/null +++ b/src/Graft.hs @@ -0,0 +1,110 @@ +-- | Lossless, immutable concrete syntax trees, modelled on rust-analyzer's +-- Rowan. +-- +-- A Graft tree keeps every byte of the source: whitespace, comments and +-- malformed fragments are ordinary tokens. You navigate the tree with +-- cursors, find syntax by byte offset, edit it, and print it back with the +-- untouched text exactly as it was. Lexing and parsing are up to you. +-- +-- This module exports the library's types and classes. The functions live in +-- modules meant to be imported qualified: +-- +-- > import Graft +-- > import qualified Graft.Ast as Ast +-- > import qualified Graft.Build as Build +-- > import qualified Graft.Builder as Builder +-- > import qualified Graft.Cursor as Cursor +-- > import qualified Graft.Edit as Edit +-- > import qualified Graft.Green as Green +-- > import qualified Graft.LineIndex as LineIndex +-- > import qualified Graft.Range as Range +-- +-- * "Graft.Green": immutable nodes and tokens with cached lengths, and edits +-- to a node's children. +-- * "Graft.Cursor": navigation and offset lookup through a zipper. +-- * "Graft.Edit": edits described against a tree and made all at once, +-- as a plan of edits or as a top-down rewrite, with the unchanged +-- subtrees shared and the text edits for an editor. +-- * "Graft.Build" and "Graft.Builder": building trees from a parser's events, +-- in a monad or as a pure value. +-- * "Graft.Ast": typed views of your grammar's nodes and tokens. +-- * "Graft.Range": half-open byte ranges. +-- * "Graft.LineIndex": line and column positions in UTF-8 or UTF-16 units. +-- +-- All lengths and offsets are t'TextLength', a count of UTF-8 bytes. +-- +-- Importing "Graft" unqualified brings in constructors with common names, +-- such as 'Node' and 'Token', and the type synonym t'Path'. If they clash +-- with other imports, import only what you use, as in +-- @import Graft (GreenElement (..), TextLength)@, or import "Graft" +-- qualified too. +-- +-- = Example +-- +-- Build a tree, find the number at byte offset 5, replace it and render: +-- +-- >>> :set -XOverloadedStrings +-- >>> import qualified Graft.Build as Build +-- >>> import qualified Graft.Cursor as Cursor +-- >>> import qualified Graft.Edit as Edit +-- >>> import qualified Graft.Green as Green +-- >>> import qualified Graft.Range as Range +-- >>> data Kind = Root | Binding | Name | Number | Trivia deriving (Eq, Show) +-- >>> :{ +-- let Right tree = Build.exec $ Build.node Root $ do +-- Build.node Binding $ do +-- Build.token Name "x" +-- Build.token Trivia " = " +-- Build.token Number "1" +-- Build.token Trivia " -- keep\r\n" +-- :} +-- +-- >>> Green.renderNode tree +-- "x = 1 -- keep\r\n" +-- >>> let Just number = Cursor.covering (Range.fromLength 5 1) (Cursor.fromGreen (Node tree)) +-- >>> Cursor.text number +-- "1" +-- >>> Green.render <$> Edit.apply (Node tree) [Edit.replace number (Token (Green.token Number "42"))] +-- Right "x = 42 -- keep\r\n" +module Graft + ( -- * Trees + GreenNode + , GreenToken + , GreenElement (..) + , TextLength (..) + , ChildEditError (..) + -- * Cursors + , Cursor + , Path + , PathError (..) + , TokenAtOffset (..) + , WalkEvent (..) + -- * Editing + , Edit + , EditError (..) + , TextEdit (..) + , Change (..) + -- * Ranges and positions + , TextRange + , LineIndex + , Utf8Position (..) + , Utf16Position (..) + -- * Building + , Build + , Builder + , Checkpoint + , BuilderError (..) + -- * Typed views + , AstView (..) + , AstNode + , AstToken + ) where + +import Graft.Ast (AstNode, AstToken, AstView (..)) +import Graft.Build (Build) +import Graft.Builder (Builder, BuilderError (..), Checkpoint) +import Graft.Cursor (Cursor, Path, PathError (..), TokenAtOffset (..), WalkEvent (..)) +import Graft.Edit (Change (..), Edit, EditError (..), TextEdit (..)) +import Graft.Green (ChildEditError (..), GreenElement (..), GreenNode, GreenToken, TextLength (..)) +import Graft.LineIndex (LineIndex, Utf16Position (..), Utf8Position (..)) +import Graft.Range (TextRange) diff --git a/src/Graft/Ast.hs b/src/Graft/Ast.hs new file mode 100644 --- /dev/null +++ b/src/Graft/Ast.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE TypeFamilies #-} + +-- | Typed views of your grammar's nodes and tokens. +-- +-- A view is a newtype over a cursor with a cast that checks the element's +-- kind. Accessors written with 'child', 'token' and friends then give +-- typed access to fields, and every view keeps its exact text, range and +-- context, so there is no separate AST to keep in sync with the source. +-- +-- The classes follow the shape of @Exception@ in "Control.Exception", with +-- 'Cursor' in the place of @SomeException@: 'fromCursor' +-- is a cast that can fail, and 'toCursor' gives back the cursor. 'AstView' +-- holds the cast, and the empty classes 'AstNode' and 'AstToken' say +-- whether the view is of nodes or of tokens. +-- +-- This module is meant to be imported qualified; its classes are also +-- exported by "Graft", so instances can be written without qualification: +-- +-- > import Graft +-- > import qualified Graft.Ast as Ast +-- > +-- > newtype Call = Call (Cursor Kind) +-- > +-- > instance AstView Call where +-- > type AstViewKind Call = Kind +-- > fromCursor = Ast.matchNode (== CallKind) Call +-- > toCursor (Call cursor) = cursor +-- > +-- > instance AstNode Call +-- > +-- > newtype Name = Name (Cursor Kind) +-- > +-- > instance AstView Name where +-- > type AstViewKind Name = Kind +-- > fromCursor = Ast.matchToken (== NameKind) Name +-- > toCursor (Name cursor) = cursor +-- > +-- > instance AstToken Name +-- > +-- > -- The function being called, if the call has one. +-- > callee :: Call -> Maybe Name +-- > callee = Ast.token . toCursor +-- +-- A cast checks only the kind, not the grammar, so a call with a missing +-- callee still casts and @callee@ returns 'Nothing'. Keep the view +-- constructors private so that views are only made by casting. +module Graft.Ast + ( -- * Views + AstView (..) + , AstNode + , AstToken + , matchNode + , matchToken + -- * Fields + , child + , children + , parent + , ancestors + , token + , tokens + ) where + +import Data.Maybe (listToMaybe, mapMaybe) +import Graft.Cursor (Cursor) +import qualified Graft.Cursor as Cursor + +-- | A typed view of a node or a token, usually a newtype around a 'Cursor'. +-- Declare an 'AstNode' or 'AstToken' instance too, to say which it is. +-- +-- Instances should satisfy these laws, which 'matchNode' and 'matchToken' +-- do: +-- +-- * Whether 'fromCursor' succeeds depends only on the focused element, +-- 'Cursor.green', not on where it is: two cursors on equal elements are +-- both accepted or both rejected. +-- * If @fromCursor cursor@ is @Just view@, then @toCursor view@ is that +-- cursor, unchanged, with the same path, range and element. +-- * Casting @toCursor view@ succeeds again. +class AstView view where + -- | The kind type of the trees this view applies to. + type AstViewKind view + -- | View an element, or 'Nothing' if it isn't one of this view's kinds. + fromCursor :: Cursor (AstViewKind view) -> Maybe view + -- | The cursor the view was made from. + toCursor :: view -> Cursor (AstViewKind view) + +-- | A view of nodes. In addition to the 'AstView' laws, 'fromCursor' must +-- reject token cursors; 'matchNode' does. 'child', 'children', 'parent' and +-- 'ancestors' look for these views. +class AstView view => AstNode view + +-- | A view of tokens. In addition to the 'AstView' laws, 'fromCursor' must +-- reject node cursors; 'matchToken' does. 'token' and 'tokens' look for these +-- views. Interpreting the token's text, for example reading a number, is up to +-- the application. +class AstView view => AstToken view + +-- | @matchNode accepts wrap@ is a 'fromCursor' for an 'AstNode' view. It wraps +-- any node whose kind satisfies @accepts@, as in +-- @fromCursor = Ast.matchNode (== CallKind) Call@, and rejects tokens. It +-- looks at the kind only, not at the node's children. +matchNode :: (kind -> Bool) -> (Cursor kind -> view) -> Cursor kind -> Maybe view +matchNode accepts wrap cursor + | not (Cursor.isToken cursor), accepts (Cursor.kind cursor) = Just (wrap cursor) + | otherwise = Nothing + +-- | The 'AstToken' counterpart of 'matchNode'. It rejects nodes and checks +-- only the kind, not the text. +matchToken :: (kind -> Bool) -> (Cursor kind -> view) -> Cursor kind -> Maybe view +matchToken accepts wrap cursor + | Cursor.isToken cursor, accepts (Cursor.kind cursor) = Just (wrap cursor) + | otherwise = Nothing + +-- | The first child node that casts to the view, or 'Nothing'. Only direct +-- children are searched. +child :: AstNode view => Cursor (AstViewKind view) -> Maybe view +child = listToMaybe . children + +-- | Every child node that casts to the view, in source order. The list is +-- lazy. +children :: AstNode view => Cursor (AstViewKind view) -> [view] +children = mapMaybe fromCursor . filter (not . Cursor.isToken) . Cursor.children + +-- | The parent, if it casts to the view. Ancestors further up are not +-- searched; use 'ancestors' for that. +parent :: AstNode view => Cursor (AstViewKind view) -> Maybe view +parent cursor = Cursor.parent cursor >>= fromCursor + +-- | Every ancestor that casts to the view, nearest first, not including the +-- cursor itself. The list is lazy. +ancestors :: AstNode view => Cursor (AstViewKind view) -> [view] +ancestors = mapMaybe fromCursor . Cursor.ancestors + +-- | The first child token that casts to the view, or 'Nothing'. Tokens inside +-- child nodes are not searched. +token :: AstToken view => Cursor (AstViewKind view) -> Maybe view +token = listToMaybe . tokens + +-- | Every child token that casts to the view, in source order. Tokens inside +-- child nodes are not included; 'Cursor.descendantTokens' finds those. The +-- list is lazy. +tokens :: AstToken view => Cursor (AstViewKind view) -> [view] +tokens = mapMaybe fromCursor . filter Cursor.isToken . Cursor.children diff --git a/src/Graft/Build.hs b/src/Graft/Build.hs new file mode 100644 --- /dev/null +++ b/src/Graft/Build.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE BangPatterns #-} + +-- | Building green trees in a monad, as a parser does. 'node' brackets a +-- node, so a body that opens and closes its own nodes in pairs leaves none +-- open, and the first error stops the build. +-- +-- This module is meant to be imported qualified; its types are also +-- exported by "Graft": +-- +-- > import Graft +-- > import qualified Graft.Build as Build +-- > +-- > -- 1 + 2: the operand is emitted before the parser knows it is wrapped. +-- > expression :: Build Kind () +-- > expression = do +-- > start <- Build.checkpoint +-- > Build.token Number "1" +-- > Build.nodeAt start Binary $ do +-- > Build.token Whitespace " " +-- > Build.token Plus "+" +-- > Build.token Whitespace " " +-- > Build.token Number "2" +-- > +-- > parsed :: Either BuilderError (GreenNode Kind) +-- > parsed = Build.exec (Build.node Root expression) +-- +-- t'Build' is a thin layer over the pure t'Builder' value from "Graft.Builder". +module Graft.Build + ( Build + , run + , exec + , node + , nodeAt + , token + , element + , checkpoint + , startNode + , startNodeAt + , finishNode + , save + , restore + ) where + +import Data.Text (Text) +import Graft.Builder (Builder, BuilderError, Checkpoint) +import qualified Graft.Builder as Builder +import Graft.Green.Internal (GreenElement, GreenNode) + +-- | A construction in progress: a state monad over t'Builder' that stops at +-- the first 'BuilderError'. +newtype Build kind a = Build (Builder kind -> Either BuilderError (a, Builder kind)) + +instance Functor (Build kind) where + fmap f (Build step) = Build $ \builder -> do + (value, next) <- step builder + pure (f value, next) + +instance Applicative (Build kind) where + pure value = Build $ \builder -> Right (value, builder) + Build stepFunction <*> Build stepValue = Build $ \builder -> do + (f, next) <- stepFunction builder + (value, final) <- stepValue next + pure (f value, final) + +instance Monad (Build kind) where + Build step >>= continue = Build $ \builder -> do + (value, next) <- step builder + let Build stepNext = continue value + stepNext next + +-- | Run a construction from 'Builder.empty' and finish it with +-- 'Builder.finish', returning its result and the tree. +run :: Build kind a -> Either BuilderError (a, GreenNode kind) +run (Build step) = do + (value, builder) <- step Builder.empty + built <- Builder.finish builder + pure (value, built) + +-- | Run a construction and return only the tree. +exec :: Build kind a -> Either BuilderError (GreenNode kind) +exec = fmap snd . run + +-- | A node around the elements that the body emits. The node is closed when +-- the body returns. If the body itself closes more nodes than it opens, with +-- 'finishNode' or 'restore', this closes some other node instead, so keep +-- the body balanced. +node :: kind -> Build kind a -> Build kind a +node nodeKind body = startNode nodeKind *> body <* finishNode + +-- | A node that starts at an earlier checkpoint, wrapping the elements +-- emitted since then together with those the body emits. Fails as +-- 'Builder.startNodeAt' does. +nodeAt :: Checkpoint -> kind -> Build kind a -> Build kind a +nodeAt marker nodeKind body = startNodeAt marker nodeKind *> body <* finishNode + +-- | Emit a token. +token :: kind -> Text -> Build kind () +token tokenKind contents = modifyBuilder (Builder.token tokenKind contents) + +-- | Emit an existing node or token, such as an unchanged subtree. +element :: GreenElement kind -> Build kind () +element emitted = modifyBuilder (Builder.element emitted) + +-- | The current position, for a later 'nodeAt'. +checkpoint :: Build kind Checkpoint +checkpoint = Build $ \builder -> Right (Builder.checkpoint builder, builder) + +-- | Open a node that a later 'finishNode' closes, for parsers that open and +-- close nodes in different places. Prefer 'node'. +startNode :: kind -> Build kind () +startNode nodeKind = modifyBuilder (Builder.startNode nodeKind) + +-- | Open a node at an earlier checkpoint. Prefer 'nodeAt'. +startNodeAt :: Checkpoint -> kind -> Build kind () +startNodeAt marker nodeKind = Build $ \builder -> (,) () <$> Builder.startNodeAt marker nodeKind builder + +-- | Close the innermost open node. +finishNode :: Build kind () +finishNode = Build $ \builder -> (,) () <$> Builder.finishNode builder + +-- | The current builder. Together with 'restore' this lets a backtracking +-- parser return to an earlier state after a failed alternative. +save :: Build kind (Builder kind) +save = Build $ \builder -> Right (builder, builder) + +-- | Replace the current builder with a saved one. +restore :: Builder kind -> Build kind () +restore saved = Build $ \_ -> Right ((), saved) + +modifyBuilder :: (Builder kind -> Builder kind) -> Build kind () +modifyBuilder step = Build $ \builder -> let !next = step builder in Right ((), next) diff --git a/src/Graft/Builder.hs b/src/Graft/Builder.hs new file mode 100644 --- /dev/null +++ b/src/Graft/Builder.hs @@ -0,0 +1,156 @@ +{-# LANGUAGE BangPatterns #-} + +-- | Building green trees from a parser's events, as a pure value. Lexing and +-- parsing are up to you; trivia is emitted as ordinary tokens, and nothing is +-- checked against a grammar. +-- +-- A parser usually builds in the 'Graft.Build.Build' monad from +-- "Graft.Build", which threads the builder and its errors and brackets each +-- node. Use t'Builder' directly when you want to keep builder states +-- around, for example to branch. +-- +-- This module is meant to be imported qualified; its types are also +-- exported by "Graft": +-- +-- > import Graft +-- > import qualified Graft.Builder as Builder +-- +-- >>> :set -XOverloadedStrings +-- >>> import qualified Graft.Builder as Builder +-- >>> import qualified Graft.Green as Green +-- >>> let operand = Builder.token 'n' "1" (Builder.startNode 'r' Builder.empty) +-- >>> let Right wrapped = Builder.startNodeAt (Builder.checkpoint (Builder.startNode 'r' Builder.empty)) 'e' operand +-- >>> let Right closed = Builder.finishNode (Builder.token 'n' "2" (Builder.token 'o' "+" wrapped)) >>= Builder.finishNode +-- >>> Green.renderNode <$> Builder.finish closed +-- Right "1+2" +module Graft.Builder + ( Builder + , Checkpoint + , BuilderError (..) + , empty + , startNode + , startNodeAt + , finishNode + , token + , element + , checkpoint + , finish + ) where + +import Control.DeepSeq (NFData (..)) +import Control.Exception (Exception) +import Data.Text (Text) +import Graft.Green.Internal (GreenElement (..), GreenNode) +import qualified Graft.Green as Green +import qualified Graft.Green.Internal as Internal + +-- | A tree under construction: the elements emitted so far and the nodes +-- still open. A builder is an ordinary immutable value, so keeping an old one +-- lets you continue from it along a different branch. +-- Pending elements are in reverse order, with their count, and each open node +-- records the position where it started. +data Builder kind = Builder !Int [GreenElement kind] [(kind, Int)] + deriving (Eq) + +-- | Shows a sequence of 'startNode' and 'element' calls that rebuilds an +-- equal builder. +instance Show kind => Show (Builder kind) where + showsPrec precedence (Builder count pending parents) = go precedence (reverse steps) + where + elements = reverse pending + opened position = [nodeKind | (nodeKind, from) <- reverse parents, from == position] + steps = concat + [ map Left (opened position) ++ [Right emitted | emitted <- take 1 rest] + | (position, rest) <- zip [0 .. count] (iterate (drop 1) elements) + ] + go _ [] = showString "Builder.empty" + go outer (Left nodeKind : earlier) = showParen (outer > 10) $ + showString "Builder.startNode " . showsPrec 11 nodeKind . showChar ' ' . go 11 earlier + go outer (Right emitted : earlier) = showParen (outer > 10) $ + showString "Builder.element " . showsPrec 11 emitted . showChar ' ' . go 11 earlier + +instance NFData kind => NFData (Builder kind) where + rnf (Builder _ pending parents) = rnf pending `seq` rnf parents + +-- | A position among the elements emitted so far, counted in elements, from +-- which 'startNodeAt' can open a node. As in Rowan, it is only a number: it +-- doesn't remember which builder it came from. Use it in the node where it +-- was taken, before that node closes. +-- +-- 'Show' displays the position, as @Checkpoint 3@; there is no expression +-- that builds a checkpoint without a builder. +newtype Checkpoint = Checkpoint Int + deriving (Eq, Show) + +instance NFData Checkpoint where + rnf (Checkpoint _) = () + +-- | Why construction failed. The checkpoint errors give the checkpoint's +-- position, then the number of elements or the start of the current node. +data BuilderError + = NoOpenNode + | UnclosedNodes !Int + | EmptyBuilder + | MultipleRoots !Int + | TokenRoot + | CheckpointOutOfBounds !Int !Int + | CheckpointBeforeCurrentNode !Int !Int + deriving (Eq, Show) + +instance Exception BuilderError + +instance NFData BuilderError where + rnf err = err `seq` () + +-- | A builder with nothing emitted and no open nodes. +empty :: Builder kind +empty = Builder 0 [] [] + +-- | Open a node, which 'finishNode' closes. +startNode :: kind -> Builder kind -> Builder kind +startNode nodeKind (Builder count pending parents) = + Builder count pending ((nodeKind, count) : parents) + +-- | Emit a token. Constant time. +token :: kind -> Text -> Builder kind -> Builder kind +token tokenKind contents = element (Token (Green.token tokenKind contents)) + +-- | Emit an existing node or token, such as an unchanged subtree from an +-- earlier tree. Constant time; the element is shared, not copied. +element :: GreenElement kind -> Builder kind -> Builder kind +element !emitted (Builder count pending parents) = + Builder (count + 1) (emitted : pending) parents + +-- | Close the innermost open node, making everything emitted since it opened +-- into its children. Takes time proportional to the number of children. +finishNode :: Builder kind -> Either BuilderError (Builder kind) +finishNode (Builder _ _ []) = Left NoOpenNode +finishNode (Builder count pending ((nodeKind, start) : parents)) = + case Internal.greenNodeReversed nodeKind (count - start) pending of + (!node, before) -> Right (Builder (start + 1) (Node node : before) parents) + +-- | The current position, for a later 'startNodeAt'. +checkpoint :: Builder kind -> Checkpoint +checkpoint (Builder count _ _) = Checkpoint count + +-- | @startNodeAt marker kind@ opens a node that starts at an earlier +-- checkpoint, so the elements emitted since then become its first children. +-- This is how a parser wraps an operand it has already emitted once it sees +-- the operator. The checkpoint must lie within the current open node. +startNodeAt :: Checkpoint -> kind -> Builder kind -> Either BuilderError (Builder kind) +startNodeAt (Checkpoint position) nodeKind (Builder count pending parents) + | position > count = Left (CheckpointOutOfBounds position count) + | (_, start) : _ <- parents, position < start = + Left (CheckpointBeforeCurrentNode position start) + | otherwise = Right (Builder count pending ((nodeKind, position) : parents)) + +-- | The finished tree. Fails if a node is still open (checked first), or +-- unless exactly one node was emitted at the top level. +finish :: Builder kind -> Either BuilderError (GreenNode kind) +finish (Builder count pending parents) = case parents of + _ : _ -> Left (UnclosedNodes (length parents)) + [] -> case pending of + [] -> Left EmptyBuilder + [Node node] -> Right node + [Token _] -> Left TokenRoot + _ -> Left (MultipleRoots count) diff --git a/src/Graft/Cursor.hs b/src/Graft/Cursor.hs new file mode 100644 --- /dev/null +++ b/src/Graft/Cursor.hs @@ -0,0 +1,357 @@ +{-# LANGUAGE DeriveTraversable #-} + +-- | Cursors: immutable zippers over green trees. A cursor focuses one +-- occurrence of a node or token in one tree and knows its parents, siblings +-- and absolute byte range. Navigation only reads the tree: a cursor does no +-- editing work, and nothing it holds is left to compute later. To change a +-- tree, describe the edits through cursors and make them with "Graft.Edit". +-- +-- This module is meant to be imported qualified; its types are also +-- exported by "Graft": +-- +-- > import Graft +-- > import qualified Graft.Cursor as Cursor +-- +-- >>> :set -XOverloadedStrings +-- >>> import qualified Graft.Cursor as Cursor +-- >>> import qualified Graft.Green as Green +-- >>> import qualified Graft.Range as Range +-- >>> data Kind = Root | Call | Name | Punct deriving (Eq, Show) +-- >>> let tok kind = Token . Green.token kind +-- >>> let call = Node (Green.node Call [tok Name "f", tok Punct "(", tok Name "x", tok Punct ")"]) +-- >>> let tree = Node (Green.node Root [call, tok Punct ";"]) +-- >>> let Just x = Cursor.covering (Range.fromLength 2 1) (Cursor.fromGreen tree) +-- >>> (Cursor.path x, Cursor.text x, map Cursor.kind (Cursor.ancestors x)) +-- ([0,2],"x",[Call,Root]) +-- >>> fmap Cursor.text (Cursor.nextToken x) +-- Just ")" +-- +-- Cursors have no equality of occurrences and expose no pointer identity; +-- compare 'path's within one tree instead. +module Graft.Cursor + ( -- * Cursors + Cursor + , fromGreen + , green + , kind + , isToken + , range + , text + , path + , Path + , PathError (..) + -- * Navigation + , root + , tree + , at + , parent + , childAt + , firstChild + , lastChild + , nextSibling + , previousSibling + -- * Traversal + , children + , ancestors + , descendants + , WalkEvent (..) + , walk + -- * Tokens + , descendantTokens + , firstToken + , lastToken + , nextToken + , previousToken + -- * Lookup by offset + , TokenAtOffset (..) + , tokenAt + , covering + ) where + +import Control.Applicative ((<|>)) +import Control.DeepSeq (NFData (..)) +import Control.Exception (Exception) +import Data.Text (Text) +import qualified Graft.Green as Green +import Graft.Green.Internal (GreenElement (..), GreenNode, TextLength) +import qualified Graft.Green.Internal as Internal +import Graft.Range (TextRange) +import qualified Graft.Range as Range + +-- | The zero-based index of a child at each level, from the root down. Every +-- child counts, tokens included, and @[]@ is the root itself. A path belongs +-- to one version of a tree: inserting or removing children shifts the paths +-- that follow. +type Path = [Int] + +-- | Why a path doesn't lead to an element, reported for the first step that +-- fails. The index is the one at that step. +data PathError + = NegativeChildIndex !Int + | ChildIndexOutOfBounds !Int + | CannotDescendIntoToken + deriving (Eq, Show) + +instance Exception PathError + +instance NFData PathError where + rnf err = err `seq` () + +-- | A position in a tree: a focused node or token and the path back to the +-- root. Nodes and tokens share the cursor type; 'isToken' tells them apart. +-- There is no 'Eq' instance, because two equal subtrees in different +-- places are different occurrences; compare 'path's instead. +-- +-- A cursor holds its parent cursor, and through it the whole tree, and +-- nothing else. Moving up costs nothing and allocates nothing. +data Cursor kind = Cursor + { focusElement :: !(GreenElement kind) + , focusOffset :: !TextLength + -- ^ the absolute start of the focus + , focusIndex :: !Int + -- ^ the position of the focus among its parent's children; 0 at the root + , focusParent :: !(Maybe (Cursor kind)) + } + +-- | Forces the whole tree, which the focus and its ancestors are parts of, +-- in time proportional to its size. +instance NFData kind => NFData (Cursor kind) where + rnf cursor = rnf (focusElement (root cursor)) + +-- | Shows the path, range and focus. Cursors have no public constructor, so +-- unlike the green types this output does not rebuild the value. +instance Show kind => Show (Cursor kind) where + showsPrec precedence cursor = showParen (precedence > 10) $ + showString "Cursor " . showsPrec 11 (path cursor) . showChar ' ' + . showsPrec 11 (range cursor) . showChar ' ' . showsPrec 11 (green cursor) + +-- | A cursor on the root of a tree, at offset zero. The root may be a token. +fromGreen :: GreenElement kind -> Cursor kind +fromGreen element = Cursor element 0 0 Nothing + +-- | The green element at the focus. +green :: Cursor kind -> GreenElement kind +green = focusElement + +-- | The kind of the focused element. +kind :: Cursor kind -> kind +kind = Green.kind . focusElement + +-- | Whether the focus is a token rather than a node. +isToken :: Cursor kind -> Bool +isToken cursor = case focusElement cursor of + Token _ -> True + Node _ -> False + +-- | The byte range of the focus in the whole tree, from the cached offset +-- and length. +range :: Cursor kind -> TextRange +range cursor = Range.fromLength (focusOffset cursor) (Internal.elementTextLength (focusElement cursor)) + +-- | The source text of the focus, rendered from its tokens. +text :: Cursor kind -> Text +text = Green.render . green + +-- | The path from the root to the focus. Takes time proportional to the +-- depth, and builds a list of that length. +path :: Cursor kind -> Path +path cursor = go cursor [] + where + go current steps = case focusParent current of + Nothing -> steps + Just up -> go up (focusIndex current : steps) + +-- | The parent, or 'Nothing' at the root, in constant time. +parent :: Cursor kind -> Maybe (Cursor kind) +parent = focusParent + +-- | A cursor on the root, in time proportional to the depth. +root :: Cursor kind -> Cursor kind +root cursor = maybe cursor root (focusParent cursor) + +-- | The whole tree the cursor is in: the element at its 'root'. +tree :: Cursor kind -> GreenElement kind +tree = green . root + +-- | Follow a path down from the focus. The first step that fails is reported. +at :: Path -> Cursor kind -> Either PathError (Cursor kind) +at [] cursor = Right cursor +at (index : rest) cursor = childAt index cursor >>= at rest + +-- | The child at a zero-based position, in constant time. +childAt :: Int -> Cursor kind -> Either PathError (Cursor kind) +childAt index cursor + | index < 0 = Left (NegativeChildIndex index) + | otherwise = case focusElement cursor of + Token _ -> Left CannotDescendIntoToken + Node node + | index >= Internal.childCount node -> Left (ChildIndexOutOfBounds index) + | otherwise -> Right (child node cursor index) + +-- The child at a valid index of the focused node. +child :: GreenNode kind -> Cursor kind -> Int -> Cursor kind +child node above index = + Cursor (Internal.childAt node index) (focusOffset above + Internal.childStart node index) index (Just above) + +childCount :: Cursor kind -> Int +childCount cursor = case focusElement cursor of + Node node -> Internal.childCount node + Token _ -> 0 + +-- | The first child, or 'Nothing' if there are none. +firstChild :: Cursor kind -> Maybe (Cursor kind) +firstChild = either (const Nothing) Just . childAt 0 + +-- | The last child, or 'Nothing' if there are none. +lastChild :: Cursor kind -> Maybe (Cursor kind) +lastChild cursor = either (const Nothing) Just (childAt (childCount cursor - 1) cursor) + +-- | The next sibling, in constant time. +nextSibling :: Cursor kind -> Maybe (Cursor kind) +nextSibling = siblingAt 1 + +-- | The previous sibling, in constant time. +previousSibling :: Cursor kind -> Maybe (Cursor kind) +previousSibling = siblingAt (-1) + +siblingAt :: Int -> Cursor kind -> Maybe (Cursor kind) +siblingAt step cursor = do + above <- focusParent cursor + case focusElement above of + Node node + | target >= 0, target < Internal.childCount node -> Just (child node above target) + _ -> Nothing + where + target = focusIndex cursor + step + +-- | The children, in source order. A token has none. The list is lazy and +-- costs a cursor per child consumed. +children :: Cursor kind -> [Cursor kind] +children cursor = case focusElement cursor of + Token _ -> [] + Node node -> map (child node cursor) [0 .. Internal.childCount node - 1] + +-- | Each ancestor of the focus, nearest first, up to the root. The focus is +-- not included, unlike Rowan's @ancestors@; 'descendants' does include it. +-- The ancestors already exist, so the list costs a cell per ancestor. +ancestors :: Cursor kind -> [Cursor kind] +ancestors = unfold parent . parent + +-- | The focus and everything below it, in preorder. A subtree that appears +-- in several places is visited at each of them. The list is lazy, and +-- consuming all of it costs a cursor per element. +descendants :: Cursor kind -> [Cursor kind] +descendants cursor = go cursor [] + where + go current rest = current : foldr go rest (children current) + +-- | Entering or leaving an occurrence during a traversal. +data WalkEvent a = Enter a | Leave a + deriving (Eq, Show, Functor, Foldable, Traversable) + +instance NFData a => NFData (WalkEvent a) where + rnf (Enter value) = rnf value + rnf (Leave value) = rnf value + +-- | A preorder traversal that also reports leaving each element, as a +-- formatter needs in order to close what it opened. Each element is entered, +-- its children are walked, and then it is left. The list is lazy. +walk :: Cursor kind -> [WalkEvent (Cursor kind)] +walk cursor = go cursor [] + where + go current rest = Enter current : foldr go (Leave current : rest) (children current) + +-- | Every token at or below the focus, in source order. A token focus gives +-- itself. The typed @Ast.tokens@ gives child tokens only. Between two +-- tokens the list passes over the elements between them. +descendantTokens :: Cursor kind -> [Cursor kind] +descendantTokens = filter isToken . descendants + +-- | The first token at or below the focus. A token is its own first token. +-- Costs the elements visited until a token is found, which is the depth of +-- that token when no tokenless subtree comes before it. +firstToken :: Cursor kind -> Maybe (Cursor kind) +firstToken cursor + | isToken cursor = Just cursor + | otherwise = firstChild cursor >>= seek firstToken nextSibling + +-- | The last token at or below the focus, at the cost of 'firstToken'. +lastToken :: Cursor kind -> Maybe (Cursor kind) +lastToken cursor + | isToken cursor = Just cursor + | otherwise = lastChild cursor >>= seek lastToken previousSibling + +-- | The first token after the focus and everything below it, anywhere in the +-- tree. Costs up to the depth, plus any tokenless subtrees passed over; a +-- walk of the whole tree by repeated calls costs the size of the tree. +nextToken :: Cursor kind -> Maybe (Cursor kind) +nextToken cursor = + (nextSibling cursor >>= seek firstToken nextSibling) + <|> (parent cursor >>= nextToken) + +-- | The last token before the focus, anywhere in the tree, at the cost of +-- 'nextToken'. +previousToken :: Cursor kind -> Maybe (Cursor kind) +previousToken cursor = + (previousSibling cursor >>= seek lastToken previousSibling) + <|> (parent cursor >>= previousToken) + +-- | The tokens at an offset: none, one, or the two on either side of a +-- boundary, left first. +data TokenAtOffset a = NoToken | SingleToken a | BetweenTokens a a + deriving (Eq, Show, Functor, Foldable, Traversable) + +instance NFData a => NFData (TokenAtOffset a) where + rnf NoToken = () + rnf (SingleToken one) = rnf one + rnf (BetweenTokens left right) = rnf left `seq` rnf right + +-- | The tokens below the focus that touch an offset. An offset inside a token +-- gives that token; an offset between two tokens gives both, as an editor's +-- caret between two words touches both. The start and end of the text give +-- the first and last token. Empty tokens are skipped, and an offset outside +-- the focus gives 'NoToken'. Each level is binary-searched, and the empty +-- children at the offset are passed over. +tokenAt :: TextLength -> Cursor kind -> TokenAtOffset (Cursor kind) +tokenAt offset cursor = case take 2 (matching cursor) of + [] -> NoToken + [one] -> SingleToken one + left : right : _ -> BetweenTokens left right + where + matching current + | Range.isEmpty extent || offset < Range.start extent || offset > Range.end extent = [] + | otherwise = case focusElement current of + Token _ -> [current] + Node node -> + let relative = offset - focusOffset current + touching index = Internal.childStart node index <= relative + candidates = takeWhile touching + [Internal.firstChildEndingAtOrAfter node relative .. Internal.childCount node - 1] + in concatMap (matching . child node current) candidates + where + extent = range current + +-- | The innermost element below the focus whose range contains the given +-- range, or 'Nothing' if the range lies outside the focus. When several +-- children contain it, as they can for an empty range on a boundary, the +-- leftmost is chosen. Each level is binary-searched. +covering :: TextRange -> Cursor kind -> Maybe (Cursor kind) +covering query cursor + | not (query `Range.isSubrangeOf` range cursor) = Nothing + | otherwise = Just (descend cursor) + where + descend current = case focusElement current of + Node node + | index < Internal.childCount node, Internal.childStart node index <= Range.start query - start -> + descend (child node current index) + where + start = focusOffset current + index = Internal.firstChildEndingAtOrAfter node (Range.end query - start) + _ -> current + +unfold :: (a -> Maybe a) -> Maybe a -> [a] +unfold _ Nothing = [] +unfold step (Just value) = value : unfold step (step value) + +seek :: (a -> Maybe b) -> (a -> Maybe a) -> a -> Maybe b +seek select step value = select value <|> (step value >>= seek select step) diff --git a/src/Graft/Edit.hs b/src/Graft/Edit.hs new file mode 100644 --- /dev/null +++ b/src/Graft/Edit.hs @@ -0,0 +1,456 @@ +{-# LANGUAGE BangPatterns #-} + +-- | Edits that are described against a tree as it is and made all at once. +-- A plan applies a list of edits, each referring to the base tree through a +-- cursor, in one pass; a rewrite visits a tree top-down and replaces +-- elements as it goes. Both read only the original tree, rebuild each node +-- above a change once, and share everything else with the base. A plan +-- also gives the text edits that take the base's source to the result's. +-- +-- This module is meant to be imported qualified; its types are also +-- exported by "Graft": +-- +-- > import Graft +-- > import qualified Graft.Edit as Edit +-- +-- >>> :set -XOverloadedStrings +-- >>> import qualified Graft.Cursor as Cursor +-- >>> import qualified Graft.Edit as Edit +-- >>> import qualified Graft.Green as Green +-- >>> import qualified Graft.Range as Range +-- >>> data Kind = Root | Name | Space deriving (Eq, Show) +-- >>> let tok kind = Token . Green.token kind +-- >>> let tree = Node (Green.node Root [tok Name "x", tok Space " ", tok Name "y"]) +-- >>> let Right y = Cursor.childAt 2 (Cursor.fromGreen tree) +-- >>> let edits = [Edit.replace y (tok Name "z"), Edit.insertBefore y [tok Name "w", tok Space " "]] +-- >>> Green.render <$> Edit.apply tree edits +-- Right "x w z" +-- >>> map (\e -> (Range.start (Edit.editRange e), Range.end (Edit.editRange e), Edit.editText e)) <$> Edit.textEdits tree edits +-- Right [(2,3,"w z")] +-- >>> let rename () cursor = if Cursor.kind cursor == Name then Replace (tok Name "z") else Descend +-- >>> Green.render (Edit.rewrite rename () tree) +-- "z z" +module Graft.Edit + ( -- * Edit plans + Edit + , replace + , splice + , insertBefore + , insertAfter + , remove + , EditError (..) + , apply + -- * Text edits + , TextEdit (..) + , textEdits + -- * Rewriting + , Change (..) + , rewrite + , rewriteM + ) where + +import Control.DeepSeq (NFData (..)) +import Control.Exception (Exception) +import Control.Monad (foldM, when) +import Data.Functor.Identity (Identity (..)) +import Data.IntMap.Strict (IntMap) +import qualified Data.IntMap.Strict as IntMap +import Data.List (sortBy, unsnoc) +import Data.Maybe (fromMaybe) +import Data.Ord (comparing) +import Data.Text (Text) +import qualified Data.Text as Text +import Graft.Cursor (Cursor, Path) +import qualified Graft.Cursor as Cursor +import qualified Graft.Green as Green +import Graft.Green.Internal (ChildEditError (..), GreenElement (..), GreenNode, TextLength) +import qualified Graft.Green.Internal as Internal +import Graft.Range (TextRange) +import qualified Graft.Range as Range + +-- | One change to a base tree, made with 'replace', 'splice', +-- 'insertBefore', 'insertAfter' or 'remove' and applied by 'apply'. It +-- refers to the tree its cursor was made from, and keeps that tree alive. +data Edit kind + = Replacement (Cursor kind) (GreenElement kind) + | Splice (Cursor kind) !Int !Int [GreenElement kind] + | InsertBefore (Cursor kind) [GreenElement kind] + | InsertAfter (Cursor kind) [GreenElement kind] + | Remove (Cursor kind) + +-- | Shows the edit with the path of its cursor in place of the cursor. +instance Show kind => Show (Edit kind) where + showsPrec precedence edit = showParen (precedence > 10) $ case edit of + Replacement cursor element -> + showString "Edit.replace " . at cursor . showChar ' ' . showsPrec 11 element + Splice cursor start end elements -> + showString "Edit.splice " . at cursor . showChar ' ' . showsPrec 11 start . showChar ' ' + . showsPrec 11 end . showChar ' ' . showsPrec 11 elements + InsertBefore cursor elements -> + showString "Edit.insertBefore " . at cursor . showChar ' ' . showsPrec 11 elements + InsertAfter cursor elements -> + showString "Edit.insertAfter " . at cursor . showChar ' ' . showsPrec 11 elements + Remove cursor -> showString "Edit.remove " . at cursor + where + at cursor = showsPrec 11 (Cursor.path cursor) + +-- | Replace the element at the cursor. The replacement may be a node or a +-- token. +replace :: Cursor kind -> GreenElement kind -> Edit kind +replace = Replacement + +-- | @splice cursor start end elements@ replaces the children at positions +-- @start@ up to but not including @end@ of the node at the cursor with the +-- elements, as 'Graft.Green.spliceChildren' does: with @start == end@ it +-- inserts, and with no elements it removes. The positions are positions +-- among the children of the base node. Nothing is added for you: include +-- any separators or whitespace in the elements. +splice :: Cursor kind -> Int -> Int -> [GreenElement kind] -> Edit kind +splice = Splice + +-- | Insert elements before the element at the cursor, among its siblings. +-- On the root, 'apply' reports 'EditAtRoot'. +insertBefore :: Cursor kind -> [GreenElement kind] -> Edit kind +insertBefore = InsertBefore + +-- | Insert elements after the element at the cursor, among its siblings. +-- On the root, 'apply' reports 'EditAtRoot'. +insertAfter :: Cursor kind -> [GreenElement kind] -> Edit kind +insertAfter = InsertAfter + +-- | Remove the element at the cursor from its parent. On the root, 'apply' +-- reports 'EditAtRoot'. +remove :: Cursor kind -> Edit kind +remove = Remove + +-- | Why a plan was not applied. Each constructor names the edits concerned +-- by their zero-based positions in the list given to 'apply'. +data EditError + = EditFromAnotherTree !Int + -- ^ The edit's cursor is in a tree that is not equal to the base. + | EditAtRoot !Int + -- ^ 'insertBefore', 'insertAfter' or 'remove' on the root, which has no + -- siblings. + | InvalidSplice !Int !ChildEditError + -- ^ The splice's positions are not valid for the base node, or its + -- cursor is on a token. + | ConflictingEdits !Int !Int + -- ^ Two edits that cannot both be made; see 'apply'. + deriving (Eq, Show) + +instance Exception EditError + +instance NFData EditError where + rnf err = err `seq` () + +-- | Apply a list of edits to the tree they were made on, all at once. +-- +-- Every cursor and every child position refers to the base: replacing the +-- children at positions 2 and 7 replaces those two original children, +-- whatever happens to the lengths or to the children between them. At +-- each node with an edit, the new children are, for each boundary @i@ +-- from 0 to the number of children: the insertions at @i@ (splices with +-- the empty range @[i, i)@), in the order of the list; then the base +-- child @i@, which is the elements of the splice that starts at @i@, or +-- nothing if an earlier splice consumed it, or its replacement, or the +-- child itself, rebuilt below if an edit lies below it and shared +-- otherwise. So an insertion at the start of a splice precedes the +-- splice's elements and one at its end follows them. Apart from the order +-- of insertions at one boundary of one node, the result does not depend +-- on the order of the list. +-- +-- A plan is rejected with 'ConflictingEdits' when a replacement and any +-- other edit apply at or below the same element; when a splice removes a +-- child, or part of one, that another edit applies to or below (an +-- insertion strictly inside a splice's range is such an edit, while one +-- at either end is not); or when two splices of one node have ranges +-- @[a, b)@ and @[c, d)@ with @a < d@ and @c < b@. Splice positions are +-- checked against the base node as 'Graft.Green.spliceChildren' checks +-- them. +-- +-- Every edit's cursor must be in a tree equal to the base, as a cursor +-- made from it is. The check compares the trees, which costs nothing +-- beyond a pointer comparison for a cursor made from the base itself and +-- up to the size of the tree otherwise; this is why @Eq kind@ is needed. +-- +-- The result shares with the base every subtree that no edit applies to +-- or below, and @apply base []@ is @base@. Each node above an edit is +-- built once. Evaluating the result to @Right@ completes the validation +-- and the construction of every rebuilt node; replacement elements and +-- the shared parts of the base are as evaluated as they were given. +apply :: Eq kind => GreenElement kind -> [Edit kind] -> Either EditError (GreenElement kind) +apply base [] = Right base +apply base edits = planOf base edits >>= \plan -> rebuild plan base + +-- | A change to the base's source text: the bytes in a range of the +-- original, replaced by new text. Ranges are UTF-8 byte offsets in the +-- base's text; "Graft.LineIndex" converts them to positions for an editor. +data TextEdit = TextEdit + { editRange :: !TextRange + , editText :: !Text + } + deriving (Eq, Show) + +instance NFData TextEdit where + rnf (TextEdit range new) = rnf range `seq` rnf new + +-- | The text edits that take the base's source to the source of +-- @'apply' base edits@, for the same plan and with the same errors. They +-- are sorted by start, their ranges neither overlap nor touch, and every +-- range is read in the original text, so patching the original with them, +-- in any order, renders the result of 'apply'. Edits at one offset, such +-- as insertions at the boundaries of an empty element, are merged into one +-- in the order of the result. +textEdits :: Eq kind => GreenElement kind -> [Edit kind] -> Either EditError [TextEdit] +textEdits _ [] = Right [] +textEdits base edits = planOf base edits >>= \plan -> coalesce <$> collect plan 0 base + +-- The edits of a plan, grouped by the path of the element they apply to. +data Plan kind = Plan + { planFirst :: !Int + -- ^ the lowest position of an edit at or below this element + , planReplacements :: [(Int, GreenElement kind)] + -- ^ replacements of this element, newest first + , planSplices :: [Splicing kind] + -- ^ splices of this node's children, newest first + , planBelow :: !(IntMap (Plan kind)) + -- ^ the plans of its children, by index + } + +-- A splice as planned: its position in the list, its range and its elements. +data Splicing kind = Splicing !Int !Int !Int [GreenElement kind] + +data Op kind = OpReplace (GreenElement kind) | OpSplice !Int !Int [GreenElement kind] + +emptyPlan :: Plan kind +emptyPlan = Plan maxBound [] [] IntMap.empty + +planOf :: Eq kind => GreenElement kind -> [Edit kind] -> Either EditError (Plan kind) +planOf base = foldM step emptyPlan . zip [0 ..] + where + step plan (position, edit) = do + (path, op) <- resolve base position edit + pure (insertPlan position path op plan) + +-- Where an edit applies in the base and what it does there, once its +-- cursor is known to be in a tree equal to the base. +resolve :: Eq kind => GreenElement kind -> Int -> Edit kind -> Either EditError (Path, Op kind) +resolve base position edit + | Cursor.tree cursor /= base = Left (EditFromAnotherTree position) + | otherwise = case edit of + Replacement _ element -> Right (path, OpReplace element) + Splice _ start end elements -> Right (path, OpSplice start end elements) + InsertBefore _ elements -> sibling (\index -> OpSplice index index elements) + InsertAfter _ elements -> sibling (\index -> OpSplice (index + 1) (index + 1) elements) + Remove _ -> sibling (\index -> OpSplice index (index + 1) []) + where + cursor = case edit of + Replacement c _ -> c + Splice c _ _ _ -> c + InsertBefore c _ -> c + InsertAfter c _ -> c + Remove c -> c + path = Cursor.path cursor + sibling op = case unsnoc path of + Nothing -> Left (EditAtRoot position) + Just (parentPath, index) -> Right (parentPath, op index) + +insertPlan :: Int -> Path -> Op kind -> Plan kind -> Plan kind +insertPlan position path op plan = case path of + [] -> case op of + OpReplace element -> touched {planReplacements = (position, element) : planReplacements plan} + OpSplice start end elements -> + touched {planSplices = Splicing position start end elements : planSplices plan} + index : rest -> + touched {planBelow = IntMap.alter (Just . insertPlan position rest op . fromMaybe emptyPlan) index (planBelow plan)} + where + touched = plan {planFirst = min position (planFirst plan)} + +-- The replacement of an element, if its plan is one replacement and nothing +-- else; a replacement with anything else at or below the element conflicts. +replacementOf :: Plan kind -> Either EditError (Maybe (GreenElement kind)) +replacementOf plan = case planReplacements plan of + [] -> Right Nothing + [(position, element)] + | null others -> Right (Just element) + | otherwise -> conflict position (minimum others) + (position, _) : (other, _) : _ -> conflict position other + where + others = [p | Splicing p _ _ _ <- planSplices plan] ++ map planFirst (IntMap.elems (planBelow plan)) + +conflict :: Int -> Int -> Either EditError a +conflict first second = Left (ConflictingEdits (min first second) (max first second)) + +-- A splice on a token is reported for the first splice in the list; a plan +-- below a token can't be made, since cursors don't descend into tokens. +tokenError :: Plan kind -> EditError +tokenError plan = case reverse (planSplices plan) of + Splicing position _ _ _ : _ -> InvalidSplice position CannotEditTokenChildren + [] -> error "Graft.Edit: internal error: a plan below a token" + +-- The changes to a node's children, as the merge lays them out, in order +-- of position; the children between them are untouched. +data Slot kind + = Replaced !Int !Int [GreenElement kind] + -- ^ the base children in this range, replaced by these elements; an + -- empty range is an insertion at its boundary + | Nested !Int (Plan kind) + -- ^ the base child at this index, rebuilt by its plan + +-- Lay out the changes to a node's children under its plan, checking the +-- splices against the node, against each other, and against the edits +-- below. The result is sorted by position and its ranges don't overlap. +slots :: Plan kind -> GreenNode kind -> Either EditError [Slot kind] +slots plan node = do + splices <- traverse check (reverse (planSplices plan)) + let ordered = sortBy (comparing key) splices + sweep Nothing ordered + merge ordered (IntMap.toAscList (planBelow plan)) + where + key (Splicing position start end _) = (start, end, position) + check splicing@(Splicing position start end _) = + maybe (Right splicing) (Left . InvalidSplice position) (Internal.spliceBoundsError start end node) + -- Two splices conflict when a < d and c < b. In (start, end) order, a + -- splice conflicts with an earlier one exactly when it starts before + -- the furthest end of the non-empty splices so far; empty splices + -- cover nothing. + sweep _ [] = Right () + sweep covering (Splicing position start end _ : rest) = case covering of + Just (coverEnd, coverPosition) | start < coverEnd -> conflict coverPosition position + _ | end > start && maybe True ((end >) . fst) covering -> sweep (Just (end, position)) rest + | otherwise -> sweep covering rest + -- Merge the splices with the children that have plans, by position: an + -- insertion at a boundary comes before the child there, and a splice + -- must not consume a child that has a plan. + merge [] below = Right [Nested index sub | (index, sub) <- below] + merge splices [] = Right [Replaced start end new | Splicing _ start end new <- splices] + merge splices@(Splicing position start end new : more) below@((index, sub) : rest) + | start > index = (Nested index sub :) <$> merge splices rest + | otherwise = do + when (end > start && end > index) (conflict position (planFirst sub)) + (Replaced start end new :) <$> merge more below + +-- The element under a plan, built from the bottom up: each rebuilt node is +-- evaluated before its parent is patched, with one copy of the parent's +-- child array. +rebuild :: Plan kind -> GreenElement kind -> Either EditError (GreenElement kind) +rebuild plan element = do + replaced <- replacementOf plan + case replaced of + Just replacement -> Right replacement + Nothing -> case element of + Token _ -> Left (tokenError plan) + Node node -> do + laid <- slots plan node + patches <- traverse (patch node) laid + let !rebuilt = Internal.patchChildren patches node + Right (Node rebuilt) + where + patch node slot = case slot of + Replaced start end new -> Right (start, end, new) + Nested index below -> + (\child -> (index, index + 1, [child])) <$> rebuild below (Internal.childAt node index) + +-- The text edits under a plan, in the order of the result, with ranges in +-- the base's text. +collect :: Plan kind -> TextLength -> GreenElement kind -> Either EditError [TextEdit] +collect plan offset element = do + replaced <- replacementOf plan + case replaced of + Just replacement -> Right [TextEdit (Range.fromLength offset (Green.length element)) (Green.render replacement)] + Nothing -> case element of + Token _ -> Left (tokenError plan) + Node node -> do + laid <- slots plan node + concat <$> traverse (edits node) laid + where + edits node slot = case slot of + Replaced start end new -> + let from = offset + Internal.childStart node start + to = offset + Internal.childStart node end + in Right [TextEdit (Range.fromLength from (to - from)) (Text.concat (map Green.render new))] + Nested index below -> collect below (offset + Internal.childStart node index) (Internal.childAt node index) + +-- Merge each run of edits in which one ends where the next starts, so that +-- no two edits share an offset. The texts of a run are concatenated once. +coalesce :: [TextEdit] -> [TextEdit] +coalesce [] = [] +coalesce (TextEdit range new : rest) = go (Range.start range) (Range.end range) [new] rest + where + go start end pieces (TextEdit next text : more) + | Range.start next == end = go start (Range.end next) (text : pieces) more + go start end pieces more = + TextEdit (Range.fromLength start (end - start)) (Text.concat (reverse pieces)) : coalesce more + +-- | What a rewrite does with the element it is looking at. 'Descend' is not +-- "unchanged": it keeps the element's own form and goes on below it, where +-- replacements may still happen. 'Skip' is the answer for an unchanged +-- subtree. For a token, 'Descend' and 'Skip' are the same answer. +data Change ctx kind + = Replace (GreenElement kind) + -- ^ Put this element in place of the current one. Nothing below the + -- current element is visited, and the replacement isn't visited either. + | Descend + -- ^ Keep the element's form and visit its children with the same context. + | DescendWith ctx + -- ^ Keep the element's form and visit its children with this context. + | Skip + -- ^ Keep the element and everything below it, unvisited. + deriving (Eq, Show) + +-- | Rewrite a tree top-down. The function is called on the root and then, +-- for each element it answers 'Descend' or 'DescendWith', on that element's +-- children in source order, with a cursor on the original tree and the +-- context from the nearest ancestor that answered 'DescendWith'. A node is +-- rebuilt, once, with one copy of its child array, exactly when something +-- below it was replaced; a node with no replacement below it is returned as +-- it is, so @rewrite (\\_ _ -> Skip)@ and @rewrite (\\_ _ -> Descend)@ give +-- back their argument. Answering 'Replace' with the original element counts +-- as a replacement. +-- +-- The cost is proportional to the number of elements visited, which covers +-- the rebuilding, plus the calls. The function never sees a replacement, +-- its own or another's: to decide on the basis of a change, rewrite the +-- result again. +rewrite :: (ctx -> Cursor kind -> Change ctx kind) -> ctx -> GreenElement kind -> GreenElement kind +rewrite step ctx root = runIdentity (rewriteM (\context cursor -> Identity (step context cursor)) ctx root) +{-# INLINE rewrite #-} + +-- | 'rewrite' with effects, which run in preorder: an element's before its +-- children's, and a child's before its next sibling's. An effect that stops +-- the computation, such as 'Left', stops the rewrite; in @StateT s (Either +-- e)@, say, a walk can collect the ranges it replaced and give up at the +-- first problem. Each rebuilt node is evaluated before it is returned +-- through the monad, so no rebuilding is left suspended in the result. +-- 'rewrite' is this function in t'Identity'. +rewriteM + :: Monad m + => (ctx -> Cursor kind -> m (Change ctx kind)) + -> ctx -> GreenElement kind -> m (GreenElement kind) +rewriteM step = \ctx root -> snd <$> element ctx (Cursor.fromGreen root) + where + -- Each result says whether it differs from the original, so a parent + -- knows to rebuild without comparing trees. + element ctx cursor = do + change <- step ctx cursor + case change of + Replace replacement -> pure (True, replacement) + Skip -> pure (False, Cursor.green cursor) + Descend -> below ctx cursor + DescendWith inner -> below inner cursor + below ctx cursor = case original of + Token _ -> pure (False, original) + Node node -> do + replaced <- children ctx (Cursor.children cursor) 0 [] + case replaced of + [] -> pure (False, original) + _ -> let !rebuilt = Internal.setChildren (reverse replaced) node + in pure (True, Node rebuilt) + where + original = Cursor.green cursor + -- The replaced children, newest first, with their positions. + children _ [] !_ replaced = pure replaced + children ctx (child : rest) !index replaced = do + (changed, result) <- element ctx child + children ctx rest (index + 1) (if changed then (index, result) : replaced else replaced) +{-# INLINE rewriteM #-} diff --git a/src/Graft/Green.hs b/src/Graft/Green.hs new file mode 100644 --- /dev/null +++ b/src/Graft/Green.hs @@ -0,0 +1,303 @@ +{-# LANGUAGE BangPatterns #-} + +-- | Green trees: immutable nodes and tokens, tagged with your own kind type. +-- +-- Every fragment of the source, whitespace and comments included, is the text +-- of some token, so rendering a tree gives back the source exactly. Green +-- values have no parents or positions, so a subtree can appear in several +-- places and in several versions of a tree. Use a cursor ("Graft.Cursor") to +-- see where an element is, and a plan or a rewrite ("Graft.Edit") to edit +-- inside a tree. +-- +-- This module is meant to be imported qualified; its types are also +-- exported by "Graft": +-- +-- > import Graft +-- > import qualified Graft.Green as Green +-- +-- >>> :set -XOverloadedStrings +-- >>> import qualified Graft.Green as Green +-- >>> data Kind = Call | Name | Punct | Space deriving (Eq, Show) +-- >>> let tok kind = Token . Green.token kind +-- >>> let call = Green.node Call [tok Name "f", tok Punct "(", tok Space " ", tok Punct ")"] +-- >>> Green.renderNode call +-- "f( )" +-- >>> Green.nodeLength call +-- 4 +-- >>> Green.childAt 1 call +-- Just (Token (Green.token Punct "(")) +-- >>> Green.renderNode <$> Green.replaceChild 2 (tok Name "x") call +-- Right "f(x)" +-- +-- 'foldM', 'fold', 'map' and 'traverse' cover the whole tree, so most +-- whole-tree functions are one line: +-- +-- >>> import qualified Data.Text as Text +-- >>> import Data.Functor.Identity (Identity (..)) +-- >>> let count n element = case element of { Token _ -> n + 1; Node _ -> n } +-- >>> runIdentity (Green.foldM (\n element -> Identity (count n element)) (0 :: Int) (Node call)) +-- 4 +-- >>> Green.fold Green.text (const Text.concat) call +-- "f( )" +-- >>> let upper t = Green.token (Green.tokenKind t) (Text.toUpper (Green.text t)) +-- >>> Green.renderNode (Green.map upper call) +-- "F( )" +-- >>> Green.renderNode <$> Green.traverse (\t -> if Green.text t == " " then Nothing else Just t) call +-- Nothing +module Graft.Green + ( -- * Trees + GreenNode + , GreenToken + , GreenElement (..) + , node + , token + -- * Lengths + , TextLength (..) + , textLengthOf + , length + , nodeLength + , tokenLength + -- * Inspection + , kind + , nodeKind + , tokenKind + , children + , childCount + , childAt + , text + -- * Rendering + , render + , renderNode + -- * Folding and traversing + , foldM + , fold + , map + , traverse + -- * Editing children + , ChildEditError (..) + , replaceChild + , spliceChildren + , insertChild + , removeChild + ) where + +import Control.Monad.ST (ST, runST) +import Data.Foldable (toList) +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.Array as Array +import qualified Data.Text.Internal as Text (Text (..)) +import Data.Primitive.SmallArray (mapSmallArray') +import Graft.Green.Internal (ChildEditError (..), GreenElement (..), GreenNode (..), GreenToken (..), TextLength (..), textLengthOf) +import qualified Graft.Green.Internal as Internal +import qualified Data.Traversable as Traversable +import qualified Data.List as List +import Prelude hiding (length, map, traverse) + +-- | A node with a kind and its children in source order, which may be none. +-- Takes time proportional to the number of children; the children are +-- shared, not copied or traversed. A node whose length would exceed +-- @maxBound :: Int@, which only shared subtrees can reach, is an error. +node :: kind -> [GreenElement kind] -> GreenNode kind +node = Internal.greenNode + +-- | A token with a kind and the exact text of a source fragment. Reading the +-- UTF-8 length of the text takes constant time. +token :: kind -> Text -> GreenToken kind +token = Internal.greenToken + +-- | The length of a node or token in UTF-8 bytes, read from its cache. +length :: GreenElement kind -> TextLength +length = Internal.elementTextLength + +-- | The length of a node in UTF-8 bytes, read from its cache. +nodeLength :: GreenNode kind -> TextLength +nodeLength (GreenNode _ len _ _) = len + +-- | The length of a token in UTF-8 bytes, read from its cache. +tokenLength :: GreenToken kind -> TextLength +tokenLength (GreenToken _ len _) = len + +-- | The kind of a node or token. +kind :: GreenElement kind -> kind +kind (Node element) = nodeKind element +kind (Token element) = tokenKind element + +-- | The kind of a node. +nodeKind :: GreenNode kind -> kind +nodeKind (GreenNode nodeKind' _ _ _) = nodeKind' + +-- | The kind of a token. +tokenKind :: GreenToken kind -> kind +tokenKind (GreenToken tokenKind' _ _) = tokenKind' + +-- | The children of a node in source order, trivia included. The list is +-- produced lazily from the node's array of children. +children :: GreenNode kind -> [GreenElement kind] +children (GreenNode _ _ elements _) = toList elements + +-- | The number of children, in constant time. +childCount :: GreenNode kind -> Int +childCount = Internal.childCount + +-- | The child at a zero-based position, in constant time. +childAt :: Int -> GreenNode kind -> Maybe (GreenElement kind) +childAt index parent + | index < 0 || index >= Internal.childCount parent = Nothing + -- Read the element now, so the result doesn't keep the parent's array alive. + | otherwise = Just $! Internal.childAt parent index + +-- | The exact text of a token, as given to 'token'. +text :: GreenToken kind -> Text +text (GreenToken _ _ contents) = contents + +-- | The source text of a node or token: the text of its tokens, in order. +-- The result is written into one buffer sized from the cached length. A +-- subtree that appears in several places is rendered at each of them. +render :: GreenElement kind -> Text +render (Token element) = text element +render element + | total == 0 = Text.empty + | otherwise = runST $ do + target <- Array.new bytes + _ <- foldM (write target) 0 element + result <- Array.unsafeFreeze target + pure (Text.Text result 0 bytes) + where + total = length element + bytes = fromIntegral total + +-- | The source text of a node, as 'render'. +renderNode :: GreenNode kind -> Text +renderNode = render . Node + +-- Copies each token into the buffer at the offset reached so far. +write :: Array.MArray s -> Int -> GreenElement kind -> ST s Int +write target !offset (Token (GreenToken _ (TextLength len) (Text.Text source start _))) = do + Array.copyI len target offset source start + pure (offset + len) +write _ offset (Node _) = pure offset +{-# INLINE write #-} + +-- | A strict left fold over a tree's elements in preorder, in any monad: +-- each element, then its children in source order, as @Graft.Cursor.descendants@ +-- lists them but without positions. +-- +-- The accumulator is evaluated to weak head normal form before each step. +-- The fold loops over each node's children by index and builds no list, so +-- when the step function is known at the call site it allocates nothing of +-- its own, in 'Data.Functor.Identity.Identity' as in @ST@. The last child of +-- each node is folded by a tail call, so a chain of single-child nodes runs +-- in constant stack. Use it for a single result: a count, a hash, a check, +-- or text written into a buffer. Track the offset in the accumulator if you +-- need positions. A subtree shared in several places is folded at each of +-- them. +-- +-- The library renders, forces and hashes trees with this function. +foldM :: Monad m => (b -> GreenElement kind -> m b) -> b -> GreenElement kind -> m b +foldM = Internal.foldM +{-# INLINE foldM #-} + +-- | Fold a tree bottom-up, like @Data.Tree.foldTree@. The first function +-- receives each token; the second receives the kind of each node and the +-- results for its children, in source order. +-- +-- The list of results is lazy, so a function that does not need every +-- child does not visit the rest. Use this fold to build a result with the +-- shape of the tree, such as a syntax tree of your own; for a single value, +-- 'foldM' is several times faster because it builds no lists. A subtree +-- shared in several places is folded at each of them. +-- +-- 'renderNode' is @fold text (const Text.concat)@, but faster: +-- 'renderNode' writes into one buffer, while that fold copies each byte +-- again at every enclosing node. +fold :: (GreenToken kind -> r) -> (kind -> [r] -> r) -> GreenNode kind -> r +fold onToken onNode = go + where + go (GreenNode nodeKind' _ elements _) = onNode nodeKind' (List.map element (toList elements)) + element (Token token') = onToken token' + element (Node child) = go child + +-- | Replace every token with the result of a function, and rebuild the +-- tree. The node kinds and the shape of the tree stay the same. The lengths +-- and offsets of every node are measured again, so the function can change +-- the text of a token freely, for example to copy it out of a large source +-- buffer with 'Text.copy'. Every node is rebuilt, and a subtree shared in +-- several places is rebuilt at each of them, so the result shares nothing +-- with the input. +-- +-- @map f@ is @runIdentity . traverse (Identity . f)@, but two to three +-- times faster. +map :: (GreenToken kind -> GreenToken kind) -> GreenNode kind -> GreenNode kind +map f = go + where + go (GreenNode nodeKind' _ elements _) = + Internal.greenNodeFromArray nodeKind' (mapSmallArray' element elements) + element (Token token') = Token (f token') + element (Node child) = Node (go child) + +-- | Apply an action to every token, from left to right, and rebuild the +-- tree from the results. The node kinds and the shape of the tree stay the +-- same. The lengths and offsets of every node are measured again, so the +-- action can change the text of a token freely. +-- +-- This is a van Laarhoven traversal, @Traversal' (GreenNode kind) +-- (GreenToken kind)@ in the terms of the lens and optics libraries, and it +-- satisfies the traversal laws. Some instances: +-- +-- * With @Maybe@ or @Either@ it rewrites the tokens or fails. +-- * With @State@ it threads a value through the tokens in source order. +-- +-- As with 'map', every node is rebuilt. For a pure function, 'map' is +-- faster; to fold without rebuilding, 'foldM' is faster than a @Const@ +-- traversal. +traverse + :: Applicative f + => (GreenToken kind -> f (GreenToken kind)) + -> GreenNode kind -> f (GreenNode kind) +traverse action = go + where + go (GreenNode nodeKind' _ elements _) = + Internal.greenNodeFromArray nodeKind' <$> Traversable.traverse element elements + element (Token token') = Token <$> action token' + element (Node child) = Node <$> go child + +-- | Replace the child at a position. Each edit returns a new node and leaves +-- the original usable; untouched children are shared between the two. +replaceChild :: Int -> GreenElement kind -> GreenNode kind -> Either ChildEditError (GreenNode kind) +replaceChild index replacement parent + | index < 0 = Left (NegativeChildBoundary index) + | index >= Internal.childCount parent = Left (ChildBoundaryOutOfBounds index) + | otherwise = Right (Internal.setChild index replacement parent) + +-- | @spliceChildren start end replacements node@ replaces the children at +-- positions @start@ up to but not including @end@. With @start == end@ it +-- inserts; with no replacements it deletes. Positions run from 0 to the +-- number of children. Nothing is added for you: include any separators or +-- whitespace in the replacements. +-- +-- Errors are checked in this order: a negative start or end, then +-- @end < start@, then a start or end past the last child. Cost is +-- proportional to the number of children plus replacements. +spliceChildren + :: Int -> Int -> [GreenElement kind] -> GreenNode kind + -> Either ChildEditError (GreenNode kind) +spliceChildren start end replacements parent = + case Internal.spliceBoundsError start end parent of + Just err -> Left err + Nothing -> Right (Internal.spliceChildrenUnchecked start end replacements parent) + +-- | Insert a child before the given position; the number of children +-- appends. As @spliceChildren index index [element]@. +insertChild + :: Int -> GreenElement kind -> GreenNode kind + -> Either ChildEditError (GreenNode kind) +insertChild index element = spliceChildren index index [element] + +-- | Remove the child at a position. Removing the last child leaves an empty +-- node of the same kind. +removeChild :: Int -> GreenNode kind -> Either ChildEditError (GreenNode kind) +removeChild index parent + | index < 0 = Left (NegativeChildBoundary index) + | index >= Internal.childCount parent = Left (ChildBoundaryOutOfBounds index) + | otherwise = Right (Internal.spliceChildrenUnchecked index (index + 1) [] parent) diff --git a/src/Graft/Green/Internal.hs b/src/Graft/Green/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Graft/Green/Internal.hs @@ -0,0 +1,469 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MagicHash #-} + +-- | Representation of green trees, shared by the library's modules and not +-- exposed by the package. Constructing values directly can break the cached +-- lengths and offsets that the rest of the library relies on; "Graft.Green" +-- re-exports the safe interface. +module Graft.Green.Internal + ( -- * Representation + TextLength (..) + , textLengthOf + , GreenNode (..) + , GreenToken (..) + , GreenElement (..) + -- * Construction + , greenNode + , greenNodeReversed + , greenNodeFromArray + , greenToken + -- * Children + , elementTextLength + , childCount + , childAt + , childStart + , firstChildEndingAtOrAfter + -- * Folding + , foldM + -- * Child edits + , ChildEditError (..) + , spliceBoundsError + , checkedLength + , setChild + , setChildren + , patchChildren + , spliceChildrenUnchecked + ) where + +import Control.DeepSeq (NFData (..)) +import Control.Exception (Exception) +import Control.Monad.ST (ST, runST) +import Data.Functor.Identity (Identity (..)) +import Data.Foldable (toList) +import Data.Hashable (Hashable (..)) +import Data.Primitive.PrimArray +import Data.Primitive.SmallArray +import Data.Text (Text) +import qualified Data.Text.Foreign as Text +import GHC.Exts (isTrue#, reallyUnsafePtrEquality#) + +-- | A count of UTF-8 bytes, used for lengths and for offsets from the start +-- of a tree. It is neither a character count (as 'Data.Text.length' returns) +-- nor a UTF-16 code-unit count (as the Language Server Protocol uses), and +-- the newtype keeps those from being mixed up by accident. Numeric literals +-- and arithmetic work as for 'Int'; use the constructor or 'fromIntegral' to +-- convert deliberately. +-- +-- Shared subtrees make a logical length exceed the physical text size. +-- Constructing or editing a node whose length would exceed +-- @maxBound :: Int@ fails with an error instead of wrapping around. +newtype TextLength = TextLength Int + deriving newtype (Eq, Ord, Show, Read, Bounded, Enum, Num, Real, Integral, NFData, Hashable) + +-- | The UTF-8 byte length of a text, in constant time. +textLengthOf :: Text -> TextLength +textLengthOf = TextLength . Text.lengthWord8 + +-- | An interior node: a kind and its children in source order. Construct one +-- with 'Graft.Green.node'. A node caches its total length and the offset of each +-- child, so reading a length or a child takes constant time. +data GreenNode kind = GreenNode + !kind + !TextLength + !(SmallArray (GreenElement kind)) + !(PrimArray Int) + +-- | A leaf: a kind and the exact text of a source fragment, which may be +-- empty. Construct one with 'Graft.Green.token'. Text is stored as given, with no +-- normalization. +data GreenToken kind = GreenToken !kind !TextLength {-# UNPACK #-} !Text + deriving (Eq) + +-- | A node or a token; either can be a child of a node. +-- Tokens are unpacked into the element, which saves a box per token (about +-- 15% of a typical tree's heap). Nodes stay boxed so that cursors can share +-- the parent node instead of re-allocating it on every descent. +data GreenElement kind + = Node !(GreenNode kind) + | Token {-# UNPACK #-} !(GreenToken kind) + deriving (Eq, Show) + +-- | Structural equality. Physically identical nodes compare equal without +-- traversal, which assumes that equality on @kind@ is reflexive. Otherwise a +-- subtree shared in several places is compared at each of them, so comparing +-- two separately built trees takes time proportional to their size written +-- out in full. +instance Eq kind => Eq (GreenNode kind) where + left@(GreenNode leftKind leftLength leftChildren _) + == right@(GreenNode rightKind rightLength rightChildren _) = + isTrue# (reallyUnsafePtrEquality# left right) + || (leftLength == rightLength && leftKind == rightKind && leftChildren == rightChildren) + +-- | Visits a subtree shared in several places at each of them. +instance NFData kind => NFData (GreenNode kind) where + rnf node = rnf (Node node) + +instance NFData kind => NFData (GreenToken kind) where + rnf (GreenToken kind _ text) = rnf kind `seq` rnf text + +-- | Forces every kind and every token's text with one walk of the tree. +instance NFData kind => NFData (GreenElement kind) where + rnf tree = runIdentity (foldM (\() element -> Identity (force element)) () tree) + where + force (Node (GreenNode kind _ _ _)) = rnf kind + force (Token token) = rnf token + +-- | Hashes the kind and number of children of every node, and every token, +-- so hashing takes time proportional to the size of the tree written out in +-- full, with a shared subtree hashed at each place it appears; hashes are not +-- cached. +instance Hashable kind => Hashable (GreenNode kind) where + hashWithSalt salt node = hashWithSalt salt (Node node) + +instance Hashable kind => Hashable (GreenToken kind) where + hashWithSalt salt (GreenToken kind _ text) = salt `hashWithSalt` kind `hashWithSalt` text + +-- | One preorder fold over the tree. Each node contributes its kind and its +-- number of children, and a preorder sequence with the number of children of +-- each node determines the tree, so the nesting is part of the hash. Lengths +-- are left out: the tokens' text already determines them. +instance Hashable kind => Hashable (GreenElement kind) where + hashWithSalt salt tree = runIdentity (foldM (\current element -> Identity (mix current element)) salt tree) + where + mix current (Node (GreenNode kind _ children _)) = + current `hashWithSalt` (0 :: Int) `hashWithSalt` kind `hashWithSalt` sizeofSmallArray children + mix current (Token token) = current `hashWithSalt` (1 :: Int) `hashWithSalt` token + +-- | Maps every kind in the tree, reusing the cached lengths and offsets. A +-- subtree shared in several places is mapped at each of them, and the +-- results are not shared. Kinds are stored strictly, so @fmap f@ evaluates +-- each result of @f@, and the functor laws hold for functions that don't +-- return bottom. +instance Functor GreenNode where + fmap f (GreenNode kind len children starts) = + GreenNode (f kind) len (mapSmallArray' (fmap f) children) starts + +instance Functor GreenToken where + fmap f (GreenToken kind len text) = GreenToken (f kind) len text + +instance Functor GreenElement where + fmap f (Node node) = Node (fmap f node) + fmap f (Token token) = Token (fmap f token) + +-- | Shows the smart-constructor call that rebuilds the node. +instance Show kind => Show (GreenNode kind) where + showsPrec precedence (GreenNode kind _ children _) = showParen (precedence > 10) $ + showString "Green.node " . showsPrec 11 kind . showChar ' ' . shows (toList children) + +-- | Shows the smart-constructor call that rebuilds the token. +instance Show kind => Show (GreenToken kind) where + showsPrec precedence (GreenToken kind _ text) = showParen (precedence > 10) $ + showString "Green.token " . showsPrec 11 kind . showChar ' ' . showsPrec 11 text + +-- | A node with a kind and its children in source order, which may be none. +-- Takes time proportional to the number of children; the children are +-- shared, not copied or traversed. +greenNode :: kind -> [GreenElement kind] -> GreenNode kind +greenNode kind children = runST $ do + let count = length children + elements <- newSmallArray count missingChild + starts <- newPrimArray count + let fill !_ !offset [] = pure offset + fill !index !offset (!child : rest) = do + writeSmallArray elements index child + writePrimArray starts index (bytes offset) + fill (index + 1) (addLength offset (elementTextLength child)) rest + total <- fill 0 0 children + freeze kind total elements starts + +-- | Construct a node from the first @count@ elements of a list in reverse +-- source order, as a builder accumulates them, and return the rest of the +-- list. The list must have at least @count@ elements. The list is walked once. +greenNodeReversed :: kind -> Int -> [GreenElement kind] -> (GreenNode kind, [GreenElement kind]) +greenNodeReversed kind count reversed = runST $ do + elements <- newSmallArray count missingChild + let place !index rest + | index < 0 = pure rest + | otherwise = case rest of + [] -> error "Graft.Green.Internal.greenNodeReversed: too few elements" + !child : older -> writeSmallArray elements index child >> place (index - 1) older + remaining <- place (count - 1) reversed + starts <- newPrimArray count + let measure !index !offset + | index == count = pure offset + | otherwise = do + child <- readSmallArray elements index + writePrimArray starts index (bytes offset) + measure (index + 1) (addLength offset (elementTextLength child)) + total <- measure 0 0 + node <- freeze kind total elements starts + pure (node, remaining) + +-- | A strict, monadic left fold over a tree's elements in preorder: each +-- element, then its children in source order. The accumulator is evaluated +-- to weak head normal form before each step. The loop runs over the child +-- arrays by index and folds the last child of each node by a tail call, so a +-- chain of single-child nodes runs in constant stack. +foldM :: Monad m => (b -> GreenElement kind -> m b) -> b -> GreenElement kind -> m b +foldM step = element + where + element !acc current = case current of + Token _ -> step acc current + Node (GreenNode _ _ elements _) -> + step acc current >>= \ !entered -> children entered elements 0 + children !acc elements !index + | index >= count = pure acc + | index == count - 1 = element acc (indexSmallArray elements index) + | otherwise = + element acc (indexSmallArray elements index) >>= \ !next -> + children next elements (index + 1) + where + count = sizeofSmallArray elements +{-# INLINE foldM #-} + +-- | Construct a node from an array of children, measuring each child once. +greenNodeFromArray :: kind -> SmallArray (GreenElement kind) -> GreenNode kind +greenNodeFromArray kind children = runST $ do + let count = sizeofSmallArray children + starts <- newPrimArray count + let measure !index !offset + | index == count = pure offset + | otherwise = do + writePrimArray starts index (bytes offset) + measure (index + 1) (addLength offset (elementTextLength (indexSmallArray children index))) + total <- measure 0 0 + GreenNode kind total children <$> unsafeFreezePrimArray starts + +freeze + :: kind -> TextLength -> SmallMutableArray s (GreenElement kind) -> MutablePrimArray s Int + -> ST s (GreenNode kind) +freeze kind total elements starts = + GreenNode kind total <$> unsafeFreezeSmallArray elements <*> unsafeFreezePrimArray starts + +bytes :: TextLength -> Int +bytes (TextLength count) = count + +missingChild :: a +missingChild = error "Graft.Green.Internal: uninitialised child" + +-- Lengths are sums of non-negative lengths, so a sum that comes out negative +-- has overflowed. Shared subtrees can reach that without the text existing, +-- and a wrapped length would make 'Graft.Green.render' size its buffer +-- wrongly, so overflow is an error. +checkedLength :: TextLength -> TextLength +checkedLength len + | len < 0 = error "Graft.Green: a tree's length exceeds maxBound :: Int" + | otherwise = len + +addLength :: TextLength -> TextLength -> TextLength +addLength offset len = checkedLength (offset + len) + +-- | Construct a token. 'Text' stores UTF-8 internally, so reading the byte +-- length takes constant time and copies nothing. +greenToken :: kind -> Text -> GreenToken kind +greenToken kind text = GreenToken kind (textLengthOf text) text + +-- | Read the cached UTF-8 byte length of either element. +elementTextLength :: GreenElement kind -> TextLength +elementTextLength (Node (GreenNode _ len _ _)) = len +elementTextLength (Token (GreenToken _ len _)) = len + +-- | Number of immediate children. +childCount :: GreenNode kind -> Int +childCount (GreenNode _ _ children _) = sizeofSmallArray children + +-- | The child at an index, which must lie in @[0, childCount node)@. +childAt :: GreenNode kind -> Int -> GreenElement kind +childAt (GreenNode _ _ children _) = indexSmallArray children + +-- | Start of the child at an index relative to the node. The child count is +-- accepted and returns the node's length. +childStart :: GreenNode kind -> Int -> TextLength +childStart (GreenNode _ len _ starts) index + | index >= sizeofPrimArray starts = len + | otherwise = TextLength (indexPrimArray starts index) + +-- | The smallest index whose child ends at or after a relative offset, or the +-- child count if there is none. Binary search over the cached child offsets. +firstChildEndingAtOrAfter :: GreenNode kind -> TextLength -> Int +firstChildEndingAtOrAfter node offset = go 0 (childCount node) + where + go low high + | low >= high = low + | childStart node (middle + 1) >= offset = go low middle + | otherwise = go (middle + 1) high + where + middle = (low + high) `div` 2 + +-- | Why a child edit failed. 'CannotEditTokenChildren' means the target is a +-- token; the others report a bad child position (or both positions of a +-- reversed range). +data ChildEditError + = CannotEditTokenChildren + | NegativeChildBoundary !Int + | ReversedChildRange !Int !Int + | ChildBoundaryOutOfBounds !Int + deriving (Eq, Show) + +instance Exception ChildEditError + +instance NFData ChildEditError where + rnf err = err `seq` () + +-- | Why @[start, end)@ is not a range of a node's children, if it isn't. +-- Errors are checked in this order: a negative start or end, then +-- @end < start@, then a start or end past the last child. +spliceBoundsError :: Int -> Int -> GreenNode kind -> Maybe ChildEditError +spliceBoundsError start end node + | start < 0 = Just (NegativeChildBoundary start) + | end < 0 = Just (NegativeChildBoundary end) + | end < start = Just (ReversedChildRange start end) + | start > count = Just (ChildBoundaryOutOfBounds start) + | end > count = Just (ChildBoundaryOutOfBounds end) + | otherwise = Nothing + where + count = childCount node + +-- | Replace the child at a valid index. The length is adjusted by the +-- difference between the old and new child; offsets are reused when the +-- lengths agree and shifted otherwise. +setChild :: Int -> GreenElement kind -> GreenNode kind -> GreenNode kind +setChild index !replacement node@(GreenNode kind len children starts) = + GreenNode kind (checkedLength (len + delta)) updated shifted + where + delta = elementTextLength replacement - elementTextLength (childAt node index) + count = sizeofSmallArray children + updated = runSmallArray $ do + copy <- thawSmallArray children 0 count + writeSmallArray copy index replacement + pure copy + shifted + | delta == 0 = starts + | otherwise = generatePrimArray count $ \position -> + let start = indexPrimArray starts position + in if position <= index then start else start + bytes delta + +-- | Replace the children at valid indices, given in increasing order, with +-- one copy of the child array. Offsets before the first replacement are +-- copied, and the rest are recomputed. +setChildren :: [(Int, GreenElement kind)] -> GreenNode kind -> GreenNode kind +setChildren [] node = node +setChildren [(index, replacement)] node = setChild index replacement node +setChildren replacements@((first, _) : _) node@(GreenNode kind _ children starts) = runST $ do + let count = sizeofSmallArray children + elements <- thawSmallArray children 0 count + mapM_ (\(index, !replacement) -> writeSmallArray elements index replacement) replacements + offsets <- newPrimArray count + copyPrimArray offsets 0 starts 0 first + let measure !index !offset + | index == count = pure offset + | otherwise = do + child <- readSmallArray elements index + writePrimArray offsets index (bytes offset) + measure (index + 1) (addLength offset (elementTextLength child)) + total <- measure first (childStart node first) + freeze kind total elements offsets + +-- | Replace several ranges of children at once, with one copy of the child +-- array: each @(start, end, elements)@ puts the elements in place of the +-- children in @[start, end)@, and an empty range inserts them at its +-- boundary. The ranges must be sorted, lie within @[0, childCount node]@ +-- and not overlap. The untouched runs of children are copied as blocks and +-- keep their offsets, shifted by the change in length before them; only +-- the new elements are measured. When every new element has the length of +-- the child it replaces, the offsets are reused. +patchChildren :: [(Int, Int, [GreenElement kind])] -> GreenNode kind -> GreenNode kind +patchChildren [] node = node +patchChildren patches@((first, _, _) : _) node@(GreenNode kind len children starts) + | sameLayout = runST $ do + elements <- newSmallArray count missingChild + copySmallArray elements 0 children 0 first + let fill !source ((start, end, new) : rest) = do + copySmallArray elements source children source (start - source) + mapM_ (\(index, !child) -> writeSmallArray elements index child) (zip [start ..] new) + fill end rest + fill !source [] = copySmallArray elements source children source (count - source) + fill first patches + GreenNode kind len <$> unsafeFreezeSmallArray elements <*> pure starts + | otherwise = patchLayout patches node + where + count = sizeofSmallArray children + sameLayout = all unchanged patches + -- Every new element must have the length of the child it replaces: an + -- equal total over the range is not enough, as the offsets inside it + -- would move. + unchanged (start, end, new) = + length new == end - start + && and (zipWith sameLength [start ..] new) + sameLength index child = + elementTextLength child == childStart node (index + 1) - childStart node index + +-- The general case of 'patchChildren': a new offset array, with the +-- untouched runs shifted and the new elements measured. +patchLayout :: [(Int, Int, [GreenElement kind])] -> GreenNode kind -> GreenNode kind +patchLayout [] node = node +patchLayout patches@((first, _, _) : _) node@(GreenNode kind len children starts) = runST $ do + let count = sizeofSmallArray children + newCount = count + sum [length new - (end - start) | (start, end, new) <- patches] + elements <- newSmallArray newCount missingChild + offsets <- newPrimArray newCount + copySmallArray elements 0 children 0 first + copyPrimArray offsets 0 starts 0 first + let -- Copy an untouched run and its offsets, shifted by the delta so far. + keep !target !source !run !delta = do + copySmallArray elements target children source run + let shift !step + | step == run = pure () + | otherwise = do + writePrimArray offsets (target + step) (indexPrimArray starts (source + step) + delta) + shift (step + 1) + shift 0 + -- Write the new elements of a patch and measure them. + place !target !offset [] = pure (target, offset) + place !target !offset (!child : more) = do + writeSmallArray elements target child + writePrimArray offsets target (bytes offset) + place (target + 1) (addLength offset (elementTextLength child)) more + go !target !source !delta ((start, end, new) : rest) = do + let run = start - source + keep target source run delta + let from = childStart node start + TextLength delta + (target', to) <- place (target + run) from new + go target' end (delta + bytes to - bytes from - bytes (childStart node end - childStart node start)) rest + go !target !source !delta [] = do + keep target source (count - source) delta + pure delta + delta <- go first first 0 patches + freeze kind (checkedLength (len + TextLength delta)) elements offsets + +-- | Replace the children in @[start, end)@, which must satisfy +-- @0 <= start <= end <= childCount node@. Offsets before the range are +-- copied, and offsets after it are shifted by the change in length. +spliceChildrenUnchecked :: Int -> Int -> [GreenElement kind] -> GreenNode kind -> GreenNode kind +spliceChildrenUnchecked start end replacements node@(GreenNode kind len children starts) = runST $ do + let count = sizeofSmallArray children + inserted = length replacements + newCount = count - (end - start) + inserted + suffix = count - end + elements <- newSmallArray newCount missingChild + offsets <- newPrimArray newCount + copySmallArray elements 0 children 0 start + copyPrimArray offsets 0 starts 0 start + let place !_ !offset [] = pure offset + place !index !offset (!child : rest) = do + writeSmallArray elements index child + writePrimArray offsets index (bytes offset) + place (index + 1) (addLength offset (elementTextLength child)) rest + afterInserted <- place start (childStart node start) replacements + let delta = afterInserted - childStart node end + shift !position + | position == suffix = pure () + | otherwise = do + writePrimArray offsets (start + inserted + position) + (indexPrimArray starts (end + position) + bytes delta) + shift (position + 1) + copySmallArray elements (start + inserted) children end suffix + shift 0 + freeze kind (checkedLength (len + delta)) elements offsets diff --git a/src/Graft/LineIndex.hs b/src/Graft/LineIndex.hs new file mode 100644 --- /dev/null +++ b/src/Graft/LineIndex.hs @@ -0,0 +1,216 @@ +{-# LANGUAGE BangPatterns #-} + +-- | Conversion between the UTF-8 byte offsets that Graft uses and line and +-- column positions, including the UTF-16 columns that the Language Server +-- Protocol uses by default. +-- +-- A t'LineIndex' describes one source text. Build it from the rendered tree, +-- and rebuild it after an edit; it does not follow the tree. +-- +-- Lines end at @\\n@, @\\r\\n@ or a lone @\\r@, as in the Language Server +-- Protocol. Lines and columns are zero-based. A line's terminator belongs to +-- that line, so an offset just after a @\\r@ that precedes @\\n@ still lies +-- on the @\\r@'s line. Its column is past the line's content, and converting +-- the position back clamps it to the end of the content, before the @\\r@: +-- that one offset per @\\r\\n@ does not round-trip. +-- +-- This module is meant to be imported qualified; its types are also +-- exported by "Graft": +-- +-- > import Graft +-- > import qualified Graft.LineIndex as LineIndex +-- +-- >>> :set -XOverloadedStrings +-- >>> import qualified Graft.LineIndex as LineIndex +-- >>> let index = LineIndex.fromText "let x =\r\n \"\x1F600\" in x\n" +-- >>> LineIndex.utf8Position 16 index +-- Just (Utf8Position {utf8Line = 1, utf8Column = 7}) +-- >>> LineIndex.utf16Position 16 index +-- Just (Utf16Position {utf16Line = 1, utf16Column = 5}) +-- >>> LineIndex.fromUtf16Position (Utf16Position 1 5) index +-- Just 16 +module Graft.LineIndex + ( LineIndex + , fromText + , lineCount + , lineStart + , Utf8Position (..) + , utf8Position + , fromUtf8Position + , Utf16Position (..) + , utf16Position + , fromUtf16Position + ) where + +import Control.DeepSeq (NFData (..)) +import Data.Bits ((.&.)) +import Data.Hashable (Hashable (..)) +import Data.Primitive.PrimArray +import Data.Text (Text) +import qualified Data.Text.Array as Array +import Data.Text.Internal (Text (..)) +import Data.Word (Word8) +import Graft.Green.Internal (TextLength (..)) + +-- | A text together with the byte offset at which each of its lines starts. +data LineIndex = LineIndex !Text !(PrimArray Int) + +instance NFData LineIndex where + rnf (LineIndex text _) = rnf text + +instance Show LineIndex where + showsPrec precedence (LineIndex text _) = showParen (precedence > 10) $ + showString "LineIndex.fromText " . showsPrec 11 text + +-- | A zero-based line and a column counted in UTF-8 bytes. The two kinds of +-- position are separate types so that a column in one unit cannot be passed +-- where the other is expected. +data Utf8Position = Utf8Position + { utf8Line :: !Int + , utf8Column :: !Int + } + deriving (Eq, Ord, Show) + +instance NFData Utf8Position where + rnf (Utf8Position _ _) = () + +instance Hashable Utf8Position where + hashWithSalt salt (Utf8Position line column) = salt `hashWithSalt` line `hashWithSalt` column + +-- | A zero-based line and a column counted in UTF-16 code units, as the +-- Language Server Protocol counts them by default. +data Utf16Position = Utf16Position + { utf16Line :: !Int + , utf16Column :: !Int + } + deriving (Eq, Ord, Show) + +instance NFData Utf16Position where + rnf (Utf16Position _ _) = () + +instance Hashable Utf16Position where + hashWithSalt salt (Utf16Position line column) = salt `hashWithSalt` line `hashWithSalt` column + +-- | Index the lines of a text, in time proportional to its length. +fromText :: Text -> LineIndex +fromText text@(Text _ _ len) = LineIndex text (primArrayFromList (0 : go 0)) + where + go !index + | index >= len = [] + | byte == 10 = (index + 1) : go (index + 1) + | byte == 13 && (index + 1 >= len || byteAt text (index + 1) /= 10) = (index + 1) : go (index + 1) + | otherwise = go (index + 1) + where + byte = byteAt text index + +-- | Number of lines. An empty text, and a text ending in a terminator, end +-- with an empty line. +lineCount :: LineIndex -> Int +lineCount (LineIndex _ starts) = sizeofPrimArray starts + +-- | Offset at which a line starts, or 'Nothing' for a line that does not exist. +lineStart :: Int -> LineIndex -> Maybe TextLength +lineStart line (LineIndex _ starts) + | line < 0 || line >= sizeofPrimArray starts = Nothing + | otherwise = Just (TextLength (indexPrimArray starts line)) + +-- | Line and UTF-8 byte column of an offset in @[0, length]@, or 'Nothing' if +-- the offset lies outside the text or inside a multibyte character. +utf8Position :: TextLength -> LineIndex -> Maybe Utf8Position +utf8Position (TextLength offset) index@(LineIndex text _) + | offset < 0 || offset > textBytes text = Nothing + | offset < textBytes text && continuation (byteAt text offset) = Nothing + | otherwise = Just (Utf8Position line (offset - startOf index line)) + where + line = lineOf offset index + +-- | Offset of a line and UTF-8 byte column. A column past the end of the +-- line's content is clamped to it, as the Language Server Protocol requires. +-- Returns 'Nothing' for a line that does not exist or a column that falls +-- inside a multibyte character, so the result is always a character boundary. +fromUtf8Position :: Utf8Position -> LineIndex -> Maybe TextLength +fromUtf8Position (Utf8Position line column) index@(LineIndex text _) + | line < 0 || line >= lineCount index || column < 0 = Nothing + | position < end && continuation (byteAt text position) = Nothing + | otherwise = Just (TextLength position) + where + start = startOf index line + end = contentEnd index line + position = start + min column (end - start) + +-- | Line and UTF-16 column of an offset in @[0, length]@, or 'Nothing' if the +-- offset lies outside the text or inside a multibyte character. +utf16Position :: TextLength -> LineIndex -> Maybe Utf16Position +utf16Position (TextLength offset) index@(LineIndex text _) + | offset < 0 || offset > textBytes text = Nothing + | offset < textBytes text && continuation (byteAt text offset) = Nothing + | otherwise = Just (Utf16Position line (go 0 (startOf index line))) + where + line = lineOf offset index + go !units !position + | position >= offset = units + | otherwise = go (units + utf16Units (byteAt text position)) (position + 1) + +-- | Offset of a line and UTF-16 column. A column past the end of the line's +-- content is clamped to it, as the Language Server Protocol requires. Returns +-- 'Nothing' for a line that does not exist or a column that falls between +-- the two halves of a surrogate pair. +fromUtf16Position :: Utf16Position -> LineIndex -> Maybe TextLength +fromUtf16Position (Utf16Position line column) index@(LineIndex text _) + | line < 0 || line >= lineCount index || column < 0 = Nothing + | otherwise = TextLength <$> go 0 (startOf index line) + where + end = contentEnd index line + go !units !position + | units > column = Nothing + | units == column || position >= end = Just position + | otherwise = go (units + utf16Units (byteAt text position)) (next position) + next position + | position + 1 < end && continuation (byteAt text (position + 1)) = next (position + 1) + | otherwise = position + 1 + +-- The last line whose start is at or before the offset. +lineOf :: Int -> LineIndex -> Int +lineOf offset (LineIndex _ starts) = go 0 (sizeofPrimArray starts - 1) + where + go low high + | low >= high = low + | indexPrimArray starts middle <= offset = go middle high + | otherwise = go low (middle - 1) + where + middle = (low + high + 1) `div` 2 + +startOf :: LineIndex -> Int -> Int +startOf (LineIndex _ starts) = indexPrimArray starts + +-- The end of a line's content, before its terminator. +contentEnd :: LineIndex -> Int -> Int +contentEnd index@(LineIndex text starts) line = stripCarriage (stripNewline end) + where + start = startOf index line + end + | line + 1 < sizeofPrimArray starts = indexPrimArray starts (line + 1) + | otherwise = textBytes text + stripNewline position + | position > start && byteAt text (position - 1) == 10 = position - 1 + | otherwise = position + stripCarriage position + | position > start && byteAt text (position - 1) == 13 = position - 1 + | otherwise = position + +textBytes :: Text -> Int +textBytes (Text _ _ len) = len + +byteAt :: Text -> Int -> Word8 +byteAt (Text array start _) index = Array.unsafeIndex array (start + index) + +continuation :: Word8 -> Bool +continuation byte = byte .&. 0xC0 == 0x80 + +-- UTF-16 code units contributed by the character that starts with this byte; +-- continuation bytes contribute none. +utf16Units :: Word8 -> Int +utf16Units byte + | continuation byte = 0 + | byte >= 0xF0 = 2 + | otherwise = 1 diff --git a/src/Graft/Range.hs b/src/Graft/Range.hs new file mode 100644 --- /dev/null +++ b/src/Graft/Range.hs @@ -0,0 +1,96 @@ +-- | Half-open ranges of UTF-8 byte offsets: a range includes its start and +-- excludes its end. +-- +-- This module is meant to be imported qualified; t'TextRange' is also +-- exported by "Graft": +-- +-- > import Graft +-- > import qualified Graft.Range as Range +-- +-- >>> import qualified Graft.Range as Range +-- >>> let range = Range.fromLength 4 3 +-- >>> (Range.start range, Range.end range) +-- (4,7) +-- >>> map (`Range.member` range) [3, 4, 6, 7] +-- [False,True,True,False] +-- >>> Range.fromLength 5 2 `Range.isSubrangeOf` range +-- True +-- >>> Range.fromEnds 7 4 +-- Nothing +module Graft.Range + ( TextRange + , fromEnds + , fromLength + , start + , end + , length + , isEmpty + , member + , isSubrangeOf + ) where + +import Control.DeepSeq (NFData (..)) +import Data.Hashable (Hashable (..)) +import Graft.Green.Internal (TextLength) +import Prelude hiding (length) + +-- | A range of byte offsets whose start is no greater than its end, and +-- whose start is not negative. The endpoints need not fall on character +-- boundaries. +data TextRange = TextRange !TextLength !TextLength + deriving (Eq, Ord) + +-- | Shows the 'fromLength' call that rebuilds the range. +instance Show TextRange where + showsPrec precedence (TextRange from to) = showParen (precedence > 10) $ + showString "Range.fromLength " . showsPrec 11 from . showChar ' ' . showsPrec 11 (to - from) + +instance NFData TextRange where + rnf (TextRange _ _) = () + +instance Hashable TextRange where + hashWithSalt salt (TextRange from to) = salt `hashWithSalt` from `hashWithSalt` to + +-- | The range from a start to an end, or 'Nothing' if the end comes first. +fromEnds :: TextLength -> TextLength -> Maybe TextRange +fromEnds from to + | 0 <= from && from <= to = Just (TextRange from to) + | otherwise = Nothing + +-- | The range with a start and a length. A negative start or length, or an +-- end past @maxBound :: Int@, is an error; use 'fromEnds' to check endpoints +-- that may be invalid. +fromLength :: TextLength -> TextLength -> TextRange +fromLength from len + | from < 0 || len < 0 || to < 0 = + error ("Graft.Range.fromLength: invalid range " ++ show from ++ " " ++ show len) + | otherwise = TextRange from to + where + to = from + len + +-- | The first offset in the range. +start :: TextRange -> TextLength +start (TextRange from _) = from + +-- | The offset just past the end of the range. +end :: TextRange -> TextLength +end (TextRange _ to) = to + +-- | The number of bytes in the range. +length :: TextRange -> TextLength +length (TextRange from to) = to - from + +-- | Whether the range has length zero. +isEmpty :: TextRange -> Bool +isEmpty range = start range == end range + +-- | Whether an offset lies in the range. The end is excluded, so an empty +-- range contains no offsets. +member :: TextLength -> TextRange -> Bool +member offset range = start range <= offset && offset < end range + +-- | @isSubrangeOf inner outer@ is whether @inner@ lies within @outer@, +-- including an empty @inner@ at either end of @outer@. The argument order is +-- that of 'Data.List.isPrefixOf', so it reads well infix. +isSubrangeOf :: TextRange -> TextRange -> Bool +isSubrangeOf inner outer = start outer <= start inner && end inner <= end outer diff --git a/test/AstTests.hs b/test/AstTests.hs new file mode 100644 --- /dev/null +++ b/test/AstTests.hs @@ -0,0 +1,230 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} + +module AstTests (astProperties) where + +import Data.List (find, inits) +import Data.Maybe (listToMaybe) +import qualified Data.Text as Text +import Graft +import qualified Graft.Ast as Ast +import qualified Graft.Cursor as Cursor +import qualified Graft.Edit as Edit +import qualified Graft.Green as Green +import qualified Graft.Range as Range +import Test.QuickCheck +import TestModel + +newtype GroupView = GroupView (Cursor Kind) +instance AstView GroupView where + type AstViewKind GroupView = Kind + fromCursor = Ast.matchNode (== Group) GroupView + toCursor (GroupView cursor) = cursor +instance AstNode GroupView + +newtype AnyNode = AnyNode (Cursor Kind) +instance AstView AnyNode where + type AstViewKind AnyNode = Kind + fromCursor = Ast.matchNode (const True) AnyNode + toCursor (AnyNode cursor) = cursor +instance AstNode AnyNode + +newtype NameView = NameView (Cursor Kind) +instance AstView NameView where + type AstViewKind NameView = Kind + fromCursor = Ast.matchToken (== Name) NameView + toCursor (NameView cursor) = cursor +instance AstToken NameView + +newtype AnyToken = AnyToken (Cursor Kind) +instance AstView AnyToken where + type AstViewKind AnyToken = Kind + fromCursor = Ast.matchToken (const True) AnyToken + toCursor (AnyToken cursor) = cursor +instance AstToken AnyToken + +type Observation = (Path, TextRange, GreenElement Kind, GreenElement Kind) + +observe :: Cursor Kind -> Observation +observe cursor = (Cursor.path cursor, Cursor.range cursor, Cursor.green cursor, + Cursor.green (Cursor.root cursor)) + +oracle :: Model -> Path -> Observation +oracle model path = case find (\(candidate, _, _, _) -> candidate == path) (contexts model) of + Just (_, prefix, selected, _) -> + (path, Range.fromLength (byteLength prefix) (byteLength (source selected)), compile selected, compile model) + Nothing -> error "invalid oracle path" + +propCasting :: Model -> Property +propCasting model = conjoin + [ case Cursor.at path (Cursor.fromGreen (compile model)) of + Left err -> counterexample (show err) False + Right cursor -> + let expected = oracle model path + group = case selected of Branch Group _ -> Just expected; _ -> Nothing + name = case selected of Leaf Name _ -> Just expected; _ -> Nothing + node = case selected of Branch _ _ -> Just expected; _ -> Nothing + token = case selected of Leaf _ _ -> Just expected; _ -> Nothing + in conjoin + [ fmap (observe . toCursor) (fromCursor cursor :: Maybe GroupView) === group + , fmap (observe . toCursor) (fromCursor cursor :: Maybe NameView) === name + , fmap (observe . toCursor) (fromCursor cursor :: Maybe AnyNode) === node + , fmap (observe . toCursor) (fromCursor cursor :: Maybe AnyToken) === token + , case fromCursor cursor :: Maybe GroupView of + Nothing -> property True + Just view -> fmap (observe . toCursor) (fromCursor (toCursor view) :: Maybe GroupView) === group + , case fromCursor cursor :: Maybe NameView of + Nothing -> property True + Just view -> fmap (observe . toCursor) (fromCursor (toCursor view) :: Maybe NameView) === name + ] + | (path, _, selected, _) <- contexts model + ] + +propFields :: Model -> Property +propFields model = conjoin + [ case Cursor.at path (Cursor.fromGreen (compile model)) of + Left err -> counterexample (show err) False + Right cursor -> + let items = case selected of Branch _ xs -> xs; Leaf _ _ -> [] + nodes = [oracle model (path ++ [index]) | (index, Branch _ _) <- zip [0 ..] items] + groups = [oracle model (path ++ [index]) | (index, Branch Group _) <- zip [0 ..] items] + leaves = [oracle model (path ++ [index]) | (index, Leaf _ _) <- zip [0 ..] items] + names = [oracle model (path ++ [index]) | (index, Leaf Name _) <- zip [0 ..] items] + in conjoin + [ map (observe . toCursor) (Ast.children cursor :: [AnyNode]) === nodes + , map (observe . toCursor) (Ast.children cursor :: [GroupView]) === groups + , fmap (observe . toCursor) (Ast.child cursor :: Maybe GroupView) === listToMaybe groups + , map (observe . toCursor) (Ast.tokens cursor :: [AnyToken]) === leaves + , map (observe . toCursor) (Ast.tokens cursor :: [NameView]) === names + , fmap (observe . toCursor) (Ast.token cursor :: Maybe NameView) === listToMaybe names + ] + | (path, _, selected, _) <- contexts model + ] + +propParents :: Model -> Property +propParents model = conjoin + [ case Cursor.at path (Cursor.fromGreen (compile model)) of + Left err -> counterexample (show err) False + Right cursor -> + let above = reverse (take (length path) (inits path)) + groups = [oracle model p | p <- above + , (_, _, Branch Group _, _) <- filter (\(candidate, _, _, _) -> candidate == p) (contexts model)] + immediate = listToMaybe above + parentGroup = case immediate of + Just p | p `elem` map (\(candidate, _, _, _) -> candidate) groups -> Just (oracle model p) + _ -> Nothing + in conjoin + [ fmap (observe . toCursor) (Ast.parent cursor :: Maybe AnyNode) === fmap (oracle model) immediate + , fmap (observe . toCursor) (Ast.parent cursor :: Maybe GroupView) === parentGroup + , map (observe . toCursor) (Ast.ancestors cursor :: [AnyNode]) === map (oracle model) above + , map (observe . toCursor) (Ast.ancestors cursor :: [GroupView]) === groups + ] + | (path, _, _, _) <- contexts model + ] + +modelReplace :: Path -> Model -> Model -> Model +modelReplace [] replacement _ = replacement +modelReplace (index : rest) replacement (Branch kind items) = + Branch kind (take index items ++ [modelReplace rest replacement (items !! index)] ++ drop (index + 1) items) +modelReplace _ _ (Leaf _ _) = error "invalid oracle path" + +matches :: Model -> GreenElement Kind -> Property +matches expected edited = conjoin + [ edited === compile expected + , Text.unpack (Green.render edited) === source expected + , counterexample "cache invariant" (validCaches edited) + , conjoin + [ fmap observe (Cursor.at path (Cursor.fromGreen edited)) === Right (oracle expected path) + | (path, _, _, _) <- contexts expected + ] + ] + +propTokenEdit :: Model -> Property +propTokenEdit subtree = forAll genText $ \newText -> + let model = Branch Root [Leaf Name "λ", subtree, Leaf Name "tail"] + root = compile model + in forAll (elements [context | context@(_, _, Leaf Name _, _) <- contexts model]) $ + \(path, prefix, selected, suffix) -> case Cursor.at path (Cursor.fromGreen root) of + Left err -> counterexample (show err) False + Right cursor -> case fromCursor cursor :: Maybe NameView of + Nothing -> counterexample "name view failed" False + Just view -> + let edited = applied root [Edit.replace (toCursor view) (compile (Leaf Name newText))] + in conjoin + [ matches (modelReplace path (Leaf Name newText) model) edited + , Text.unpack (Green.render edited) === prefix ++ newText ++ suffix + , observe (toCursor view) === oracle model path + , Text.unpack (Green.render (Cursor.green (toCursor view))) === source selected + ] + +propNodeEdit :: Model -> Model -> Property +propNodeEdit subtree replacement = + let model = Branch Root [subtree] + root = compile model + in forAll (elements [(path, kind, items) | (path, _, Branch kind items, _) <- contexts model]) $ + \(path, kind, items) -> forAll (chooseInt (0, length items)) $ \index -> + case Cursor.at path (Cursor.fromGreen root) of + Left err -> counterexample (show err) False + Right cursor -> case fromCursor cursor :: Maybe AnyNode of + Nothing -> counterexample "node view failed" False + Just view -> case Edit.apply root [Edit.splice (toCursor view) index index [compile replacement]] of + Left err -> counterexample (show err) False + Right edited -> conjoin + [ matches (modelReplace path (Branch kind (take index items ++ [replacement] ++ drop index items)) model) edited + , observe (toCursor view) === oracle model path + ] + +-- These predicates fail if first-match queries force a later cast. +newtype StopNode = StopNode (Cursor Kind) +instance AstView StopNode where + type AstViewKind StopNode = Kind + fromCursor = Ast.matchNode (\kind -> if kind == Comment then error "later node cast forced" else kind == Group) StopNode + toCursor (StopNode cursor) = cursor +instance AstNode StopNode + +newtype StopToken = StopToken (Cursor Kind) +instance AstView StopToken where + type AstViewKind StopToken = Kind + fromCursor = Ast.matchToken (\kind -> if kind == Space then error "later token cast forced" else kind == Name) StopToken + toCursor (StopToken cursor) = cursor +instance AstToken StopToken + +regressions :: Property +regressions = once $ conjoin + [ fmap (Cursor.path . toCursor) (fromCursor emptyGroup :: Maybe GroupView) === Just [] + , fmap (Cursor.path . toCursor) (Ast.token emptyGroup :: Maybe NameView) === Nothing + , fmap (Cursor.path . toCursor) (fromCursor (Cursor.fromGreen (tok "")) :: Maybe NameView) === Just [] + , fmap (Cursor.path . toCursor) (fromCursor (Cursor.fromGreen (Node (Green.node Name []))) :: Maybe NameView) === Nothing + , fmap (Cursor.path . toCursor) (fromCursor (Cursor.fromGreen (Token (Green.token Group "bad"))) :: Maybe GroupView) === Nothing + , map (Cursor.path . toCursor) (Ast.children sharedRoot :: [GroupView]) === [[0], [1]] + , map (Cursor.range . toCursor) (Ast.children sharedRoot :: [GroupView]) + === [Range.fromLength 0 2, Range.fromLength 2 2] + , fmap (Cursor.path . toCursor) (Ast.token sharedRoot :: Maybe NameView) === Nothing + , map (Cursor.path . toCursor) (Ast.tokens (Cursor.fromGreen (tok "x")) :: [NameView]) === [] + , fmap (Cursor.path . toCursor) (Ast.child lazyRoot :: Maybe StopNode) === Just [0] + , fmap (Cursor.path . toCursor) (Ast.token lazyRoot :: Maybe StopToken) === Just [2] + , Ast.matchNode (error "token must not check node predicate") (const ()) (Cursor.fromGreen (tok "x")) === Nothing + , Ast.matchToken (error "node must not check token predicate") (const ()) emptyGroup === Nothing + , fmap (Cursor.range . toCursor) (fromCursor hugeRoot :: Maybe GroupView) + === Just (Range.fromLength 0 (2 ^ hugeDepth)) + , fmap (Cursor.range . toCursor) (Ast.child hugeRoot :: Maybe GroupView) + === Just (Range.fromLength 0 (2 ^ (hugeDepth - 1))) + ] + where + tok = Token . Green.token Name + emptyGroup = Cursor.fromGreen (Node (Green.node Group [])) + shared = Node (Green.node Group [tok "λ", tok ""]) + sharedRoot = Cursor.fromGreen (Node (Green.node Root [shared, shared])) + lazyRoot = Cursor.fromGreen (Node (Green.node Root + [ Node (Green.node Group []), Node (Green.node Comment []), tok "x", Token (Green.token Space " ") ])) + hugeRoot = Cursor.fromGreen (iterate (\element -> Node (Green.node Group [element, element])) (tok "x") !! hugeDepth) + +astProperties :: [(String, Property)] +astProperties = + [ ("typed casts retain occurrences and round-trip syntax", property propCasting) + , ("typed immediate fields and source order", property propFields) + , ("typed parents and ancestors", property propParents) + , ("exact-preserving edits through typed tokens", property propTokenEdit) + , ("persistent child edits through typed nodes", property propNodeEdit) + , ("typed malformed, shared-occurrence, lazy-query and large-range regressions", regressions) + ] diff --git a/test/BuilderTests.hs b/test/BuilderTests.hs new file mode 100644 --- /dev/null +++ b/test/BuilderTests.hs @@ -0,0 +1,281 @@ +{-# LANGUAGE OverloadedStrings #-} + +module BuilderTests (builderProperties) where + +import Control.Monad (foldM) +import Data.Char (ord) +import qualified Data.List as List +import qualified Data.Text as Text +import Graft +import qualified Graft.Build as Build +import qualified Graft.Builder as Builder +import qualified Graft.Green as Green +import Test.QuickCheck +import TestModel (halfMax, hugeDepth, overflows) + +-- An independent source-ordered tree, with no caches or builder positions. +data Tree = Branch Int [Tree] | Leaf Int String + deriving (Eq, Show) + +instance Arbitrary Tree where + arbitrary = sized genTree + shrink (Leaf kind text) = [Leaf kind s | s <- shrink text] + shrink (Branch kind items) = items ++ [Branch kind xs | xs <- shrinkList shrink items] + +genTree :: Int -> Gen Tree +genTree size + | size <= 0 = Leaf <$> chooseInt (0, 3) <*> genText + | otherwise = frequency + [ (2, genTree 0) + , (3, do + count <- chooseInt (0, min 4 size) + Branch <$> chooseInt (0, 3) <*> vectorOf count (genTree (size `div` (count + 1)))) + ] + where + genText = chooseInt (0, 12) >>= \n -> vectorOf n + (elements "ab09 \t\r\n\0éλ中😀\x0301\x10FFFF") + +genForest :: Gen [Tree] +genForest = chooseInt (0, 5) >>= \n -> vectorOf n (resize 12 arbitrary) + +source :: Tree -> String +source (Leaf _ text) = text +source (Branch _ items) = concatMap source items + +byteLength :: String -> TextLength +byteLength = sum . map width + where + width c + | ord c <= 0x7F = 1 + | ord c <= 0x7FF = 2 + | ord c <= 0xFFFF = 3 + | otherwise = 4 + +compile :: Tree -> GreenElement Int +compile (Leaf kind text) = Token (Green.token kind (Text.pack text)) +compile (Branch kind items) = Node (Green.node kind (map compile items)) + +decode :: GreenElement Int -> Tree +decode (Token token) = Leaf (Green.tokenKind token) (Text.unpack (Green.text token)) +decode (Node node) = Branch (Green.nodeKind node) (map decode (Green.children node)) + +cacheChecks :: GreenElement Int -> Property +cacheChecks element = conjoin $ + (Green.length element === byteLength (source (decode element))) : case element of + Token _ -> [] + Node node -> map cacheChecks (Green.children node) + +matches :: Tree -> Either BuilderError (GreenNode Int) -> Property +matches expected result = case result of + Left err -> counterexample (show err) False + Right node -> conjoin + [ decode (Node node) === expected + , Text.unpack (Green.renderNode node) === source expected + , cacheChecks (Node node) + ] + +-- Stream start/token/finish events from the oracle rather than using Green.node. +emit :: Tree -> Builder Int -> Either BuilderError (Builder Int) +emit (Leaf kind text) builder = Right (Builder.token kind (Text.pack text) builder) +emit (Branch kind items) builder = + foldM (flip emit) (Builder.startNode kind builder) items >>= Builder.finishNode + +emitAll :: [Tree] -> Builder Int -> Either BuilderError (Builder Int) +emitAll items builder = foldM (flip emit) builder items + +-- The monadic layer streams the same events with bracketed nodes. +build :: Tree -> Build Int () +build (Leaf kind text) = Build.token kind (Text.pack text) +build (Branch kind items) = Build.node kind (mapM_ build items) + +propMonadicConstruction :: Tree -> Property +propMonadicConstruction tree = conjoin + [ matches (Branch 9 [tree]) (Build.exec (Build.node 9 (build tree))) + , fmap fst (Build.run (Build.node 9 (build tree >> pure 'x'))) === Right 'x' + ] + +propMonadicWrapping :: Property +propMonadicWrapping = forAll ((,,) <$> genForest <*> genForest <*> genForest) $ \(prefix, middle, suffix) -> + matches (Branch 9 (prefix ++ [Branch 8 (middle ++ suffix)])) $ Build.exec $ Build.node 9 $ do + mapM_ build prefix + marker <- Build.checkpoint + mapM_ build middle + Build.nodeAt marker 8 (mapM_ build suffix) + +propMonadicBacktracking :: Property +propMonadicBacktracking = forAll ((,) <$> genForest <*> genForest) $ \(abandoned, kept) -> + matches (Branch 9 kept) $ Build.exec $ Build.node 9 $ do + saved <- Build.save + mapM_ build abandoned + Build.restore saved + mapM_ build kept + +propConstruction :: Tree -> Property +propConstruction tree = matches (Branch 9 [tree]) $ do + builder <- emit tree (Builder.startNode 9 Builder.empty) + Builder.finishNode builder >>= Builder.finish + +propWrapping :: Property +propWrapping = forAll ((,,) <$> genForest <*> genForest <*> genForest) $ \(prefix, middle, suffix) -> + classify (null middle) "empty initial suffix" $ + classify (not (null suffix)) "emission after wrapping starts" $ + matches (Branch 9 (prefix ++ [Branch 8 (middle ++ suffix)])) $ do + before <- emitAll prefix (Builder.startNode 9 Builder.empty) + let marker = Builder.checkpoint before + pending <- emitAll middle before + wrapped <- Builder.startNodeAt marker 8 pending + extended <- emitAll suffix wrapped + Builder.finishNode extended >>= Builder.finishNode >>= Builder.finish + +propRepeatedWrapping :: Property +propRepeatedWrapping = forAll genForest $ \items -> + let seed = Leaf 1 "λ" + expected = Branch 9 [List.foldl' (\left right -> Branch 8 [left, right]) seed items] + initial = Builder.startNode 9 Builder.empty + marker = Builder.checkpoint initial + wrap builder item = do + opened <- Builder.startNodeAt marker 8 builder + emit item opened >>= Builder.finishNode + in matches expected $ do + first <- emit seed initial + folded <- foldM wrap first items + Builder.finishNode folded >>= Builder.finish + +propBranching :: Property +propBranching = forAll ((,,) <$> genForest <*> genForest <*> genForest) $ \(prefix, left, right) -> + let saved = List.foldl' (flip (Builder.element . compile)) (Builder.startNode 9 Builder.empty) prefix + complete items = emitAll items saved >>= Builder.finishNode >>= Builder.finish + in conjoin + [ matches (Branch 9 (prefix ++ left)) (complete left) + , matches (Branch 9 (prefix ++ right)) (complete right) + , matches (Branch 9 prefix) (Builder.finishNode saved >>= Builder.finish) + ] + +propCheckpointBounds :: Property +propCheckpointBounds = forAll (chooseInt (2, 30)) $ \count -> + let initial = Builder.startNode 9 Builder.empty + pending = List.foldl' (\builder _ -> Builder.token 1 "x" builder) initial [1 .. count] + marker = Builder.checkpoint pending + prefix = List.foldl' (\builder _ -> Builder.token 1 "x" builder) + (Builder.empty :: Builder Int) [1 .. count] + in case Builder.finishNode pending of + Left err -> counterexample (show err) False + Right collapsed -> conjoin + [ Builder.startNodeAt marker 8 collapsed === Left (CheckpointOutOfBounds count 1) + , Builder.startNodeAt (Builder.checkpoint Builder.empty) 8 (Builder.startNode 9 prefix) + === Left (CheckpointBeforeCurrentNode 0 count) + , matches (Branch 9 (replicate count (Leaf 1 "x"))) (Builder.finish collapsed) + ] + +propBalance :: Property +propBalance = forAll (chooseInt (1, 30)) $ \depth -> + let opened = List.foldl' (\builder kind -> Builder.startNode kind builder) Builder.empty [1 .. depth] + -- At each step an open node must be reported, even if the forest already + -- contains one completed node. Finishing cannot implicitly close it. + check remaining builder = conjoin + [ Builder.finish builder === Left (UnclosedNodes remaining) + , case Builder.finishNode builder of + Left err -> counterexample (show err) False + Right closed + | remaining == 1 -> matches (foldr (\kind inner -> Branch kind [inner]) + (Branch depth []) [1 .. depth - 1]) (Builder.finish closed) + | otherwise -> check (remaining - 1) closed + ] + in check depth opened + +regressions :: Property +regressions = once $ conjoin + [ Builder.finishNode (Builder.empty :: Builder Int) === Left NoOpenNode + , Builder.finish (Builder.empty :: Builder Int) === Left EmptyBuilder + , Builder.finish (Builder.token 1 "" blank) === Left TokenRoot + , Builder.finish (Builder.token 1 "a" (Builder.token 1 "b" blank)) === Left (MultipleRoots 2) + , Builder.finish (Builder.startNode 9 (Builder.token 1 "a" blank)) === Left (UnclosedNodes 1) + , matches (Branch 9 []) (Builder.finishNode (Builder.startNode 9 Builder.empty) >>= Builder.finish) + , matches (Branch 9 [Leaf 1 "a", Leaf 1 "b"]) (do + let pending = Builder.token 1 "b" (Builder.token 1 "a" Builder.empty) + opened <- Builder.startNodeAt (Builder.checkpoint Builder.empty) 9 pending + Builder.finishNode opened >>= Builder.finish) + , matches (Branch 9 [Branch 8 [Leaf 1 "a"]]) (do + let initial = Builder.startNode 9 Builder.empty + marker = Builder.checkpoint initial + outer <- Builder.startNodeAt marker 8 (Builder.token 1 "a" initial) + Builder.finishNode outer >>= Builder.finishNode >>= Builder.finish) + -- The end position may be reused to create successive empty nodes. + , matches (Branch 9 [Branch 8 [], Branch 7 []]) (do + let initial = Builder.startNode 9 Builder.empty + emptyNode <- Builder.startNodeAt (Builder.checkpoint initial) 8 initial >>= Builder.finishNode + next <- Builder.startNodeAt (Builder.checkpoint emptyNode) 7 emptyNode >>= Builder.finishNode + Builder.finishNode next >>= Builder.finish) + -- Markers are numeric positions, with no provenance or history validation. + , matches (Branch 9 [Leaf 1 "a", Branch 8 [Leaf 1 "b"]]) (do + let foreignMarker = Builder.checkpoint (Builder.token (1 :: Int) "unrelated" Builder.empty) + initial = Builder.startNode 9 Builder.empty + pending = Builder.token 1 "b" (Builder.token 1 "a" initial) + opened <- Builder.startNodeAt foreignMarker 8 pending + Builder.finishNode opened >>= Builder.finishNode >>= Builder.finish) + , matches (Branch 7 [Branch 9 [Leaf 1 "a", Leaf 1 "b"], Leaf 1 "c", Branch 8 []]) (do + let initial = Builder.startNode 9 Builder.empty + pending = Builder.token 1 "b" (Builder.token 1 "a" initial) + oldMarker = Builder.checkpoint pending + collapsed <- Builder.finishNode pending + let revived = Builder.token 1 "c" collapsed + opened <- Builder.startNodeAt oldMarker 8 revived + -- The collapsed root and new token precede the revived position. + emptyNode <- Builder.finishNode opened + Builder.startNodeAt (Builder.checkpoint Builder.empty) 7 emptyNode >>= Builder.finishNode >>= Builder.finish) + -- Show prints calls that rebuild an equal builder, with open nodes placed + -- at their start positions even when they were opened at a checkpoint. + , either (\err -> counterexample (show err) False) (\opened -> show opened === concat + [ "Builder.element (Token (Green.token 1 \"b\")) " + , "(Builder.element (Token (Green.token 1 \"a\")) (Builder.startNode 8 (Builder.startNode 9 Builder.empty)))" + ]) (do + let initial = Builder.startNode 9 blank + Builder.startNodeAt (Builder.checkpoint initial) 8 (Builder.token 1 "b" (Builder.token 1 "a" initial))) + , show (Builder.empty :: Builder Int) === "Builder.empty" + -- Reused subtrees whose lengths overflow fail when the node closes. + , overflows (Builder.finishNode (Builder.element (halfMax (1 :: Int)) (Builder.element (halfMax (1 :: Int)) (Builder.startNode 9 Builder.empty)))) + , conjoin + [ Green.nodeLength hugeRoot === 2 ^ hugeDepth + , Green.nodeKind hugeRoot === 9 + , length (Green.children hugeRoot) === 1 + ] + ] + where + blank :: Builder Int + blank = Builder.empty + -- Reuse cached huge lengths without rendering or comparing the shared DAG. + huge :: GreenElement Int + huge = iterate (\element -> Node (Green.node 8 [element, element])) + (Token (Green.token 1 "x")) !! hugeDepth + hugeRoot = case Builder.finishNode (Builder.element huge (Builder.startNode 9 Builder.empty)) >>= Builder.finish of + Right node -> node + Left err -> error (show err) + +monadicErrors :: Property +monadicErrors = once $ conjoin + [ Build.exec (Build.finishNode :: Build Int ()) === Left NoOpenNode + , Build.exec (Build.startNode (9 :: Int)) === Left (UnclosedNodes 1) + , Build.exec (pure () :: Build Int ()) === Left EmptyBuilder + , Build.exec (Build.token (1 :: Int) "a") === Left TokenRoot + , Build.exec (Build.node (9 :: Int) (Build.token 1 "a") >> Build.node 9 (pure ())) === Left (MultipleRoots 2) + -- A checkpoint taken inside a node lies past the end once it closes. + , Build.exec (Build.node (9 :: Int) (Build.token 1 "a" + >> Build.node 8 (Build.token 1 "b" >> Build.token 1 "c" >> Build.checkpoint) + >>= \marker -> Build.nodeAt marker 7 (pure ()))) + === Left (CheckpointOutOfBounds 3 2) + ] + +builderProperties :: [(String, Property)] +builderProperties = + [ ("builder streamed construction, rendering and caches", property propConstruction) + , ("builder checkpoint wrapping with later emission", propWrapping) + , ("builder repeated checkpoint wrapping", propRepeatedWrapping) + , ("builder persistent branches and green element reuse", propBranching) + , ("builder checkpoint bounds and recovery", propCheckpointBounds) + , ("builder balanced construction at every close", propBalance) + , ("builder empty, root, checkpoint lifetime and shared-length regressions", regressions) + , ("monadic builder construction and results", property propMonadicConstruction) + , ("monadic builder checkpoint wrapping", propMonadicWrapping) + , ("monadic builder saved states", propMonadicBacktracking) + , ("monadic builder errors", monadicErrors) + ] diff --git a/test/ChildEditTests.hs b/test/ChildEditTests.hs new file mode 100644 --- /dev/null +++ b/test/ChildEditTests.hs @@ -0,0 +1,287 @@ +{-# LANGUAGE OverloadedStrings #-} + +module ChildEditTests (childEditProperties) where + +import Data.List (isPrefixOf) +import qualified Data.Text as Text +import Graft +import qualified Graft.Cursor as Cursor +import qualified Graft.Edit as Edit +import qualified Graft.Green as Green +import qualified Graft.Range as Range +import Test.QuickCheck +import TestModel + +genForest :: Gen [Model] +genForest = chooseInt (0, 5) >>= \n -> vectorOf n (resize 12 arbitrary) + +genNode :: Gen Model +genNode = Branch <$> genKind <*> genForest + +-- Wrapping supplies at least one node, even when the generated tree is a leaf. +genTarget :: Bool -> Gen (Model, Path, Kind, [Model]) +genTarget nonempty = do + model <- Branch Root . (: []) <$> resize 20 arbitrary + (path, kind, items) <- elements + [ (path, kind, items) | (path, _, Branch kind items, _) <- contexts model + , not nonempty || not (null items) ] + pure (model, path, kind, items) + +modelReplace :: Path -> Model -> Model -> Model +modelReplace [] replacement _ = replacement +modelReplace (index : rest) replacement (Branch kind items) = + Branch kind (take index items ++ [modelReplace rest replacement (items !! index)] + ++ drop (index + 1) items) +modelReplace _ _ (Leaf _ _) = error "invalid oracle path" + +matches :: Show err => Model -> Either err (GreenElement Kind) -> Property +matches expected result = case result of + Left err -> counterexample (show err) False + Right edited -> conjoin + [ edited === compile expected + , Text.unpack (Green.render edited) === source expected + , counterexample "cache invariant" (validCaches edited) + , conjoin + [ case Cursor.at path (Cursor.fromGreen edited) of + Left err -> counterexample (show (path, err)) False + Right focus -> conjoin + [ Cursor.green focus === compile selected + , Cursor.range focus === Range.fromLength (byteLength prefix) (byteLength (source selected)) + ] + | (path, prefix, selected, _) <- contexts expected + ] + ] + +asNode :: Model -> GreenNode Kind +asNode model = case compile model of + Node node -> node + Token _ -> error "expected oracle node" + +childCursor :: Int -> Cursor Kind -> Cursor Kind +childCursor index = either (error . show) id . Cursor.childAt index + +-- The tree an edit produced, or Nothing, so that plans and path helpers +-- with different error types compare. +accepted :: Either err (GreenElement Kind) -> Maybe (GreenElement Kind) +accepted = either (const Nothing) Just + +propDirectSplice :: Property +propDirectSplice = forAll genNode $ \model -> case model of + Branch kind items -> forAll genForest $ \replacements -> + forAll (chooseInt (0, length items)) $ \start -> + forAll (chooseInt (start, length items)) $ \end -> + classify (start == end) "insertion" $ + classify (null replacements && start /= end) "deletion" $ + matches (Branch kind (take start items ++ replacements ++ drop end items)) + (Node <$> Green.spliceChildren start end (map compile replacements) (asNode model)) + Leaf _ _ -> error "expected oracle node" + +-- Map only untouched occurrences. Ancestors/focus change structurally, and +-- children inside the removed range have no corresponding occurrence. +mapUntouched :: Path -> Int -> Int -> Int -> Path -> Maybe Path +mapUntouched target start end replacementCount old + | old `isPrefixOf` target = Nothing + | target `isPrefixOf` old = case drop (length target) old of + index : rest + | index < start -> Just old + | index >= end -> Just (target ++ (index + replacementCount - (end - start)) : rest) + | otherwise -> Nothing + [] -> Nothing + | otherwise = Just old + +propNestedSplice :: Property +propNestedSplice = forAll (genTarget False) $ \(model, path, kind, items) -> + forAll genForest $ \replacements -> + forAll (chooseInt (0, length items)) $ \start -> + forAll (chooseInt (start, length items)) $ \end -> + let root = compile model + expected = modelReplace path (Branch kind (take start items ++ replacements ++ drop end items)) model + edited = spliceChildrenAt path start end (map compile replacements) root + in classify (not (null path)) "nested node" $ case Cursor.at path (Cursor.fromGreen root) of + Left err -> counterexample (show err) False + Right focus -> conjoin + [ matches expected edited + , Cursor.green (Cursor.root focus) === root + , Cursor.path focus === path + , Text.unpack (Green.render root) === source model + , case edited of + Left err -> counterexample (show err) False + Right result -> conjoin + [ counterexample (show (oldPath, newPath)) $ + elementAt newPath result === Right (compile untouched) + | (oldPath, _, untouched, _) <- contexts model + , Just newPath <- [mapUntouched path start end (length replacements) oldPath] + ] + ] + +propInsertion :: Property +propInsertion = forAll (genTarget False) $ \(model, path, kind, items) -> + forAll (resize 12 arbitrary) $ \replacement -> + forAll (chooseInt (0, length items)) $ \index -> + let target = Branch kind items + updated = Branch kind (take index items ++ [replacement] ++ drop index items) + element = compile replacement + root = compile model + direct = Green.insertChild index element (asNode target) + edited = insertChildAt path index element root + in classify (index == length items) "append" $ + conjoin + [ matches updated (Node <$> direct) + , matches (modelReplace path updated model) edited + , (direct >>= Green.removeChild index) === Right (asNode target) + , (edited >>= removeChildAt path index) === Right root + -- the same insertion anchored at a sibling, where there is one + , case Cursor.at path (Cursor.fromGreen root) of + Left err -> counterexample (show err) False + Right focus -> + let anchored + | index < length items = Edit.insertBefore (childCursor index focus) [element] + | index > 0 = Edit.insertAfter (childCursor (index - 1) focus) [element] + | otherwise = Edit.splice focus 0 0 [element] + in accepted (Edit.apply root [anchored]) === accepted edited + ] + +propRemoval :: Property +propRemoval = forAll (genTarget True) $ \(model, path, kind, items) -> + forAll (chooseInt (0, length items - 1)) $ \index -> + let target = Branch kind items + updated = Branch kind (take index items ++ drop (index + 1) items) + root = compile model + direct = Green.removeChild index (asNode target) + edited = removeChildAt path index root + in conjoin + [ matches updated (Node <$> direct) + , matches (modelReplace path updated model) edited + , (direct >>= Green.insertChild index (compile (items !! index))) === Right (asNode target) + , case Cursor.at path (Cursor.fromGreen root) of + Left err -> counterexample (show err) False + Right focus -> accepted (Edit.apply root [Edit.remove (childCursor index focus)]) === accepted edited + ] + +propNoOp :: Property +propNoOp = forAll (genTarget False) $ \(model, path, _, items) -> + forAll (chooseInt (0, length items)) $ \start -> + forAll (chooseInt (start, length items)) $ \end -> + let root = compile model + originalSlice = map compile (take (end - start) (drop start items)) + in conjoin + [ spliceChildrenAt path start start [] root === Right root + , spliceChildrenAt path start end originalSlice root === Right root + ] + +propInvalidBounds :: Property +propInvalidBounds = forAll (genTarget False) $ \(model, path, kind, items) -> + let node = asNode (Branch kind items) + count = length items + bad = [(minBound, -1, NegativeChildBoundary minBound) + , (0, -1, NegativeChildBoundary (-1)) + , (count + 2, count + 1, ReversedChildRange (count + 2) (count + 1)) + , (count + 1, count + 1, ChildBoundaryOutOfBounds (count + 1)) + , (count, maxBound, ChildBoundaryOutOfBounds maxBound)] + root = compile model + in conjoin $ + [ conjoin + [ Green.spliceChildren start end [] node === Left err + , spliceChildrenAt path start end [] root === Left (EditError err) + , case Cursor.at path (Cursor.fromGreen root) of + Left pathErr -> counterexample (show pathErr) False + Right focus -> Edit.apply root [Edit.splice focus start end []] === Left (InvalidSplice 0 err) + ] + | (start, end, err) <- bad + ] ++ + [ Green.insertChild (-1) root node === Left (NegativeChildBoundary (-1)) + , Green.removeChild (-1) node === Left (NegativeChildBoundary (-1)) + , Green.removeChild count node === Left (ChildBoundaryOutOfBounds count) + , Green.removeChild maxBound node === Left (ChildBoundaryOutOfBounds maxBound) + ] + +propInvalidTargets :: Model -> Property +propInvalidTargets model = conjoin + [ case selected of + Leaf _ _ -> conjoin + [ spliceChildrenAt path (-1) (-2) [] root === Left (EditError CannotEditTokenChildren) + , insertChildAt path (-1) root root === Left (EditError CannotEditTokenChildren) + , removeChildAt path (-1) root === Left (EditError CannotEditTokenChildren) + , case Cursor.at path (Cursor.fromGreen root) of + Left err -> counterexample (show err) False + Right focus -> + Edit.apply root [Edit.splice focus (-1) (-2) []] === Left (InvalidSplice 0 CannotEditTokenChildren) + , badPath (path ++ [0]) CannotDescendIntoToken + , badPath (path ++ [-1]) (NegativeChildIndex (-1)) + ] + Branch _ items -> conjoin + [ badPath (path ++ [-1]) (NegativeChildIndex (-1)) + , badPath (path ++ [length items]) (ChildIndexOutOfBounds (length items)) + ] + | (path, _, selected, _) <- contexts model + ] + where + root = compile model + badPath path err = conjoin + [ spliceChildrenAt path (-1) (-2) [] root === Left (ChildEditPathError err) + , insertChildAt path (-1) root root === Left (ChildEditPathError err) + , removeChildAt path (-1) root === Left (ChildEditPathError err) + ] + +regressions :: Property +regressions = once $ conjoin + [ Green.insertChild 0 (tok "") empty === Right (Green.node Group [tok ""]) + , Green.removeChild 0 (Green.node Group [tok "x"]) === Right empty + , Green.removeChild 0 empty === Left (ChildBoundaryOutOfBounds 0) + , fmap Green.renderNode (Green.spliceChildren 1 2 [tok " + ", tok "中"] original) + === Right "λ + 中\r\n-- keep\0" + , fmap Green.renderNode (Green.spliceChildren 0 3 [] original) === Right "" + , fmap Green.nodeKind (Green.spliceChildren 0 3 [] original) === Right Group + , Green.spliceChildren 0 maxBound (error "invalid edit must not inspect replacements") empty + === Left (ChildBoundaryOutOfBounds maxBound) + , Green.spliceChildren maxBound maxBound [] empty === Left (ChildBoundaryOutOfBounds maxBound) + , Green.spliceChildren minBound maxBound [] empty === Left (NegativeChildBoundary minBound) + , conjoin + [ Green.length hugeEdited === 2 ^ hugeDepth + 1 + , case Cursor.at [1] (Cursor.fromGreen hugeEdited) of + Left err -> counterexample (show err) False + Right focus -> Cursor.range focus === Range.fromLength (2 ^ hugeDepth) 1 + ] + , -- Replacing children with as many of the same total length must still + -- move the offsets inside the range. + conjoin + [ counterexample which $ case edit of + Left err -> counterexample err False + Right edited -> conjoin + [ counterexample "cache invariant" (validCaches edited) + , Green.render edited === "abc\r\n-- keep\0" + , case Cursor.at [1] (Cursor.fromGreen edited) of + Left err -> counterexample (show err) False + Right focus -> Cursor.range focus === Range.fromLength 1 2 + ] + | (which, edit) <- + [ ("plan", either (Left . show) Right (spliceChildrenAt [] 0 2 [tok "a", tok "bc"] (Node original))) + , ("green", either (Left . show) (Right . Node) (Green.spliceChildren 0 2 [tok "a", tok "bc"] original)) + ] + ] + , case Green.insertChild 0 (Node empty) (Green.node Root [tok "x"]) of + Left err -> counterexample (show err) False + Right node -> case Cursor.at [1] (Cursor.fromGreen (Node node)) of + Left err -> counterexample (show err) False + Right focus -> conjoin [Cursor.path focus === [1], Cursor.range focus === Range.fromLength 0 1] + ] + where + empty = Green.node Group [] + tok = Token . Green.token Name + original = Green.node Group [tok "λ", tok "\t", tok "\r\n-- keep\0"] + huge = iterate (\element -> Node (Green.node Group [element, element])) (tok "x") !! hugeDepth + hugeEdited = case Green.insertChild 1 (tok "z") (Green.node Root [huge]) of + Right node -> Node node + Left err -> error (show err) + +childEditProperties :: [(String, Property)] +childEditProperties = + [ ("child splicing shape, source, caches and ranges", propDirectSplice) + , ("nested child splicing, shifted paths and persistent cursors", propNestedSplice) + , ("child insertion and removal inverse", propInsertion) + , ("child removal and restoration", propRemoval) + , ("empty and identity child splices", propNoOp) + , ("child boundary errors and precedence", propInvalidBounds) + , ("child edit path and token-target errors", property propInvalidTargets) + , ("child edit empty, trivia, Unicode, extreme-index and shared-length regressions", regressions) + ] diff --git a/test/CursorTests.hs b/test/CursorTests.hs new file mode 100644 --- /dev/null +++ b/test/CursorTests.hs @@ -0,0 +1,142 @@ +module CursorTests (cursorProperties) where + +import qualified Data.Text as Text +import Graft +import qualified Graft.Cursor as Cursor +import qualified Graft.Range as Range +import Test.QuickCheck +import TestModel + +-- One step of a program run on a cursor and on the model. +data Step + = Up + | Next + | Previous + | First + | Last + | Child Int + | Top + | Look + | Lookup Int + deriving (Show) + +genStep :: Gen Step +genStep = frequency + [ (4, pure Next), (2, pure Previous), (3, pure Up), (3, pure First), (1, pure Last) + , (1, Child <$> chooseInt (0, 4)), (1, pure Top) + , (2, pure Look), (1, Lookup <$> chooseInt (0, 40)) + ] + +shrinkStep :: Step -> [Step] +shrinkStep (Child index) = Child <$> shrink index +shrinkStep (Lookup offset) = Lookup <$> shrink offset +shrinkStep _ = [] + +modelAt :: Path -> Model -> Maybe Model +modelAt [] model = Just model +modelAt (index : rest) (Branch _ items) + | index >= 0, index < length items = modelAt rest (items !! index) +modelAt _ _ = Nothing + +modelKind :: Model -> Kind +modelKind (Branch kind _) = kind +modelKind (Leaf kind _) = kind + +modelChildren :: Model -> [Model] +modelChildren (Branch _ items) = items +modelChildren (Leaf _ _) = [] + +isLeaf :: Model -> Bool +isLeaf (Leaf _ _) = True +isLeaf (Branch _ _) = False + +-- The path, range and kind of an occurrence, from the model's own text. +expected :: Model -> Path -> (Path, TextRange, Kind, Bool) +expected model path = case [(prefix, selected) | (other, prefix, selected, _) <- contexts model, other == path] of + (prefix, selected) : _ -> + (path, Range.fromLength (byteLength prefix) (byteLength (source selected)), modelKind selected, isLeaf selected) + [] -> error ("no occurrence at " ++ show path) + +observe :: Cursor Kind -> (Path, TextRange, Kind, Bool) +observe cursor = (Cursor.path cursor, Cursor.range cursor, Cursor.kind cursor, Cursor.isToken cursor) + +-- Where a step leads in the model, or Nothing where the cursor has nowhere +-- to go. +target :: Model -> Path -> Step -> Maybe Path +target model path step = case step of + Up -> case reverse path of + _ : above -> Just (reverse above) + [] -> Nothing + Next -> sibling 1 + Previous -> sibling (-1) + First -> child 0 + Last -> child (length focusChildren - 1) + Child index -> child index + Top -> Just [] + _ -> Just path + where + focusChildren = maybe [] modelChildren (modelAt path model) + child index + | index >= 0, index < length focusChildren = Just (path ++ [index]) + | otherwise = Nothing + sibling offset = case reverse path of + index : above + | Just above' <- modelAt (reverse above) model + , let next = index + offset + , next >= 0, next < length (modelChildren above') -> Just (reverse above ++ [next]) + _ -> Nothing + +move :: Step -> Cursor Kind -> Maybe (Cursor Kind) +move step cursor = case step of + Up -> Cursor.parent cursor + Next -> Cursor.nextSibling cursor + Previous -> Cursor.previousSibling cursor + First -> Cursor.firstChild cursor + Last -> Cursor.lastChild cursor + Child index -> either (const Nothing) Just (Cursor.childAt index cursor) + Top -> Just (Cursor.root cursor) + _ -> Just cursor + +-- Run a program on a cursor and on the model. After every step the focus +-- and its ancestors agree with the model; reading steps also compare the +-- focus, its children and offset lookups from the root; at the end the +-- cursor is still in the tree it started in. +propProgram :: Model -> Property +propProgram model = forAllShrink (listOf genStep) (shrinkList shrinkStep) $ \steps -> + go (Cursor.fromGreen tree) [] steps + where + tree = compile model + go cursor path [] = + counterexample "tree kept" (Cursor.tree cursor === tree) + .&&. counterexample "path kept" (Cursor.path cursor === path) + go cursor path (step : rest) = case (move step cursor, target model path step) of + (Nothing, Nothing) -> go cursor path rest + (Just moved, Just path') -> + counterexample (show step) (check moved path' step) .&&. go moved path' rest + (moved, path') -> + counterexample (show step ++ ": cursor " ++ show (fmap Cursor.path moved) ++ ", model " ++ show path') + False + check cursor path step = conjoin $ + [ observe cursor === expected model path + , map observe (Cursor.ancestors cursor) === map (expected model) (drop 1 (reverse (inits' path))) + ] ++ case step of + Look -> + [ Cursor.green cursor === maybe (error "no focus") compile (modelAt path model) + , Text.unpack (Cursor.text cursor) === maybe "" source (modelAt path model) + , map observe (Cursor.children cursor) + === [expected model (path ++ [index]) | index <- [0 .. length (maybe [] modelChildren (modelAt path model)) - 1]] + ] + Lookup offset -> + let fresh = Cursor.fromGreen tree + position = fromIntegral offset + query = Range.fromLength position 0 + in [ fmap observe (Cursor.tokenAt position (Cursor.root cursor)) === fmap observe (Cursor.tokenAt position fresh) + , fmap observe (Cursor.covering query (Cursor.root cursor)) === fmap observe (Cursor.covering query fresh) + ] + _ -> [] + inits' path = [take count path | count <- [0 .. length path]] + +cursorProperties :: [(String, Property)] +cursorProperties = + [ ("cursor programs of moves and lookups against the model", property propProgram) + ] diff --git a/test/EditTests.hs b/test/EditTests.hs new file mode 100644 --- /dev/null +++ b/test/EditTests.hs @@ -0,0 +1,521 @@ +{-# LANGUAGE OverloadedStrings #-} + +module EditTests (editProperties) where + +import Control.Exception (evaluate) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE) +import Control.Monad.Trans.State.Strict (State, modify', runState) +import qualified Data.ByteString as B +import Data.List (isPrefixOf, nub, sortOn, stripPrefix, unsnoc) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as TE +import Graft +import qualified Graft.Cursor as Cursor +import qualified Graft.Edit as Edit +import qualified Graft.Green as Green +import qualified Graft.Range as Range +import System.Mem.StableName (makeStableName) +import Test.QuickCheck +import TestModel + +childOf :: Int -> GreenNode Kind -> GreenElement Kind +childOf index node = maybe (error "missing child") id (Green.childAt index node) + +cursorAt :: Path -> GreenElement Kind -> Cursor Kind +cursorAt path base = either (error . show) id (Cursor.at path (Cursor.fromGreen base)) + +-- A second compilation of a model, kept apart from the first by the +-- optimiser, so that the two trees are equal but not the same object. +separately :: Model -> GreenElement Kind +separately = compile +{-# NOINLINE separately #-} + +-- --------------------------------------------------------------------------- +-- Rewriting + +-- What a rewrite is told at each path. The table is generated independently +-- of any traversal and read by the library's callback and by the model's, so +-- both see the same decisions. +data Decision = ReplaceWith Model | ReplaceSame | GoOn | GoOnWith Int | Untouched + deriving (Show) + +genTable :: Model -> Gen (Map Path Decision) +genTable model = Map.fromList <$> traverse decide [path | (path, _, _, _) <- contexts model] + where + decide path = (,) path <$> frequency + [ (2, ReplaceWith <$> resize 3 arbitrary) + , (1, pure ReplaceSame) + , (5, pure GoOn) + , (2, GoOnWith <$> chooseInt (0, 9)) + , (2, pure Untouched) + ] + +decisionAt :: Map Path Decision -> Path -> Decision +decisionAt table path = Map.findWithDefault GoOn path table + +-- A replacement carries the context it was made with, so a context passed +-- to the wrong elements shows in the result. +stamped :: Int -> Model -> Model +stamped ctx new = Branch Group [Leaf Comment (show ctx), new] + +-- The library's callback. +change :: Map Path Decision -> Int -> Cursor Kind -> Change Int Kind +change table ctx cursor = case decisionAt table (Cursor.path cursor) of + ReplaceWith new -> Replace (compile (stamped ctx new)) + ReplaceSame -> Replace (Cursor.green cursor) + GoOn -> Descend + GoOnWith inner -> DescendWith inner + Untouched -> Skip + +-- The model's rewrite, over the oracle tree. +rewriteModel :: Map Path Decision -> Int -> Model -> Model +rewriteModel table = go [] + where + go path ctx model = case decisionAt table path of + ReplaceWith new -> stamped ctx new + ReplaceSame -> model + Untouched -> model + GoOn -> below ctx + GoOnWith inner -> below inner + where + below inner = case model of + Leaf _ _ -> model + Branch kind children -> + Branch kind [go (path ++ [i]) inner child | (i, child) <- zip [0 ..] children] + +-- The paths the callback is called on, in order: nothing below a +-- replacement or a skipped element. +visits :: Map Path Decision -> Model -> [Path] +visits table = go [] + where + go path model = path : case decisionAt table path of + GoOn -> below + GoOnWith _ -> below + _ -> [] + where + below = case model of + Leaf _ _ -> [] + Branch _ children -> concat [go (path ++ [i]) child | (i, child) <- zip [0 ..] children] + +isReplacement, isContext, isSkip :: Decision -> Bool +isReplacement decision = case decision of { ReplaceWith _ -> True; ReplaceSame -> True; _ -> False } +isContext decision = case decision of { GoOnWith _ -> True; _ -> False } +isSkip decision = case decision of { Untouched -> True; _ -> False } + +-- The rewrite gives the model's tree, kinds and empty elements included, with +-- valid caches in every rebuilt node. +propRewriteModel :: Model -> Property +propRewriteModel model = forAll (genTable model) $ \table -> + let expected = rewriteModel table 0 model + result = Edit.rewrite (change table) 0 (compile model) + seen = map (decisionAt table) (visits table model) + in checkCoverage $ + cover 20 (any isReplacement seen) "a replacement" $ + cover 10 (any isContext seen) "a context" $ + cover 10 (any isSkip seen) "a skip" $ + conjoin + [ result === compile expected + , Text.unpack (Green.render result) === source expected + , counterexample "stale cached lengths or offsets" (validCaches result) + ] + +logged :: Map Path Decision -> Int -> Cursor Kind -> State [Path] (Change Int Kind) +logged table ctx cursor = do + modify' (Cursor.path cursor :) + pure (change table ctx cursor) + +-- The callback runs in preorder, on exactly the elements the model says. +propRewriteVisits :: Model -> Property +propRewriteVisits model = forAll (genTable model) $ \table -> + let (result, visited) = runState (Edit.rewriteM (logged table) 0 (compile model)) [] + in conjoin + [ reverse visited === visits table model + , result === compile (rewriteModel table 0 model) + ] + +-- A failing effect stops the rewrite at once: nothing after it is visited. +propRewriteStops :: Model -> Property +propRewriteStops model = forAll (genTable model) $ \table -> + let planned = visits table model + in forAll (chooseInt (0, length planned - 1)) $ \k -> + let stopAt = planned !! k + step :: Int -> Cursor Kind -> ExceptT Path (State [Path]) (Change Int Kind) + step ctx cursor = do + let path = Cursor.path cursor + lift (modify' (path :)) + if path == stopAt then throwE path else pure (change table ctx cursor) + (outcome, visited) = runState (runExceptT (Edit.rewriteM step 0 (compile model))) [] + in conjoin + [ outcome === Left stopAt + , reverse visited === take (k + 1) planned + ] + +-- A rewrite that replaces nothing returns its argument, not a copy. +propRewriteShares :: Model -> Property +propRewriteShares model = ioProperty $ do + tree <- evaluate (compile model) + original <- makeStableName tree + skipped <- evaluate (Edit.rewrite (\() _ -> Skip) () tree) >>= makeStableName + descended <- evaluate (Edit.rewrite (\() _ -> Descend) () tree) >>= makeStableName + pure $ conjoin + [ counterexample "Skip everywhere copied the tree" (skipped == original) + , counterexample "Descend everywhere copied the tree" (descended == original) + ] + +-- A sibling with nothing replaced below it is reused, not copied. +propRewriteSharesSiblings :: Model -> Model -> Property +propRewriteSharesSiblings left right = ioProperty $ do + let tree = compile (Branch Root [left, right]) + table = Map.fromList [([0], ReplaceWith (Leaf Name "new"))] + rewritten <- evaluate (Edit.rewrite (change table) 0 tree) + case (tree, rewritten) of + (Node before, Node after) -> do + untouched <- evaluate (childOf 1 before) >>= makeStableName + kept <- evaluate (childOf 1 after) >>= makeStableName + pure (counterexample "the untouched sibling was copied" (untouched == kept)) + _ -> pure (counterexample "the roots are not nodes" False) + +-- The replacements a rewrite makes, applied as a plan to the original, give +-- the rewrite's result. +propRewriteIsApply :: Model -> Property +propRewriteIsApply model = forAll (genTable model) $ \table -> + let base = compile model + recording ctx cursor = do + let answer = change table ctx cursor + case answer of + Replace new -> modify' (Edit.replace cursor new :) + _ -> pure () + pure answer + (rewritten, collected) = runState (Edit.rewriteM recording 0 base) [] + in Edit.apply base (reverse collected) === Right rewritten + +rewriteRegressions :: Property +rewriteRegressions = once $ conjoin + [ Green.render (Edit.rewrite (\() _ -> Replace (tok "y")) () (tok "x")) === "y" + , Green.render (Edit.rewrite (\() _ -> Replace (tok "y")) () empty) === "y" + , Edit.rewrite (\() _ -> Descend) () empty === empty + , Edit.rewrite (\() _ -> DescendWith ()) () (tok "x") === tok "x" + , Green.render (Edit.rewrite grow () wide) === "aéé béécéé" + , counterexample "offsets after a longer child" (validCaches (Edit.rewrite grow () wide)) + ] + where + tok = Token . Green.token Name + empty = Node (Green.node Root []) + wide = Node (Green.node Root [tok "a", Token (Green.token Space " "), Node (Green.node Group [tok "b", tok "c"])]) + grow () cursor = case Cursor.green cursor of + Token token | Green.tokenKind token == Name -> + Replace (Token (Green.token Name (Green.text token <> "éé"))) + _ -> Descend + +-- --------------------------------------------------------------------------- +-- Edit plans + +-- What an edit does, at the path of the element it applies to; the model of +-- a child-anchored edit is a splice of its parent. +data ModelOp = MReplace Model | MSplice Int Int [Model] + deriving (Show) + +-- A library edit on the base with its model, or Nothing for a +-- child-anchored edit on the root, which has no model. +data Planned = Planned (Edit Kind) (Maybe (Path, ModelOp)) + deriving (Show) + +plannedEdit :: Planned -> Edit Kind +plannedEdit (Planned edit _) = edit + +-- The edits of a plan with their positions in the list. +type ModelPlan = [(Int, Path, ModelOp)] + +modelPlan :: [Planned] -> Maybe ModelPlan +modelPlan planned = + sequence [fmap (\(path, op) -> (n, path, op)) model | (n, Planned _ model) <- zip [0 ..] planned] + +genPlan :: GreenElement Kind -> Model -> Gen [Planned] +genPlan base model = do + count <- frequency [(1, pure 0), (6, chooseInt (1, 3)), (2, pure 4)] + vectorOf count (genEdit base model) + +genEdit :: GreenElement Kind -> Model -> Gen Planned +genEdit base model = frequency + [ (4, anywhere $ \path _ -> do + new <- resize 3 arbitrary + pure (Planned (Edit.replace (cursorAt path base) (compile new)) (Just (path, MReplace new)))) + , (4, anywhere $ \path selected -> do + let width = case selected of { Branch _ children -> length children; Leaf _ _ -> 0 } + (start, end) <- genRange width + new <- small + pure (Planned (Edit.splice (cursorAt path base) start end (map compile new)) (Just (path, MSplice start end new)))) + , (2, child $ \path -> do + new <- small + pure (Planned (Edit.insertBefore (cursorAt path base) (map compile new)) (inParent path (\i -> MSplice i i new)))) + , (2, child $ \path -> do + new <- small + pure (Planned (Edit.insertAfter (cursorAt path base) (map compile new)) (inParent path (\i -> MSplice (i + 1) (i + 1) new)))) + , (2, child $ \path -> pure (Planned (Edit.remove (cursorAt path base)) (inParent path (\i -> MSplice i (i + 1) [])))) + ] + where + small = resize 2 (listOf (resize 2 arbitrary)) + anywhere make = do + (path, _, selected, _) <- elements (contexts model) + make path selected + -- A child-anchored edit mostly targets a child; the root, which has no + -- siblings, is tried now and then. + child make = case [path | (path@(_ : _), _, _, _) <- contexts model] of + [] -> make [] + paths -> frequency [(9, elements paths), (1, pure [])] >>= make + inParent path op = case unsnoc path of + Nothing -> Nothing + Just (parent, index) -> Just (parent, op index) + +-- Mostly valid ranges and insertions, with the occasional invalid range. +genRange :: Int -> Gen (Int, Int) +genRange width = frequency + [ (5, do start <- chooseInt (0, width); end <- chooseInt (start, width); pure (start, end)) + , (4, do start <- chooseInt (0, width); pure (start, start)) + , (1, elements [(-1, 0), (0, -1), (1, 0), (width + 1, width + 1), (0, width + 1)]) + ] + +modelAt :: Path -> Model -> Model +modelAt (index : rest) (Branch _ children) = modelAt rest (children !! index) +modelAt _ model = model + +-- The splices that are not valid for the base, with the error the library +-- reports for them. +invalidSplices :: Model -> ModelPlan -> [(Int, ChildEditError)] +invalidSplices model plan = + [ (n, err) | (n, path, MSplice start end _) <- plan, Just err <- [spliceError (modelAt path model) start end] ] + where + spliceError target start end = case target of + Leaf _ _ -> Just CannotEditTokenChildren + Branch _ children + | start < 0 -> Just (NegativeChildBoundary start) + | end < 0 -> Just (NegativeChildBoundary end) + | end < start -> Just (ReversedChildRange start end) + | start > count -> Just (ChildBoundaryOutOfBounds start) + | end > count -> Just (ChildBoundaryOutOfBounds end) + | otherwise -> Nothing + where + count = length children + +-- The pairs of edits the three rules reject, stated on paths and ranges: a +-- replacement with any edit at or below it; a non-empty splice with an edit +-- at or below a child it consumes; two splices of one node whose ranges +-- [a, b) and [c, d) have a < d and c < b. +conflictPairs :: ModelPlan -> [(Int, Int)] +conflictPairs plan = + [ (n, m) + | (n, p, op) <- plan + , (m, q, op') <- plan + , n < m + , conflicts (p, op) (q, op') || conflicts (q, op') (p, op) + ] + where + conflicts (p, MReplace _) (q, _) = p `isPrefixOf` q + conflicts (p, MSplice a b _) (q, MSplice c d _) | p == q = a < d && c < b + conflicts (p, MSplice a b _) (q, _) = case stripPrefix p q of + Just (i : _) -> a < b && a <= i && i < b + _ -> False + +-- Two insertions at one boundary of one node, whose order is the list's. +sameBoundary :: ModelPlan -> Bool +sameBoundary plan = length boundaries /= length (nub boundaries) + where + boundaries = [(p, i) | (_, p, MSplice i j _) <- plan, i == j] + +-- The merge, written over lists: at each node, for each boundary, the +-- insertions there in list order, then the child or what replaces it. +mergeModel :: ModelPlan -> Model -> Model +mergeModel plan = go [] + where + go path model = case [new | (_, p, MReplace new) <- plan, p == path] of + new : _ -> new + [] -> case model of + Leaf _ _ -> model + Branch kind children -> + let splices = sortOn (\(n, _, _, _) -> n) [(n, a, b, xs) | (n, p, MSplice a b xs) <- plan, p == path] + count = length children + insertions i = concat [xs | (_, a, b, xs) <- splices, a == i, b == i] + starting i = [xs | (_, a, b, xs) <- splices, a == i, b > i] + consumed i = or [a <= i && i < b | (_, a, b, _) <- splices] + slot i = case starting i of + xs : _ -> xs + [] + | consumed i -> [] + | otherwise -> [go (path ++ [i]) (children !! i)] + in Branch kind (concat [insertions i ++ (if i < count then slot i else []) | i <- [0 .. count]]) + +-- A valid plan gives the model's merge; an invalid one is rejected for a +-- reason the model agrees with. +propApplyModel :: Model -> Property +propApplyModel model = forAll (genPlan base model) $ \planned -> + let edits = map plannedEdit planned + outcome = Edit.apply base edits + atRoot = [n | (n, Planned _ Nothing) <- zip [0 :: Int ..] planned] + in case modelPlan planned of + Nothing -> label "anchored at the root" $ outcome === Left (EditAtRoot (minimum atRoot)) + Just plan -> + let invalid = invalidSplices model plan + conflicting = conflictPairs plan + valid = null invalid && null conflicting + expected = mergeModel plan model + in checkCoverage $ + cover 30 valid "valid" $ + cover 10 (not (null conflicting)) "conflicting" $ + cover 3 (not (null invalid)) "an invalid splice" $ + if valid + then case outcome of + Right result -> conjoin + [ result === compile expected + , Text.unpack (Green.render result) === source expected + , counterexample "stale cached lengths or offsets" (validCaches result) + ] + Left err -> counterexample ("rejected: " ++ show err) False + else counterexample (show outcome) $ case outcome of + Left (InvalidSplice n err) -> (n, err) `elem` invalid + Left (ConflictingEdits n m) -> (n, m) `elem` conflicting + _ -> False + where + base = compile model + +-- A valid plan with no two insertions at one boundary gives the same tree +-- in any order. +propApplyOrder :: Model -> Property +propApplyOrder model = forAll (genPlan base model) $ \planned -> + let edits = map plannedEdit planned + applicable = case modelPlan planned of + Just plan -> null (invalidSplices model plan) && null (conflictPairs plan) && not (sameBoundary plan) + Nothing -> False + in cover 30 applicable "order-independent plan" $ + if applicable + then forAll (shuffle edits) $ \shuffled -> Edit.apply base shuffled === Edit.apply base edits + else property True + where + base = compile model + +-- Replace each edit's range in the original text, reading every range in +-- the original. +patch :: Text -> [TextEdit] -> Text +patch original edits = TE.decodeUtf8 (B.concat (go 0 edits)) + where + bytes = TE.encodeUtf8 original + go position [] = [B.drop position bytes] + go position (TextEdit range new : rest) = + B.take (start - position) (B.drop position bytes) : TE.encodeUtf8 new : go end rest + where + start = fromIntegral (Range.start range) + end = fromIntegral (Range.end range) + +-- Patching the base's text with the text edits renders the applied tree, +-- and the edits are sorted and apart, so the patch order doesn't matter. +propTextEdits :: Model -> Property +propTextEdits model = forAll (genPlan base model) $ \planned -> + let edits = map plannedEdit planned + in case (Edit.apply base edits, Edit.textEdits base edits) of + (Right result, Right texts) -> conjoin + [ patch (Green.render base) texts === Green.render result + , counterexample ("not sorted and apart: " ++ show texts) (apart texts) + ] + (Left err, Left err') -> err === err' + (outcome, texts) -> counterexample (show (outcome, texts)) False + where + base = compile model + apart texts = and (zipWith (\a b -> Range.end (editRange a) < Range.start (editRange b)) texts (drop 1 texts)) + +-- An empty plan returns the base, and a sibling off every edit's path is +-- reused, not copied. +propApplyShares :: Model -> Model -> Property +propApplyShares left right = ioProperty $ do + tree <- evaluate (compile (Branch Root [left, right])) + same <- makeStableName tree + unchanged <- evaluate (either (error . show) id (Edit.apply tree [])) >>= makeStableName + let first = cursorAt [0] tree + edited <- evaluate (either (error . show) id (Edit.apply tree [Edit.replace first (compile (Leaf Name "new"))])) + case (tree, edited) of + (Node before, Node after) -> do + untouched <- evaluate (childOf 1 before) >>= makeStableName + kept <- evaluate (childOf 1 after) >>= makeStableName + pure $ conjoin + [ counterexample "an empty plan copied the tree" (unchanged == same) + , counterexample "the untouched sibling was copied" (untouched == kept) + ] + _ -> pure (counterexample "the roots are not nodes" False) + +-- A cursor from an equal tree built separately is accepted, with the same +-- result; a cursor from a tree that differs anywhere, here above an equal +-- target, is rejected by its position in the list. +propCompatibility :: Model -> Property +propCompatibility model = forAll (genPlan twin model) $ \planned -> + let edits = map plannedEdit planned + wrapped = compile (Branch Group [model]) + fromOther = [Edit.replace (cursorAt [0] wrapped) (compile (Leaf Name "x"))] + anchoredAtRoot = or [True | Planned _ Nothing <- planned] + in conjoin + [ counterexample "an equal tree built separately" (Edit.apply base edits === Edit.apply twin edits) + , counterexample "a different tree" (Edit.apply base fromOther === Left (EditFromAnotherTree 0)) + , counterexample "a different tree among edits" $ + anchoredAtRoot || Edit.apply base (edits ++ fromOther) == Left (EditFromAnotherTree (length edits)) + ] + where + base = compile model + twin = separately model + +planRegressions :: Property +planRegressions = once $ conjoin + [ -- insertions at the ends of a splice are placed by the merge; inside, they conflict + rendered [Edit.splice root 0 2 [tok "X"], Edit.insertBefore a [tok "I"]] === Right "IXbc" + , rendered [Edit.splice root 0 2 [tok "X"], Edit.insertAfter sp [tok "J"]] === Right "XJbc" + , rendered [Edit.splice root 0 2 [tok "X"], Edit.insertAfter a [tok "K"]] === Left (ConflictingEdits 0 1) + -- insertions at one boundary keep the order of the list + , rendered [Edit.insertBefore sp [tok "P"], Edit.insertBefore sp [tok "Q"]] === Right "aPQ bc" + , rendered [Edit.insertBefore sp [tok "Q"], Edit.insertBefore sp [tok "P"]] === Right "aQP bc" + -- a removed child can't also be replaced; two replacements of one element conflict + , rendered [Edit.remove a, Edit.replace a (tok "Z")] === Left (ConflictingEdits 0 1) + , rendered [Edit.replace a (tok "Z"), Edit.replace a (tok "Z")] === Left (ConflictingEdits 0 1) + , rendered [Edit.replace group (tok "Z"), Edit.remove b] === Left (ConflictingEdits 0 1) + -- the root has no siblings; a token has no children; positions are checked + , rendered [Edit.remove root] === Left (EditAtRoot 0) + , rendered [Edit.replace b (tok "B"), Edit.insertAfter root []] === Left (EditAtRoot 1) + , rendered [Edit.splice a 0 0 []] === Left (InvalidSplice 0 CannotEditTokenChildren) + , rendered [Edit.splice root 3 5 []] === Left (InvalidSplice 0 (ChildBoundaryOutOfBounds 5)) + , rendered [Edit.splice root 3 3 [tok "E"]] === Right "a bcE" + -- the whole tree can be replaced + , rendered [Edit.replace root (tok "r")] === Right "r" + , Edit.textEdits wide [Edit.replace root (tok "r")] === Right [TextEdit (Range.fromLength 0 4) "r"] + -- adjacent edits are merged, and so are edits at one offset through an empty element + , Edit.textEdits wide [Edit.replace a (tok "X"), Edit.replace sp (tok "Y")] === Right [TextEdit (Range.fromLength 0 2) "XY"] + , (Green.render <$> Edit.apply narrow [Edit.insertAfter e [tok "X"], Edit.insertBefore e [tok "Y"]]) === Right "aYXb" + , Edit.textEdits narrow [Edit.insertAfter e [tok "X"], Edit.insertBefore e [tok "Y"]] === Right [TextEdit (Range.fromLength 1 0) "YX"] + , Edit.textEdits wide [] === Right [] + ] + where + tok = Token . Green.token Name + wide = Node (Green.node Root [tok "a", Token (Green.token Space " "), Node (Green.node Group [tok "b", tok "c"])]) + root = Cursor.fromGreen wide + a = cursorAt [0] wide + sp = cursorAt [1] wide + group = cursorAt [2] wide + b = cursorAt [2, 0] wide + narrow = Node (Green.node Root [tok "a", tok "", tok "b"]) + e = cursorAt [1] narrow + rendered edits = Green.render <$> Edit.apply wide edits + +editProperties :: [(String, Property)] +editProperties = + [ ("rewrite gives the model's tree with valid caches", property propRewriteModel) + , ("rewriteM visits the model's elements in preorder", property propRewriteVisits) + , ("rewriteM stops at the first failure", property propRewriteStops) + , ("a rewrite that replaces nothing returns its argument", property propRewriteShares) + , ("a rewrite reuses untouched siblings", property propRewriteSharesSiblings) + , ("a rewrite is the plan of its replacements", property propRewriteIsApply) + , ("rewrite regressions: token and empty roots, longer children", rewriteRegressions) + , ("apply gives the model's merge or the model's rejection", property propApplyModel) + , ("apply is order-independent but for insertions at one boundary", property propApplyOrder) + , ("text edits patch the source to the applied tree", property propTextEdits) + , ("apply shares the base and untouched siblings", property propApplyShares) + , ("edits from an equal tree are accepted, from another rejected", property propCompatibility) + , ("plan regressions: boundaries, conflicts, errors and text edits", planRegressions) + ] diff --git a/test/FoldTests.hs b/test/FoldTests.hs new file mode 100644 --- /dev/null +++ b/test/FoldTests.hs @@ -0,0 +1,158 @@ +{-# LANGUAGE OverloadedStrings #-} + +module FoldTests (foldProperties) where + +import Data.Functor.Compose (Compose (..)) +import Data.Functor.Const (Const (..)) +import Control.DeepSeq (rnf) +import Data.Functor.Identity (Identity (..)) +import Data.Hashable (hash) +import qualified Data.Text as Text +import Graft +import qualified Graft.Cursor as Cursor +import qualified Graft.Green as Green +import Test.QuickCheck +import TestModel + +-- Every model becomes a node by wrapping it in a root, so leaves are tested too. +rooted :: Model -> GreenNode Kind +rooted model = Green.node Root [compile model] + +leaves :: Model -> [(Kind, String)] +leaves (Leaf kind text) = [(kind, text)] +leaves (Branch _ children) = concatMap leaves children + +-- Rewrites the model's leaves independently of the library. +mapLeaves :: (String -> String) -> Model -> Model +mapLeaves f (Leaf kind text) = Leaf kind (f text) +mapLeaves f (Branch kind children) = Branch kind (map (mapLeaves f) children) + +observe :: GreenToken Kind -> (Kind, String) +observe token = (Green.tokenKind token, Text.unpack (Green.text token)) + +retext :: (String -> String) -> GreenToken Kind -> GreenToken Kind +retext f token = Green.token (Green.tokenKind token) (Text.pack (f (Text.unpack (Green.text token)))) + +-- Changes the byte length of most tokens, including empty ones. +grow :: String -> String +grow text = text ++ "é" ++ take 1 text + +-- The fold rebuilds the oracle exactly, so it sees every kind, every token's +-- text and the shape of the tree. +propFoldRebuildsModel :: Model -> Property +propFoldRebuildsModel model = + Green.fold (\token -> uncurry Leaf (observe token)) Branch (rooted model) === Branch Root [model] + +propFoldRendering :: Model -> Property +propFoldRendering model = + let tree = rooted model + in Green.fold Green.text (const Text.concat) tree === Green.renderNode tree + +-- Taking only the first child of each node walks one spine of a DAG whose +-- full size is 2 ^ (bits - 2) tokens, so the fold must not force the rest. +propFoldIsLazy :: Property +propFoldIsLazy = once $ + case halfMax Group of + Node top -> Green.fold Green.text (const (Text.concat . take 1)) top === "x" + Token _ -> counterexample "halfMax is a token" False + +-- The fold visits the elements that a cursor lists as descendants, in the +-- same order, for nodes and for a token on its own. +propFoldMOrder :: Model -> Property +propFoldMOrder model = + let tree = compile model + visited = reverse (runIdentity (Green.foldM (\seen element -> Identity (element : seen)) [] tree)) + in visited === map Cursor.green (Cursor.descendants (Cursor.fromGreen tree)) + +-- In Either the fold stops at the first Left, which is the first leaf with a +-- given kind in source order. +propFoldMStops :: Model -> Property +propFoldMStops model = + let firstSpace = [text | (Space, text) <- leaves model] + step () (Token token) | Green.tokenKind token == Space = Left (observe token) + step () _ = Right () + in either (Just . snd) (const Nothing) (Green.foldM step () (compile model)) + === case firstSpace of { text : _ -> Just text; [] -> Nothing } + +-- The accumulator is evaluated before every step, even by a step that +-- ignores it, so a fold cannot build a chain of thunks. The empty node at the +-- end gives the fold one more step after every token. +propFoldMForcesAccumulator :: Model -> Property +propFoldMForcesAccumulator model = + let step :: Int -> GreenElement Kind -> Identity Int + step _ (Token _) = Identity (error "forced") + step _ (Node _) = Identity 0 + in not (null (leaves model)) ==> + failsWith "forced" (runIdentity (Green.foldM step 0 (compile (Branch Root [model, Branch Group []])))) + +-- The hash depends on how the nodes nest, not only on the tokens and the +-- kinds in order. +propHashKeepsNesting :: Property +propHashKeepsNesting = once $ + let tok text = Token (Green.token 'n' text) + early = Green.node 'r' [Node (Green.node 'g' [tok "a"]), tok "b"] + late = Green.node 'r' [Node (Green.node 'g' [tok "a", tok "b"])] + in counterexample "same hash for different nesting" (hash early /= hash late) + +-- Forcing a tree forces every kind, including a token on its own, the last +-- token of a node, and a nested node. +propForcesEveryKind :: Property +propForcesEveryKind = once $ conjoin + [ failsWith "forced" (rnf (Token (bad "x"))) + , failsWith "forced" (rnf (Node (Green.node (Just 'r') [Token (good "a"), Token (bad "b")]))) + , failsWith "forced" (rnf (Node (Green.node (Just 'r') [Node (Green.node (Just (error "forced")) [])]))) + , rnf (Node (Green.node (Just 'r') [Token (good "a")])) === () + ] + where + good = Green.token (Just 'n') + bad = Green.token (Just (error "forced" :: Char)) + +propMapIsTraverse :: Model -> Property +propMapIsTraverse model = + let tree = rooted model + in Green.map (retext grow) tree === runIdentity (Green.traverse (Identity . retext grow) tree) + +propTraverseIdentity :: Model -> Property +propTraverseIdentity model = + let tree = rooted model + in runIdentity (Green.traverse Identity tree) === tree + +propTraverseOrder :: Model -> Property +propTraverseOrder model = + map observe (getConst (Green.traverse (\token -> Const [token]) (rooted model))) + === leaves model + +propTraverseRewrites :: Model -> Property +propTraverseRewrites model = + let edited = runIdentity (Green.traverse (Identity . retext grow) (rooted model)) + in conjoin + [ Node edited === Node (Green.node Root [compile (mapLeaves grow model)]) + , counterexample "stale cached lengths or offsets" (validCaches (Node edited)) + , Text.unpack (Green.renderNode edited) === source (mapLeaves grow model) + ] + +-- The composition law, with two effects that fail on different tokens. +propTraverseComposition :: Model -> Property +propTraverseComposition model = + let tree = rooted model + f token = if Green.text token == "a" then Nothing else Just (retext grow token) + g token = if Text.length (Green.text token) > 12 then Left (observe token) else Right token + in getCompose (Green.traverse (Compose . fmap g . f) tree) + === fmap (Green.traverse g) (Green.traverse f tree) + +foldProperties :: [(String, Property)] +foldProperties = + [ ("foldM visits the descendants in preorder", property propFoldMOrder) + , ("foldM stops at the first failure", property propFoldMStops) + , ("foldM forces the accumulator before each step", property propFoldMForcesAccumulator) + , ("hashes keep the nesting", propHashKeepsNesting) + , ("forcing a tree forces every kind", propForcesEveryKind) + , ("fold rebuilds the model", property propFoldRebuildsModel) + , ("fold with concatenation renders", property propFoldRendering) + , ("fold visits only the children it needs", propFoldIsLazy) + , ("map is traverse with Identity", property propMapIsTraverse) + , ("traverse with Identity is the identity", property propTraverseIdentity) + , ("traverse visits tokens in source order", property propTraverseOrder) + , ("traverse rewrites tokens and measures nodes again", property propTraverseRewrites) + , ("traverse composes", property propTraverseComposition) + ] diff --git a/test/LineIndexTests.hs b/test/LineIndexTests.hs new file mode 100644 --- /dev/null +++ b/test/LineIndexTests.hs @@ -0,0 +1,116 @@ +module LineIndexTests (lineIndexProperties) where + +import Data.Char (ord) +import qualified Data.Text as Text +import Graft +import qualified Graft.LineIndex as LineIndex +import Test.QuickCheck +import TestModel (byteLength, genText) + +-- An independent oracle over Strings: each character's byte offset, line, +-- byte column and UTF-16 column, plus the position of the end of the text. +data Place = Place + { placeOffset :: TextLength + , placeLine :: Int + , placeUtf8 :: Int + , placeUtf16 :: Int + , placeAfterCarriage :: Bool + } + deriving (Show) + +places :: String -> [Place] +places = go 0 0 0 0 False + where + go offset line utf8 utf16 afterCarriage text = Place offset line utf8 utf16 afterCarriage : case text of + [] -> [] + '\r' : rest@('\n' : _) -> go (offset + 1) line (utf8 + 1) (utf16 + 1) True rest + c : rest + | c == '\n' || c == '\r' -> go (offset + 1) (line + 1) 0 0 False rest + | otherwise -> go (offset + byteLength [c]) line (utf8 + width8 c) (utf16 + width16 c) False rest + width8 c = fromIntegral (byteLength [c]) + width16 c = if ord c > 0xFFFF then 2 else 1 + +terminators :: String -> Int +terminators ('\r' : '\n' : rest) = 1 + terminators rest +terminators (c : rest) | c == '\r' || c == '\n' = 1 + terminators rest +terminators (_ : rest) = terminators rest +terminators [] = 0 + +propPositions :: Property +propPositions = forAll genText $ \text -> + let index = LineIndex.fromText (Text.pack text) + in conjoin + [ LineIndex.lineCount index === terminators text + 1 + , conjoin + [ counterexample (show place) $ conjoin + [ LineIndex.utf8Position (placeOffset place) index === Just (Utf8Position (placeLine place) (placeUtf8 place)) + , LineIndex.utf16Position (placeOffset place) index === Just (Utf16Position (placeLine place) (placeUtf16 place)) + , placeAfterCarriage place .||. conjoin + [ LineIndex.fromUtf8Position (Utf8Position (placeLine place) (placeUtf8 place)) index === Just (placeOffset place) + , LineIndex.fromUtf16Position (Utf16Position (placeLine place) (placeUtf16 place)) index === Just (placeOffset place) + ] + ] + | place <- places text + ] + ] + +propInvalid :: Property +propInvalid = forAll genText $ \text -> + let index = LineIndex.fromText (Text.pack text) + size = byteLength text + starts = map placeOffset (places text) + inside = [offset | offset <- [0 .. size], offset `notElem` starts] + in conjoin + [ LineIndex.utf8Position (-1) index === Nothing + , LineIndex.utf8Position (size + 1) index === Nothing + , LineIndex.utf16Position (size + 1) index === Nothing + , conjoin [LineIndex.utf16Position offset index === Nothing | offset <- inside] + , conjoin [LineIndex.utf8Position offset index === Nothing | offset <- inside] + , LineIndex.fromUtf16Position (Utf16Position (LineIndex.lineCount index) 0) index === Nothing + , LineIndex.fromUtf16Position (Utf16Position 0 (-1)) index === Nothing + -- A column between the two halves of a surrogate pair, including + -- one at the end of a line or of the text. + , conjoin + [ LineIndex.fromUtf16Position (Utf16Position (placeLine here) (placeUtf16 here + 1)) index === Nothing + | (here, next) <- zip (places text) (drop 1 (places text)) + , placeLine next == placeLine here + , placeUtf16 next == placeUtf16 here + 2 + ] + -- A UTF-8 column inside a multibyte character. + , conjoin + [ LineIndex.fromUtf8Position (Utf8Position (placeLine here) (placeUtf8 here + k)) index === Nothing + | (here, next) <- zip (places text) (drop 1 (places text)) + , placeLine next == placeLine here + , k <- [1 .. placeUtf8 next - placeUtf8 here - 1] + ] + ] + +regressions :: Property +regressions = once $ conjoin + [ LineIndex.lineCount (LineIndex.fromText (Text.pack "")) === 1 + , LineIndex.lineCount (LineIndex.fromText (Text.pack "a\r\nb\rc\n")) === 4 + , map (`LineIndex.lineStart` LineIndex.fromText (Text.pack "a\r\nb\rc\n")) [0 .. 4] === map (fmap TextLength) [Just 0, Just 3, Just 5, Just 7, Nothing] + -- Columns past the end of a line clamp to its content, before "\r\n". + , LineIndex.fromUtf16Position (Utf16Position 0 99) (LineIndex.fromText (Text.pack "ab\r\ncd")) === Just 2 + , LineIndex.fromUtf8Position (Utf8Position 1 99) (LineIndex.fromText (Text.pack "ab\r\ncd")) === Just 6 + -- U+1F600 takes four bytes and two UTF-16 code units. + , LineIndex.utf16Position 5 (LineIndex.fromText (Text.pack "x\x1F600y")) === Just (Utf16Position 0 3) + , LineIndex.fromUtf16Position (Utf16Position 0 2) (LineIndex.fromText (Text.pack "x\x1F600y")) === Nothing + , LineIndex.fromUtf16Position (Utf16Position 0 3) (LineIndex.fromText (Text.pack "x\x1F600y")) === Just 5 + -- UTF-8 columns and offsets inside a character are rejected, as UTF-16 ones are. + , LineIndex.fromUtf8Position (Utf8Position 0 2) (LineIndex.fromText (Text.pack "\x1F600x")) === Nothing + , LineIndex.fromUtf8Position (Utf8Position 0 4) (LineIndex.fromText (Text.pack "\x1F600x")) === Just 4 + , LineIndex.utf8Position 2 (LineIndex.fromText (Text.pack "\x1F600x")) === Nothing + -- A surrogate pair last on its line is not skipped by the clamp. + , LineIndex.fromUtf16Position (Utf16Position 0 1) (LineIndex.fromText (Text.pack "\x1F600")) === Nothing + , LineIndex.fromUtf16Position (Utf16Position 0 2) (LineIndex.fromText (Text.pack "a\x1F600\nb")) === Nothing + , LineIndex.fromUtf16Position (Utf16Position 0 2) (LineIndex.fromText (Text.pack "\x1F600")) === Just 4 + , LineIndex.fromUtf16Position (Utf16Position 0 9) (LineIndex.fromText (Text.pack "\x1F600")) === Just 4 + ] + +lineIndexProperties :: [(String, Property)] +lineIndexProperties = + [ ("line index positions agree with a String oracle", propPositions) + , ("line index rejects offsets and columns inside characters, and missing lines", propInvalid) + , ("line index terminators, clamping and surrogate regressions", regressions) + ] diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,533 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main (main) where + +import AstTests (astProperties) +import BuilderTests (builderProperties) +import ChildEditTests (childEditProperties) +import CursorTests (cursorProperties) +import EditTests (editProperties) +import FoldTests (foldProperties) +import Control.Monad (unless) +import Data.Bits (finiteBitSize) +import Data.Hashable (hash) +import Data.List (find, isPrefixOf) +import qualified Data.Text as Text +import Graft +import qualified Graft.Cursor as Cursor +import qualified Graft.Edit as Edit +import qualified Graft.Green as Green +import qualified Graft.Range as Range +import LineIndexTests (lineIndexProperties) +import System.Exit (exitFailure) +import Test.QuickCheck +import TestModel + +propRendering :: Model -> Property +propRendering model = + Text.unpack (Green.render (compile model)) === source model + +propLengths :: Model -> Property +propLengths model = conjoin + [ counterexample (show path) $ + case elementAt path (compile model) of + Left err -> counterexample (show err) False + Right tree -> Green.length tree === byteLength (source selected) + | (path, _, selected, _) <- contexts model + ] + +propToken :: Property +propToken = forAll genText $ \text -> + let token = Green.token Name (Text.pack text) + in conjoin + [ Text.unpack (Green.text token) === text + , Green.text token === Text.pack text + , Green.tokenLength token === byteLength text + , Green.tokenKind token === Name + ] + +propChunking :: Property +propChunking = forAll genText $ \text -> + forAll (chooseInt (0, length text)) $ \n -> + let (before, after) = splitAt n text + leaf s = Token (Green.token Name (Text.pack s)) + split = Green.node Root [leaf before, Node (Green.node Group [leaf "", leaf after])] + whole = Green.node Root [leaf text] + in conjoin + [ Green.renderNode split === Green.renderNode whole + , Green.nodeLength split === byteLength text + ] + +propReplacement :: Model -> Model -> Property +propReplacement model new = + forAll (elements (contexts model)) $ \(path, prefix, selected, suffix) -> + checkCoverage $ + cover 10 (null path) "root" $ + cover 10 (not (null path)) "non-root" $ + cover 5 (length path > 1) "nested" $ + cover 10 (isLeaf selected) "token target" $ + cover 10 (not (isLeaf selected)) "node target" $ + cover 10 (isLeaf new) "token replacement" $ + cover 10 (not (isLeaf new)) "node replacement" $ + case replaceAt path (compile new) (compile model) of + Left err -> counterexample (show err) False + Right edited -> conjoin + [ Text.unpack (Green.render edited) === prefix ++ source new ++ suffix + , elementAt path edited === Right (compile new) + , Green.length edited + byteLength (source selected) + === byteLength (source model) + byteLength (source new) + , counterexample "all edited caches" (validCaches edited) + , Text.unpack (Green.render (compile model)) === source model + , conjoin + [ counterexample ("unaffected path " ++ show other) $ + elementAt other edited === Right (compile subtree) + | (other, _, subtree, _) <- contexts model + , not (path `isPrefixOf` other || other `isPrefixOf` path) + ] + ] + +-- Mapping kinds keeps text and caches; equal trees built separately hash alike. +propKindsAndHashes :: Model -> Property +propKindsAndHashes model = + let tree = compile model + next kind = if kind == maxBound then minBound else succ kind + in conjoin + [ fmap id tree === tree + , fmap (next . next) tree === fmap next (fmap next tree) + , Green.render (fmap fromEnum tree) === Green.render tree + , Green.length (fmap next tree) === Green.length tree + , Green.kind (fmap next tree) === next (Green.kind tree) + , counterexample "mapped caches" (validCaches (fmap next tree)) + , hash (fmap fromEnum tree) === hash (fmap fromEnum (compile model)) + , hash (Cursor.range (Cursor.fromGreen tree)) === hash (Range.fromLength 0 (byteLength (source model))) + ] + +propIdentity :: Model -> Property +propIdentity model = forAll (elements (contexts model)) $ \(path, _, selected, _) -> + replaceAt path (compile selected) (compile model) === Right (compile model) + +propInvalidPaths :: Model -> Model -> Property +propInvalidPaths model new = + forAll (elements (contexts model)) $ \(path, _, selected, _) -> + let (step, err) = case selected of + Leaf _ _ -> (0, CannotDescendIntoToken) + Branch _ children -> (length children, ChildIndexOutOfBounds (length children)) + invalid = path ++ [step] + negative = path ++ [-1] + root = compile model + in conjoin + [ elementAt invalid root === Left err + , replaceAt invalid (compile new) root === Left err + , elementAt negative root === Left (NegativeChildIndex (-1)) + , replaceAt negative (compile new) root === Left (NegativeChildIndex (-1)) + ] + +propChildReplacement :: [Model] -> Model -> Property +propChildReplacement children new = + let node = Green.node Root (map compile children) + in forAll (chooseInt (-1, length children)) $ \i -> + let expected + | i < 0 = Left (NegativeChildBoundary i) + | i >= length children = Left (ChildBoundaryOutOfBounds i) + | otherwise = Right (compile (Branch Root + (take i children ++ [new] ++ drop (i + 1) children))) + in (Node <$> Green.replaceChild i (compile new) node) === expected + +-- Cursor descriptions deliberately compare an occurrence's path and range as +-- well as its green value, so equal shared subtrees cannot be confused. +describe :: Cursor Kind -> (Path, GreenElement Kind, TextRange) +describe cursor = (Cursor.path cursor, Cursor.green cursor, Cursor.range cursor) + +modelOccurrences :: Model -> [(Path, GreenElement Kind, TextRange)] +modelOccurrences model = + [ (path, compile selected, Range.fromLength (byteLength prefix) (byteLength (source selected))) + | (path, prefix, selected, _) <- contexts model + ] + +isLeaf :: Model -> Bool +isLeaf (Leaf _ _) = True +isLeaf _ = False + +propCursorOccurrences :: Model -> Property +propCursorOccurrences model = + let cursor = Cursor.fromGreen (compile model) + expected = modelOccurrences model + leafPaths = [path | (path, _, selected, _) <- contexts model, isLeaf selected] + in conjoin + [ map describe (Cursor.descendants cursor) === expected + , map Cursor.path (Cursor.descendantTokens cursor) === leafPaths + , conjoin + [ fmap describe (Cursor.at path cursor) === Right occurrence + | occurrence@(path, _, _) <- expected + ] + ] + +propCursorNavigation :: Model -> Property +propCursorNavigation model = forAll (elements (contexts model)) $ \(path, _, selected, _) -> + checkCoverage $ + cover 10 (null path) "root" $ + cover 10 (not (null path)) "non-root" $ + cover 5 (length path > 1) "nested" $ + cover 5 (null (source selected)) "empty focus" $ + case Cursor.at path modelRoot of + Left err -> counterexample (show err) False + Right focus -> + let expectedChildren = + [ occurrence + | occurrence@(other, _, _) <- modelOccurrences model + , length other == length path + 1, path `isPrefixOf` other + ] + expectedParent = case reverse path of + [] -> Nothing + _ : rest -> find (\(other, _, _) -> other == reverse rest) (modelOccurrences model) + expectedSibling delta = case reverse path of + [] -> Nothing + index : rest -> find (\(other, _, _) -> other == reverse rest ++ [index + delta]) + (modelOccurrences model) + maybeFirst [] = Nothing + maybeFirst (value : _) = Just value + in conjoin + [ describe (Cursor.root focus) === describe modelRoot + , map Cursor.path (Cursor.ancestors focus) === [take n path | n <- reverse [0 .. length path - 1]] + , fmap describe (Cursor.parent focus) === expectedParent + , map describe (Cursor.children focus) === expectedChildren + , fmap describe (Cursor.firstChild focus) === maybeFirst expectedChildren + , fmap describe (Cursor.lastChild focus) === maybeFirst (reverse expectedChildren) + , fmap describe (Cursor.nextSibling focus) === expectedSibling 1 + , fmap describe (Cursor.previousSibling focus) === expectedSibling (-1) + , fmap describe (Cursor.nextSibling focus >>= Cursor.previousSibling) + === (describe focus <$ Cursor.nextSibling focus) + , fmap describe (Cursor.previousSibling focus >>= Cursor.nextSibling) + === (describe focus <$ Cursor.previousSibling focus) + , case selected of + Leaf _ _ -> fmap Cursor.green (Cursor.childAt 0 focus) === Left CannotDescendIntoToken + Branch _ kids -> conjoin + [ fmap describe (Cursor.childAt i focus) === Right occurrence + | (i, occurrence) <- zip [0 .. length kids - 1] expectedChildren + ] + , fmap Cursor.green (Cursor.childAt (-1) focus) === Left (NegativeChildIndex (-1)) + , conjoin + [ fmap Cursor.green (Cursor.at relative focus) + === elementAt relative (compile selected) + | (relative, _, _, _) <- contexts selected + ] + ] + where + modelRoot = Cursor.fromGreen (compile model) + +propCursorTokenNavigation :: Model -> Property +propCursorTokenNavigation model = + forAll (elements (contexts model)) $ \(path, _, _, _) -> + case Cursor.at path (Cursor.fromGreen (compile model)) of + Left err -> counterexample (show err) False + Right focus -> + let leafPaths = [other | (other, _, selected, _) <- contexts model, isLeaf selected] + inside = filter (path `isPrefixOf`) leafPaths + after = filter (\other -> other > path && not (path `isPrefixOf` other)) leafPaths + before = filter (< path) leafPaths + maybeHead [] = Nothing + maybeHead (value : _) = Just value + in conjoin + [ map Cursor.path (Cursor.descendantTokens focus) === inside + , fmap Cursor.path (Cursor.firstToken focus) === maybeHead inside + , fmap Cursor.path (Cursor.lastToken focus) === maybeHead (reverse inside) + , fmap Cursor.path (Cursor.nextToken focus) === maybeHead after + , fmap Cursor.path (Cursor.previousToken focus) === maybeHead (reverse before) + ] + +propCursorWalk :: Model -> Property +propCursorWalk model = conjoin + [ map (fmap Cursor.path) (Cursor.walk (Cursor.fromGreen (compile model))) === walk [] model + , conjoin + [ fmap (Text.unpack . Cursor.text) (Cursor.at path (Cursor.fromGreen (compile model))) === Right (source selected) + | (path, _, selected, _) <- contexts model + ] + ] + where + walk path (Leaf _ _) = [Enter path, Leave path] + walk path (Branch _ children) = + Enter path : concat [walk (path ++ [i]) child | (i, child) <- zip [0 ..] children] ++ [Leave path] + +-- Replacing through a cursor keeps the rest of the tree, shifts the ranges +-- after the edit, and leaves the cursor on the original. +propCursorReplacement :: Model -> Model -> Property +propCursorReplacement model replacement = + forAll (elements (contexts model)) $ \(path, prefix, selected, suffix) -> + case Cursor.at path (Cursor.fromGreen root) of + Left err -> counterexample (show err) False + Right focus -> + let edited = applied root [Edit.replace focus (compile replacement)] + expectedRange = Range.fromLength (byteLength prefix) (byteLength (source replacement)) + in conjoin + [ Text.unpack (Green.render edited) === prefix ++ source replacement ++ suffix + , counterexample "rebuilt caches" (validCaches edited) + , fmap Cursor.range (Cursor.at path (Cursor.fromGreen edited)) === Right expectedRange + , Text.unpack (Green.render (Cursor.green focus)) === source selected + , Cursor.tree focus === root + , conjoin + [ fmap describe (Cursor.at other (Cursor.fromGreen edited)) + === Right (other, compile subtree, + Range.fromLength expectedStart (byteLength (source subtree))) + | (other, otherPrefix, subtree, _) <- contexts model + , not (path `isPrefixOf` other || other `isPrefixOf` path) + , let shift = if other > path + then byteLength (source replacement) - byteLength (source selected) + else 0 + , let expectedStart = byteLength otherPrefix + shift + ] + ] + where + root = compile model + +propCursorInvalidPaths :: Model -> Property +propCursorInvalidPaths model = forAll (elements (contexts model)) $ \(path, _, selected, _) -> + let (index, err) = case selected of + Leaf _ _ -> (0, CannotDescendIntoToken) + Branch _ kids -> (length kids, ChildIndexOutOfBounds (length kids)) + cursor = Cursor.fromGreen (compile model) + in conjoin + [ fmap Cursor.green (Cursor.at (path ++ [index]) cursor) === Left err + , fmap Cursor.green (Cursor.at (path ++ [-1]) cursor) === Left (NegativeChildIndex (-1)) + ] + +offsetPaths :: TokenAtOffset (Cursor Kind) -> TokenAtOffset Path +offsetPaths NoToken = NoToken +offsetPaths (SingleToken cursor) = SingleToken (Cursor.path cursor) +offsetPaths (BetweenTokens left right) = BetweenTokens (Cursor.path left) (Cursor.path right) + +propCursorOffsetLookup :: Model -> Property +propCursorOffsetLookup model = + forAll (elements (contexts model)) $ \(scope, _, _, _) -> + forAll (chooseInteger (0, toInteger (byteLength (source model)) + 1)) $ \rawOffset -> + let offset = fromInteger rawOffset + touching = + [ path + | (path, prefix, Leaf _ text, _) <- contexts model + , scope `isPrefixOf` path + , not (null text) + , byteLength prefix <= offset + , offset <= byteLength prefix + byteLength text + ] + expected = case touching of + [] -> NoToken + [path] -> SingleToken path + left : right : _ -> BetweenTokens left right + in case Cursor.at scope (Cursor.fromGreen (compile model)) of + Left err -> counterexample (show err) False + Right focus -> offsetPaths (Cursor.tokenAt offset focus) === expected + +propCoveringRange :: Model -> Property +propCoveringRange model = + forAll (chooseInteger (0, toInteger len + 1)) $ \a -> + forAll (chooseInteger (0, toInteger len + 1)) $ \b -> + let start = fromInteger (min a b) + end = fromInteger (max a b) + query = Range.fromLength start (end - start) + containing = + [ path + | (path, prefix, selected, _) <- contexts model + , byteLength prefix <= start + , end <= byteLength prefix + byteLength (source selected) + ] + -- Lexicographic maximum under the leftmost covering top-level branch: + -- retain an initial chain only, never jump to an ambiguous later sibling. + expected = case containing of + [] -> Nothing + first : rest -> Just (foldl descend first rest) + descend current candidate + | current `isPrefixOf` candidate = candidate + | otherwise = current + in fmap Cursor.path (Cursor.covering query (Cursor.fromGreen (compile model))) === expected + where + len = byteLength (source model) + +propRanges :: NonNegative Integer -> NonNegative Integer -> NonNegative Integer -> Property +propRanges (NonNegative rawStart) (NonNegative rawLen) (NonNegative rawPoint) = + let start = fromInteger rawStart + len = fromInteger rawLen + point = fromInteger rawPoint + range = Range.fromLength start len + in conjoin + [ Range.start range === start + , Range.end range === start + len + , Range.length range === len + , Range.isEmpty range === (len == 0) + , Range.fromEnds start (start + len) === Just range + , Range.member point range === (start <= point && point < start + len) + , Range.fromLength (start + len) 0 `Range.isSubrangeOf` range === True + , range `Range.isSubrangeOf` Range.fromLength 0 (start + len + 1) === True + , Range.fromLength 0 (start + len + 1) `Range.isSubrangeOf` range === False + , if len > 0 then Range.fromEnds (start + len) start === Nothing else property True + ] + +-- Error values are strict in their positions, so forcing one, as rnf does, +-- forces the positions it reports. +strictErrors :: Property +strictErrors = once $ conjoin + [ failsWith "undefined" (NegativeChildBoundary undefined) + , failsWith "undefined" (ReversedChildRange 1 undefined) + , failsWith "undefined" (ChildIndexOutOfBounds undefined) + , failsWith "undefined" (CheckpointOutOfBounds undefined 1) + ] + +-- Ranges that would break the start <= end invariant, or start before the +-- text, are rejected rather than built. +invalidRanges :: Property +invalidRanges = once $ conjoin + [ failsWith "invalid range" (Range.fromLength 5 (-3)) + , failsWith "invalid range" (Range.fromLength (-1) 2) + , failsWith "invalid range" (Range.fromLength maxBound 1) + , Range.end (Range.fromLength 0 maxBound) === maxBound + , Range.fromEnds (-5) 3 === Nothing + , Range.fromEnds 5 2 === Nothing + , Range.fromEnds 0 0 === Just (Range.fromLength 0 0) + ] + +cursorRegressions :: Property +cursorRegressions = once $ conjoin + [ map Cursor.path (Cursor.descendantTokens tree) === [[1, 0], [1, 1], [2], [3, 0], [3, 1], [5], [6]] + , fmap Cursor.path (Cursor.firstToken tree) === Just [1, 0] + , fmap Cursor.path (Cursor.lastToken tree) === Just [6] + , fmap Cursor.path (Cursor.firstChild tree >>= Cursor.nextToken) === Just [1, 0] + , fmap Cursor.path (Cursor.lastChild tree >>= Cursor.previousToken) === Just [5] + , atPath [1, 1] (fmap Cursor.path . Cursor.nextToken) (Just [2]) + , atPath [2] (fmap Cursor.path . Cursor.nextToken) (Just [3, 0]) + , atPath [5] (fmap Cursor.path . Cursor.previousToken) (Just [3, 1]) + , atPath [3] (fmap Cursor.path . Cursor.previousToken) (Just [2]) + , atPath [3] (fmap Cursor.path . Cursor.nextToken) (Just [5]) + , atPath [3, 0] Cursor.range (Range.fromLength 1 4) + , offsetPaths (Cursor.tokenAt 0 tree) === SingleToken [1, 1] + , offsetPaths (Cursor.tokenAt 1 tree) === BetweenTokens [1, 1] [3, 0] + , offsetPaths (Cursor.tokenAt 3 tree) === SingleToken [3, 0] + , offsetPaths (Cursor.tokenAt 5 tree) === BetweenTokens [3, 0] [5] + , offsetPaths (Cursor.tokenAt 6 tree) === SingleToken [5] + , offsetPaths (Cursor.tokenAt 7 tree) === NoToken + , atPath [3] (offsetPaths . Cursor.tokenAt 1) (SingleToken [3, 0]) + , atPath [3] (offsetPaths . Cursor.tokenAt 0) NoToken + , fmap Cursor.path (Cursor.covering (Range.fromLength 0 0) tree) === Just [0] + , fmap Cursor.path (Cursor.covering (Range.fromLength 1 0) tree) === Just [1, 1] + , fmap Cursor.path (Cursor.covering (Range.fromLength 6 0) tree) === Just [5] + , fmap Cursor.path (Cursor.covering (Range.fromLength 1 4) tree) === Just [3, 0] + , fmap Cursor.path (Cursor.covering (Range.fromLength 0 5) tree) === Just [] + , fmap Cursor.path (Cursor.covering (Range.fromLength 6 1) tree) === Nothing + , tokensEmpty (Cursor.fromGreen (Node (Green.node Group []))) + , offsetPaths (Cursor.tokenAt 0 (Cursor.fromGreen (tok ""))) === NoToken + , fmap Cursor.path (Cursor.firstToken (Cursor.fromGreen (tok ""))) === Just [] + , Cursor.range sharedSecond === Range.fromLength 1 1 + -- A cursor shows its parts with the parentheses each needs. + , fmap show (Cursor.childAt 1 (Cursor.fromGreen (Node (Green.node Root [tok "a", tok "b"])))) + === Right "Cursor [1] (Range.fromLength 1 1) (Token (Green.token Name \"b\"))" + -- Abstract values show as the public calls that rebuild them. + , show (Just (Range.fromLength 5 3)) === "Just (Range.fromLength 5 3)" + , show (Node (Green.node Group [Token (Green.token Space "\t")])) + === "Node (Green.node Group [Token (Green.token Space \"\\t\")])" + , Cursor.path sharedSecond === [1] + , Cursor.green sharedSecond === shared + , fmap Green.render (Edit.apply (Cursor.tree sharedSecond) [Edit.replace sharedSecond (tok "long")]) === Right "along" + , Cursor.range sharedSecond === Range.fromLength 1 1 + , Range.end (Cursor.range hugeCursor) === 2 ^ hugeDepth + , offsetPaths (Cursor.tokenAt (2 ^ hugeDepth) hugeCursor) + === SingleToken (replicate hugeDepth 1) + ] + where + tok = Token . Green.token Name + empty = Node (Green.node Group []) + tree = Cursor.fromGreen (Node (Green.node Root + [ empty, Node (Green.node Group [tok "", tok "a", empty]), tok "" + , Node (Green.node Group [tok "😀", tok ""]), empty, tok "b", tok "" + ])) + atPath path inspect expected = case Cursor.at path tree of + Left err -> counterexample (show err) False + Right focus -> inspect focus === expected + tokensEmpty cursor = conjoin + [ map Cursor.path (Cursor.descendantTokens cursor) === [] + , fmap Cursor.path (Cursor.firstToken cursor) === Nothing + , fmap Cursor.path (Cursor.lastToken cursor) === Nothing + , offsetPaths (Cursor.tokenAt 0 cursor) === NoToken + ] + shared = Node (Green.node Group [tok "a"]) + sharedSecond = case Cursor.childAt 1 (Cursor.fromGreen (Node (Green.node Root [shared, shared]))) of + Right cursor -> cursor + Left err -> error (show err) + hugeCursor = Cursor.fromGreen (iterate (\child -> Node (Green.node Group [child, child])) (tok "x") !! hugeDepth) + +-- Shared subtrees can describe more text than an Int can count. Building or +-- editing such a node fails instead of wrapping its length, which once let +-- render write outside its buffer. +lengthOverflow :: Property +lengthOverflow = once $ conjoin + [ overflows (Green.node Root [half, half]) + , overflows (Green.node Root [half, Node (Green.node Group [half])]) + , overflows (edited (Green.replaceChild 1 half (Green.node Root [half, tok "x"]))) + , overflows (edited (Green.insertChild 1 half (Green.node Root [half]))) + , overflows (edited (Green.spliceChildren 0 0 [half, half] (Green.node Root []))) + , overflows (Edit.apply wide [Edit.replace (edited (Cursor.at [1] (Cursor.fromGreen wide))) half]) + , overflows (Green.render (Node (Green.node Root [half, half, half, half, tok "AB"]))) + , Green.length half === TextLength (2 ^ (finiteBitSize (0 :: Int) - 2)) + , Green.length (Node (Green.node Root [half, Node (Green.node Group [])])) === Green.length half + ] + where + half = halfMax Group + wide = Node (Green.node Root [half, tok "x"]) + edited :: Show e => Either e a -> a + edited = either (error . show) id + tok = Token . Green.token Name + +regressions :: Property +regressions = once $ conjoin + [ Green.renderNode empty === "" + , Green.nodeLength empty === 0 + , Green.renderNode original === "x\t{- keep -}\r\n😀e\x0301\0" + , Green.nodeLength original === 22 + , fmap Green.renderNode (Green.replaceChild 0 (tok "y") original) + === Right "y\t{- keep -}\r\n😀e\x0301\0" + , Green.length huge === 2 ^ hugeDepth + , Green.nodeKind original === Root + , Green.kind (tok "x") === Name + , fmap Green.render (replaceAt [] (tok "new") (Node original)) === Right "new" + , Green.replaceChild maxBound (tok "x") empty === Left (ChildBoundaryOutOfBounds maxBound) + ] + where + empty = Green.node Root [] + tok = Token . Green.token Name + original = Green.node Root + [ tok "x" + , Token (Green.token Space "\t") + , Token (Green.token Comment "{- keep -}") + , Node (Green.node Group [tok "\r\n", tok "😀e\x0301\0", tok ""]) + ] + -- A tiny shared DAG with a logical size of 2 ^ hugeDepth. Never render it. + huge = iterate (\child -> Node (Green.node Group [child, child])) (tok "x") !! hugeDepth + +main :: IO () +main = do + results <- sequence $ + [ run "lossless rendering" propRendering + , run "cached UTF-8 lengths at every path" propLengths + , run "token round-trip and byte length" propToken + , run "independent token boundaries" propChunking + , run "replacement source, caches and unaffected branches" propReplacement + , run "identity replacement" propIdentity + , run "kind mapping and structural hashing" propKindsAndHashes + , run "invalid paths" propInvalidPaths + , run "immediate child replacement" propChildReplacement + , run "empty, trivia, Unicode and unbounded-length regressions" regressions + , run "cursor occurrences and source ranges" propCursorOccurrences + , run "cursor parent, child and sibling navigation" propCursorNavigation + , run "cursor token navigation" propCursorTokenNavigation + , run "enter/leave walk and occurrence text" propCursorWalk + , run "replacement through a cursor and shifted ranges" propCursorReplacement + , run "cursor invalid paths" propCursorInvalidPaths + , run "boundary-aware token lookup" propCursorOffsetLookup + , run "covering range lookup" propCoveringRange + , run "half-open range invariants" propRanges + , run "invalid ranges are rejected" invalidRanges + , run "error values are strict in their positions" strictErrors + , run "cursor empty, boundary, shared-occurrence and large-range regressions" cursorRegressions + , run "length overflow fails instead of wrapping" lengthOverflow + ] ++ [run title prop | (title, prop) <- builderProperties ++ childEditProperties ++ cursorProperties ++ editProperties ++ foldProperties ++ astProperties ++ lineIndexProperties] + unless (all isSuccess results) exitFailure + where + run title prop = do + putStrLn title + quickCheckWithResult stdArgs {maxSuccess = 1000} prop diff --git a/test/TestModel.hs b/test/TestModel.hs new file mode 100644 --- /dev/null +++ b/test/TestModel.hs @@ -0,0 +1,168 @@ +module TestModel + ( Kind (..), Model (..), scalar, genChar, genText, genKind, genModel + , compile, source, byteLength, validCaches, contexts, hugeDepth, halfMax, overflows, failsWith + , PathEditError (..), elementAt, replaceAt, applied, spliceChildrenAt, insertChildAt, removeChildAt + ) where + +import Control.Exception (ErrorCall (..), evaluate, try) +import Data.Bits (finiteBitSize) +import Data.List (isInfixOf) +import Data.Char (chr, ord) +import qualified Data.Text as Text +import Graft +import qualified Graft.Cursor as Cursor +import qualified Graft.Edit as Edit +import qualified Graft.Green as Green +import qualified Graft.Range as Range +import Test.QuickCheck + +data Kind = Root | Group | Name | Space | Comment + deriving (Eq, Show, Enum, Bounded) + +-- The oracle stores no lengths and renders through String, independently of +-- the library's cached representation and text builder. +data Model = Branch Kind [Model] | Leaf Kind String + deriving (Eq, Show) + +instance Arbitrary Model where + arbitrary = sized genModel + shrink (Leaf kind text) = [Leaf kind s | s <- shrink text, all scalar s] + shrink (Branch kind children) = + children ++ [Branch kind xs | xs <- shrinkList shrink children] + +scalar :: Char -> Bool +scalar c = ord c < 0xD800 || ord c > 0xDFFF + +genChar :: Gen Char +genChar = frequency + [ (5, elements "abcXYZ09 \t\r\n\0") + , (3, elements ['é', 'λ', '中', '\x0301', '\x1F600', '\x10FFFF']) + , (1, chr <$> oneof [chooseInt (0, 0xD7FF), chooseInt (0xE000, 0x10FFFF)]) + ] + +genText :: Gen String +genText = chooseInt (0, 20) >>= \n -> vectorOf n genChar + +genKind :: Gen Kind +genKind = elements [minBound .. maxBound] + +genModel :: Int -> Gen Model +genModel size + | size <= 0 = Leaf <$> genKind <*> genText + | otherwise = frequency + [ (2, Leaf <$> genKind <*> genText) + , (3, do + count <- chooseInt (0, min 5 size) + Branch <$> genKind <*> vectorOf count (genModel (size `div` (count + 1)))) + ] + +compile :: Model -> GreenElement Kind +compile (Leaf kind text) = Token (Green.token kind (Text.pack text)) +compile (Branch kind children) = Node (Green.node kind (map compile children)) + +source :: Model -> String +source (Leaf _ text) = text +source (Branch _ children) = concatMap source children + +-- Independent UTF-8 width oracle for Unicode scalar values. +byteLength :: String -> TextLength +byteLength = sum . map width + where + width c + | ord c <= 0x7F = 1 + | ord c <= 0x7FF = 2 + | ord c <= 0xFFFF = 3 + | otherwise = 4 + +-- Depth of the shared regression DAGs: their logical length 2 ^ hugeDepth +-- exceeds any real text but stays below maxBound on 32- and 64-bit Int. +hugeDepth :: Int +hugeDepth = finiteBitSize (0 :: Int) - 24 + +-- A shared DAG of logical length 2 ^ (bits - 2), so that two of them side by +-- side overflow Int. Never render, compare or deeply force it. +halfMax :: kind -> GreenElement kind +halfMax kind = iterate (\child -> Node (Green.node kind [child, child])) (Token (Green.token kind (Text.pack "x"))) + !! (finiteBitSize (0 :: Int) - 2) + +-- Whether evaluating a value to weak head normal form fails with the +-- length-overflow error, rather than wrapping around or succeeding. +overflows :: a -> Property +overflows = failsWith "exceeds maxBound" + +-- Whether evaluating a value to weak head normal form fails with an error +-- whose message contains the given text. +failsWith :: String -> a -> Property +failsWith expected value = ioProperty $ do + result <- try (evaluate value) + pure $ case result of + Left (ErrorCall message) -> counterexample message (expected `isInfixOf` message) + Right _ -> counterexample ("no error mentioning " ++ show expected) False + +-- | Every node's cached length is the length of its text, and every child's +-- cached offset is the length of the children before it. +validCaches :: GreenElement Kind -> Bool +validCaches tree = Green.length tree == byteLength (Text.unpack (Green.render tree)) + && case tree of + Token _ -> True + Node node -> all validCaches (Green.children node) && offsetsAgree + where + offsetsAgree = and + [ Cursor.range child == Range.fromLength offset (Green.length (Cursor.green child)) + | (offset, child) <- zip offsets (Cursor.children (Cursor.fromGreen tree)) + ] + offsets = scanl (+) 0 (map Green.length (childrenOf tree)) + childrenOf (Node node) = Green.children node + childrenOf (Token _) = [] + +-- Each occurrence supplies its path and surrounding source. Contexts come +-- from the model's leaf text, not from the editing implementation. +contexts :: Model -> [(Path, String, Model, String)] +contexts model = ([], "", model, "") : case model of + Leaf _ _ -> [] + Branch _ children -> concat + [ [ (i : path, concatMap source before ++ prefix, selected, + suffix ++ concatMap source after) + | (path, prefix, selected, suffix) <- contexts child + ] + | (i, child) <- zip [0 ..] children + , let before = take i children + , let after = drop (i + 1) children + ] + + +-- Edits by path, written with cursors and plans as applications write them. +-- The properties state their expectations in terms of paths. +elementAt :: Path -> GreenElement k -> Either PathError (GreenElement k) +elementAt path root = Cursor.green <$> Cursor.at path (Cursor.fromGreen root) + +replaceAt :: Eq k => Path -> GreenElement k -> GreenElement k -> Either PathError (GreenElement k) +replaceAt path replacement root = do + focus <- Cursor.at path (Cursor.fromGreen root) + pure (applied root [Edit.replace focus replacement]) + +-- A plan on cursors of the base can only fail for the reasons the test +-- states; anything else is a bug in the test. +applied :: Eq k => GreenElement k -> [Edit k] -> GreenElement k +applied root edits = either (error . show) id (Edit.apply root edits) + +data PathEditError = ChildEditPathError PathError | EditError ChildEditError + deriving (Eq, Show) + +editAt :: Eq k => (Cursor k -> Edit k) -> Path -> GreenElement k -> Either PathEditError (GreenElement k) +editAt edit path root = case Cursor.at path (Cursor.fromGreen root) of + Left err -> Left (ChildEditPathError err) + Right focus -> case Edit.apply root [edit focus] of + Left (InvalidSplice _ err) -> Left (EditError err) + Left other -> error ("unexpected plan error: " ++ show other) + Right edited -> Right edited + +spliceChildrenAt + :: Eq k => Path -> Int -> Int -> [GreenElement k] -> GreenElement k -> Either PathEditError (GreenElement k) +spliceChildrenAt path start end replacements = editAt (\focus -> Edit.splice focus start end replacements) path + +insertChildAt :: Eq k => Path -> Int -> GreenElement k -> GreenElement k -> Either PathEditError (GreenElement k) +insertChildAt path index element = editAt (\focus -> Edit.splice focus index index [element]) path + +removeChildAt :: Eq k => Path -> Int -> GreenElement k -> Either PathEditError (GreenElement k) +removeChildAt path index = editAt (\focus -> Edit.splice focus index (index + 1) []) path diff --git a/test/doctest/Main.hs b/test/doctest/Main.hs new file mode 100644 --- /dev/null +++ b/test/doctest/Main.hs @@ -0,0 +1,41 @@ +-- Checks the examples in the Haddock documentation. GHC finds the library's +-- dependencies through the environment file that cabal writes at the end of +-- a build (write-ghc-environment-files in cabal.project), so build once +-- before the first run: +-- +-- > cabal build all -fdoctest +-- > cabal test graft-doctest -fdoctest +-- +-- Outside the repository, where cabal.project is absent, pass +-- --write-ghc-environment-files=always to the build. +module Main (main) where + +import Control.Monad (unless) +import Data.Version (showVersion) +import System.Directory (doesFileExist) +import System.Exit (exitFailure) +import System.IO (hPutStrLn, stderr) +import System.Info (arch, fullCompilerVersion, os) +import Test.DocTest (doctest) + +main :: IO () +main = do + -- doctest runs this GHC, so it needs this GHC's environment file. + let environment = ".ghc.environment." ++ arch ++ "-" ++ os ++ "-" ++ showVersion fullCompilerVersion + present <- doesFileExist environment + unless present $ do + hPutStrLn stderr ("No " ++ environment ++ " in the package directory. Build once with") + hPutStrLn stderr " cabal build all -fdoctest --write-ghc-environment-files=always" + hPutStrLn stderr "using the same compiler, then run the doctests again." + exitFailure + doctest + [ "-isrc" + , "src/Graft.hs" + , "src/Graft/Ast.hs" + , "src/Graft/Build.hs" + , "src/Graft/Builder.hs" + , "src/Graft/Cursor.hs" + , "src/Graft/Green.hs" + , "src/Graft/LineIndex.hs" + , "src/Graft/Range.hs" + ]