github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-11-29 21:52:59 +03:00
Code Issues Projects Releases Wiki Activity

Merge pull request #570 from github/deprecate-diffing-graphing

Browse Source 
Deprecate diffing graphing
This commit is contained in:
Patrick Thomson 2020-06-24 10:56:39 -04:00 committed by GitHub
commit 8ce5575cd5
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
73 changed files with 519 additions and 6541 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
.github/workflows/haskell.yml vendored
View File

@ -14,8 +14,8 @@ jobs:
runs-on: ubuntu-latest
strategy:
matrix:
ghc: ["8.8.1"]
cabal: ["3.0"]
ghc: ["8.8.3"]
cabal: ["3.2.0.0"]
steps:
- uses: actions/checkout@v2

80
README.md
View File

@ -18,80 +18,42 @@ Run `semantic --help` for complete list of up-to-date options.
#### Parse
```
Usage: semantic parse ([--sexpression] | [--json] | [--json-graph] | [--symbols]
| [--dot] | [--show] | [--quiet]) [FILES...]
Usage: semantic parse [--sexpression | (--json-symbols|--symbols) |
--proto-symbols | --show | --quiet] [FILES...]
Generate parse trees for path(s)
Available options:
--sexpression Output s-expression parse trees (default)
--json Output JSON parse trees
--json-graph Output JSON adjacency list
--symbols Output JSON symbol list
--dot Output DOT graph parse trees
--json-symbols,--symbols Output JSON symbol list
--proto-symbols Output protobufs symbol list
--show Output using the Show instance (debug only, format
subject to change without notice)
--quiet Don't produce output, but show timing stats
-h,--help Show this help text
```
#### Diff
```
Usage: semantic diff ([--sexpression] | [--json] | [--json-graph] |
[--dot] | [--show]) [FILE_A] [FILE_B]
Compute changes between paths
Available options:
--sexpression Output s-expression diff tree (default)
--json Output JSON diff trees
--json-graph Output JSON diff trees
--dot Output the diff as a DOT graph
--show Output using the Show instance (debug only, format
subject to change without notice)
```
#### Graph
```
Usage: semantic graph ([--imports] | [--calls]) [--packages] ([--dot] | [--json]
| [--show]) ([--root DIR] [--exclude-dir DIR]
DIR:LANGUAGE | FILE | --language ARG (FILES... | --stdin))
Compute a graph for a directory or from a top-level entry point module
Available options:
--imports Compute an import graph (default)
--calls Compute a call graph
--packages Include a vertex for the package, with edges from it
to each module
--dot Output in DOT graph format (default)
--json Output JSON graph
--show Output using the Show instance (debug only, format
subject to change without notice)
--root DIR Root directory of project. Optional, defaults to
entry file/directory.
--exclude-dir DIR Exclude a directory (e.g. vendor)
--language ARG The language for the analysis.
--stdin Read a list of newline-separated paths to analyze
from stdin.
```
## Language support
| Priority | Language | Parse | Assign | Diff | Symbols | Import graph | Call graph | Control flow graph |
| :---: | :------------- | :---: | :---: | :---: | :---: | :---: | :---: | :---: |
| 1 | Ruby | ✅ | ✅ | ✅ | ✅ | ✅ | 🚧 | |
| 2 | JavaScript | ✅ | ✅ | ✅ | ✅ | ✅ | 🚧 | |
| 3 | TypeScript | ✅ | ✅ | ✅ | ✅ | ✅ | 🚧 | |
| 4 | Python | ✅ | ✅ | ✅ | ✅ | ✅ | 🚧 | |
| 5 | Go | ✅ | ✅ | ✅ | ✅ | ✅ | 🚧 | |
| | PHP | 🚧 | 🚧 | 🚧 | 🚧 | | | |
| | Java | 🚧 | N/A | 🚧 | ✅ | | | |
| | JSON | ✅ | N/A | ✅ | N/A | N/A | N/A | |
| | JSX | ✅ | ✅ | ✅ | | | | |
| | Haskell | 🚧 | 🚧 | 🚧 | 🚧 | | | |
| | Markdown | 🚧 | 🚧 | 🚧 | N/A | N/A | N/A |   |
| | CodeQL | ✅ | N/A | 🚧 | ✅ | | | |
| Language | Parse | AST Symbols† | Stack graphs |
| :------------- | :---: | :---: | :---: |
| Ruby | ✅ | ✅ | |
| JavaScript | ✅ | ✅ | |
| TypeScript | ✅ | ✅ | 🚧 |
| Python | ✅ | ✅ | 🚧 |
| Go | ✅ | ✅ | |
| PHP | ✅ | ✅ | |
| Java | 🚧 | ✅ | |
| JSON | ✅ | ⬜️ | ⬜️ |
| JSX | ✅ | ✅ | |
| TSX | ✅ | ✅ | |
| CodeQL | ✅ | ✅ | |
| Haskell | 🚧 | 🚧 | |
† Used for [code navigation](https://help.github.com/en/github/managing-files-in-a-repository/navigating-code-on-github) on github.com.
* ✅ — Supported
* 🔶 — Partial support
* 🚧 — Under development
* ⬜ - N/A ️
## Development

5
bench/Tagging.hs
View File

@ -9,7 +9,7 @@ import Control.Carrier.Reader
import Control.Exception (throwIO)
import Control.Monad
import Data.Foldable
import Data.Language (PerLanguageModes (..), aLaCarteLanguageModes, preciseLanguageModes)
import Data.Language (PerLanguageModes (..), preciseLanguageModes)
import Gauge
import System.FilePath.Glob
import qualified System.Path as Path
@ -32,21 +32,18 @@ benchmarks = bgroup "tagging"
pythonBenchmarks :: Benchmark
pythonBenchmarks = bgroup "python"
[ bench "precise" $ runTagging preciseLanguageModes pyDir "*.py"
, bench "a la carte" $ runTagging aLaCarteLanguageModes pyDir "*.py"
]
where pyDir = Path.relDir "tmp/python-examples/keras/keras"
goBenchmarks :: Benchmark
goBenchmarks = bgroup "go"
[ bench "precise" $ runTagging preciseLanguageModes dir "*.go"
, bench "a la carte" $ runTagging aLaCarteLanguageModes dir "*.go"
]
where dir = Path.relDir "tmp/go-examples/go/src/database/sql"
rubyBenchmarks :: Benchmark
rubyBenchmarks = bgroup "ruby"
[ bench "precise" $ runTagging preciseLanguageModes dir "*.rb"
, bench "a la carte" $ runTagging aLaCarteLanguageModes dir "*.rb"
]
where dir = Path.relDir "tmp/ruby-examples/ruby_spec/command_line"

135
docs/assignment.md
View File

@ -1,135 +0,0 @@
_Note that this document describes a process that is now deprecated. For more information, see documentation on [adding a new language](https://github.com/github/semantic/blob/master/docs/adding-new-languages.md)._
### What is Assignment?
"Assignment" refers to the part of our system that parses parse trees. The step preceding assignment uses [`tree-sitter`](https://github.com/tree-sitter/tree-sitter) to parse source code and output rose trees labeled with symbols in the [language's grammar](https://github.com/github/semantic/blob/master/docs/grammar-development-guide.md) and source locations (represented as byte range and span). Assignment is a second layer of parsing required to get these ASTs in a shape appropriate for our Haskell project and to support the types of analyses we'd like to perform further along. Assignment represents a partial map from AST nodes onto another structure, typically terms.
We do this for a few reasons:
1. **Generalization:** this approach lets us reason about all languages in a standardized way. We can build necessary machinery to define the type of each specific language independently, while retaining the ability to share computations on the overlapping constructs (such as `if` statements).
2. **Type system:** Assignment gives us a way to represent the semantics of a language such that we know its behavior at runtime. Dynamic languages such as Ruby or JavaScript have looser rules which produce unpredictable results or may perform implicit type conversion at runtime. Having a finite list of items in syntax trees gives us a way to place a hard limitation on expected behavior.
### Relevant files
- [`Language.InsertSomeLanguage.Assignment`](https://github.com/github/semantic/tree/master/src/Language)
- [`Assigning.Assignment`](https://github.com/github/semantic/blob/master/src/Assigning/Assignment.hs)
- [`Data.Syntax`](https://github.com/github/semantic/blob/master/src/Data/Syntax.hs)
- [`Data.Syntax.SomeSubsetOfLanguageFeatures`](https://github.com/github/semantic/tree/master/src/Data/Syntax)
- [`Parsing.Parser`](https://github.com/github/semantic/blob/master/src/Parsing/Parser.hs)
#### Relevant ghci commands
- Assignment AST: `quieterm <$> parseFile javaParser "/example.java"`
- Tree-sitter AST: `fmap nodeSymbol <$> parseFile javaASTParser "/example.java"`
### How we construct an assignment
Assignments for supported language are defined in a file that is named something like this: `Language.InsertSomeLanguage.Assignment`. Working in this file is akin to writing another grammar, one that parses the tree-sitter parse tree instead of source code.
Assignments typically take on this pattern:
```Haskell
someLanguageConstruct :: Assignment
someLanguageConstruct = makeTerm <$> symbol NodeNameOfSymbolToMatch <*> children (SyntaxDataType <$> field1 <*> field2)
```
The building blocks that compose this DSL come from: `Assigning.Assignment`, explained below.
### The underlying machinery of `Assigning.Assignment`
Assignments are matched based on symbol, sequence and hierarchy. This gives us specificity (ex., in `@x = y@`, both `@x@` and `@y@` might have the same symbol, `@Identifier@`, but we can remove the possibility of doubt by assigning the left hand side to a variable declaration and the right hand side to a variable reference).
#### Assignments can be any of the following primitive rules
`Assigning.Assignment` gives us the primitive rules:
- [`symbol`](symbol)
- [`location`](location)
- [`source`](source)
- [`children`](children)
- [`Alternative` instance](alternative)
- [`Applicative` instance](applicative)
#### `symbol`:
- Produces the current node's location by matching against a specific symbol in the source language's grammar.
- Succeeds iff a) a current node exists, and b) its symbol is equal to the argument symbol. This rule fails if no node is found, for example at the end of any branch once we've matched all nodes.
- Matching a `symbol` rule does not advance past the current node, meaning you can match against a symbol and also match against the node's `children`. This also means some care must be taken, as repeating a symbol with `many` or `some` will never advance past the current node and could infinitely loop.
#### `location`:
- Produces the current node's location (byte Range and Span)
- Always succeeds. If there is no current node (i.e. if matching has advanced past the root node or past the last child node when operating within a `children` rule), the location is instead the end of the most recently matched node, specified as a zero-width Range and Span. `location` rules don't advance past the current node, meaning that you can both match a node's `location` and other properties. Dissimilar to `source` which requires we match a node—the `location` rule is only used for bookkeeping and thus does not place that hard expectation.
#### `source`:
- Produces a node's source as a ByteString.
- `source` rules succeed whenever a current node exists (i.e. matching has not advanced past the root node or past the last child node when operating within a `children` rule).
- `source` is intended to match leaf nodes such as comments. `source` rules advance past the current node.
#### `children`:
- `children` rules apply their argument (an assignment) to the children of the current node, succeeding iff a) a current node exists, b) the argument assignment matches the children, and c) there are no (regular) nodes left over (the distinction between nodes is given below in the [Matching tokens](matching-tokens) section), producing the result of matching the argument assignment against the children.
<!---
TODO: explain how traversal works in terms of matching/advancing -->
#### `Alternative` instance:
- Allows you to define the way you expect to get a `ByteString`, failing if it doesn't meet the standards you've defined. _Insert example_
- Allows you to accept 0 or more alternatives—0 meaning accept nothing and failing on the choice between them. `empty` assignments always fail. This can be used (in combination with the 'Monad' instance) to, for example, fail if a `source` assignment produces an ill-formatted ByteString. However, see below re: committed choice.
#### `Applicative` instance:
- `pure` (or via the 'Monad' instance, `return`) assignments always succeed, producing the passed value. They do not advance past the current node. In combination with the `Alternative` instance, `pure` can provide default values when optional syntax is not present in the AST.
#### Ways to combine assignments
1. The `Functor` instance maps values from the AST (`Loc`, `ByteString`, etc.) onto another structure.
2. The `Applicative` instance assigns sequences of (sibling) AST nodes in order, as well as providing `pure` assignments.
3. The `Alternative` instance chooses between a set of assignments, as well as providing `empty` assignments (see above). See below re: committed choice for best practices for efficiency & error reporting when it comes to assigning multiple alternatives. Most high-level assignments (e.g. “declaration” or “statement” assignments) consist of choices among two or more `Applicative` chains of assignments, mirroring the structure of the parser’s choices. The `Alternative` instance also enables repetitions via the 'many' (≥ 0 repetitions) and 'some' (≥ 1 repetition) methods. Finally, the 'optional' function uses the 'Alternative' instance to assign a value in 'Maybe', succeeding with 'Nothing' when unmatched.
4. The `Monad` instance allows assignments to depend on the results of earlier assignments. In general, most assignments should not be written using the `Monad` instance; however, some specific situations require it, e.g. assigning 'x += y' to be equivalent to 'x = x + y'.
_need example of this--I thought the monad instance allows us to chain things together such that we don't have to use do notation_
#### Assignment best practices
Because of their flexibility, the same assignment can often be written in multiple different ways. The following best practices should ensure efficient assignment with clear error messages for ill-formed AST.
#### Committed choice
Assignments can represent alternatives as either _committed_ or _uncommitted_ choices, both written with `<|>`. “Committed” in this context means that a failure in one of the alternatives will not result in backtracking followed by an attempt of one of the other alternatives; thus, committed choice is more efficient. (By the same token, it enables much better error messages since backtracking erases most of the relevant context.) Committed choices are constructed via the following rules:
1. `empty` is dropped from choices.
2. `symbol` rules construct a committed choice (with only a single alternative).
3. `fmap` (and by extension `<$>` and `<$`) of a committed choice is a committed choice.
4. `<*>` (and by extension `*>` and `<*`) with a committed choice on the left is a committed choice.
5. `>>=` (and by extension `>>`, `=<<`, and `<<`) of a committed choice is a committed choice. It may be helpful to think of this and the above rule for `<*>` as “sequences starting with committed choices remain committed choices.”
6. `<|>` of two committed choices is a committed choice.
Finally, if a given choice is not a committed choice, it is an uncommitted choice.
Given the above, it is a good idea to always start an assignment for a given piece of syntax with either a `symbol` rule or an `fmap` over a `symbol` rule. When assigning multiple pieces of syntax, place any known uncommitted choices at the (rightmost) end of the chain; `<|>` is left-associative, so this guarantees that you’re adding at most one uncommitted choice on top of the ones already present.
#### Matching tokens
AST symbols are classified by their 'symbolType' as either 'Regular', 'Anonymous', or 'Auxiliary'. 'Regular' is for the symbols of explicitly named productions in the grammar; 'Anonymous' is for unnamed productions of content such as tokens. 'Auxiliary' never appears in ASTs. Most of the time, assignments are only concerned with the named productions, and thus will be using 'Regular' symbols. Therefore, when matching a committed choice of all-'Regular' symbols, nodes with 'Anonymous' symbols will be skipped. However, in some cases grammars don’t provide a named symbol for e.g. every kind of infix operator, and thus the only way to differentiate between them is by means of a `symbol` rule for an 'Anonymous' `token`. In these cases, and before every other kind of assignment, the 'Anonymous' nodes will not be skipped so that matching can succeed.
This means that in addition to the rule of thumb for committed choices (see above), it's a good idea to try to match 'Regular' symbols up front, and only match 'Anonymous' ones in the middle of a chain. That will ensure that you don’t have to make redundant effort to explicitly skip 'Anonymous' nodes ahead of multiple alternatives, and can instead rely on them being automatically skipped except when explicitly required.
### `Data.Syntax`
This is the file from where we get combinators (`makeTerm`, `contextualize`, `emptyTerm`, `handleError`, `infixContext`, `makeTerm`, `makeTerm'`, `makeTerm''`, `makeTerm1`, `parseError`, `postContextualize`).
#### The difference between `makeTerm`, `makeTerm'` and `makeTerm1`
The `makeTerm` family of functions all construct terms whose `Range` and `Span` are at least as large as the union of all of their child terms’ Ranges and Spans. In the case of makeTerm and makeTerm', it also includes the Range and Span matched by their first argument, typically produced by a `symbol` rule. By way of contrast, `makeTerm1` is named by analogy with `foldr1`, and only takes a single argument, which is expected to be a non-empty piece of syntax, i.e. a piece of syntax which has one or more child terms; the resulting term’s Range and Span are then precisely the union of the child terms’.
<!---TODO: expand on this later-->
### `Data.Syntax.SomeSubsetOfLanguageFeatures`
These are files where data types for syntaxes are defined for use in your assignment.
<!---TODO: expand on this later-->
### `Parsing.Parser`
Contains data constructors required to produce ASTs.
- `ASTParser` - parser producing AST using tree-sitter language grammar.
- `AssignmentParser` - parser producing à la carte term given an `AST`-producing parser and an `Assignment` onto `Term`s in some syntax type.
- `javaParser` - parses according to what's defined in `Language.Java.Assignment`.
<!---TODO: expand on this later-->

205
docs/examples.md
View File

@ -14,134 +14,109 @@ Now, let's generate an abstract syntax tree (AST).
``` bash
$ semantic parse test.A.py
(Statements
(Annotation
(Function
(Identifier)
(Identifier)
(Return
(Identifier)))
(Empty))
(Call
(Identifier)
(Call
(Identifier)
(TextElement)
(Empty))
(Empty)))
(Module
(CompoundStatement
(FunctionDefinition
(Block
(SimpleStatement
(ReturnStatement
(ExpressionList
(Expression
(PrimaryExpression
(Identifier "x")))))))
(Identifier "Foo")
(Parameters
(Parameter
(Identifier "x")))))
(SimpleStatement
(PrintStatement
(Expression
(PrimaryExpression
(Call
(PrimaryExpression
(Identifier "Foo"))
(ArgumentList
(Expression
(PrimaryExpression
(String))))))))))
```
The default s-expression output is a good format for quickly visualizing the structure of code. We can see that there is a function declared and that then there is a call expression, nested in another call expression which matches the function calls to `print` and `Foo`. Feel free to play with some of the other output formats, for example the following will give back the same AST, but in JSON and with much more information about each node including things like the span and range of each syntactic element in the original source file.
The default s-expression output is a good format for quickly visualizing the structure of code. We can see that there is a function declared and that then there is a call expression, nested in another call expression which matches the function calls to `print` and `Foo`. Feel free to play with some of the other output formats, for example the following will give back the same AST, but with much more details about the underlying data structure.
``` bash
$ semantic parse --json test.A.py
$ semantic parse test.py --show
```
## Diffs
## Symbols
Now, let's look at a simple, syntax aware diff. Create a second file `test.B.py` that looks like this (The function `Foo` has been renamed).
Symbols are named identifiers driven by the ASTs. This is the format that github.com uses to generate code navigation information allowing c-tags style lookup of symbolic names for fast, incremental navigation in all the supported languages. The incremental part is important because files change often so we want to be able to parse just what's changed and not have to analyze the entire project again.
``` python
def Bar(x):
return x
print Bar("hi")
```
First, let's just see what the diff looks like.
``` bash
$ git diff --no-index test.A.py test.B.py
```
``` diff
diff --git a/test.A.py b/test.B.py
index 81f210023..5f37f4260 100644
--- a/test.A.py
+++ b/test.B.py
@@ -1,3 +1,3 @@
-def Foo(x):
+def Bar(x):
return x
-print Foo("hi")
+print Bar("hi")
```
Now, let's look at a syntax aware diff.
``` bash
$ semantic diff test.A.py test.B.py
(Statements
(Annotation
(Function
{ (Identifier)
->(Identifier) }
(Identifier)
(Return
(Identifier)))
(Empty))
(Call
(Identifier)
(Call
{ (Identifier)
->(Identifier) }
(TextElement)
(Empty))
(Empty)))
```
Notice the difference? Instead of showing that entire lines were added and removed, the semantic diff is aware that the identifier of the function declaration and function call changed. Pretty cool.
## Import graphs
OK, now for the fun stuff. Semantic can currently produce a couple of different graph-based views of source code, let's first take a look at import graphs. An import graph shows how files include other files within a software project. For this example, we are going to write a little bit more code in order to see this work. Start by creating a couple of new files:
``` python
# main.py
import numpy as np
from a import foo as foo_
def qux():
return foo_()
foo_(1)
```
``` python
# a.py
def foo(x):
return x
```
Now, let's graph.
``` bash
$ semantic graph --language Python main.py
digraph
$ semantic parse test.py --json-symbols
{
"a.py (Module)" [style="dotted, rounded" shape="box"]
"main.py (Module)" [style="dotted, rounded" shape="box"]
"numpy (Unknown Module)" [style="dotted, rounded" shape="box" color="red" fontcolor="red"]
"main.py (Module)" -> "a.py (Module)" [len="5.0" label="imports"]
"main.py (Module)" -> "numpy (Unknown Module)" [len="5.0" label="imports"]
"files": [
{
"path": "test.py",
"language": "Python",
"symbols": [
{
"symbol": "Foo",
"kind": "Function",
"line": "def Foo(x):",
"span": {
"start": {
"line": 1,
"column": 5
},
"end": {
"line": 1,
"column": 8
}
},
"nodeType": "DEFINITION"
},
{
"symbol": "print",
"kind": "Function",
"line": "print Foo(\"hi\")",
"span": {
"start": {
"line": 3,
"column": 1
},
"end": {
"line": 3,
"column": 16
}
},
"nodeType": "DEFINITION"
},
{
"symbol": "Foo",
"kind": "Call",
"line": "Foo(\"hi\")",
"span": {
"start": {
"line": 3,
"column": 7
},
"end": {
"line": 3,
"column": 10
}
},
"nodeType": "REFERENCE",
"syntaxType": "CALL"
}
]
}
]
}
```
To make this easier to visualize, let's use the `dot` utility from `graphviz` and write this graph to SVG:
There's also a protobuf version of this same information (slightly more compact wire representation).
```
$ semantic graph --language Python main.py | dot -Tsvg > main.html && open main.html
```
## Diffs
You'll get something that looks like this:
![an import graph](images/import_graph.svg)
## Call graphs
Call graphs expand on the import graphing capabilities by adding in some additional vertices and edges to the graph to identify named symbols and the connections between them. Taking the same example code, simply add `--call` to the invocation of semantic:
```
$ semantic graph --language Python --calls main.py | dot -Tsvg > main.html && open main.html
```
![a call graph](images/call_graph.svg)
NOTE: Diffs are temporarily disabled as part of the effort to migrate to a new AST representation (precise ASTs).

133
docs/images/call_graph.svg
View File

@ -1,133 +0,0 @@
<svg width="333pt" height="410pt"
viewBox="0.00 0.00 332.61 410.00" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink">
<g id="graph0" class="graph" transform="scale(1 1) rotate(0) translate(4 406)">
<title>%3</title>
<polygon fill="#ffffff" stroke="transparent" points="-4,4 -4,-406 328.6089,-406 328.6089,4 -4,4"/>
<!-- a.py (Module) -->
<g id="node1" class="node">
<title>a.py (Module)</title>
<path fill="none" stroke="#000000" stroke-dasharray="1,5" d="M84.1348,-262C84.1348,-262 11.955,-262 11.955,-262 5.955,-262 -.045,-256 -.045,-250 -.045,-250 -.045,-238 -.045,-238 -.045,-232 5.955,-226 11.955,-226 11.955,-226 84.1348,-226 84.1348,-226 90.1348,-226 96.1348,-232 96.1348,-238 96.1348,-238 96.1348,-250 96.1348,-250 96.1348,-256 90.1348,-262 84.1348,-262"/>
<text text-anchor="middle" x="48.0449" y="-239.8" font-family="Times,serif" font-size="14.00" fill="#000000">a.py (Module)</text>
</g>
<!-- a.py::foo (Function [1, 1] &#45; [3, 1]) -->
<g id="node7" class="node">
<title>a.py::foo (Function [1, 1] &#45; [3, 1])</title>
<g id="a_node7"><a xlink:title="[1, 1] &#45; [3, 1]">
<path fill="none" stroke="#000000" d="M184.8109,-122C184.8109,-122 111.2789,-122 111.2789,-122 105.2789,-122 99.2789,-116 99.2789,-110 99.2789,-110 99.2789,-98 99.2789,-98 99.2789,-92 105.2789,-86 111.2789,-86 111.2789,-86 184.8109,-86 184.8109,-86 190.8109,-86 196.8109,-92 196.8109,-98 196.8109,-98 196.8109,-110 196.8109,-110 196.8109,-116 190.8109,-122 184.8109,-122"/>
<text text-anchor="middle" x="148.0449" y="-99.8" font-family="Times,serif" font-size="14.00" fill="#000000">foo (Function)</text>
</a>
</g>
</g>
<!-- a.py (Module)&#45;&gt;a.py::foo (Function [1, 1] &#45; [3, 1]) -->
<g id="edge1" class="edge">
<title>a.py (Module)&#45;&gt;a.py::foo (Function [1, 1] &#45; [3, 1])</title>
<path fill="none" stroke="#ff0000" d="M60.9135,-225.9841C78.219,-201.7563 109.12,-158.4949 129.0891,-130.5382"/>
<polygon fill="#ff0000" stroke="#ff0000" points="131.9439,-132.5631 134.9082,-122.3914 126.2477,-128.4944 131.9439,-132.5631"/>
<text text-anchor="middle" x="117.876" y="-185.8" font-family="Times,serif" font-size="14.00" fill="#000000">defines</text>
</g>
<!-- main.py (Module) -->
<g id="node2" class="node">
<title>main.py (Module)</title>
<path fill="none" stroke="#000000" stroke-dasharray="1,5" d="M200.9141,-402C200.9141,-402 107.1757,-402 107.1757,-402 101.1757,-402 95.1757,-396 95.1757,-390 95.1757,-390 95.1757,-378 95.1757,-378 95.1757,-372 101.1757,-366 107.1757,-366 107.1757,-366 200.9141,-366 200.9141,-366 206.9141,-366 212.9141,-372 212.9141,-378 212.9141,-378 212.9141,-390 212.9141,-390 212.9141,-396 206.9141,-402 200.9141,-402"/>
<text text-anchor="middle" x="154.0449" y="-379.8" font-family="Times,serif" font-size="14.00" fill="#000000">main.py (Module)</text>
</g>
<!-- main.py (Module)&#45;&gt;a.py (Module) -->
<g id="edge2" class="edge">
<title>main.py (Module)&#45;&gt;a.py (Module)</title>
<path fill="none" stroke="#000000" d="M100.9885,-365.9661C79.1556,-355.3239 56.7292,-339.2668 47.0449,-316 41.397,-302.4308 41.1477,-286.139 42.5296,-272.4873"/>
<polygon fill="#000000" stroke="#000000" points="46.048,-272.5855 43.9155,-262.2075 39.1107,-271.6501 46.048,-272.5855"/>
<text text-anchor="middle" x="93.4346" y="-336.8" font-family="Times,serif" font-size="14.00" fill="#000000">imports</text>
</g>
<!-- numpy (Module) -->
<g id="node3" class="node">
<title>numpy (Module)</title>
<path fill="none" stroke="#000000" stroke-dasharray="1,5" d="M155.8109,-316C155.8109,-316 68.279,-316 68.279,-316 62.279,-316 56.279,-310 56.279,-304 56.279,-304 56.279,-292 56.279,-292 56.279,-286 62.279,-280 68.279,-280 68.279,-280 155.8109,-280 155.8109,-280 161.8109,-280 167.8109,-286 167.8109,-292 167.8109,-292 167.8109,-304 167.8109,-304 167.8109,-310 161.8109,-316 155.8109,-316"/>
<text text-anchor="middle" x="112.0449" y="-293.8" font-family="Times,serif" font-size="14.00" fill="#000000">numpy (Module)</text>
</g>
<!-- main.py (Module)&#45;&gt;numpy (Module) -->
<g id="edge3" class="edge">
<title>main.py (Module)&#45;&gt;numpy (Module)</title>
<path fill="none" stroke="#000000" d="M141.5019,-365.7227C137.9566,-360.1633 134.254,-353.948 131.2656,-348 127.7638,-341.03 124.4933,-333.26 121.6786,-325.9623"/>
<polygon fill="#000000" stroke="#000000" points="124.9005,-324.5841 118.1438,-316.4233 118.3367,-327.0164 124.9005,-324.5841"/>
<text text-anchor="middle" x="153.4346" y="-336.8" font-family="Times,serif" font-size="14.00" fill="#000000">imports</text>
</g>
<!-- main.py::foo_ (Variable [7, 1] &#45; [7, 5]) -->
<g id="node5" class="node">
<title>main.py::foo_ (Variable [7, 1] &#45; [7, 5])</title>
<g id="a_node5"><a xlink:title="[7, 1] &#45; [7, 5]">
<path fill="none" stroke="#000000" d="M210.6729,-262C210.6729,-262 133.4169,-262 133.4169,-262 127.4169,-262 121.4169,-256 121.4169,-250 121.4169,-250 121.4169,-238 121.4169,-238 121.4169,-232 127.4169,-226 133.4169,-226 133.4169,-226 210.6729,-226 210.6729,-226 216.6729,-226 222.6729,-232 222.6729,-238 222.6729,-238 222.6729,-250 222.6729,-250 222.6729,-256 216.6729,-262 210.6729,-262"/>
<text text-anchor="middle" x="172.0449" y="-239.8" font-family="Times,serif" font-size="14.00" fill="#000000">foo_ (Variable)</text>
</a>
</g>
</g>
<!-- main.py (Module)&#45;&gt;main.py::foo_ (Variable [7, 1] &#45; [7, 5]) -->
<g id="edge4" class="edge">
<title>main.py (Module)&#45;&gt;main.py::foo_ (Variable [7, 1] &#45; [7, 5])</title>
<path fill="none" stroke="#00ff00" d="M165.9663,-365.9735C169.1046,-360.4211 172.1415,-354.1468 174.0449,-348 181.722,-323.2074 180.1489,-293.4742 177.2921,-272.1616"/>
<polygon fill="#00ff00" stroke="#00ff00" points="180.7329,-271.5068 175.7727,-262.1448 173.8121,-272.5566 180.7329,-271.5068"/>
<text text-anchor="middle" x="189.8726" y="-336.8" font-family="Times,serif" font-size="14.00" fill="#000000">calls</text>
</g>
<!-- main.py::qux (Function [4, 1] &#45; [6, 1]) -->
<g id="node8" class="node">
<title>main.py::qux (Function [4, 1] &#45; [6, 1])</title>
<g id="a_node8"><a xlink:title="[4, 1] &#45; [6, 1]">
<path fill="none" stroke="#000000" d="M311.6492,-316C311.6492,-316 236.4406,-316 236.4406,-316 230.4406,-316 224.4406,-310 224.4406,-304 224.4406,-304 224.4406,-292 224.4406,-292 224.4406,-286 230.4406,-280 236.4406,-280 236.4406,-280 311.6492,-280 311.6492,-280 317.6492,-280 323.6492,-286 323.6492,-292 323.6492,-292 323.6492,-304 323.6492,-304 323.6492,-310 317.6492,-316 311.6492,-316"/>
<text text-anchor="middle" x="274.0449" y="-293.8" font-family="Times,serif" font-size="14.00" fill="#000000">qux (Function)</text>
</a>
</g>
</g>
<!-- main.py (Module)&#45;&gt;main.py::qux (Function [4, 1] &#45; [6, 1]) -->
<g id="edge5" class="edge">
<title>main.py (Module)&#45;&gt;main.py::qux (Function [4, 1] &#45; [6, 1])</title>
<path fill="none" stroke="#ff0000" d="M196.2031,-365.9415C206.3744,-360.7811 216.9296,-354.7123 226.0449,-348 235.5406,-341.0076 244.8004,-332.0415 252.6132,-323.6375"/>
<polygon fill="#ff0000" stroke="#ff0000" points="255.2622,-325.9261 259.3468,-316.1503 250.0575,-321.2452 255.2622,-325.9261"/>
<text text-anchor="middle" x="260.876" y="-336.8" font-family="Times,serif" font-size="14.00" fill="#000000">defines</text>
</g>
<!-- main.py::foo_ (Variable [5, 12] &#45; [5, 16]) -->
<g id="node4" class="node">
<title>main.py::foo_ (Variable [5, 12] &#45; [5, 16])</title>
<g id="a_node4"><a xlink:title="[5, 12] &#45; [5, 16]">
<path fill="none" stroke="#000000" d="M312.6729,-208C312.6729,-208 235.4169,-208 235.4169,-208 229.4169,-208 223.4169,-202 223.4169,-196 223.4169,-196 223.4169,-184 223.4169,-184 223.4169,-178 229.4169,-172 235.4169,-172 235.4169,-172 312.6729,-172 312.6729,-172 318.6729,-172 324.6729,-178 324.6729,-184 324.6729,-184 324.6729,-196 324.6729,-196 324.6729,-202 318.6729,-208 312.6729,-208"/>
<text text-anchor="middle" x="274.0449" y="-185.8" font-family="Times,serif" font-size="14.00" fill="#000000">foo_ (Variable)</text>
</a>
</g>
</g>
<!-- main.py::foo_ (Variable [5, 12] &#45; [5, 16])&#45;&gt;a.py::foo (Function [1, 1] &#45; [3, 1]) -->
<g id="edge6" class="edge">
<title>main.py::foo_ (Variable [5, 12] &#45; [5, 16])&#45;&gt;a.py::foo (Function [1, 1] &#45; [3, 1])</title>
<path fill="none" stroke="#0000ff" d="M247.6312,-171.9716C228.8148,-159.1286 203.3349,-141.7376 182.8589,-127.7619"/>
<polygon fill="#0000ff" stroke="#0000ff" points="184.6565,-124.7513 174.4239,-122.0047 180.7103,-130.533 184.6565,-124.7513"/>
<text text-anchor="middle" x="246.7969" y="-142.8" font-family="Times,serif" font-size="14.00" fill="#000000">references</text>
</g>
<!-- main.py::foo_ (Variable [7, 1] &#45; [7, 5])&#45;&gt;a.py::foo (Function [1, 1] &#45; [3, 1]) -->
<g id="edge7" class="edge">
<title>main.py::foo_ (Variable [7, 1] &#45; [7, 5])&#45;&gt;a.py::foo (Function [1, 1] &#45; [3, 1])</title>
<path fill="none" stroke="#0000ff" d="M162.8094,-225.7163C160.3767,-220.1567 158.0211,-213.9429 156.541,-208 150.315,-183.0011 148.3844,-153.6829 147.8982,-132.5587"/>
<polygon fill="#0000ff" stroke="#0000ff" points="151.3948,-132.2773 147.7605,-122.3253 144.3955,-132.3715 151.3948,-132.2773"/>
<text text-anchor="middle" x="185.7969" y="-185.8" font-family="Times,serif" font-size="14.00" fill="#000000">references</text>
</g>
<!-- a.py::x (Variable [2, 12] &#45; [2, 13]) -->
<g id="node6" class="node">
<title>a.py::x (Variable [2, 12] &#45; [2, 13])</title>
<g id="a_node6"><a xlink:title="[2, 12] &#45; [2, 13]">
<path fill="none" stroke="#000000" d="M177.5121,-36C177.5121,-36 118.5778,-36 118.5778,-36 112.5778,-36 106.5778,-30 106.5778,-24 106.5778,-24 106.5778,-12 106.5778,-12 106.5778,-6 112.5778,0 118.5778,0 118.5778,0 177.5121,0 177.5121,0 183.5121,0 189.5121,-6 189.5121,-12 189.5121,-12 189.5121,-24 189.5121,-24 189.5121,-30 183.5121,-36 177.5121,-36"/>
<text text-anchor="middle" x="148.0449" y="-13.8" font-family="Times,serif" font-size="14.00" fill="#000000">x (Variable)</text>
</a>
</g>
</g>
<!-- a.py::foo (Function [1, 1] &#45; [3, 1])&#45;&gt;a.py::x (Variable [2, 12] &#45; [2, 13]) -->
<g id="edge8" class="edge">
<title>a.py::foo (Function [1, 1] &#45; [3, 1])&#45;&gt;a.py::x (Variable [2, 12] &#45; [2, 13])</title>
<path fill="none" stroke="#00ff00" d="M148.0449,-85.7616C148.0449,-74.3597 148.0449,-59.4342 148.0449,-46.494"/>
<polygon fill="#00ff00" stroke="#00ff00" points="151.545,-46.2121 148.0449,-36.2121 144.545,-46.2121 151.545,-46.2121"/>
<text text-anchor="middle" x="160.8726" y="-56.8" font-family="Times,serif" font-size="14.00" fill="#000000">calls</text>
</g>
<!-- main.py::qux (Function [4, 1] &#45; [6, 1])&#45;&gt;main.py::foo_ (Variable [5, 12] &#45; [5, 16]) -->
<g id="edge9" class="edge">
<title>main.py::qux (Function [4, 1] &#45; [6, 1])&#45;&gt;main.py::foo_ (Variable [5, 12] &#45; [5, 16])</title>
<path fill="none" stroke="#00ff00" d="M274.0449,-279.6793C274.0449,-262.821 274.0449,-237.5651 274.0449,-218.147"/>
<polygon fill="#00ff00" stroke="#00ff00" points="277.545,-218.0501 274.0449,-208.0502 270.545,-218.0502 277.545,-218.0501"/>
<text text-anchor="middle" x="286.8726" y="-239.8" font-family="Times,serif" font-size="14.00" fill="#000000">calls</text>
</g>
</g>
</svg>
Side by Side

Before

Width:  |  Height:  |  Size: 11 KiB

39
docs/images/import_graph.svg
View File

@ -1,39 +0,0 @@
<svg width="292pt" height="130pt"
viewBox="0.00 0.00 292.04 130.00" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink">
<g id="graph0" class="graph" transform="scale(1 1) rotate(0) translate(4 126)">
<title>%3</title>
<polygon fill="#ffffff" stroke="transparent" points="-4,4 -4,-126 288.0381,-126 288.0381,4 -4,4"/>
<!-- a.py (Module) -->
<g id="node1" class="node">
<title>a.py (Module)</title>
<path fill="none" stroke="#000000" stroke-dasharray="1,5" d="M84.1348,-36C84.1348,-36 11.955,-36 11.955,-36 5.955,-36 -.045,-30 -.045,-24 -.045,-24 -.045,-12 -.045,-12 -.045,-6 5.955,0 11.955,0 11.955,0 84.1348,0 84.1348,0 90.1348,0 96.1348,-6 96.1348,-12 96.1348,-12 96.1348,-24 96.1348,-24 96.1348,-30 90.1348,-36 84.1348,-36"/>
<text text-anchor="middle" x="48.0449" y="-13.8" font-family="Times,serif" font-size="14.00" fill="#000000">a.py (Module)</text>
</g>
<!-- main.py (Module) -->
<g id="node2" class="node">
<title>main.py (Module)</title>
<path fill="none" stroke="#000000" stroke-dasharray="1,5" d="M169.9141,-122C169.9141,-122 76.1757,-122 76.1757,-122 70.1757,-122 64.1757,-116 64.1757,-110 64.1757,-110 64.1757,-98 64.1757,-98 64.1757,-92 70.1757,-86 76.1757,-86 76.1757,-86 169.9141,-86 169.9141,-86 175.9141,-86 181.9141,-92 181.9141,-98 181.9141,-98 181.9141,-110 181.9141,-110 181.9141,-116 175.9141,-122 169.9141,-122"/>
<text text-anchor="middle" x="123.0449" y="-99.8" font-family="Times,serif" font-size="14.00" fill="#000000">main.py (Module)</text>
</g>
<!-- main.py (Module)&#45;&gt;a.py (Module) -->
<g id="edge1" class="edge">
<title>main.py (Module)&#45;&gt;a.py (Module)</title>
<path fill="none" stroke="#000000" d="M107.1394,-85.7616C96.4997,-73.5615 82.342,-57.3273 70.5516,-43.8076"/>
<polygon fill="#000000" stroke="#000000" points="73.1381,-41.4483 63.9276,-36.2121 67.8624,-46.0492 73.1381,-41.4483"/>
<text text-anchor="middle" x="111.4346" y="-56.8" font-family="Times,serif" font-size="14.00" fill="#000000">imports</text>
</g>
<!-- numpy (Unknown Module) -->
<g id="node3" class="node">
<title>numpy (Unknown Module)</title>
<path fill="none" stroke="#ff0000" stroke-dasharray="1,5" d="M272.0313,-36C272.0313,-36 126.0586,-36 126.0586,-36 120.0586,-36 114.0586,-30 114.0586,-24 114.0586,-24 114.0586,-12 114.0586,-12 114.0586,-6 120.0586,0 126.0586,0 126.0586,0 272.0313,0 272.0313,0 278.0313,0 284.0313,-6 284.0313,-12 284.0313,-12 284.0313,-24 284.0313,-24 284.0313,-30 278.0313,-36 272.0313,-36"/>
<text text-anchor="middle" x="199.0449" y="-13.8" font-family="Times,serif" font-size="14.00" fill="#ff0000">numpy (Unknown Module)</text>
</g>
<!-- main.py (Module)&#45;&gt;numpy (Unknown Module) -->
<g id="edge2" class="edge">
<title>main.py (Module)&#45;&gt;numpy (Unknown Module)</title>
<path fill="none" stroke="#000000" d="M139.1626,-85.7616C149.944,-73.5615 164.2905,-57.3273 176.2382,-43.8076"/>
<polygon fill="#000000" stroke="#000000" points="178.9512,-46.0231 182.9505,-36.2121 173.7058,-41.3877 178.9512,-46.0231"/>
<text text-anchor="middle" x="186.4346" y="-56.8" font-family="Times,serif" font-size="14.00" fill="#000000">imports</text>
</g>
</g>
</svg>
Side by Side

Before

Width:  |  Height:  |  Size: 3.1 KiB

73
proto/semantic.proto
View File

@ -23,10 +23,6 @@ message ParseTreeSymbolResponse {
repeated File files = 1;
}
message ParseTreeGraphResponse {
repeated ParseTreeFileGraph files = 1;
}
message StackGraphRequest {
repeated Blob blobs = 1;
}
@ -35,79 +31,10 @@ message StackGraphResponse {
repeated StackGraphFile files = 1;
}
message ParseTreeFileGraph {
string path = 1;
string language = 2;
repeated TermVertex vertices = 3;
repeated TermEdge edges = 4;
repeated ParseError errors = 5;
}
message TermEdge {
int32 source = 1;
int32 target = 2;
}
message TermVertex {
int32 vertex_id = 1;
string term = 2;
Span span = 3;
}
message ParseError {
string error = 1;
}
message DiffTreeGraphResponse {
repeated DiffTreeFileGraph files = 1;
}
message DiffTreeFileGraph {
string path = 1;
string language = 2;
repeated DiffTreeVertex vertices = 3;
repeated DiffTreeEdge edges = 4;
repeated ParseError errors = 5;
}
message DiffTreeEdge {
int32 source = 1;
int32 target = 2;
}
message DiffTreeVertex {
int32 diff_vertex_id = 1;
oneof diff_term {
DeletedTerm deleted = 2;
InsertedTerm inserted = 3;
ReplacedTerm replaced = 4;
MergedTerm merged = 5;
}
}
message DeletedTerm {
string term = 1;
Span span = 2;
}
message InsertedTerm {
string term = 1;
Span span = 2;
}
message ReplacedTerm {
string before_term = 1;
Span before_span = 2;
string after_term = 3;
Span after_span = 4;
}
message MergedTerm {
string term = 1;
Span before_span = 2;
Span after_span = 3;
}
message Blob {
string content = 1;
string path = 2;

2
semantic-core/semantic-core.cabal
View File

@ -17,7 +17,7 @@ stability: alpha
extra-source-files: README.md
tested-with:
GHC == 8.6.5
GHC == 8.8.3
common common
default-language: Haskell2010

2727
semantic-proto/src/Proto/Semantic.hs
View File

File diff suppressed because it is too large Load Diff

135
semantic-proto/src/Proto/Semantic_Fields.hs
View File

@ -28,30 +28,6 @@ import qualified Data.ProtoLens.Runtime.Data.Vector as Data.Vector
import qualified Data.ProtoLens.Runtime.Data.Vector.Generic as Data.Vector.Generic
import qualified Data.ProtoLens.Runtime.Data.Vector.Unboxed as Data.Vector.Unboxed
import qualified Data.ProtoLens.Runtime.Text.Read as Text.Read
afterSpan ::
forall f s a.
(Prelude.Functor f,
Data.ProtoLens.Field.HasField s "afterSpan" a) =>
Lens.Family2.LensLike' f s a
afterSpan = Data.ProtoLens.Field.field @"afterSpan"
afterTerm ::
forall f s a.
(Prelude.Functor f,
Data.ProtoLens.Field.HasField s "afterTerm" a) =>
Lens.Family2.LensLike' f s a
afterTerm = Data.ProtoLens.Field.field @"afterTerm"
beforeSpan ::
forall f s a.
(Prelude.Functor f,
Data.ProtoLens.Field.HasField s "beforeSpan" a) =>
Lens.Family2.LensLike' f s a
beforeSpan = Data.ProtoLens.Field.field @"beforeSpan"
beforeTerm ::
forall f s a.
(Prelude.Functor f,
Data.ProtoLens.Field.HasField s "beforeTerm" a) =>
Lens.Family2.LensLike' f s a
beforeTerm = Data.ProtoLens.Field.field @"beforeTerm"
blobOid ::
forall f s a.
(Prelude.Functor f, Data.ProtoLens.Field.HasField s "blobOid" a) =>
@ -72,17 +48,6 @@ content ::
(Prelude.Functor f, Data.ProtoLens.Field.HasField s "content" a) =>
Lens.Family2.LensLike' f s a
content = Data.ProtoLens.Field.field @"content"
deleted ::
forall f s a.
(Prelude.Functor f, Data.ProtoLens.Field.HasField s "deleted" a) =>
Lens.Family2.LensLike' f s a
deleted = Data.ProtoLens.Field.field @"deleted"
diffVertexId ::
forall f s a.
(Prelude.Functor f,
Data.ProtoLens.Field.HasField s "diffVertexId" a) =>
Lens.Family2.LensLike' f s a
diffVertexId = Data.ProtoLens.Field.field @"diffVertexId"
docs ::
forall f s a.
(Prelude.Functor f, Data.ProtoLens.Field.HasField s "docs" a) =>
@ -147,12 +112,6 @@ id ::
(Prelude.Functor f, Data.ProtoLens.Field.HasField s "id" a) =>
Lens.Family2.LensLike' f s a
id = Data.ProtoLens.Field.field @"id"
inserted ::
forall f s a.
(Prelude.Functor f,
Data.ProtoLens.Field.HasField s "inserted" a) =>
Lens.Family2.LensLike' f s a
inserted = Data.ProtoLens.Field.field @"inserted"
kind ::
forall f s a.
(Prelude.Functor f, Data.ProtoLens.Field.HasField s "kind" a) =>
@ -169,30 +128,6 @@ line ::
(Prelude.Functor f, Data.ProtoLens.Field.HasField s "line" a) =>
Lens.Family2.LensLike' f s a
line = Data.ProtoLens.Field.field @"line"
maybe'afterSpan ::
forall f s a.
(Prelude.Functor f,
Data.ProtoLens.Field.HasField s "maybe'afterSpan" a) =>
Lens.Family2.LensLike' f s a
maybe'afterSpan = Data.ProtoLens.Field.field @"maybe'afterSpan"
maybe'beforeSpan ::
forall f s a.
(Prelude.Functor f,
Data.ProtoLens.Field.HasField s "maybe'beforeSpan" a) =>
Lens.Family2.LensLike' f s a
maybe'beforeSpan = Data.ProtoLens.Field.field @"maybe'beforeSpan"
maybe'deleted ::
forall f s a.
(Prelude.Functor f,
Data.ProtoLens.Field.HasField s "maybe'deleted" a) =>
Lens.Family2.LensLike' f s a
maybe'deleted = Data.ProtoLens.Field.field @"maybe'deleted"
maybe'diffTerm ::
forall f s a.
(Prelude.Functor f,
Data.ProtoLens.Field.HasField s "maybe'diffTerm" a) =>
Lens.Family2.LensLike' f s a
maybe'diffTerm = Data.ProtoLens.Field.field @"maybe'diffTerm"
maybe'docs ::
forall f s a.
(Prelude.Functor f,
@ -205,24 +140,6 @@ maybe'end ::
Data.ProtoLens.Field.HasField s "maybe'end" a) =>
Lens.Family2.LensLike' f s a
maybe'end = Data.ProtoLens.Field.field @"maybe'end"
maybe'inserted ::
forall f s a.
(Prelude.Functor f,
Data.ProtoLens.Field.HasField s "maybe'inserted" a) =>
Lens.Family2.LensLike' f s a
maybe'inserted = Data.ProtoLens.Field.field @"maybe'inserted"
maybe'merged ::
forall f s a.
(Prelude.Functor f,
Data.ProtoLens.Field.HasField s "maybe'merged" a) =>
Lens.Family2.LensLike' f s a
maybe'merged = Data.ProtoLens.Field.field @"maybe'merged"
maybe'replaced ::
forall f s a.
(Prelude.Functor f,
Data.ProtoLens.Field.HasField s "maybe'replaced" a) =>
Lens.Family2.LensLike' f s a
maybe'replaced = Data.ProtoLens.Field.field @"maybe'replaced"
maybe'span ::
forall f s a.
(Prelude.Functor f,
@ -235,11 +152,6 @@ maybe'start ::
Data.ProtoLens.Field.HasField s "maybe'start" a) =>
Lens.Family2.LensLike' f s a
maybe'start = Data.ProtoLens.Field.field @"maybe'start"
merged ::
forall f s a.
(Prelude.Functor f, Data.ProtoLens.Field.HasField s "merged" a) =>
Lens.Family2.LensLike' f s a
merged = Data.ProtoLens.Field.field @"merged"
name ::
forall f s a.
(Prelude.Functor f, Data.ProtoLens.Field.HasField s "name" a) =>
@ -266,12 +178,6 @@ paths ::
(Prelude.Functor f, Data.ProtoLens.Field.HasField s "paths" a) =>
Lens.Family2.LensLike' f s a
paths = Data.ProtoLens.Field.field @"paths"
replaced ::
forall f s a.
(Prelude.Functor f,
Data.ProtoLens.Field.HasField s "replaced" a) =>
Lens.Family2.LensLike' f s a
replaced = Data.ProtoLens.Field.field @"replaced"
service ::
forall f s a.
(Prelude.Functor f, Data.ProtoLens.Field.HasField s "service" a) =>
@ -282,11 +188,6 @@ sha ::
(Prelude.Functor f, Data.ProtoLens.Field.HasField s "sha" a) =>
Lens.Family2.LensLike' f s a
sha = Data.ProtoLens.Field.field @"sha"
source ::
forall f s a.
(Prelude.Functor f, Data.ProtoLens.Field.HasField s "source" a) =>
Lens.Family2.LensLike' f s a
source = Data.ProtoLens.Field.field @"source"
span ::
forall f s a.
(Prelude.Functor f, Data.ProtoLens.Field.HasField s "span" a) =>
@ -332,16 +233,6 @@ syntaxType ::
Data.ProtoLens.Field.HasField s "syntaxType" a) =>
Lens.Family2.LensLike' f s a
syntaxType = Data.ProtoLens.Field.field @"syntaxType"
target ::
forall f s a.
(Prelude.Functor f, Data.ProtoLens.Field.HasField s "target" a) =>
Lens.Family2.LensLike' f s a
target = Data.ProtoLens.Field.field @"target"
term ::
forall f s a.
(Prelude.Functor f, Data.ProtoLens.Field.HasField s "term" a) =>
Lens.Family2.LensLike' f s a
term = Data.ProtoLens.Field.field @"term"
timestamp ::
forall f s a.
(Prelude.Functor f,
@ -359,12 +250,6 @@ vec'blobs ::
Data.ProtoLens.Field.HasField s "vec'blobs" a) =>
Lens.Family2.LensLike' f s a
vec'blobs = Data.ProtoLens.Field.field @"vec'blobs"
vec'edges ::
forall f s a.
(Prelude.Functor f,
Data.ProtoLens.Field.HasField s "vec'edges" a) =>
Lens.Family2.LensLike' f s a
vec'edges = Data.ProtoLens.Field.field @"vec'edges"
vec'endingScopeStack ::
forall f s a.
(Prelude.Functor f,
@ -415,22 +300,4 @@ vec'symbols ::
(Prelude.Functor f,
Data.ProtoLens.Field.HasField s "vec'symbols" a) =>
Lens.Family2.LensLike' f s a
vec'symbols = Data.ProtoLens.Field.field @"vec'symbols"
vec'vertices ::
forall f s a.
(Prelude.Functor f,
Data.ProtoLens.Field.HasField s "vec'vertices" a) =>
Lens.Family2.LensLike' f s a
vec'vertices = Data.ProtoLens.Field.field @"vec'vertices"
vertexId ::
forall f s a.
(Prelude.Functor f,
Data.ProtoLens.Field.HasField s "vertexId" a) =>
Lens.Family2.LensLike' f s a
vertexId = Data.ProtoLens.Field.field @"vertexId"
vertices ::
forall f s a.
(Prelude.Functor f,
Data.ProtoLens.Field.HasField s "vertices" a) =>
Lens.Family2.LensLike' f s a
vertices = Data.ProtoLens.Field.field @"vertices"
vec'symbols = Data.ProtoLens.Field.field @"vec'symbols"

358
semantic-proto/src/Proto/Semantic_JSON.hs
View File

@ -113,27 +113,6 @@ instance ToJSON ParseTreeSymbolResponse where
toJSON = toAesonValue
toEncoding = toAesonEncoding
instance FromJSONPB ParseTreeGraphResponse where
parseJSONPB = withObject "ParseTreeGraphResponse" $ \obj -> do
files' <- obj .: "files"
pure $ defMessage
& P.files .~ files'
instance ToJSONPB ParseTreeGraphResponse where
toJSONPB x = object
[ "files" .= (x^.files)
]
toEncodingPB x = pairs
[ "files" .= (x^.files)
]
instance FromJSON ParseTreeGraphResponse where
parseJSON = parseJSONPB
instance ToJSON ParseTreeGraphResponse where
toJSON = toAesonValue
toEncoding = toAesonEncoding
instance FromJSONPB StackGraphRequest where
parseJSONPB = withObject "StackGraphRequest" $ \obj -> do
blobs' <- obj .: "blobs"
@ -176,97 +155,6 @@ instance ToJSON StackGraphResponse where
toJSON = toAesonValue
toEncoding = toAesonEncoding
instance FromJSONPB ParseTreeFileGraph where
parseJSONPB = withObject "ParseTreeFileGraph" $ \obj -> do
path' <- obj .: "path"
language' <- obj .: "language"
vertices' <- obj .: "vertices"
edges' <- obj .: "edges"
errors' <- obj .: "errors"
pure $ defMessage
& P.path .~ path'
& P.language .~ language'
& P.vertices .~ vertices'
& P.edges .~ edges'
& P.errors .~ errors'
instance ToJSONPB ParseTreeFileGraph where
toJSONPB x = object
[ "path" .= (x^.path)
, "language" .= (x^.language)
, "vertices" .= (x^.vertices)
, "edges" .= (x^.edges)
, "errors" .= (x^.errors)
]
toEncodingPB x = pairs
[ "path" .= (x^.path)
, "language" .= (x^.language)
, "vertices" .= (x^.vertices)
, "edges" .= (x^.edges)
, "errors" .= (x^.errors)
]
instance FromJSON ParseTreeFileGraph where
parseJSON = parseJSONPB
instance ToJSON ParseTreeFileGraph where
toJSON = toAesonValue
toEncoding = toAesonEncoding
instance FromJSONPB TermEdge where
parseJSONPB = withObject "TermEdge" $ \obj -> do
source' <- obj .: "source"
target' <- obj .: "target"
pure $ defMessage
& P.source .~ source'
& P.target .~ target'
instance ToJSONPB TermEdge where
toJSONPB x = object
[ "source" .= (x^.source)
, "target" .= (x^.target)
]
toEncodingPB x = pairs
[ "source" .= (x^.source)
, "target" .= (x^.target)
]
instance FromJSON TermEdge where
parseJSON = parseJSONPB
instance ToJSON TermEdge where
toJSON = toAesonValue
toEncoding = toAesonEncoding
instance FromJSONPB TermVertex where
parseJSONPB = withObject "TermVertex" $ \obj -> do
vertexId' <- obj .: "vertexId"
term' <- obj .: "term"
span' <- obj A..:? "span"
pure $ defMessage
& P.vertexId .~ vertexId'
& P.term .~ term'
& P.maybe'span .~ span'
instance ToJSONPB TermVertex where
toJSONPB x = object
[ "vertexId" .= (x^.vertexId)
, "term" .= (x^.term)
, "span" .= (x^.maybe'span)
]
toEncodingPB x = pairs
[ "vertexId" .= (x^.vertexId)
, "term" .= (x^.term)
, "span" .= (x^.maybe'span)
]
instance FromJSON TermVertex where
parseJSON = parseJSONPB
instance ToJSON TermVertex where
toJSON = toAesonValue
toEncoding = toAesonEncoding
instance FromJSONPB ParseError where
parseJSONPB = withObject "ParseError" $ \obj -> do
error' <- obj .: "error"
@ -288,252 +176,6 @@ instance ToJSON ParseError where
toJSON = toAesonValue
toEncoding = toAesonEncoding
instance FromJSONPB DiffTreeGraphResponse where
parseJSONPB = withObject "DiffTreeGraphResponse" $ \obj -> do
files' <- obj .: "files"
pure $ defMessage
& P.files .~ files'
instance ToJSONPB DiffTreeGraphResponse where
toJSONPB x = object
[ "files" .= (x^.files)
]
toEncodingPB x = pairs
[ "files" .= (x^.files)
]
instance FromJSON DiffTreeGraphResponse where
parseJSON = parseJSONPB
instance ToJSON DiffTreeGraphResponse where
toJSON = toAesonValue
toEncoding = toAesonEncoding
instance FromJSONPB DiffTreeFileGraph where
parseJSONPB = withObject "DiffTreeFileGraph" $ \obj -> do
path' <- obj .: "path"
language' <- obj .: "language"
vertices' <- obj .: "vertices"
edges' <- obj .: "edges"
errors' <- obj .: "errors"
pure $ defMessage
& P.path .~ path'
& P.language .~ language'
& P.vertices .~ vertices'
& P.edges .~ edges'
& P.errors .~ errors'
instance ToJSONPB DiffTreeFileGraph where
toJSONPB x = object
[ "path" .= (x^.path)
, "language" .= (x^.language)
, "vertices" .= (x^.vertices)
, "edges" .= (x^.edges)
, "errors" .= (x^.errors)
]
toEncodingPB x = pairs
[ "path" .= (x^.path)
, "language" .= (x^.language)
, "vertices" .= (x^.vertices)
, "edges" .= (x^.edges)
, "errors" .= (x^.errors)
]
instance FromJSON DiffTreeFileGraph where
parseJSON = parseJSONPB
instance ToJSON DiffTreeFileGraph where
toJSON = toAesonValue
toEncoding = toAesonEncoding
instance FromJSONPB DiffTreeEdge where
parseJSONPB = withObject "DiffTreeEdge" $ \obj -> do
source' <- obj .: "source"
target' <- obj .: "target"
pure $ defMessage
& P.source .~ source'
& P.target .~ target'
instance ToJSONPB DiffTreeEdge where
toJSONPB x = object
[ "source" .= (x^.source)
, "target" .= (x^.target)
]
toEncodingPB x = pairs
[ "source" .= (x^.source)
, "target" .= (x^.target)
]
instance FromJSON DiffTreeEdge where
parseJSON = parseJSONPB
instance ToJSON DiffTreeEdge where
toJSON = toAesonValue
toEncoding = toAesonEncoding
instance FromJSONPB DiffTreeVertex'DiffTerm where
parseJSONPB = A.withObject "DiffTreeVertex'DiffTerm" $ \obj -> mconcat
[
DiffTreeVertex'Deleted <$> parseField obj "deleted"
, DiffTreeVertex'Inserted <$> parseField obj "inserted"
, DiffTreeVertex'Replaced <$> parseField obj "replaced"
, DiffTreeVertex'Merged <$> parseField obj "merged"
]
instance ToJSONPB DiffTreeVertex'DiffTerm where
toJSONPB (DiffTreeVertex'Deleted x) = object [ "deleted" .= Just x ]
toJSONPB (DiffTreeVertex'Inserted x) = object [ "inserted" .= Just x ]
toJSONPB (DiffTreeVertex'Replaced x) = object [ "replaced" .= Just x ]
toJSONPB (DiffTreeVertex'Merged x) = object [ "merged" .= Just x ]
toEncodingPB (DiffTreeVertex'Deleted x) = pairs [ "deleted" .= Just x ]
toEncodingPB (DiffTreeVertex'Inserted x) = pairs [ "inserted" .= Just x ]
toEncodingPB (DiffTreeVertex'Replaced x) = pairs [ "replaced" .= Just x ]
toEncodingPB (DiffTreeVertex'Merged x) = pairs [ "merged" .= Just x ]
instance FromJSON DiffTreeVertex'DiffTerm where
parseJSON = parseJSONPB
instance ToJSON DiffTreeVertex'DiffTerm where
toJSON = toAesonValue
toEncoding = toAesonEncoding
instance FromJSONPB DiffTreeVertex where
parseJSONPB = withObject "DiffTreeVertex" $ \obj -> do
diffVertexId' <- obj .: "diffVertexId"
diffTerm' <- obj A..:? "diffTerm"
pure $ defMessage
& P.diffVertexId .~ diffVertexId'
& P.maybe'diffTerm .~ diffTerm'
instance ToJSONPB DiffTreeVertex where
toJSONPB x = object
[ "diffVertexId" .= (x^.diffVertexId)
, "diffTerm" .= (x^.maybe'diffTerm)
]
toEncodingPB x = pairs
[ "diffVertexId" .= (x^.diffVertexId)
, "diffTerm" .= (x^.maybe'diffTerm)
]
instance FromJSON DiffTreeVertex where
parseJSON = parseJSONPB
instance ToJSON DiffTreeVertex where
toJSON = toAesonValue
toEncoding = toAesonEncoding
instance FromJSONPB DeletedTerm where
parseJSONPB = withObject "DeletedTerm" $ \obj -> do
term' <- obj .: "term"
span' <- obj A..:? "span"
pure $ defMessage
& P.term .~ term'
& P.maybe'span .~ span'
instance ToJSONPB DeletedTerm where
toJSONPB x = object
[ "term" .= (x^.term)
, "span" .= (x^.maybe'span)
]
toEncodingPB x = pairs
[ "term" .= (x^.term)
, "span" .= (x^.maybe'span)
]
instance FromJSON DeletedTerm where
parseJSON = parseJSONPB
instance ToJSON DeletedTerm where
toJSON = toAesonValue
toEncoding = toAesonEncoding
instance FromJSONPB InsertedTerm where
parseJSONPB = withObject "InsertedTerm" $ \obj -> do
term' <- obj .: "term"
span' <- obj A..:? "span"
pure $ defMessage
& P.term .~ term'
& P.maybe'span .~ span'
instance ToJSONPB InsertedTerm where
toJSONPB x = object
[ "term" .= (x^.term)
, "span" .= (x^.maybe'span)
]
toEncodingPB x = pairs
[ "term" .= (x^.term)
, "span" .= (x^.maybe'span)
]
instance FromJSON InsertedTerm where
parseJSON = parseJSONPB
instance ToJSON InsertedTerm where
toJSON = toAesonValue
toEncoding = toAesonEncoding
instance FromJSONPB ReplacedTerm where
parseJSONPB = withObject "ReplacedTerm" $ \obj -> do
beforeTerm' <- obj .: "beforeTerm"
beforeSpan' <- obj A..:? "beforeSpan"
afterTerm' <- obj .: "afterTerm"
afterSpan' <- obj A..:? "afterSpan"
pure $ defMessage
& P.beforeTerm .~ beforeTerm'
& P.maybe'beforeSpan .~ beforeSpan'
& P.afterTerm .~ afterTerm'
& P.maybe'afterSpan .~ afterSpan'
instance ToJSONPB ReplacedTerm where
toJSONPB x = object
[ "beforeTerm" .= (x^.beforeTerm)
, "beforeSpan" .= (x^.maybe'beforeSpan)
, "afterTerm" .= (x^.afterTerm)
, "afterSpan" .= (x^.maybe'afterSpan)
]
toEncodingPB x = pairs
[ "beforeTerm" .= (x^.beforeTerm)
, "beforeSpan" .= (x^.maybe'beforeSpan)
, "afterTerm" .= (x^.afterTerm)
, "afterSpan" .= (x^.maybe'afterSpan)
]
instance FromJSON ReplacedTerm where
parseJSON = parseJSONPB
instance ToJSON ReplacedTerm where
toJSON = toAesonValue
toEncoding = toAesonEncoding
instance FromJSONPB MergedTerm where
parseJSONPB = withObject "MergedTerm" $ \obj -> do
term' <- obj .: "term"
beforeSpan' <- obj A..:? "beforeSpan"
afterSpan' <- obj A..:? "afterSpan"
pure $ defMessage
& P.term .~ term'
& P.maybe'beforeSpan .~ beforeSpan'
& P.maybe'afterSpan .~ afterSpan'
instance ToJSONPB MergedTerm where
toJSONPB x = object
[ "term" .= (x^.term)
, "beforeSpan" .= (x^.maybe'beforeSpan)
, "afterSpan" .= (x^.maybe'afterSpan)
]
toEncodingPB x = pairs
[ "term" .= (x^.term)
, "beforeSpan" .= (x^.maybe'beforeSpan)
, "afterSpan" .= (x^.maybe'afterSpan)
]
instance FromJSON MergedTerm where
parseJSON = parseJSONPB
instance ToJSON MergedTerm where
toJSON = toAesonValue
toEncoding = toAesonEncoding
instance FromJSONPB Blob where
parseJSONPB = withObject "Blob" $ \obj -> do
content' <- obj .: "content"

23
semantic.cabal
View File

@ -16,7 +16,7 @@ build-type: Simple
stability: alpha
extra-source-files: README.md
tested-with: GHC == 8.8.1
tested-with: GHC == 8.8.3
flag release
description: Build with optimizations on (for CI or deployment builds)
@ -92,9 +92,7 @@ library
, Analysis.Abstract.Tracing
, Analysis.ConstructorName
, Analysis.CyclomaticComplexity
, Analysis.Decorator
, Analysis.HasTextElement
, Analysis.PackageDef
-- Semantic assignment
, Assigning.Assignment
, Assigning.Assignment.Table
@ -141,11 +139,9 @@ library
, Data.Abstract.Value.Concrete
, Data.Abstract.Value.Type
-- General datatype definitions & generic algorithms
, Data.Algebra
, Data.AST
, Data.Blob
, Data.Blob.IO
, Data.Diff
, Data.Duration
, Data.Edit
, Data.Error
@ -156,13 +152,13 @@ library
, Data.Handle
, Data.History
, Data.ImportPath
, Data.JSON.Fields
, Data.Language
, Data.Map.Monoidal
, Data.Maybe.Exts
, Data.Quieterm
, Data.Semigroup.App
, Data.Scientific.Exts
, Data.Term
-- À la carte syntax types
, Data.Syntax
, Data.Syntax.Comment
@ -172,13 +168,6 @@ library
, Data.Syntax.Literal
, Data.Syntax.Statement
, Data.Syntax.Type
, Data.Term
-- Diffing algorithms & interpretation thereof
, Diffing.Algorithm
, Diffing.Algorithm.RWS
, Diffing.Algorithm.RWS.FeatureVector
, Diffing.Algorithm.SES
, Diffing.Interpreter
-- Language-specific grammar/syntax types, & assignments
, Language.Go.Assignment
, Language.Go.Syntax
@ -208,15 +197,11 @@ library
-- Parser glue
, Parsing.Parser
, Parsing.TreeSitter
-- Rendering formats
, Rendering.Graph
, Rendering.JSON
-- High-level flow & operational functionality (logging, stats, etc.)
, Semantic.Analysis
-- API
, Semantic.Api
, Semantic.Api.Bridge
, Semantic.Api.Diffs
, Semantic.Api.StackGraph
, Semantic.Api.Symbols
, Semantic.Api.Terms
@ -322,7 +307,6 @@ test-suite test
, Control.Abstract.Evaluator.Spec
, Data.Abstract.Path.Spec
, Data.Abstract.Name.Spec
, Data.Diff.Spec
, Data.Functor.Classes.Generic.Spec
, Data.Functor.Listable
, Data.Graph.Spec
@ -331,9 +315,6 @@ test-suite test
, Data.Scientific.Spec
, Data.Semigroup.App.Spec
, Data.Term.Spec
, Diffing.Algorithm.RWS.Spec
, Diffing.Algorithm.SES.Spec
, Diffing.Interpreter.Spec
, Graphing.Calls.Spec
, Integration.Spec
, Numeric.Spec

17
src/Analysis/Decorator.hs
View File

@ -1,17 +0,0 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
module Analysis.Decorator
( decoratorWithAlgebra
) where
import Data.Algebra
import Data.Bifunctor
import Data.Functor.Foldable
import Data.Term
-- | Lift an algebra into a decorator for terms annotated with records.
decoratorWithAlgebra :: (Functor (Syntax term), IsTerm term, Recursive (term a), Base (term a) ~ TermF (Syntax term) a)
=> RAlgebra (TermF (Syntax term) a) (term a) b -- ^ An R-algebra on terms.
-> term a -- ^ A term to decorate with values produced by the R-algebra.
-> term b -- ^ A term decorated with values produced by the R-algebra.
decoratorWithAlgebra alg = para $ \ c@(In _ f) -> termIn (alg (fmap (second termAnnotation) c)) (fmap snd f)

101
src/Analysis/PackageDef.hs
View File

@ -1,101 +0,0 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Analysis.PackageDef
( PackageDef(..)
, HasPackageDef
, packageDefAlgebra
) where
import Data.Algebra
import Data.Blob
import Data.Proxy
import Data.Sum
import Data.Term
import qualified Data.Text as T
import qualified Language.Go.Syntax
import Source.Loc
import Source.Source as Source
newtype PackageDef = PackageDef { moduleDefIdentifier :: T.Text }
deriving (Eq, Show)
-- | An r-algebra producing 'Just' a 'PackageDef' for syntax nodes corresponding to high-level declarations, or 'Nothing' otherwise.
--
-- Customizing this for a given syntax type involves two steps:
--
-- 1. Defining a 'CustomHasPackageDef' instance for the type.
-- 2. Adding the type to the 'PackageDefStrategy' type family.
--
-- If you’re getting errors about missing a 'CustomHasPackageDef' instance for your syntax type, you probably forgot step 1.
--
-- If you’re getting 'Nothing' for your syntax node at runtime, you probably forgot step 2.
packageDefAlgebra :: (Foldable syntax, HasPackageDef syntax) => Blob -> RAlgebra (TermF syntax Loc) (Term syntax Loc) (Maybe PackageDef)
packageDefAlgebra blob (In ann syntax) = toPackageDef blob ann syntax
-- | Types for which we can produce a 'PackageDef' in 'Maybe'. There is exactly one instance of this typeclass; adding customized 'PackageDef's for a new type is done by defining an instance of 'CustomHasPackageDef' instead.
--
-- This typeclass employs the Advanced Overlap techniques designed by Oleg Kiselyov & Simon Peyton Jones: https://wiki.haskell.org/GHC/AdvancedOverlap.
class HasPackageDef syntax where
-- | Compute a 'PackageDef' for a syntax type using its 'CustomHasPackageDef' instance, if any, or else falling back to the default definition (which simply returns 'Nothing').
toPackageDef :: (Foldable whole) => Blob -> Loc -> syntax (Term whole Loc, Maybe PackageDef) -> Maybe PackageDef
-- | Define 'toPackageDef' using the 'CustomHasPackageDef' instance for a type if there is one or else use the default definition.
--
-- This instance determines whether or not there is an instance for @syntax@ by looking it up in the 'PackageDefStrategy' type family. Thus producing a 'PackageDef' for a node requires both defining a 'CustomHasPackageDef' instance _and_ adding a definition for the type to the 'PackageDefStrategy' type family to return 'Custom'.
--
-- Note that since 'PackageDefStrategy' has a fallback case for its final entry, this instance will hold for all types of kind @* -> *@. Thus, this must be the only instance of 'HasPackageDef', as any other instance would be indistinguishable.
instance (PackageDefStrategy syntax ~ strategy, HasPackageDefWithStrategy strategy syntax) => HasPackageDef syntax where
toPackageDef = toPackageDefWithStrategy (Proxy :: Proxy strategy)
-- | Types for which we can produce a customized 'PackageDef'. This returns in 'Maybe' so that some values can be opted out (e.g. anonymous functions).
class CustomHasPackageDef syntax where
-- | Produce a customized 'PackageDef' for a given syntax node.
customToPackageDef :: (Foldable whole) => Blob -> Loc -> syntax (Term whole Loc, Maybe PackageDef) -> Maybe PackageDef
instance CustomHasPackageDef Language.Go.Syntax.Package where
customToPackageDef Blob{..} _ (Language.Go.Syntax.Package (Term (In fromAnn _), _) _)
= Just $ PackageDef (getSource fromAnn)
where getSource = toText . Source.slice blobSource . byteRange
-- | Produce a 'PackageDef' for 'Sum's using the 'HasPackageDef' instance & therefore using a 'CustomHasPackageDef' instance when one exists & the type is listed in 'PackageDefStrategy'.
instance Apply HasPackageDef fs => CustomHasPackageDef (Sum fs) where
customToPackageDef blob ann = apply @HasPackageDef (toPackageDef blob ann)
-- | A strategy for defining a 'HasPackageDef' instance. Intended to be promoted to the kind level using @-XDataKinds@.
data Strategy = Default | Custom
-- | Produce a 'PackageDef' for a syntax node using either the 'Default' or 'Custom' strategy.
--
-- You should probably be using 'CustomHasPackageDef' instead of this class; and you should not define new instances of this class.
class HasPackageDefWithStrategy (strategy :: Strategy) syntax where
toPackageDefWithStrategy :: (Foldable whole) => proxy strategy -> Blob -> Loc -> syntax (Term whole Loc, Maybe PackageDef) -> Maybe PackageDef
-- | A predicate on syntax types selecting either the 'Custom' or 'Default' strategy.
--
-- Only entries for which we want to use the 'Custom' strategy should be listed, with the exception of the final entry which maps all other types onto the 'Default' strategy.
--
-- If you’re seeing errors about missing a 'CustomHasPackageDef' instance for a given type, you’ve probably listed it in here but not defined a 'CustomHasPackageDef' instance for it, or else you’ve listed the wrong type in here. Conversely, if your 'customHasPackageDef' method is never being called, you may have forgotten to list the type in here.
type family PackageDefStrategy syntax where
PackageDefStrategy Language.Go.Syntax.Package = 'Custom
PackageDefStrategy (Sum _) = 'Custom
PackageDefStrategy _ = 'Default
-- | The 'Default' strategy produces 'Nothing'.
instance HasPackageDefWithStrategy 'Default syntax where
toPackageDefWithStrategy _ _ _ _ = Nothing
-- | The 'Custom' strategy delegates the selection of the strategy to the 'CustomHasPackageDef' instance for the type.
instance CustomHasPackageDef syntax => HasPackageDefWithStrategy 'Custom syntax where
toPackageDefWithStrategy _ = customToPackageDef

10
src/Data/AST.hs
View File

@ -7,9 +7,6 @@ module Data.AST
) where
import Data.Term
import Data.Aeson
import Data.Text (pack)
import Data.JSON.Fields
import Source.Loc as Loc
-- | An AST node labelled with symbols and source location.
@ -21,13 +18,6 @@ data Node grammar = Node
}
deriving (Eq, Ord, Show)
instance Show grammar => ToJSONFields (Node grammar) where
toJSONFields Node{..} =
[ "symbol" .= pack (show nodeSymbol)
, "span" .= Loc.span nodeLocation
]
nodeSpan :: Node grammar -> Span
nodeSpan = Loc.span . nodeLocation

48
src/Data/Algebra.hs
View File

@ -1,48 +0,0 @@
{-# LANGUAGE DeriveGeneric, DeriveTraversable, RankNTypes #-}
module Data.Algebra
( FAlgebra
, RAlgebra
, Subterm(..)
, SubtermAlgebra
, embedTerm
, foldSubterms
) where
import Data.Functor.Classes.Generic as X
import Data.Functor.Foldable ( Base
, Corecursive(embed)
, Recursive(project)
)
import GHC.Generics
-- | An F-algebra on some 'Recursive' type @t@.
--
-- An F-algebra is an evaluator for a functor (@f@) populated with the results (@a@s) of evaluating each child of the functor to a result (@a@), applied at each node starting from the leaves and working towards the root. @a@ is called the carrier type of the algebra because it carries the (results of the) functions used to compute the functor’s structure and enforce the laws of that algebra.
type FAlgebra f a = f a -> a
-- | An R-algebra on some 'Recursive' type @t@.
--
-- An R-algebra is an evaluator for a functor (@f@) populated with pairs of the children (@t@) and the results (@a@s) of evaluating each child of the functor to a result (@a@), applied at each node starting from the leaves and working towards the root.
--
-- See also 'FAlgebra'.
type RAlgebra f t a = f (t, a) -> a
-- | A subterm and its computed value, used in 'SubtermAlgebra'.
data Subterm t a = Subterm { subterm :: !t, subtermRef :: !a }
deriving (Eq, Foldable, Functor, Generic1, Ord, Show, Traversable)
instance Eq t => Eq1 (Subterm t) where liftEq = genericLiftEq
instance Ord t => Ord1 (Subterm t) where liftCompare = genericLiftCompare
instance Show t => Show1 (Subterm t) where liftShowsPrec = genericLiftShowsPrec
-- | Like an R-algebra, but using 'Subterm' to label the fields instead of an anonymous pair.
type SubtermAlgebra f t a = f (Subterm t a) -> a
-- | Fold a 'Recursive' structure using a 'SubtermAlgebra'. Like 'para', but with named fields for subterms and values.
foldSubterms :: Recursive t => SubtermAlgebra (Base t) t a -> t -> a
foldSubterms algebra = go where go = algebra . fmap (Subterm <*> go) . project
-- | Extract a term from the carrier tuple associated with a paramorphism. See also 'embedSubterm'.
embedTerm :: Corecursive t => Base t (t, a) -> t
embedTerm e = embed (fst <$> e)

4
src/Data/Blob.hs
View File

@ -31,7 +31,6 @@ import Data.Aeson
import Data.Bifunctor
import qualified Data.ByteString.Lazy as BL
import Data.Edit
import Data.JSON.Fields
import Data.Maybe.Exts
import Data.Module
import Data.List (stripPrefix)
@ -100,8 +99,5 @@ pathKeyForBlobPair = mergeEdit combine . bimap blobFilePath blobFilePath where
combine before after | before == after = after
| otherwise = before <> " -> " <> after
instance ToJSONFields Blob where
toJSONFields p = [ "path" .= blobFilePath p, "language" .= blobLanguage p]
decodeBlobPairs :: BL.ByteString -> Either String [BlobPair]
decodeBlobPairs = fmap blobs <$> eitherDecode

199
src/Data/Diff.hs
View File

@ -1,199 +0,0 @@
{-# LANGUAGE DataKinds, LambdaCase, OverloadedStrings, RankNTypes, TypeFamilies, TypeOperators, ScopedTypeVariables, UndecidableInstances #-}
module Data.Diff
( Diff(..)
, DiffF(..)
, comparing
, compareF
, inserting
, insertF
, deleting
, deleteF
, merge
, mergeF
, merging
, diffPatches
) where
import Data.Aeson
import Data.Bifoldable
import Data.Bifunctor
import Data.Bitraversable
import Data.Edit
import Data.Functor.Classes
import Data.Functor.Foldable
import Data.JSON.Fields
import Data.Term
import Text.Show
-- | A recursive structure indicating the changed & unchanged portions of a labelled tree.
newtype Diff syntax ann1 ann2 = Diff { unDiff :: DiffF syntax ann1 ann2 (Diff syntax ann1 ann2) }
-- | A single entry within a recursive 'Diff'.
data DiffF syntax ann1 ann2 recur
-- | A changed node, represented as 'Insert'ed, 'Delete'd, or 'Compare'd 'TermF's, consisting of syntax labelled with an annotation.
= Patch (Edit (TermF syntax ann1 recur)
(TermF syntax ann2 recur))
-- | An unchanged node, consisting of syntax labelled with both the original annotations.
| Merge (TermF syntax (ann1, ann2) recur)
-- | Constructs a 'Diff' comparing one 'Term' with another recursively.
comparing :: Functor syntax => Term syntax ann1 -> Term syntax ann2 -> Diff syntax ann1 ann2
comparing (Term (In a1 r1)) (Term (In a2 r2)) = compareF (In a1 (deleting <$> r1)) (In a2 (inserting <$> r2))
-- | Constructs a 'Diff' comparing one 'TermF' populated by further 'Diff's with another.
compareF :: TermF syntax ann1 (Diff syntax ann1 ann2) -> TermF syntax ann2 (Diff syntax ann1 ann2) -> Diff syntax ann1 ann2
compareF t1 t2 = Diff (Patch (Compare t1 t2))
-- | Constructs a 'Diff' inserting a 'Term' recursively.
inserting :: Functor syntax => Term syntax ann2 -> Diff syntax ann1 ann2
inserting = cata insertF
-- | Constructs a 'Diff' inserting a single 'TermF' populated by further 'Diff's.
insertF :: TermF syntax ann2 (Diff syntax ann1 ann2) -> Diff syntax ann1 ann2
insertF = Diff . Patch . Insert
-- | Constructs a 'Diff' deleting a 'Term' recursively.
deleting :: Functor syntax => Term syntax ann1 -> Diff syntax ann1 ann2
deleting = cata deleteF
-- | Constructs a 'Diff' deleting a single 'TermF' populated by further 'Diff's.
deleteF :: TermF syntax ann1 (Diff syntax ann1 ann2) -> Diff syntax ann1 ann2
deleteF = Diff . Patch . Delete
-- | Constructs a 'Diff' merging two annotations for a single syntax functor populated by further 'Diff's.
merge :: (ann1, ann2) -> syntax (Diff syntax ann1 ann2) -> Diff syntax ann1 ann2
merge = fmap mergeF . In
-- | Constructs a 'Diff' merging a single 'TermF' populated by further 'Diff's.
mergeF :: TermF syntax (ann1, ann2) (Diff syntax ann1 ann2) -> Diff syntax ann1 ann2
mergeF = Diff . Merge
-- | Constructs a 'Diff' merging a 'Term' recursively.
--
-- Note that since this simply duplicates the 'Term'’s annotations, it is only really useful in tests or other contexts where preserving annotations from both sides is unnecessary.
merging :: Functor syntax => Term syntax ann -> Diff syntax ann ann
merging = cata (\ (In ann syntax) -> mergeF (In (ann, ann) syntax))
diffPatches :: (Foldable syntax, Functor syntax) => Diff syntax ann1 ann2 -> [Edit (TermF syntax ann1 (Diff syntax ann1 ann2)) (TermF syntax ann2 (Diff syntax ann1 ann2))]
diffPatches = para $ \case
Patch patch -> bimap (fmap fst) (fmap fst) patch : bifoldMap (foldMap snd) (foldMap snd) patch
Merge merge -> foldMap snd merge
type instance Base (Diff syntax ann1 ann2) = DiffF syntax ann1 ann2
instance Functor syntax => Recursive (Diff syntax ann1 ann2) where project = unDiff
instance Functor syntax => Corecursive (Diff syntax ann1 ann2) where embed = Diff
instance Eq1 syntax => Eq2 (Diff syntax) where
liftEq2 eq1 eq2 = go where go (Diff d1) (Diff d2) = liftEq3 eq1 eq2 go d1 d2
instance (Eq1 syntax, Eq ann1, Eq ann2) => Eq (Diff syntax ann1 ann2) where
(==) = eq2
instance Eq1 syntax => Eq3 (DiffF syntax) where
liftEq3 eq1 eq2 eqRecur d1 d2 = case (d1, d2) of
(Patch p1, Patch p2) -> liftEq2 (liftEq2 eq1 eqRecur) (liftEq2 eq2 eqRecur) p1 p2
(Merge t1, Merge t2) -> liftEq2 (liftEq2 eq1 eq2) eqRecur t1 t2
_ -> False
instance (Eq1 syntax, Eq ann1, Eq ann2) => Eq1 (DiffF syntax ann1 ann2) where
liftEq = liftEq3 (==) (==)
instance (Eq1 syntax, Eq ann1, Eq ann2, Eq recur) => Eq (DiffF syntax ann1 ann2 recur) where
(==) = eq3
instance Show1 syntax => Show2 (Diff syntax) where
liftShowsPrec2 sp1 sl1 sp2 sl2 = go where go d = showsUnaryWith (liftShowsPrec3 sp1 sl1 sp2 sl2 go (showListWith (go 0))) "Diff" d . unDiff
instance (Show1 syntax, Show ann1, Show ann2) => Show (Diff syntax ann1 ann2) where
showsPrec = showsPrec2
instance Show1 syntax => Show3 (DiffF syntax) where
liftShowsPrec3 sp1 sl1 sp2 sl2 spRecur slRecur d diff = case diff of
Patch patch -> showsUnaryWith (liftShowsPrec2 (liftShowsPrec2 sp1 sl1 spRecur slRecur) (liftShowList2 sp1 sl1 spRecur slRecur) (liftShowsPrec2 sp2 sl2 spRecur slRecur) (liftShowList2 sp2 sl2 spRecur slRecur)) "Patch" d patch
Merge term -> showsUnaryWith (liftShowsPrec2 spBoth slBoth spRecur slRecur) "Merge" d term
where spBoth = liftShowsPrec2 sp1 sl1 sp2 sl2
slBoth = liftShowList2 sp1 sl1 sp2 sl2
instance (Show1 syntax, Show ann1, Show ann2) => Show1 (DiffF syntax ann1 ann2) where
liftShowsPrec = liftShowsPrec3 showsPrec showList showsPrec showList
instance (Show1 syntax, Show ann1, Show ann2, Show recur) => Show (DiffF syntax ann1 ann2 recur) where
showsPrec = showsPrec3
instance Functor syntax => Bifunctor (Diff syntax) where
bimap f g = go where go = Diff . trimap f g go . unDiff
instance Foldable syntax => Bifoldable (Diff syntax) where
bifoldMap f g = go where go = trifoldMap f g go . unDiff
instance Traversable syntax => Bitraversable (Diff syntax) where
bitraverse f g = go where go = fmap Diff . tritraverse f g go . unDiff
instance Functor syntax => Functor (DiffF syntax ann1 ann2) where
fmap = trimap id id
instance Functor syntax => Trifunctor (DiffF syntax) where
trimap f g h (Patch patch) = Patch (bimap (bimap f h) (bimap g h) patch)
trimap f g h (Merge term) = Merge (bimap (bimap f g) h term)
instance Foldable syntax => Foldable (DiffF syntax ann1 ann2) where
foldMap = trifoldMap (const mempty) (const mempty)
instance Foldable syntax => Trifoldable (DiffF syntax) where
trifoldMap f g h (Patch patch) = bifoldMap (bifoldMap f h) (bifoldMap g h) patch
trifoldMap f g h (Merge term) = bifoldMap (bifoldMap f g) h term
instance Traversable syntax => Traversable (DiffF syntax ann1 ann2) where
traverse = tritraverse pure pure
instance Traversable syntax => Tritraversable (DiffF syntax) where
tritraverse f g h (Patch patch) = Patch <$> bitraverse (bitraverse f h) (bitraverse g h) patch
tritraverse f g h (Merge term) = Merge <$> bitraverse (bitraverse f g) h term
instance (ToJSONFields1 syntax, ToJSONFields ann1, ToJSONFields ann2) => ToJSON (Diff syntax ann1 ann2) where
toJSON = object . toJSONFields
toEncoding = pairs . mconcat . toJSONFields
instance (ToJSONFields1 syntax, ToJSONFields ann1, ToJSONFields ann2) => ToJSONFields (Diff syntax ann1 ann2) where
toJSONFields = toJSONFields . unDiff
instance (ToJSONFields1 syntax, ToJSONFields ann1, ToJSONFields ann2) => ToJSONFields1 (DiffF syntax ann1 ann2) where
toJSONFields1 (Patch patch) = [ "patch" .= JSONFields patch ]
toJSONFields1 (Merge term) = [ "merge" .= JSONFields term ]
instance (ToJSONFields1 syntax, ToJSONFields ann1, ToJSONFields ann2, ToJSON recur) => ToJSONFields (DiffF syntax ann1 ann2 recur) where
toJSONFields = toJSONFields1
instance (ToJSONFields1 syntax, ToJSONFields ann1, ToJSONFields ann2, ToJSON recur) => ToJSON (DiffF syntax ann1 ann2 recur) where
toJSON = object . toJSONFields
toEncoding = pairs . mconcat . toJSONFields
class Eq3 f where
liftEq3 :: (a1 -> a2 -> Bool) -> (b1 -> b2 -> Bool) -> (c1 -> c2 -> Bool) -> f a1 b1 c1 -> f a2 b2 c2 -> Bool
eq3 :: (Eq3 f, Eq a, Eq b, Eq c) => f a b c -> f a b c -> Bool
eq3 = liftEq3 (==) (==) (==)
class Show3 f where
liftShowsPrec3 :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> (Int -> b -> ShowS) -> ([b] -> ShowS) -> (Int -> c -> ShowS) -> ([c] -> ShowS) -> Int -> f a b c -> ShowS
showsPrec3 :: (Show3 f, Show a, Show b, Show c) => Int -> f a b c -> ShowS
showsPrec3 = liftShowsPrec3 showsPrec showList showsPrec showList showsPrec showList
class Trifunctor f where
trimap :: (a -> a') -> (b -> b') -> (c -> c') -> f a b c -> f a' b' c'
class Trifoldable f where
trifoldMap :: Monoid m => (a -> m) -> (b -> m) -> (c -> m) -> f a b c -> m
class Tritraversable f where
tritraverse :: Applicative g => (a -> g a') -> (b -> g b') -> (c -> g c') -> f a b c -> g (f a' b' c')

6
src/Data/Graph/Algebraic.hs
View File

@ -25,15 +25,12 @@ import qualified Algebra.Graph.Class as Class
import qualified Algebra.Graph.ToGraph as Class
import Control.Applicative
import Control.Carrier.State.Strict
import Control.Lens (view)
import Data.Aeson
import Data.Foldable
import Data.Function
import Data.Semilattice.Lower
import Data.Set (Set)
import qualified Data.Set as Set
import Proto.Semantic as P
import Proto.Semantic_Fields as P
-- | An algebraic graph with 'Ord', 'Semigroup', and 'Monoid' instances.
newtype Graph vertex = Graph { unGraph :: G.Graph vertex }
@ -110,9 +107,6 @@ instance Ord vertex => Ord (Graph vertex) where
class VertexTag vertex where
uniqueTag :: vertex -> Int
instance VertexTag DiffTreeVertex where uniqueTag = fromIntegral . view diffVertexId
instance VertexTag TermVertex where uniqueTag = fromIntegral . view vertexId
instance (Ord vertex, ToJSON vertex, VertexTag vertex) => ToJSON (Graph vertex) where
toJSON (Graph graph) = object ["vertices" .= G.vertexList graph, "edges" .= (Edge <$> G.edgeList graph)]
toEncoding (Graph graph) = pairs ("vertices" .= G.vertexList graph <> "edges" .= (Edge <$> G.edgeList graph))

176
src/Data/JSON/Fields.hs
View File

@ -1,176 +0,0 @@
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Data.JSON.Fields
( JSONFields (..)
, JSONFields1 (..)
, ToJSONFields (..)
, ToJSONFields1 (..)
, (.=)
) where
import Data.Aeson
import Data.Bifunctor.Join
import Data.Edit
import qualified Data.Map as Map
import Data.Maybe
import Data.ScopeGraph
import Data.Sum
import Data.Text (Text)
import qualified Data.Text as Text
import GHC.Generics
import Source.Loc
import Source.Range
class ToJSONFields a where
toJSONFields :: KeyValue kv => a -> [kv]
class ToJSONFields1 f where
toJSONFields1 :: (KeyValue kv, ToJSON a) => f a -> [kv]
default toJSONFields1 :: (KeyValue kv, ToJSON a, GToJSONFields1 (Rep1 f), GConstructorName1 (Rep1 f), Generic1 f) => f a -> [kv]
toJSONFields1 s = let r = from1 s in
"term" .= gconstructorName1 r : Map.foldrWithKey m [] (gtoJSONFields1 r)
where
m _ [] acc = acc
m k [v] acc = (k .= v) : acc
m k vs acc = (k .= vs) : acc
instance ToJSONFields a => ToJSONFields (Join (,) a) where
toJSONFields (Join (a, b)) = [ "before" .= object (toJSONFields a), "after" .= object (toJSONFields b) ]
instance ToJSONFields a => ToJSONFields (Maybe a) where
toJSONFields = maybe [] toJSONFields
instance ToJSON a => ToJSONFields [a] where
toJSONFields list = [ "children" .= list ]
instance ToJSONFields1 [] where
toJSONFields1 list = [ "children" .= list ]
instance Apply ToJSONFields1 fs => ToJSONFields1 (Sum fs) where
toJSONFields1 = apply @ToJSONFields1 toJSONFields1
instance (ToJSONFields a, ToJSONFields b) => ToJSONFields (a, b) where
toJSONFields (a, b) = [ "before" .= JSONFields a, "after" .= JSONFields b ]
instance ToJSONFields Range where
toJSONFields Range{..} = ["sourceRange" .= [ start, end ]]
instance ToJSONFields Span where
toJSONFields sourceSpan = [ "sourceSpan" .= sourceSpan ]
instance ToJSONFields Loc where
toJSONFields Loc{..} = toJSONFields byteRange <> toJSONFields span
instance (ToJSONFields a, ToJSONFields b) => ToJSONFields (Edit a b) where
toJSONFields (Insert a) = [ "insert" .= object (toJSONFields a) ]
toJSONFields (Delete a) = [ "delete" .= object (toJSONFields a) ]
toJSONFields (Compare a b) = [ "replace" .= [object (toJSONFields a), object (toJSONFields b)] ]
newtype JSONFields a = JSONFields { unJSONFields :: a }
instance ToJSONFields a => ToJSONFields (JSONFields a) where
toJSONFields = toJSONFields . unJSONFields
instance ToJSONFields a => ToJSON (JSONFields a) where
toJSON = object . toJSONFields . unJSONFields
toEncoding = pairs . mconcat . toJSONFields . unJSONFields
instance ToJSONFields AccessControl where
toJSONFields accessControl = ["accessControl" .= accessControl]
newtype JSONFields1 f a = JSONFields1 { unJSONFields1 :: f a }
instance ToJSONFields1 f => ToJSONFields1 (JSONFields1 f) where
toJSONFields1 = toJSONFields1 . unJSONFields1
instance (ToJSON a, ToJSONFields1 f) => ToJSONFields (JSONFields1 f a) where
toJSONFields = toJSONFields1 . unJSONFields1
instance (ToJSON a, ToJSONFields1 f) => ToJSON (JSONFields1 f a) where
toJSON = object . toJSONFields1 . unJSONFields1
toEncoding = pairs . mconcat . toJSONFields1 . unJSONFields1
-- | A typeclass to retrieve the name of a data constructor.
class GConstructorName1 f where
gconstructorName1 :: f a -> String
instance Apply GConstructorName1 fs => GConstructorName1 (Sum fs) where
gconstructorName1 = apply @GConstructorName1 gconstructorName1
instance GConstructorName1 f => GConstructorName1 (M1 D c f) where
gconstructorName1 = gconstructorName1 . unM1
instance Constructor c => GConstructorName1 (M1 C c f) where
gconstructorName1 = conName
instance (GConstructorName1 f, GConstructorName1 g) => GConstructorName1 (f :+: g) where
gconstructorName1 (L1 l) = gconstructorName1 l
gconstructorName1 (R1 r) = gconstructorName1 r
-- | A typeclass to calculate a list of 'KeyValue's describing the record selector names and associated values on a datatype.
class GToJSONFields1 f where
-- FIXME: Not ideal to allocate a Map each time here, but not an obvious way
-- to deal with product types without record selectors that all end up as an
-- array under a "children" property.
gtoJSONFields1 :: (ToJSON a) => f a -> Map.Map Text [SomeJSON]
instance GToJSONFields1 f => GToJSONFields1 (M1 D c f) where
gtoJSONFields1 = gtoJSONFields1 . unM1
instance GToJSONFields1 f => GToJSONFields1 (M1 C c f) where
gtoJSONFields1 = gtoJSONFields1 . unM1
instance GToJSONFields1 U1 where
gtoJSONFields1 _ = mempty
instance (Selector c, GSelectorJSONValue1 f) => GToJSONFields1 (M1 S c f) where
gtoJSONFields1 m1 = Map.fromList [gselectorJSONValue1 keyName (unM1 m1)]
where keyName = case selName m1 of
"" -> Nothing
n -> Just (Text.pack n)
instance (GToJSONFields1 f, GToJSONFields1 g) => GToJSONFields1 (f :+: g) where
gtoJSONFields1 (L1 l) = gtoJSONFields1 l
gtoJSONFields1 (R1 r) = gtoJSONFields1 r
instance (GToJSONFields1 f, GToJSONFields1 g) => GToJSONFields1 (f :*: g) where
gtoJSONFields1 (x :*: y) = Map.unionWith (<>) (gtoJSONFields1 x) (gtoJSONFields1 y)
-- | A typeclass to retrieve the JSON 'Value' of a record selector.
class GSelectorJSONValue1 f where
gselectorJSONValue1 :: (ToJSON a) => Maybe Text -> f a -> (Text, [SomeJSON])
instance GSelectorJSONValue1 Par1 where
gselectorJSONValue1 k x = (fromMaybe "children" k, [SomeJSON (unPar1 x)])
instance ToJSON1 f => GSelectorJSONValue1 (Rec1 f) where
gselectorJSONValue1 k x = (fromMaybe "children" k, [SomeJSON (SomeJSON1 (unRec1 x))])
instance ToJSON k => GSelectorJSONValue1 (K1 r k) where
gselectorJSONValue1 k x = (fromMaybe "value" k, [SomeJSON (unK1 x)])
-- | An existential type wrapping an JSON-compatible data type.
data SomeJSON where
SomeJSON :: ToJSON a => a -> SomeJSON
instance ToJSON SomeJSON where
toJSON (SomeJSON a) = toJSON a
toEncoding (SomeJSON a) = toEncoding a
data SomeJSON1 where
SomeJSON1 :: (ToJSON1 f, ToJSON a) => f a -> SomeJSON1
instance ToJSON SomeJSON1 where
toJSON (SomeJSON1 fa) = toJSON1 fa
toEncoding (SomeJSON1 fa) = toEncoding1 fa

19
src/Data/Syntax.hs
View File

@ -17,12 +17,14 @@
{-# LANGUAGE UndecidableInstances #-}
module Data.Syntax (module Data.Syntax) where
import qualified Assigning.Assignment as Assignment
import Control.Abstract.Heap (deref, lookupSlot)
import Control.Abstract.ScopeGraph (Declaration (..), Reference (..), reference)
import Data.Abstract.Evaluatable hiding (Empty, Error)
import qualified Data.Abstract.ScopeGraph as ScopeGraph
import Data.Aeson as Aeson (ToJSON (..), object)
import Data.Aeson ((.=))
import Data.Bifunctor
import qualified Data.Error as Error
import Data.Foldable
@ -33,7 +35,6 @@ import Data.Functor.Foldable (cata)
import Data.Hashable
import Data.Hashable.Lifted
import Data.Ix
import Data.JSON.Fields
import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
import Data.Proxy
import Data.Semigroup (sconcat)
@ -41,7 +42,6 @@ import qualified Data.Set as Set
import Data.Sum
import Data.Term
import Data.Text (Text)
import Diffing.Algorithm
import GHC.Generics
import GHC.Stack
import GHC.TypeLits
@ -143,7 +143,7 @@ instance (Element f all, c f, Generate c all fs) => Generate c all (f ': fs) whe
-- | An identifier of some other construct, whether a containing declaration (e.g. a class name) or a reference (e.g. a variable).
newtype Identifier a = Identifier { name :: Name }
deriving (Diffable, Foldable, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Foldable, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Identifier where liftEq = genericLiftEq
instance Ord1 Identifier where liftCompare = genericLiftCompare
@ -169,7 +169,7 @@ instance Declarations1 Identifier where
-- | An accessibility modifier, e.g. private, public, protected, etc.
newtype AccessibilityModifier a = AccessibilityModifier { contents :: Text }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 AccessibilityModifier where liftEq = genericLiftEq
instance Ord1 AccessibilityModifier where liftCompare = genericLiftCompare
@ -182,7 +182,7 @@ instance Evaluatable AccessibilityModifier
--
-- This can be used to represent an implicit no-op, e.g. the alternative in an 'if' statement without an 'else'.
data Empty a = Empty
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Empty where liftEq = genericLiftEq
instance Ord1 Empty where liftCompare = genericLiftCompare
@ -193,7 +193,7 @@ instance Evaluatable Empty where
-- | Syntax representing a parsing or assignment error.
data Error a = Error { errorCallStack :: ErrorStack, errorExpected :: [String], errorActual :: Maybe String, errorChildren :: [a] }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Error where liftEq = genericLiftEq
instance Ord1 Error where liftCompare = genericLiftCompare
@ -257,17 +257,12 @@ instance (Error :< fs, Apply Foldable fs, Apply Functor fs) => HasErrors (Term (
data Context a = Context { contextTerms :: NonEmpty a, contextSubject :: a }
deriving (Foldable, FreeVariables1, Functor, Generic1, ToJSONFields1, Traversable)
deriving (Foldable, FreeVariables1, Functor, Generic1, Traversable)
instance Eq1 Context where liftEq = genericLiftEq
instance Ord1 Context where liftCompare = genericLiftCompare
instance Show1 Context where liftShowsPrec = genericLiftShowsPrec
instance Diffable Context where
subalgorithmFor blur focus (Context n s) = Context <$> traverse blur n <*> focus s
equivalentBySubterm = Just . contextSubject
instance Hashable1 Context where liftHashWithSalt = foldl
instance Evaluatable Context where

6
src/Data/Syntax/Comment.hs
View File

@ -8,14 +8,12 @@ module Data.Syntax.Comment (module Data.Syntax.Comment) where
import Data.Abstract.Evaluatable
import Data.Functor.Classes.Generic
import Data.Hashable.Lifted
import Data.JSON.Fields
import Data.Text (Text)
import Diffing.Algorithm
import GHC.Generics (Generic1)
-- | An unnested comment (line or block).
newtype Comment a = Comment { commentContent :: Text }
deriving (Diffable, Foldable, Functor, Generic1, Hashable1, Traversable, FreeVariables1, Declarations1, ToJSONFields1)
deriving (Foldable, Functor, Generic1, Hashable1, Traversable, FreeVariables1, Declarations1)
instance Eq1 Comment where liftEq = genericLiftEq
instance Ord1 Comment where liftCompare = genericLiftCompare
@ -31,7 +29,7 @@ instance Evaluatable Comment where
-- | HashBang line (e.g. `#!/usr/bin/env node`)
newtype HashBang a = HashBang { value :: Text }
deriving (Diffable, Foldable, Functor, Generic1, Hashable1, Traversable, FreeVariables1, Declarations1, ToJSONFields1)
deriving (Foldable, Functor, Generic1, Hashable1, Traversable, FreeVariables1, Declarations1)
instance Eq1 HashBang where liftEq = genericLiftEq
instance Ord1 HashBang where liftCompare = genericLiftCompare

43
src/Data/Syntax/Declaration.hs
View File

@ -25,20 +25,15 @@ import GHC.Generics (Generic1)
import Control.Abstract hiding (AccessControl (..), Function)
import Data.Abstract.Evaluatable
import qualified Data.Abstract.ScopeGraph as ScopeGraph
import Data.JSON.Fields
import Diffing.Algorithm
import Source.Span
data Function a = Function { functionContext :: ![a], functionName :: !a, functionParameters :: ![a], functionBody :: !a }
deriving (Foldable, Traversable, Functor, Generic1, Hashable1, ToJSONFields1)
deriving (Foldable, Traversable, Functor, Generic1, Hashable1)
instance Eq1 Function where liftEq = genericLiftEq
instance Ord1 Function where liftCompare = genericLiftCompare
instance Show1 Function where liftShowsPrec = genericLiftShowsPrec
instance Diffable Function where
equivalentBySubterm = Just . functionName
-- TODO: Filter the closed-over environment by the free variables in the term.
-- TODO: How should we represent function types, where applicable?
@ -87,15 +82,12 @@ data Method a = Method
, methodBody :: a
, methodAccessControl :: ScopeGraph.AccessControl
}
deriving (Foldable, Traversable, Functor, Generic1, Hashable1, ToJSONFields1)
deriving (Foldable, Traversable, Functor, Generic1, Hashable1)
instance Eq1 Method where liftEq = genericLiftEq
instance Ord1 Method where liftCompare = genericLiftCompare
instance Show1 Method where liftShowsPrec = genericLiftShowsPrec
instance Diffable Method where
equivalentBySubterm = Just . methodName
-- Evaluating a Method creates a closure and makes that value available in the
-- local environment.
instance Evaluatable Method where
@ -126,7 +118,7 @@ data MethodSignature a = MethodSignature
, methodSignatureParameters :: [a]
, methodSignatureAccessControl :: ScopeGraph.AccessControl
}
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 MethodSignature where liftEq = genericLiftEq
instance Ord1 MethodSignature where liftCompare = genericLiftCompare
@ -137,7 +129,7 @@ instance Evaluatable MethodSignature
newtype RequiredParameter a = RequiredParameter { requiredParameter :: a }
deriving (Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 RequiredParameter where liftEq = genericLiftEq
instance Ord1 RequiredParameter where liftCompare = genericLiftCompare
@ -155,7 +147,7 @@ instance Evaluatable RequiredParameter where
newtype OptionalParameter a = OptionalParameter { optionalParameter :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 OptionalParameter where liftEq = genericLiftEq
instance Ord1 OptionalParameter where liftCompare = genericLiftCompare
@ -170,7 +162,7 @@ instance Evaluatable OptionalParameter
-- TODO: It would be really nice to have a more meaningful type contained in here than [a]
-- | A declaration of possibly many variables such as var foo = 5, bar = 6 in JavaScript.
newtype VariableDeclaration a = VariableDeclaration { variableDeclarations :: [a] }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 VariableDeclaration where liftEq = genericLiftEq
instance Ord1 VariableDeclaration where liftCompare = genericLiftCompare
@ -193,7 +185,7 @@ instance Declarations a => Declarations (VariableDeclaration a) where
-- | A TypeScript/Java style interface declaration to implement.
data InterfaceDeclaration a = InterfaceDeclaration { interfaceDeclarationContext :: ![a], interfaceDeclarationIdentifier :: !a, interfaceDeclarationSuperInterfaces :: ![a], interfaceDeclarationBody :: !a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 InterfaceDeclaration where liftEq = genericLiftEq
instance Ord1 InterfaceDeclaration where liftCompare = genericLiftCompare
@ -213,7 +205,7 @@ data PublicFieldDefinition a = PublicFieldDefinition
, publicFieldValue :: a
, publicFieldAccessControl :: ScopeGraph.AccessControl
}
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 PublicFieldDefinition where liftEq = genericLiftEq
instance Ord1 PublicFieldDefinition where liftCompare = genericLiftCompare
@ -230,7 +222,7 @@ instance Evaluatable PublicFieldDefinition where
unit
data Variable a = Variable { variableName :: !a, variableType :: !a, variableValue :: !a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Variable where liftEq = genericLiftEq
instance Ord1 Variable where liftCompare = genericLiftCompare
@ -240,7 +232,7 @@ instance Show1 Variable where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Variable
data Class a = Class { classContext :: ![a], classIdentifier :: !a, classSuperclasses :: ![a], classBody :: !a }
deriving (Foldable, Traversable, Functor, Generic1, Hashable1, FreeVariables1, ToJSONFields1)
deriving (Foldable, Traversable, Functor, Generic1, Hashable1, FreeVariables1)
instance Eq1 Class where liftEq = genericLiftEq
instance Ord1 Class where liftCompare = genericLiftCompare
@ -249,9 +241,6 @@ instance Show1 Class where liftShowsPrec = genericLiftShowsPrec
instance Declarations a => Declarations (Class a) where
declaredName (Class _ name _ _) = declaredName name
instance Diffable Class where
equivalentBySubterm = Just . classIdentifier
instance Evaluatable Class where
eval eval _ Class{..} = do
span <- ask @Span
@ -288,7 +277,7 @@ instance Declarations1 Class where
-- | A decorator in Python
data Decorator a = Decorator { decoratorIdentifier :: !a, decoratorParamaters :: ![a], decoratorBody :: !a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Decorator where liftEq = genericLiftEq
instance Ord1 Decorator where liftCompare = genericLiftCompare
@ -302,7 +291,7 @@ instance Evaluatable Decorator
-- | An ADT, i.e. a disjoint sum of products, like 'data' in Haskell, or 'enum' in Rust or Swift.
data Datatype a = Datatype { datatypeContext :: a, datatypeName :: a, datatypeConstructors :: [a], datatypeDeriving :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Datatype where liftEq = genericLiftEq
instance Ord1 Datatype where liftCompare = genericLiftCompare
@ -314,7 +303,7 @@ instance Evaluatable Data.Syntax.Declaration.Datatype
-- | A single constructor in a datatype, or equally a 'struct' in C, Rust, or Swift.
data Constructor a = Constructor { constructorContext :: [a], constructorName :: a, constructorFields :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Constructor where liftEq = genericLiftEq
instance Ord1 Constructor where liftCompare = genericLiftCompare
@ -326,7 +315,7 @@ instance Evaluatable Data.Syntax.Declaration.Constructor
-- | Comprehension (e.g. ((a for b in c if a()) in Python)
data Comprehension a = Comprehension { comprehensionValue :: !a, comprehensionBody :: !a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Comprehension where liftEq = genericLiftEq
instance Ord1 Comprehension where liftCompare = genericLiftCompare
@ -338,7 +327,7 @@ instance Evaluatable Comprehension
-- | A declared type (e.g. `a []int` in Go).
data Type a = Type { typeName :: !a, typeKind :: !a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Type where liftEq = genericLiftEq
instance Ord1 Type where liftCompare = genericLiftCompare
@ -350,7 +339,7 @@ instance Evaluatable Type
-- | Type alias declarations in Javascript/Haskell, etc.
data TypeAlias a = TypeAlias { typeAliasContext :: ![a], typeAliasIdentifier :: !a, typeAliasKind :: !a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 TypeAlias where liftEq = genericLiftEq
instance Ord1 TypeAlias where liftCompare = genericLiftCompare

6
src/Data/Syntax/Directive.hs
View File

@ -10,16 +10,14 @@ import Data.Abstract.Evaluatable
import Data.Abstract.Module (ModuleInfo (..))
import Data.Functor.Classes.Generic
import Data.Hashable.Lifted
import Data.JSON.Fields
import qualified Data.Text as T
import Diffing.Algorithm
import GHC.Generics (Generic1)
import Source.Span
import qualified System.Path as Path
-- A file directive like the Ruby constant `__FILE__`.
data File a = File
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 File where liftEq = genericLiftEq
instance Ord1 File where liftCompare = genericLiftCompare
@ -31,7 +29,7 @@ instance Evaluatable File where
-- A line directive like the Ruby constant `__LINE__`.
data Line a = Line
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Line where liftEq = genericLiftEq
instance Ord1 Line where liftCompare = genericLiftCompare

92
src/Data/Syntax/Expression.hs
View File

@ -25,19 +25,17 @@ import Data.Fixed
import Data.Foldable (for_)
import Data.Functor.Classes.Generic
import Data.Hashable.Lifted
import Data.JSON.Fields
import Data.List (find)
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.Map.Strict as Map
import Data.Maybe
import Data.Maybe.Exts
import Diffing.Algorithm hiding (Delete)
import GHC.Generics (Generic1)
-- | Typical prefix function application, like `f(x)` in many languages, or `f x` in Haskell.
data Call a = Call { callContext :: ![a], callFunction :: !a, callParams :: ![a], callBlock :: !a }
deriving (Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Call where liftEq = genericLiftEq
instance Ord1 Call where liftCompare = genericLiftCompare
@ -53,7 +51,7 @@ instance Evaluatable Call where
call op args
data LessThan a = LessThan { lhs :: a, rhs :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 LessThan where liftEq = genericLiftEq
instance Ord1 LessThan where liftCompare = genericLiftCompare
@ -64,7 +62,7 @@ instance Evaluatable LessThan where
go (LessThan a b) = liftComparison (Concrete (<)) a b
data LessThanEqual a = LessThanEqual { lhs :: a, rhs :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 LessThanEqual where liftEq = genericLiftEq
instance Ord1 LessThanEqual where liftCompare = genericLiftCompare
@ -75,7 +73,7 @@ instance Evaluatable LessThanEqual where
go (LessThanEqual a b) = liftComparison (Concrete (<=)) a b
data GreaterThan a = GreaterThan { lhs :: a, rhs :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 GreaterThan where liftEq = genericLiftEq
instance Ord1 GreaterThan where liftCompare = genericLiftCompare
@ -86,7 +84,7 @@ instance Evaluatable GreaterThan where
go (GreaterThan a b) = liftComparison (Concrete (>)) a b
data GreaterThanEqual a = GreaterThanEqual { lhs :: a, rhs :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 GreaterThanEqual where liftEq = genericLiftEq
instance Ord1 GreaterThanEqual where liftCompare = genericLiftCompare
@ -97,7 +95,7 @@ instance Evaluatable GreaterThanEqual where
go (GreaterThanEqual a b) = liftComparison (Concrete (>=)) a b
data Equal a = Equal { lhs :: a, rhs :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Equal where liftEq = genericLiftEq
instance Ord1 Equal where liftCompare = genericLiftCompare
@ -110,7 +108,7 @@ instance Evaluatable Equal where
go (Equal a b) = liftComparison (Concrete (==)) a b
data StrictEqual a = StrictEqual { lhs :: a, rhs :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 StrictEqual where liftEq = genericLiftEq
instance Ord1 StrictEqual where liftCompare = genericLiftCompare
@ -123,7 +121,7 @@ instance Evaluatable StrictEqual where
go (StrictEqual a b) = liftComparison (Concrete (==)) a b
data Comparison a = Comparison { lhs :: a, rhs :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Comparison where liftEq = genericLiftEq
instance Ord1 Comparison where liftCompare = genericLiftCompare
@ -134,7 +132,7 @@ instance Evaluatable Comparison where
go (Comparison a b) = liftComparison (Concrete (==)) a b
data Plus a = Plus { lhs :: a, rhs :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Plus where liftEq = genericLiftEq
instance Ord1 Plus where liftCompare = genericLiftCompare
@ -145,7 +143,7 @@ instance Evaluatable Plus where
go (Plus a b) = liftNumeric2 add a b where add = liftReal (+)
data Minus a = Minus { lhs :: a, rhs :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Minus where liftEq = genericLiftEq
instance Ord1 Minus where liftCompare = genericLiftCompare
@ -156,7 +154,7 @@ instance Evaluatable Minus where
go (Minus a b) = liftNumeric2 (liftReal (-)) a b
data Times a = Times { lhs :: a, rhs :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Times where liftEq = genericLiftEq
instance Ord1 Times where liftCompare = genericLiftCompare
@ -167,7 +165,7 @@ instance Evaluatable Times where
go (Times a b) = liftNumeric2 (liftReal (*)) a b
data DividedBy a = DividedBy { lhs :: a, rhs :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 DividedBy where liftEq = genericLiftEq
instance Ord1 DividedBy where liftCompare = genericLiftCompare
@ -178,7 +176,7 @@ instance Evaluatable DividedBy where
go (DividedBy a b) = liftNumeric2 (liftIntegralFrac div (/)) a b
data Modulo a = Modulo { lhs :: a, rhs :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Modulo where liftEq = genericLiftEq
instance Ord1 Modulo where liftCompare = genericLiftCompare
@ -189,7 +187,7 @@ instance Evaluatable Modulo where
go (Modulo a b) = liftNumeric2 (liftIntegralFrac mod mod') a b
data Power a = Power { lhs :: a, rhs :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Power where liftEq = genericLiftEq
instance Ord1 Power where liftCompare = genericLiftCompare
@ -200,7 +198,7 @@ instance Evaluatable Power where
go (Power a b) = liftNumeric2 liftedExponent a b
newtype Negate a = Negate { value :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Negate where liftEq = genericLiftEq
instance Ord1 Negate where liftCompare = genericLiftCompare
@ -211,7 +209,7 @@ instance Evaluatable Negate where
go (Negate a) = liftNumeric negate a
data FloorDivision a = FloorDivision { lhs :: a, rhs :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 FloorDivision where liftEq = genericLiftEq
instance Ord1 FloorDivision where liftCompare = genericLiftCompare
@ -223,7 +221,7 @@ instance Evaluatable FloorDivision where
-- | Regex matching operators (Ruby's =~ and ~!)
data Matches a = Matches { lhs :: a, rhs :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Matches where liftEq = genericLiftEq
instance Ord1 Matches where liftCompare = genericLiftCompare
@ -232,7 +230,7 @@ instance Show1 Matches where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Matches
data NotMatches a = NotMatches { lhs :: a, rhs :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 NotMatches where liftEq = genericLiftEq
instance Ord1 NotMatches where liftCompare = genericLiftCompare
@ -241,7 +239,7 @@ instance Show1 NotMatches where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable NotMatches
data Or a = Or { lhs :: a, rhs :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Or where liftEq = genericLiftEq
instance Ord1 Or where liftCompare = genericLiftCompare
@ -253,7 +251,7 @@ instance Evaluatable Or where
ifthenelse a' (pure a') (eval b)
data And a = And { lhs :: a, rhs :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 And where liftEq = genericLiftEq
instance Ord1 And where liftCompare = genericLiftCompare
@ -265,7 +263,7 @@ instance Evaluatable And where
ifthenelse a' (eval b) (pure a')
newtype Not a = Not { value :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Not where liftEq = genericLiftEq
instance Ord1 Not where liftCompare = genericLiftCompare
@ -275,7 +273,7 @@ instance Evaluatable Not where
eval eval _ (Not a) = eval a >>= asBool >>= boolean . not
data XOr a = XOr { lhs :: a, rhs :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 XOr where liftEq = genericLiftEq
instance Ord1 XOr where liftCompare = genericLiftCompare
@ -287,7 +285,7 @@ instance Evaluatable XOr where
-- | Javascript delete operator
newtype Delete a = Delete { value :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Delete where liftEq = genericLiftEq
instance Ord1 Delete where liftCompare = genericLiftCompare
@ -298,7 +296,7 @@ instance Evaluatable Delete where
-- | A sequence expression such as Javascript or C's comma operator.
data SequenceExpression a = SequenceExpression { firstExpression :: !a, secondExpression :: !a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 SequenceExpression where liftEq = genericLiftEq
instance Ord1 SequenceExpression where liftCompare = genericLiftCompare
@ -310,7 +308,7 @@ instance Evaluatable SequenceExpression where
-- | Javascript void operator
newtype Void a = Void { value :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Void where liftEq = genericLiftEq
instance Ord1 Void where liftCompare = genericLiftCompare
@ -322,7 +320,7 @@ instance Evaluatable Void where
-- | Javascript typeof operator
newtype Typeof a = Typeof { value :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Typeof where liftEq = genericLiftEq
instance Ord1 Typeof where liftCompare = genericLiftCompare
@ -333,7 +331,7 @@ instance Evaluatable Typeof
-- | Bitwise operators.
data BOr a = BOr { lhs :: a, rhs :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 BOr where liftEq = genericLiftEq
instance Ord1 BOr where liftCompare = genericLiftCompare
@ -346,7 +344,7 @@ instance Evaluatable BOr where
liftBitwise2 (.|.) a' b'
data BAnd a = BAnd { lhs :: a, rhs :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 BAnd where liftEq = genericLiftEq
instance Ord1 BAnd where liftCompare = genericLiftCompare
@ -359,7 +357,7 @@ instance Evaluatable BAnd where
liftBitwise2 (.&.) a' b'
data BXOr a = BXOr { lhs :: a, rhs :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 BXOr where liftEq = genericLiftEq
instance Ord1 BXOr where liftCompare = genericLiftCompare
@ -372,7 +370,7 @@ instance Evaluatable BXOr where
liftBitwise2 xor a' b'
data LShift a = LShift { lhs :: a, rhs :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 LShift where liftEq = genericLiftEq
instance Ord1 LShift where liftCompare = genericLiftCompare
@ -387,7 +385,7 @@ instance Evaluatable LShift where
shiftL' a b = shiftL a (fromIntegral (toInteger b))
data RShift a = RShift { lhs :: a, rhs :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 RShift where liftEq = genericLiftEq
instance Ord1 RShift where liftCompare = genericLiftCompare
@ -402,7 +400,7 @@ instance Evaluatable RShift where
shiftR' a b = shiftR a (fromIntegral (toInteger b))
data UnsignedRShift a = UnsignedRShift { lhs :: a, rhs :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 UnsignedRShift where liftEq = genericLiftEq
instance Ord1 UnsignedRShift where liftCompare = genericLiftCompare
@ -415,7 +413,7 @@ instance Evaluatable UnsignedRShift where
unsignedRShift a' b'
newtype Complement a = Complement { value :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Complement where liftEq = genericLiftEq
instance Ord1 Complement where liftCompare = genericLiftCompare
@ -428,7 +426,7 @@ instance Evaluatable Complement where
-- | Member Access (e.g. a.b)
data MemberAccess a = MemberAccess { lhs :: a, rhs :: a }
deriving (Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 MemberAccess where liftEq = genericLiftEq
instance Ord1 MemberAccess where liftCompare = genericLiftCompare
@ -479,7 +477,7 @@ instance Evaluatable MemberAccess where
-- | Subscript (e.g a[1])
data Subscript a = Subscript { lhs :: a, rhs :: [a] }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Subscript where liftEq = genericLiftEq
instance Ord1 Subscript where liftCompare = genericLiftCompare
@ -492,7 +490,7 @@ instance Evaluatable Subscript where
eval _ _ (Subscript _ _) = throwUnspecializedError (UnspecializedError "Eval unspecialized for subscript with slices")
data Member a = Member { lhs :: a, rhs :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Member where liftEq = genericLiftEq
instance Ord1 Member where liftCompare = genericLiftCompare
@ -502,7 +500,7 @@ instance Evaluatable Member where
-- | Enumeration (e.g. a[1:10:1] in Python (start at index 1, stop at index 10, step 1 element from start to stop))
data Enumeration a = Enumeration { enumerationStart :: !a, enumerationEnd :: !a, enumerationStep :: !a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Enumeration where liftEq = genericLiftEq
instance Ord1 Enumeration where liftCompare = genericLiftCompare
@ -513,7 +511,7 @@ instance Evaluatable Enumeration
-- | InstanceOf (e.g. a instanceof b in JavaScript
data InstanceOf a = InstanceOf { instanceOfSubject :: !a, instanceOfObject :: !a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 InstanceOf where liftEq = genericLiftEq
instance Ord1 InstanceOf where liftCompare = genericLiftCompare
@ -525,7 +523,7 @@ instance Evaluatable InstanceOf
-- | ScopeResolution (e.g. import a.b in Python or a::b in C++)
newtype ScopeResolution a = ScopeResolution { scopes :: NonEmpty a }
deriving (Diffable, Foldable, FreeVariables1, Functor, Generic1, ToJSONFields1, Traversable)
deriving (Foldable, FreeVariables1, Functor, Generic1, Traversable)
instance Eq1 ScopeResolution where liftEq = genericLiftEq
instance Ord1 ScopeResolution where liftCompare = genericLiftCompare
@ -540,7 +538,7 @@ instance Declarations1 ScopeResolution where
-- | A non-null expression such as Typescript or Swift's ! expression.
newtype NonNullExpression a = NonNullExpression { nonNullExpression :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 NonNullExpression where liftEq = genericLiftEq
instance Ord1 NonNullExpression where liftCompare = genericLiftCompare
@ -552,7 +550,7 @@ instance Evaluatable NonNullExpression
-- | An await expression in Javascript or C#.
newtype Await a = Await { awaitSubject :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Await where liftEq = genericLiftEq
instance Ord1 Await where liftCompare = genericLiftCompare
@ -564,7 +562,7 @@ instance Evaluatable Await where
-- | An object constructor call in Javascript, Java, etc.
data New a = New { newSubject :: a , newTypeParameters :: a, newArguments :: [a] }
deriving (Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 New where liftEq = genericLiftEq
instance Ord1 New where liftCompare = genericLiftCompare
@ -610,7 +608,7 @@ instance Evaluatable New where
-- | A cast expression to a specified type.
data Cast a = Cast { castSubject :: !a, castType :: !a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Cast where liftEq = genericLiftEq
instance Ord1 Cast where liftCompare = genericLiftCompare
@ -619,7 +617,7 @@ instance Show1 Cast where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Cast
data Super a = Super
deriving (Diffable, Foldable, Functor, Generic1, Traversable, FreeVariables1, Declarations1, ToJSONFields1, Hashable1)
deriving (Foldable, Functor, Generic1, Traversable, FreeVariables1, Declarations1, Hashable1)
instance Eq1 Super where liftEq = genericLiftEq
instance Ord1 Super where liftCompare = genericLiftCompare
@ -628,7 +626,7 @@ instance Show1 Super where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Super
data This a = This
deriving (Diffable, Foldable, Functor, Generic1, Traversable, FreeVariables1, Declarations1, ToJSONFields1, Hashable1)
deriving (Foldable, Functor, Generic1, Traversable, FreeVariables1, Declarations1, Hashable1)
instance Eq1 This where liftEq = genericLiftEq
instance Ord1 This where liftCompare = genericLiftCompare

44
src/Data/Syntax/Literal.hs
View File

@ -14,11 +14,9 @@ import Control.Monad
import Data.Abstract.Evaluatable as Eval
import Data.Functor.Classes.Generic
import Data.Hashable.Lifted
import Data.JSON.Fields
import Data.Scientific.Exts
import Data.Text (Text)
import qualified Data.Text as T
import Diffing.Algorithm
import GHC.Generics (Generic1)
import Numeric.Exts
import Text.Read (readMaybe)
@ -26,7 +24,7 @@ import Text.Read (readMaybe)
-- Boolean
newtype Boolean a = Boolean { booleanContent :: Bool }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Boolean where liftEq = genericLiftEq
instance Ord1 Boolean where liftCompare = genericLiftCompare
@ -43,7 +41,7 @@ instance Evaluatable Boolean where
-- | A literal integer of unspecified width. No particular base is implied.
newtype Integer a = Integer { integerContent :: Text }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Data.Syntax.Literal.Integer where liftEq = genericLiftEq
instance Ord1 Data.Syntax.Literal.Integer where liftCompare = genericLiftCompare
@ -57,7 +55,7 @@ instance Evaluatable Data.Syntax.Literal.Integer where
-- | A literal float of unspecified width.
newtype Float a = Float { floatContent :: Text }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Data.Syntax.Literal.Float where liftEq = genericLiftEq
instance Ord1 Data.Syntax.Literal.Float where liftCompare = genericLiftCompare
@ -70,7 +68,7 @@ instance Evaluatable Data.Syntax.Literal.Float where
-- Rational literals e.g. `2/3r`
newtype Rational a = Rational { value :: Text }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Data.Syntax.Literal.Rational where liftEq = genericLiftEq
instance Ord1 Data.Syntax.Literal.Rational where liftCompare = genericLiftCompare
@ -85,7 +83,7 @@ instance Evaluatable Data.Syntax.Literal.Rational where
-- Complex literals e.g. `3 + 2i`
newtype Complex a = Complex { value :: Text }
deriving (Diffable, Foldable, Functor, Generic1, Hashable1, Traversable, FreeVariables1, Declarations1, ToJSONFields1)
deriving (Foldable, Functor, Generic1, Hashable1, Traversable, FreeVariables1, Declarations1)
instance Eq1 Complex where liftEq = genericLiftEq
instance Ord1 Complex where liftCompare = genericLiftCompare
@ -97,7 +95,7 @@ instance Evaluatable Complex
-- Strings, symbols
newtype String a = String { stringElements :: [a] }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Data.Syntax.Literal.String where liftEq = genericLiftEq
instance Ord1 Data.Syntax.Literal.String where liftCompare = genericLiftCompare
@ -109,7 +107,7 @@ instance Show1 Data.Syntax.Literal.String where liftShowsPrec = genericLiftShows
instance Evaluatable Data.Syntax.Literal.String
newtype Character a = Character { characterContent :: Text }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Character where liftEq = genericLiftEq
instance Ord1 Character where liftCompare = genericLiftCompare
@ -119,7 +117,7 @@ instance Evaluatable Data.Syntax.Literal.Character
-- | An interpolation element within a string literal.
newtype InterpolationElement a = InterpolationElement { interpolationBody :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 InterpolationElement where liftEq = genericLiftEq
instance Ord1 InterpolationElement where liftCompare = genericLiftCompare
@ -130,7 +128,7 @@ instance Evaluatable InterpolationElement
-- | A sequence of textual contents within a string literal.
newtype TextElement a = TextElement { textElementContent :: Text }
deriving (Diffable, Foldable, Functor, Generic1, Hashable1, Traversable, FreeVariables1, Declarations1, ToJSONFields1)
deriving (Foldable, Functor, Generic1, Hashable1, Traversable, FreeVariables1, Declarations1)
instance Eq1 TextElement where liftEq = genericLiftEq
instance Ord1 TextElement where liftCompare = genericLiftCompare
@ -149,7 +147,7 @@ quoted t = TextElement ("\"" <> t <> "\"")
-- | A sequence of textual contents within a string literal.
newtype EscapeSequence a = EscapeSequence { value :: Text }
deriving (Diffable, Foldable, Functor, Generic1, Hashable1, Traversable, FreeVariables1, Declarations1, ToJSONFields1)
deriving (Foldable, Functor, Generic1, Hashable1, Traversable, FreeVariables1, Declarations1)
instance Eq1 EscapeSequence where liftEq = genericLiftEq
instance Ord1 EscapeSequence where liftCompare = genericLiftCompare
@ -159,7 +157,7 @@ instance Show1 EscapeSequence where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable EscapeSequence
data Null a = Null
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Null where liftEq = genericLiftEq
instance Ord1 Null where liftCompare = genericLiftCompare
@ -168,7 +166,7 @@ instance Show1 Null where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Null where eval _ _ _ = pure null
newtype Symbol a = Symbol { symbolElements :: [a] }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Symbol where liftEq = genericLiftEq
instance Ord1 Symbol where liftCompare = genericLiftCompare
@ -178,7 +176,7 @@ instance Show1 Symbol where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Symbol
newtype SymbolElement a = SymbolElement { symbolContent :: Text }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 SymbolElement where liftEq = genericLiftEq
instance Ord1 SymbolElement where liftCompare = genericLiftCompare
@ -188,7 +186,7 @@ instance Evaluatable SymbolElement where
eval _ _ (SymbolElement s) = string s
newtype Regex a = Regex { regexContent :: Text }
deriving (Diffable, Foldable, Functor, Generic1, Hashable1, Traversable, FreeVariables1, Declarations1, ToJSONFields1)
deriving (Foldable, Functor, Generic1, Hashable1, Traversable, FreeVariables1, Declarations1)
instance Eq1 Regex where liftEq = genericLiftEq
instance Ord1 Regex where liftCompare = genericLiftCompare
@ -203,7 +201,7 @@ instance Evaluatable Regex where
-- Collections
newtype Array a = Array { arrayElements :: [a] }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Array where liftEq = genericLiftEq
instance Ord1 Array where liftCompare = genericLiftCompare
@ -213,7 +211,7 @@ instance Evaluatable Array where
eval eval _ Array{..} = array =<< traverse eval arrayElements
newtype Hash a = Hash { hashElements :: [a] }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Hash where liftEq = genericLiftEq
instance Ord1 Hash where liftCompare = genericLiftCompare
@ -225,7 +223,7 @@ instance Evaluatable Hash where
Eval.hash elements
data KeyValue a = KeyValue { key :: !a, value :: !a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 KeyValue where liftEq = genericLiftEq
instance Ord1 KeyValue where liftCompare = genericLiftCompare
@ -238,7 +236,7 @@ instance Evaluatable KeyValue where
kvPair k v
newtype Tuple a = Tuple { tupleContents :: [a] }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Tuple where liftEq = genericLiftEq
instance Ord1 Tuple where liftCompare = genericLiftCompare
@ -248,7 +246,7 @@ instance Evaluatable Tuple where
eval eval _ (Tuple cs) = tuple =<< traverse eval cs
newtype Set a = Set { setElements :: [a] }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Set where liftEq = genericLiftEq
instance Ord1 Set where liftCompare = genericLiftCompare
@ -262,7 +260,7 @@ instance Evaluatable Set
-- | A declared pointer (e.g. var pointer *int in Go)
newtype Pointer a = Pointer { value :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Pointer where liftEq = genericLiftEq
instance Ord1 Pointer where liftCompare = genericLiftCompare
@ -274,7 +272,7 @@ instance Evaluatable Pointer
-- | A reference to a pointer's address (e.g. &pointer in Go)
newtype Reference a = Reference { value :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Reference where liftEq = genericLiftEq
instance Ord1 Reference where liftCompare = genericLiftCompare

62
src/Data/Syntax/Statement.hs
View File

@ -15,13 +15,11 @@ import qualified Data.Abstract.ScopeGraph as ScopeGraph
import Data.Aeson (ToJSON1 (..))
import Data.Functor.Classes.Generic
import Data.Hashable.Lifted
import Data.JSON.Fields
import Data.List.NonEmpty (nonEmpty)
import qualified Data.Map.Strict as Map
import Data.Maybe.Exts
import Data.Semigroup.App
import Data.Semigroup.Foldable
import Diffing.Algorithm
import GHC.Generics (Generic1)
-- | Imperative sequence of statements/declarations s.t.:
@ -31,7 +29,7 @@ import GHC.Generics (Generic1)
-- 3. Only the last statement’s return value is returned.
-- TODO: Separate top-level statement nodes into non-lexical Statement and lexical StatementBlock nodes
newtype Statements a = Statements { statements :: [a] }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Statements where liftEq = genericLiftEq
instance Ord1 Statements where liftCompare = genericLiftCompare
@ -44,7 +42,7 @@ instance Evaluatable Statements where
maybe unit (runApp . foldMap1 (App . eval)) (nonEmpty xs)
newtype StatementBlock a = StatementBlock { statements :: [a] }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 StatementBlock where liftEq = genericLiftEq
instance Ord1 StatementBlock where liftCompare = genericLiftCompare
@ -58,7 +56,7 @@ instance Evaluatable StatementBlock where
-- | Conditional. This must have an else block, which can be filled with some default value when omitted in the source, e.g. 'pure ()' for C-style if-without-else or 'pure Nothing' for Ruby-style, in both cases assuming some appropriate Applicative context into which the If will be lifted.
data If a = If { ifCondition :: !a, ifThenBody :: !a, ifElseBody :: !a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 If where liftEq = genericLiftEq
instance Ord1 If where liftCompare = genericLiftCompare
@ -72,7 +70,7 @@ instance Evaluatable If where
-- | Else statement. The else condition is any term, that upon successful completion, continues evaluation to the elseBody, e.g. `for ... else` in Python.
data Else a = Else { elseCondition :: !a, elseBody :: !a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Else where liftEq = genericLiftEq
instance Ord1 Else where liftCompare = genericLiftCompare
@ -86,7 +84,7 @@ instance Evaluatable Else
-- | Goto statement (e.g. `goto a` in Go).
newtype Goto a = Goto { gotoLocation :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Goto where liftEq = genericLiftEq
instance Ord1 Goto where liftCompare = genericLiftCompare
@ -97,7 +95,7 @@ instance Evaluatable Goto
-- | A pattern-matching or computed jump control-flow statement, like 'switch' in C or JavaScript, or 'case' in Ruby or Haskell.
data Match a = Match { matchSubject :: !a, matchPatterns :: !a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Match where liftEq = genericLiftEq
instance Ord1 Match where liftCompare = genericLiftCompare
@ -109,7 +107,7 @@ instance Evaluatable Match
-- | A pattern in a pattern-matching or computed jump control-flow statement, like 'case' in C or JavaScript, 'when' in Ruby, or the left-hand side of '->' in the body of Haskell 'case' expressions.
data Pattern a = Pattern { value :: !a, patternBody :: !a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Pattern where liftEq = genericLiftEq
instance Ord1 Pattern where liftCompare = genericLiftCompare
@ -120,7 +118,7 @@ instance Evaluatable Pattern
-- | A let statement or local binding, like 'a as b' or 'let a = b'.
data Let a = Let { letVariable :: !a, letValue :: !a, letBody :: !a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Let where liftEq = genericLiftEq
instance Ord1 Let where liftCompare = genericLiftCompare
@ -145,7 +143,7 @@ instance Evaluatable Let where
-- AugmentedAssignment
newtype AugmentedAssignment a = AugmentedAssignment { augmentedAssignmentTarget :: a }
deriving (Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 AugmentedAssignment where liftEq = genericLiftEq
instance Ord1 AugmentedAssignment where liftCompare = genericLiftCompare
@ -161,7 +159,7 @@ instance Evaluatable AugmentedAssignment
-- | Assignment to a variable or other lvalue.
data Assignment a = Assignment { assignmentContext :: ![a], assignmentTarget :: !a, assignmentValue :: !a }
deriving (Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Assignment where liftEq = genericLiftEq
instance Ord1 Assignment where liftCompare = genericLiftCompare
@ -191,7 +189,7 @@ instance Evaluatable Assignment where
-- | Post increment operator (e.g. 1++ in Go, or i++ in C).
newtype PostIncrement a = PostIncrement { value :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 PostIncrement where liftEq = genericLiftEq
instance Ord1 PostIncrement where liftCompare = genericLiftCompare
@ -203,7 +201,7 @@ instance Evaluatable PostIncrement
-- | Post decrement operator (e.g. 1-- in Go, or i-- in C).
newtype PostDecrement a = PostDecrement { value :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 PostDecrement where liftEq = genericLiftEq
instance Ord1 PostDecrement where liftCompare = genericLiftCompare
@ -214,7 +212,7 @@ instance Evaluatable PostDecrement
-- | Pre increment operator (e.g. ++1 in C or Java).
newtype PreIncrement a = PreIncrement { value :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 PreIncrement where liftEq = genericLiftEq
instance Ord1 PreIncrement where liftCompare = genericLiftCompare
@ -226,7 +224,7 @@ instance Evaluatable PreIncrement
-- | Pre decrement operator (e.g. --1 in C or Java).
newtype PreDecrement a = PreDecrement { value :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 PreDecrement where liftEq = genericLiftEq
instance Ord1 PreDecrement where liftCompare = genericLiftCompare
@ -239,7 +237,7 @@ instance Evaluatable PreDecrement
-- Returns
newtype Return a = Return { value :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Return where liftEq = genericLiftEq
instance Ord1 Return where liftCompare = genericLiftCompare
@ -249,7 +247,7 @@ instance Evaluatable Return where
eval eval _ (Return x) = eval x >>= earlyReturn
newtype Yield a = Yield { value :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Yield where liftEq = genericLiftEq
instance Ord1 Yield where liftCompare = genericLiftCompare
@ -260,7 +258,7 @@ instance Evaluatable Yield
newtype Break a = Break { value :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Break where liftEq = genericLiftEq
instance Ord1 Break where liftCompare = genericLiftCompare
@ -270,7 +268,7 @@ instance Evaluatable Break where
eval eval _ (Break x) = eval x >>= throwBreak
newtype Continue a = Continue { value :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Continue where liftEq = genericLiftEq
instance Ord1 Continue where liftCompare = genericLiftCompare
@ -280,7 +278,7 @@ instance Evaluatable Continue where
eval eval _ (Continue x) = eval x >>= throwContinue
newtype Retry a = Retry { value :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Retry where liftEq = genericLiftEq
instance Ord1 Retry where liftCompare = genericLiftCompare
@ -290,7 +288,7 @@ instance Show1 Retry where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Retry
newtype NoOp a = NoOp { value :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 NoOp where liftEq = genericLiftEq
instance Ord1 NoOp where liftCompare = genericLiftCompare
@ -302,7 +300,7 @@ instance Evaluatable NoOp where
-- Loops
data For a = For { forBefore :: !a, forCondition :: !a, forStep :: !a, forBody :: !a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 For where liftEq = genericLiftEq
instance Ord1 For where liftCompare = genericLiftCompare
@ -312,7 +310,7 @@ instance Evaluatable For where
eval eval _ (fmap eval -> For before cond step body) = forLoop before cond step body
data ForEach a = ForEach { forEachBinding :: !a, forEachSubject :: !a, forEachBody :: !a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 ForEach where liftEq = genericLiftEq
instance Ord1 ForEach where liftCompare = genericLiftCompare
@ -322,7 +320,7 @@ instance Show1 ForEach where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable ForEach
data While a = While { whileCondition :: !a, whileBody :: !a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 While where liftEq = genericLiftEq
instance Ord1 While where liftCompare = genericLiftCompare
@ -332,7 +330,7 @@ instance Evaluatable While where
eval eval _ While{..} = while (eval whileCondition) (eval whileBody)
data DoWhile a = DoWhile { doWhileCondition :: !a, doWhileBody :: !a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 DoWhile where liftEq = genericLiftEq
instance Ord1 DoWhile where liftCompare = genericLiftCompare
@ -344,7 +342,7 @@ instance Evaluatable DoWhile where
-- Exception handling
newtype Throw a = Throw { value :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Throw where liftEq = genericLiftEq
instance Ord1 Throw where liftCompare = genericLiftCompare
@ -355,7 +353,7 @@ instance Evaluatable Throw
data Try a = Try { tryBody :: !a, tryCatch :: ![a] }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Try where liftEq = genericLiftEq
instance Ord1 Try where liftCompare = genericLiftCompare
@ -365,7 +363,7 @@ instance Show1 Try where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Try
data Catch a = Catch { catchException :: !a, catchBody :: !a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Catch where liftEq = genericLiftEq
instance Ord1 Catch where liftCompare = genericLiftCompare
@ -375,7 +373,7 @@ instance Show1 Catch where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Catch
newtype Finally a = Finally { value :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Finally where liftEq = genericLiftEq
instance Ord1 Finally where liftCompare = genericLiftCompare
@ -388,7 +386,7 @@ instance Evaluatable Finally
-- | ScopeEntry (e.g. `BEGIN {}` block in Ruby or Perl).
newtype ScopeEntry a = ScopeEntry { terms :: [a] }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 ScopeEntry where liftEq = genericLiftEq
instance Ord1 ScopeEntry where liftCompare = genericLiftCompare
@ -400,7 +398,7 @@ instance Evaluatable ScopeEntry
-- | ScopeExit (e.g. `END {}` block in Ruby or Perl).
newtype ScopeExit a = ScopeExit { terms :: [a] }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 ScopeExit where liftEq = genericLiftEq
instance Ord1 ScopeExit where liftCompare = genericLiftCompare

34
src/Data/Syntax/Type.hs
View File

@ -11,13 +11,11 @@ module Data.Syntax.Type (module Data.Syntax.Type) where
import Data.Abstract.Evaluatable
import Data.Functor.Classes.Generic
import Data.Hashable.Lifted
import Data.JSON.Fields
import Diffing.Algorithm
import GHC.Generics (Generic1)
import Prelude hiding (Bool, Double, Float, Int)
data Array a = Array { arraySize :: Maybe a, arrayElementType :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Array where liftEq = genericLiftEq
instance Ord1 Array where liftCompare = genericLiftCompare
@ -29,7 +27,7 @@ instance Evaluatable Array
-- TODO: What about type variables? re: FreeVariables1
data Annotation a = Annotation { annotationSubject :: a, annotationType :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Annotation where liftEq = genericLiftEq
instance Ord1 Annotation where liftCompare = genericLiftCompare
@ -41,7 +39,7 @@ instance Evaluatable Annotation where
data Function a = Function { functionParameters :: [a], functionReturn :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Function where liftEq = genericLiftEq
instance Ord1 Function where liftCompare = genericLiftCompare
@ -52,7 +50,7 @@ instance Evaluatable Function
newtype Interface a = Interface { values :: [a] }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Interface where liftEq = genericLiftEq
instance Ord1 Interface where liftCompare = genericLiftCompare
@ -62,7 +60,7 @@ instance Show1 Interface where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Interface
data Map a = Map { mapKeyType :: a, mapElementType :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Map where liftEq = genericLiftEq
instance Ord1 Map where liftCompare = genericLiftCompare
@ -72,7 +70,7 @@ instance Show1 Map where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Map
newtype Parenthesized a = Parenthesized { value :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Parenthesized where liftEq = genericLiftEq
instance Ord1 Parenthesized where liftCompare = genericLiftCompare
@ -82,7 +80,7 @@ instance Show1 Parenthesized where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Parenthesized
newtype Pointer a = Pointer { value :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Pointer where liftEq = genericLiftEq
instance Ord1 Pointer where liftCompare = genericLiftCompare
@ -92,7 +90,7 @@ instance Show1 Pointer where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Pointer
newtype Product a = Product { values :: [a] }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Product where liftEq = genericLiftEq
instance Ord1 Product where liftCompare = genericLiftCompare
@ -103,7 +101,7 @@ instance Evaluatable Product
data Readonly a = Readonly
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Readonly where liftEq = genericLiftEq
instance Ord1 Readonly where liftCompare = genericLiftCompare
@ -113,7 +111,7 @@ instance Show1 Readonly where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Readonly
newtype Slice a = Slice { value :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Slice where liftEq = genericLiftEq
instance Ord1 Slice where liftCompare = genericLiftCompare
@ -123,7 +121,7 @@ instance Show1 Slice where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Slice
newtype TypeParameters a = TypeParameters { terms :: [a] }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 TypeParameters where liftEq = genericLiftEq
instance Ord1 TypeParameters where liftCompare = genericLiftCompare
@ -134,7 +132,7 @@ instance Evaluatable TypeParameters
-- data instead of newtype because no payload
data Void a = Void
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Void where liftEq = genericLiftEq
instance Ord1 Void where liftCompare = genericLiftCompare
@ -145,7 +143,7 @@ instance Evaluatable Void
-- data instead of newtype because no payload
data Int a = Int
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Int where liftEq = genericLiftEq
instance Ord1 Int where liftCompare = genericLiftCompare
@ -155,7 +153,7 @@ instance Show1 Int where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Int
data Float a = Float
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Float where liftEq = genericLiftEq
instance Ord1 Float where liftCompare = genericLiftCompare
@ -165,7 +163,7 @@ instance Show1 Float where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Float
data Double a = Double
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Double where liftEq = genericLiftEq
instance Ord1 Double where liftCompare = genericLiftCompare
@ -175,7 +173,7 @@ instance Show1 Double where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Double
data Bool a = Bool
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Bool where liftEq = genericLiftEq
instance Ord1 Bool where liftCompare = genericLiftCompare

17
src/Data/Term.hs
View File

@ -24,13 +24,11 @@ module Data.Term
) where
import Control.Lens.Lens
import Data.Aeson
import Data.Bifoldable
import Data.Bifunctor
import Data.Bitraversable
import Data.Functor.Classes
import Data.Functor.Foldable
import Data.JSON.Fields
import Data.Sum
import qualified Data.Sum as Sum
import GHC.Generics (Generic1)
@ -142,21 +140,6 @@ instance Ord1 f => Ord2 (TermF f) where
instance (Ord1 f, Ord a) => Ord1 (TermF f a) where
liftCompare = liftCompare2 compare
instance (ToJSONFields a, ToJSONFields1 f) => ToJSON (Term f a) where
toJSON = object . toJSONFields
toEncoding = pairs . mconcat . toJSONFields
instance (ToJSONFields a, ToJSONFields1 f) => ToJSONFields (Term f a) where
toJSONFields = toJSONFields . unTerm
instance (ToJSON b, ToJSONFields a, ToJSONFields1 f) => ToJSONFields (TermF f a b) where
toJSONFields (In a f) = toJSONFields1 f <> toJSONFields a
instance (ToJSON b, ToJSONFields a, ToJSONFields1 f) => ToJSON (TermF f a b) where
toJSON = object . toJSONFields
toEncoding = pairs . mconcat . toJSONFields
class IsTerm term where
type Syntax term :: * -> *

311
src/Diffing/Algorithm.hs
View File

@ -1,311 +0,0 @@
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Diffing.Algorithm
( Diff (..)
, Algorithm(..)
, Diffable (..)
, Equivalence (..)
, diff
, diffEdit
, diffMaybe
, linearly
, byReplacing
, comparableTerms
, equivalentTerms
, algorithmForTerms
) where
import Control.Algebra hiding ((:+:))
import Control.Applicative
import Control.Effect.NonDet
import qualified Data.Diff as Diff
import qualified Data.Edit as Edit
import Data.Functor
import Data.Functor.Classes
import Data.List.NonEmpty
import Data.Maybe
import Data.Maybe.Exts
import Data.Sum
import Data.Term
import GHC.Generics
-- | A single step in a diffing algorithm, parameterized by the types of terms, diffs, and the result of the applicable algorithm.
data Diff term1 term2 diff (m :: * -> *) k
-- | Diff two terms with the choice of algorithm left to the interpreter’s discretion.
= Diff term1 term2 (diff -> m k)
-- | Diff two terms recursively in O(n) time, resulting in a single diff node.
| Linear term1 term2 (diff -> m k)
-- | Diff two lists of terms by each element’s similarity in O(n³ log n), resulting in a list of diffs.
| RWS [term1] [term2] ([diff] -> m k)
-- | Delete a term.
| Delete term1 (diff -> m k)
-- | Insert a term.
| Insert term2 (diff -> m k)
-- | Replace one term with another.
| Replace term1 term2 (diff -> m k)
deriving (Functor, Generic1)
instance HFunctor (Diff term1 term2 diff)
instance Effect (Diff term1 term2 diff)
newtype Algorithm term1 term2 diff m a = Algorithm { runAlgorithm :: m a }
deriving (Applicative, Alternative, Functor, Monad)
instance Algebra sig m => Algebra sig (Algorithm term1 term2 diff m) where
alg = Algorithm . alg . handleCoercible
-- DSL
-- | Diff two terms without specifying the algorithm to be used.
diff :: Has (Diff term1 term2 diff) sig m => term1 -> term2 -> m diff
diff a1 a2 = send (Diff a1 a2 pure)
-- | Diff an 'Edit.Edit' of terms without specifying the algorithm to be used.
diffEdit :: Has (Diff term1 term2 diff) sig m => Edit.Edit term1 term2 -> Algorithm term1 term2 diff m diff
diffEdit = Edit.edit byDeleting byInserting diff
-- | Diff a pair of optional terms without specifying the algorithm to be used.
diffMaybe :: Has (Diff term1 term2 diff) sig m => Maybe term1 -> Maybe term2 -> Algorithm term1 term2 diff m (Maybe diff)
diffMaybe (Just a1) (Just a2) = Just <$> diff a1 a2
diffMaybe (Just a1) _ = Just <$> byDeleting a1
diffMaybe _ (Just a2) = Just <$> byInserting a2
diffMaybe _ _ = pure Nothing
-- | Diff two terms linearly.
linearly :: Has (Diff term1 term2 diff) sig m => term1 -> term2 -> Algorithm term1 term2 diff m diff
linearly f1 f2 = send (Linear f1 f2 pure)
-- | Diff two terms using RWS.
byRWS :: Has (Diff term1 term2 diff) sig m => [term1] -> [term2] -> Algorithm term1 term2 diff m [diff]
byRWS as1 as2 = send (RWS as1 as2 pure)
-- | Delete a term.
byDeleting :: Has (Diff term1 term2 diff) sig m => term1 -> Algorithm term1 term2 diff m diff
byDeleting a1 = sendDiff (Delete a1 pure)
-- | Insert a term.
byInserting :: Has (Diff term1 term2 diff) sig m => term2 -> Algorithm term1 term2 diff m diff
byInserting a2 = sendDiff (Insert a2 pure)
-- | Replace one term with another.
byReplacing :: Has (Diff term1 term2 diff) sig m => term1 -> term2 -> Algorithm term1 term2 diff m diff
byReplacing a1 a2 = send (Replace a1 a2 pure)
sendDiff :: Has (Diff term1 term2 diff) sig m => Diff term1 term2 diff m a -> Algorithm term1 term2 diff m a
sendDiff = Algorithm . send
-- | Diff two terms based on their 'Diffable' instances, performing substructural comparisons iff the initial comparison fails.
algorithmForTerms :: (Diffable syntax, Has (Diff (Term syntax ann1) (Term syntax ann2) (Diff.Diff syntax ann1 ann2)) sig m, Has NonDet sig m, Alternative m)
=> Term syntax ann1
-> Term syntax ann2
-> Algorithm (Term syntax ann1) (Term syntax ann2) (Diff.Diff syntax ann1 ann2) m (Diff.Diff syntax ann1 ann2)
algorithmForTerms t1@(Term (In ann1 f1)) t2@(Term (In ann2 f2))
= mergeFor t1 t2
<|> Diff.deleteF . In ann1 <$> subalgorithmFor byDeleting (`mergeFor` t2) f1
<|> Diff.insertF . In ann2 <$> subalgorithmFor byInserting (mergeFor t1) f2
where mergeFor (Term (In ann1 f1)) (Term (In ann2 f2)) = Diff.merge (ann1, ann2) <$> algorithmFor f1 f2
-- | An O(1) relation on terms indicating their non-recursive comparability (i.e. are they of the same “kind” in a way that warrants comparison), defined in terms of the comparability of their respective syntax.
comparableTerms :: Diffable syntax
=> TermF syntax ann1 term1
-> TermF syntax ann2 term2
-> Bool
comparableTerms (In _ syntax1) (In _ syntax2) = comparableTo syntax1 syntax2
-- | An O(n) relation on terms indicating their recursive equivalence (i.e. are they _notionally_ “the same,” as distinct from literal equality), defined at each node in terms of the equivalence of their respective syntax, computed first on a nominated subterm (if any), falling back to substructural equivalence (e.g. equivalence of one term against the subject of the other, annotating term), and finally to equality.
equivalentTerms :: (Diffable syntax, Eq1 syntax)
=> Term syntax ann1
-> Term syntax ann2
-> Bool
equivalentTerms term1@(Term (In _ syntax1)) term2@(Term (In _ syntax2))
= fromMaybe False (equivalentTerms <$> equivalentBySubterm syntax1 <*> equivalentBySubterm syntax2)
|| runEquivalence (subalgorithmFor pure (Equivalence . flip equivalentTerms term2) syntax1)
|| runEquivalence (subalgorithmFor pure (Equivalence . equivalentTerms term1) syntax2)
|| liftEq equivalentTerms syntax1 syntax2
-- | A constant 'Alternative' functor used by 'equivalentTerms' to compute the substructural equivalence of syntax.
newtype Equivalence a = Equivalence { runEquivalence :: Bool }
deriving (Eq, Functor)
instance Applicative Equivalence where
pure _ = Equivalence True
Equivalence a <*> Equivalence b = Equivalence (a && b)
instance Alternative Equivalence where
empty = Equivalence False
Equivalence a <|> Equivalence b = Equivalence (a || b)
-- | A type class for determining what algorithm to use for diffing two terms.
class Diffable f where
-- | Construct an algorithm to diff a pair of @f@s populated with disjoint terms.
algorithmFor :: (Alternative m, Has (Diff term1 term2 diff) sig m, Has NonDet sig m)
=> f term1
-> f term2
-> Algorithm term1 term2 diff m (f diff)
default
algorithmFor :: (Alternative m, Generic1 f, GDiffable (Rep1 f), Has (Diff term1 term2 diff) sig m, Has NonDet sig m)
=> f term1
-> f term2
-> Algorithm term1 term2 diff m (f diff)
algorithmFor = genericAlgorithmFor
tryAlignWith :: Alternative g => (Edit.Edit a1 a2 -> g b) -> f a1 -> f a2 -> g (f b)
default tryAlignWith :: (Alternative g, Generic1 f, GDiffable (Rep1 f)) => (Edit.Edit a1 a2 -> g b) -> f a1 -> f a2 -> g (f b)
tryAlignWith f a b = to1 <$> gtryAlignWith f (from1 a) (from1 b)
-- | Construct an algorithm to diff against positions inside an @f@.
--
-- This is very like 'traverse', with two key differences:
--
-- 1. The traversal distributes through an 'Alternative' functor, not just an 'Applicative'.
-- 2. The traversal is mediated by two different functions, one for positions which should be ignored for substructural diffing, the other for positions which should be diffed substructurally.
--
-- These two functions allow us to say e.g. that comparisons against 'Data.Syntax.Context' should also be made against its subject, but not against any of the comments, resulting in the insertion of both comments and context when documenting an existing function.
--
-- By default, 'subalgorithmFor' produces 'empty', rejecting substructural comparisons. This is important for performance, as alternations with 'empty' are eliminated at construction time.
-- ^ The 'Alternative' instance will in general be 'Diff', but left opaque to make it harder to shoot oneself in the foot.
subalgorithmFor :: Alternative g
=> (a -> g b) -- ^ A “blur” function to traverse positions which should not be diffed against.
-> (a -> g b) -- ^ A “focus” function to traverse positions which should be diffed against.
-> f a -- ^ The syntax to diff inside of.
-> g (f b) -- ^ The resulting algorithm (or other 'Alternative' context), producing the traversed syntax.
subalgorithmFor _ _ _ = empty
-- | Syntax having a human-provided identifier, such as function/method definitions, can use equivalence of identifiers as a proxy for their overall equivalence, improving the quality & efficiency of the diff as a whole.
--
-- This can also be used for annotation nodes to ensure that their subjects’ equivalence is weighed appropriately.
--
-- Other syntax should use the default definition, and thus have equivalence computed piece-wise.
equivalentBySubterm :: f a -> Maybe a
equivalentBySubterm _ = Nothing
-- | A relation on syntax values indicating their In general this should be true iff both values have the same constructor (this is the relation computed by the default, generic definition).
--
-- For syntax with constant fields which serve as a classifier, this method can be overloaded to consider equality on that classifier in addition to/instead of the constructors themselves, and thus limit the comparisons accordingly.
comparableTo :: f term1 -> f term2 -> Bool
default comparableTo :: (Generic1 f, GDiffable (Rep1 f)) => f term1 -> f term2 -> Bool
comparableTo = genericComparableTo
genericAlgorithmFor :: (Alternative m, Generic1 f, GDiffable (Rep1 f),Has (Diff term1 term2 diff) sig m, Has NonDet sig m)
=> f term1
-> f term2
-> Algorithm term1 term2 diff m (f diff)
genericAlgorithmFor a1 a2 = to1 <$> galgorithmFor (from1 a1) (from1 a2)
genericComparableTo :: (Generic1 f, GDiffable (Rep1 f)) => f term1 -> f term2 -> Bool
genericComparableTo a1 a2 = gcomparableTo (from1 a1) (from1 a2)
-- | 'Diffable' for 'Sum's of syntax functors is defined in general by straightforward lifting of each method into the functors in the 'Sum'.
instance Apply Diffable fs => Diffable (Sum fs) where
algorithmFor u1 u2 = fromMaybe empty (apply2' @Diffable (\ inj f1 f2 -> inj <$> algorithmFor f1 f2) u1 u2)
tryAlignWith f u1 u2 = fromMaybe empty (apply2' @Diffable (\ inj t1 t2 -> inj <$> tryAlignWith f t1 t2) u1 u2)
subalgorithmFor blur focus = apply' @Diffable (\ inj f -> inj <$> subalgorithmFor blur focus f)
equivalentBySubterm = apply @Diffable equivalentBySubterm
-- | Comparability on 'Sum's is defined first by comparability of their contained functors (when they’re the same), falling back to using 'subalgorithmFor' to opt substructurally-diffable syntax into comparisons (e.g. to allow annotating nodes to be compared against the kind of nodes they annotate).
comparableTo u1 u2 = fromMaybe False (apply2 @Diffable comparableTo u1 u2 <|> True <$ subalgorithmFor pure pure u1 <|> True <$ subalgorithmFor pure pure u2)
-- | Diff two 'Maybe's.
instance Diffable Maybe where
algorithmFor = diffMaybe
tryAlignWith f (Just a1) (Just a2) = Just <$> f (Edit.Compare a1 a2)
tryAlignWith f (Just a1) Nothing = Just <$> f (Edit.Delete a1)
tryAlignWith f Nothing (Just a2) = Just <$> f (Edit.Insert a2)
tryAlignWith _ Nothing Nothing = pure Nothing
-- | Diff two lists using RWS.
instance Diffable [] where
algorithmFor = byRWS
tryAlignWith f (a1:as1) (a2:as2) = (:) <$> f (Edit.Compare a1 a2) <*> tryAlignWith f as1 as2
tryAlignWith f [] as2 = traverse (f . Edit.Insert) as2
tryAlignWith f as1 [] = traverse (f . Edit.Delete) as1
-- | Diff two non-empty lists using RWS.
instance Diffable NonEmpty where
algorithmFor (a1:|as1) (a2:|as2) = nonEmpty <$> byRWS (a1:as1) (a2:as2) >>= maybeM empty
tryAlignWith f (a1:|as1) (a2:|as2) = (:|) <$> f (Edit.Compare a1 a2) <*> tryAlignWith f as1 as2
-- | A generic type class for diffing two terms defined by the Generic1 interface.
class GDiffable f where
galgorithmFor :: (Alternative m, Has (Diff term1 term2 diff) sig m, Has NonDet sig m) => f term1 -> f term2 -> Algorithm term1 term2 diff m (f diff)
gtryAlignWith :: Alternative g => (Edit.Edit a1 a2 -> g b) -> f a1 -> f a2 -> g (f b)
gcomparableTo :: f term1 -> f term2 -> Bool
gcomparableTo _ _ = True
-- | Diff two constructors (M1 is the Generic1 newtype for meta-information (possibly related to type constructors, record selectors, and data types))
instance GDiffable f => GDiffable (M1 i c f) where
galgorithmFor (M1 a1) (M1 a2) = M1 <$> galgorithmFor a1 a2
gtryAlignWith f (M1 a) (M1 b) = M1 <$> gtryAlignWith f a b
gcomparableTo (M1 a1) (M1 a2) = gcomparableTo a1 a2
-- | Diff the fields of a product type.
-- i.e. data Foo a b = Foo a b (the 'Foo a b' is captured by 'a :*: b').
instance (GDiffable f, GDiffable g) => GDiffable (f :*: g) where
galgorithmFor (a1 :*: b1) (a2 :*: b2) = (:*:) <$> galgorithmFor a1 a2 <*> galgorithmFor b1 b2
gtryAlignWith f (a1 :*: b1) (a2 :*: b2) = (:*:) <$> gtryAlignWith f a1 a2 <*> gtryAlignWith f b1 b2
-- | Diff the constructors of a sum type.
-- i.e. data Foo a = Foo a | Bar a (the 'Foo a' is captured by L1 and 'Bar a' is R1).
instance (GDiffable f, GDiffable g) => GDiffable (f :+: g) where
galgorithmFor (L1 a1) (L1 a2) = L1 <$> galgorithmFor a1 a2
galgorithmFor (R1 b1) (R1 b2) = R1 <$> galgorithmFor b1 b2
galgorithmFor _ _ = empty
gtryAlignWith f a b = case (a, b) of
(L1 a, L1 b) -> L1 <$> gtryAlignWith f a b
(R1 a, R1 b) -> R1 <$> gtryAlignWith f a b
_ -> empty
gcomparableTo (L1 _) (L1 _) = True
gcomparableTo (R1 _) (R1 _) = True
gcomparableTo _ _ = False
-- | Diff two parameters (Par1 is the Generic1 newtype representing a type parameter).
-- i.e. data Foo a = Foo a (the 'a' is captured by Par1).
instance GDiffable Par1 where
galgorithmFor (Par1 a1) (Par1 a2) = Par1 <$> diff a1 a2
gtryAlignWith f (Par1 a) (Par1 b) = Par1 <$> f (Edit.Compare a b)
-- | Diff two constant parameters (K1 is the Generic1 newtype representing type parameter constants).
-- i.e. data Foo = Foo Int (the 'Int' is a constant parameter).
instance Eq c => GDiffable (K1 i c) where
galgorithmFor (K1 a1) (K1 a2) = guard (a1 == a2) $> K1 a1
gtryAlignWith _ (K1 a) (K1 b) = guard (a == b) $> K1 b
-- | Diff two terms whose constructors contain 0 type parameters.
-- i.e. data Foo = Foo.
instance GDiffable U1 where
galgorithmFor _ _ = pure U1
gtryAlignWith _ _ _ = pure U1
-- | Diff two 'Diffable' containers of parameters.
instance Diffable f => GDiffable (Rec1 f) where
galgorithmFor a1 a2 = Rec1 <$> algorithmFor (unRec1 a1) (unRec1 a2)
gtryAlignWith f (Rec1 a) (Rec1 b) = Rec1 <$> tryAlignWith f a b

191
src/Diffing/Algorithm/RWS.hs
View File

@ -1,191 +0,0 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} -- FIXME
module Diffing.Algorithm.RWS
( rws
, Options(..)
, defaultOptions
, ComparabilityRelation
, FeatureVector
, defaultFeatureVectorDecorator
, featureVectorDecorator
, pqGramDecorator
, Gram(..)
, canCompareTerms
, equalTerms
) where
import Control.Applicative
import Control.Arrow ((&&&))
import Control.Monad.State.Strict
import Data.Diff (DiffF (..), comparing, deleting, inserting, merge)
import Data.Edit
import Data.Foldable
import Data.Function
import Data.Functor.Classes
import Data.Functor.Foldable (cata)
import Data.Hashable
import Data.Hashable.Lifted
import Data.Ix (inRange)
import qualified Data.KdMap.Static as KdMap
import Data.List (sortOn)
import Data.Maybe
import Data.Term as Term
import Data.Traversable
import Diffing.Algorithm (Diffable (..))
import Diffing.Algorithm.RWS.FeatureVector
import Diffing.Algorithm.SES
import GHC.Generics (Generic)
-- | A relation on 'Term's, guaranteed constant-time in the size of the 'Term' by parametricity.
--
-- This is used both to determine whether two root terms can be compared in O(1), and, recursively, to determine whether two nodes are equal in O(n); thus, comparability is defined s.t. two terms are equal if they are recursively comparable subterm-wise.
type ComparabilityRelation syntax ann1 ann2 = forall a b. TermF syntax ann1 a -> TermF syntax ann2 b -> Bool
rws :: (Foldable syntax, Functor syntax, Diffable syntax)
=> ComparabilityRelation syntax (FeatureVector, ann1) (FeatureVector, ann2)
-> (Term syntax (FeatureVector, ann1) -> Term syntax (FeatureVector, ann2) -> Bool)
-> [Term syntax (FeatureVector, ann1)]
-> [Term syntax (FeatureVector, ann2)]
-> [Edit (Term syntax (FeatureVector, ann1)) (Term syntax (FeatureVector, ann2))]
rws _ _ as [] = Delete <$> as
rws _ _ [] bs = Insert <$> bs
rws canCompare _ [a] [b] = if canCompareTerms canCompare a b then [Compare a b] else [Insert b, Delete a]
rws canCompare equivalent as bs
= ses equivalent as bs
& mapContiguous [] []
where Options{..} = defaultOptions
-- Map contiguous sequences of unmapped terms separated by SES-mapped equivalencies.
mapContiguous as bs [] = mapSimilar (reverse as) (reverse bs)
mapContiguous as bs (first : rest) = case first of
Delete a -> mapContiguous (a : as) bs rest
Insert b -> mapContiguous as (b : bs) rest
Compare _ _ -> mapSimilar (reverse as) (reverse bs) <> (first : mapContiguous [] [] rest)
-- Map comparable, mutually similar terms, inserting & deleting surrounding terms.
mapSimilar as' bs' = go as bs
where go as [] = Delete . snd <$> as
go [] bs = Insert . snd <$> bs
go [a] [b] | canCompareTerms canCompare (snd a) (snd b) = [Compare (snd a) (snd b)]
| otherwise = [Insert (snd b), Delete (snd a)]
go as@((i, _) : _) ((j, b) : restB) =
fromMaybe (Insert b : go as restB) $ do
-- Look up the most similar term to b near i.
(i', a) <- mostSimilarMatching (\ i' a -> inRange (i, i + optionsLookaheadPlaces) i' && canCompareTerms canCompare a b) kdMapA b
-- Look up the most similar term to a near j.
(j', _) <- mostSimilarMatching (\ j' b -> inRange (j, j + optionsLookaheadPlaces) j' && canCompareTerms canCompare a b) kdMapB a
-- Fail out if there’s a better match for a nearby.
guard (j == j')
-- Delete any elements of as before the selected element.
let (deleted, _ : restA) = span ((< i') . fst) as
pure $! (Delete . snd <$> deleted) <> (Compare a b : go restA restB)
(as, bs) = (zip [0..] as', zip [0..] bs')
(kdMapA, kdMapB) = (toKdMap as, toKdMap bs)
-- Find the most similar term matching a predicate, if any.
--
-- RWS can produce false positives in the case of e.g. hash collisions. Therefore, we find the _l_ nearest candidates, filter out any which don’t match the predicate, and select the minimum of the remaining by (a constant-time approximation of) edit distance.
--
-- cf §4.2 of RWS-Diff
mostSimilarMatching isEligible tree term = listToMaybe (sortOn (editDistanceUpTo optionsNodeComparisons term . snd) candidates)
where candidates = filter (uncurry isEligible) (snd <$> KdMap.kNearest tree optionsMaxSimilarTerms (fst (termAnnotation term)))
data Options = Options
{ optionsLookaheadPlaces :: {-# UNPACK #-} !Int -- ^ How many places ahead should we look for similar terms?
, optionsMaxSimilarTerms :: {-# UNPACK #-} !Int -- ^ The maximum number of similar terms to consider.
, optionsNodeComparisons :: {-# UNPACK #-} !Int -- ^ The number of nodes to compare when selecting the most similar term.
}
defaultOptions :: Options
defaultOptions = Options
{ optionsLookaheadPlaces = 0
, optionsMaxSimilarTerms = 2
, optionsNodeComparisons = 10
}
defaultP, defaultQ :: Int
defaultP = 0
defaultQ = 3
toKdMap :: [(Int, Term syntax (FeatureVector, ann))] -> KdMap.KdMap Double FeatureVector (Int, Term syntax (FeatureVector, ann))
toKdMap = KdMap.build unFV . fmap (fst . termAnnotation . snd &&& id)
-- | A `Gram` is a fixed-size view of some portion of a tree, consisting of a `stem` of _p_ labels for parent nodes, and a `base` of _q_ labels of sibling nodes. Collectively, the bag of `Gram`s for each node of a tree (e.g. as computed by `pqGrams`) form a summary of the tree.
data Gram label = Gram { stem :: [Maybe label], base :: [Maybe label] }
deriving (Eq, Generic, Hashable, Show)
-- | Annotates a term with a feature vector at each node, using the default values for the p, q, and d parameters.
defaultFeatureVectorDecorator :: (Hashable1 syntax, Traversable syntax)
=> Term syntax ann
-> Term syntax (FeatureVector, ann)
defaultFeatureVectorDecorator = featureVectorDecorator . pqGramDecorator defaultP defaultQ
-- | Annotates a term with a feature vector at each node, parameterized by stem length, base width, and feature vector dimensions.
featureVectorDecorator :: (Foldable syntax, Functor syntax, Hashable label) => Term syntax (Gram label, ann) -> Term syntax (FeatureVector, ann)
featureVectorDecorator = cata (\ (In (label, ann) functor) ->
termIn (foldl' addSubtermVector (unitVector (hash label)) functor, ann) functor)
where addSubtermVector v term = addVectors v (fst (termAnnotation term))
-- | Annotates a term with the corresponding p,q-gram at each node.
pqGramDecorator :: Traversable syntax
=> Int -- ^ 'p'; the desired stem length for the grams.
-> Int -- ^ 'q'; the desired base length for the grams.
-> Term syntax ann -- ^ The term to decorate.
-> Term syntax (Gram (Label syntax), ann) -- ^ The decorated term.
pqGramDecorator p q = cata algebra
where
algebra term = let label = Label (termFOut term) in
termIn (gram label, termFAnnotation term) (assignParentAndSiblingLabels (termFOut term) label)
gram label = Gram (padToSize p []) (padToSize q (pure (Just label)))
assignParentAndSiblingLabels functor label = (`evalState` (replicate (q `div` 2) Nothing <> siblingLabels functor)) (for functor (assignLabels label))
assignLabels :: label
-> Term syntax (Gram label, ann)
-> State [Maybe label] (Term syntax (Gram label, ann))
assignLabels label (Term.Term (In (gram, rest) functor)) = do
labels <- get
put (drop 1 labels)
pure $! termIn (gram { stem = padToSize p (Just label : stem gram), base = padToSize q labels }, rest) functor
siblingLabels :: Traversable syntax => syntax (Term syntax (Gram label, ann)) -> [Maybe label]
siblingLabels = foldMap (base . fst . termAnnotation)
padToSize n list = take n (list <> repeat empty)
-- | Test the comparability of two root 'Term's in O(1).
canCompareTerms :: ComparabilityRelation syntax ann1 ann2 -> Term syntax ann1 -> Term syntax ann2 -> Bool
canCompareTerms canCompare t1 t2 = canCompare (unTerm t1) (unTerm t2)
-- | Recursively test the equality of two 'Term's in O(n).
equalTerms :: Eq1 syntax => ComparabilityRelation syntax ann1 ann2 -> Term syntax ann1 -> Term syntax ann2 -> Bool
equalTerms canCompare = go
where go a b = canCompareTerms canCompare a b && liftEq go (termOut a) (termOut b)
-- | Return an edit distance between two terms, up to a certain depth.
--
-- Computes a constant-time approximation to the edit distance of a diff. This is done by comparing at most _m_ nodes, & assuming the rest are zero-cost.
editDistanceUpTo :: (Diffable syntax, Foldable syntax, Functor syntax) => Int -> Term syntax ann1 -> Term syntax ann2 -> Int
editDistanceUpTo m a b = diffCost m (approximateDiff a b)
where diffCost = flip . cata $ \ diff m -> case diff of
_ | m <= 0 -> 0
Merge body -> sum (fmap ($ pred m) body)
body -> succ (sum (fmap ($ pred m) body))
approximateDiff a b = maybe (comparing a b) (merge (termAnnotation a, termAnnotation b)) (tryAlignWith (Just . edit deleting inserting approximateDiff) (termOut a) (termOut b))
data Label syntax where
Label :: syntax a -> Label syntax
instance Hashable1 syntax => Hashable (Label syntax) where hashWithSalt salt (Label syntax) = liftHashWithSalt const salt syntax
instance Eq1 syntax => Eq (Label syntax) where Label a == Label b = liftEq (const (const True)) a b
instance Ord1 syntax => Ord (Label syntax) where Label a `compare` Label b = liftCompare (const (const EQ)) a b
instance Show1 syntax => Show (Label syntax) where showsPrec d (Label syntax) = liftShowsPrec (const (const id)) (const id) d syntax

55
src/Diffing/Algorithm/RWS/FeatureVector.hs
View File

@ -1,55 +0,0 @@
{-# LANGUAGE BangPatterns, MagicHash #-}
module Diffing.Algorithm.RWS.FeatureVector
( FeatureVector
, unFV
, unitVector
, addVectors
) where
import GHC.Prim
import GHC.Types
import System.Random.Mersenne.Pure64
-- | A 15-dimensional feature vector represented with machine doubles.
--
-- 15 dimensions ought to be enough for anyone. cf §5.2 of RWS-Diff: “We obtained best results with 10 ≤ d ≤ 20.”
data FeatureVector = FV !Double# !Double# !Double# !Double# !Double#
!Double# !Double# !Double# !Double# !Double#
!Double# !Double# !Double# !Double# !Double#
unFV :: FeatureVector -> [Double]
unFV (FV d00 d01 d02 d03 d04 d05 d06 d07 d08 d09 d10 d11 d12 d13 d14)
= [ D# d00, D# d01, D# d02, D# d03, D# d04
, D# d05, D# d06, D# d07, D# d08, D# d09
, D# d10, D# d11, D# d12, D# d13, D# d14 ]
-- | Computes a unit vector of the specified dimension from a hash.
unitVector :: Int -> FeatureVector
unitVector !hash =
let !(D# d00, r00) = randomDouble (pureMT (fromIntegral hash))
!(D# d01, r01) = randomDouble r00
!(D# d02, r02) = randomDouble r01
!(D# d03, r03) = randomDouble r02
!(D# d04, r04) = randomDouble r03
!(D# d05, r05) = randomDouble r04
!(D# d06, r06) = randomDouble r05
!(D# d07, r07) = randomDouble r06
!(D# d08, r08) = randomDouble r07
!(D# d09, r09) = randomDouble r08
!(D# d10, r10) = randomDouble r09
!(D# d11, r11) = randomDouble r10
!(D# d12, r12) = randomDouble r11
!(D# d13, r13) = randomDouble r12
!(D# d14, _) = randomDouble r13
!(D# one) = 1
!invMagnitude = one /## sqrtDouble# (d00 *## d00 +## d01 *## d01 +## d02 *## d02 +## d03 *## d03 +## d04 *## d04 +## d05 *## d05 +## d06 *## d06 +## d07 *## d07 +## d08 *## d08 +## d09 *## d09 +## d10 *## d10 +## d11 *## d11 +## d12 *## d12 +## d13 *## d13 +## d14 *## d14)
in FV (invMagnitude *## d00) (invMagnitude *## d01) (invMagnitude *## d02) (invMagnitude *## d03) (invMagnitude *## d04)
(invMagnitude *## d05) (invMagnitude *## d06) (invMagnitude *## d07) (invMagnitude *## d08) (invMagnitude *## d09)
(invMagnitude *## d10) (invMagnitude *## d11) (invMagnitude *## d12) (invMagnitude *## d13) (invMagnitude *## d14)
addVectors :: FeatureVector -> FeatureVector -> FeatureVector
addVectors (FV a00 a01 a02 a03 a04 a05 a06 a07 a08 a09 a10 a11 a12 a13 a14)
(FV b00 b01 b02 b03 b04 b05 b06 b07 b08 b09 b10 b11 b12 b13 b14)
= FV (a00 +## b00) (a01 +## b01) (a02 +## b02) (a03 +## b03) (a04 +## b04)
(a05 +## b05) (a06 +## b06) (a07 +## b07) (a08 +## b08) (a09 +## b09)
(a10 +## b10) (a11 +## b11) (a12 +## b12) (a13 +## b13) (a14 +## b14)

66
src/Diffing/Algorithm/SES.hs
View File

@ -1,66 +0,0 @@
{-# LANGUAGE BangPatterns, GADTs, MultiParamTypeClasses, ScopedTypeVariables #-}
module Diffing.Algorithm.SES
( ses
) where
import Data.Array ((!))
import qualified Data.Array as Array
import Data.Edit
import Data.Foldable (find, toList)
import Data.Ix
data Endpoint a b = Endpoint { x :: {-# UNPACK #-} !Int, _y :: {-# UNPACK #-} !Int, _script :: [Edit a b] }
deriving (Eq, Show)
-- | Compute the shortest edit script using Myers’ algorithm.
ses :: (Foldable t, Foldable u) => (a -> b -> Bool) -> t a -> u b -> [Edit a b]
ses eq as' bs'
| null bs = Delete <$> toList as
| null as = Insert <$> toList bs
| otherwise = reverse (searchUpToD 0 (Array.array (1, 1) [(1, Endpoint 0 (-1) [])]))
where (as, bs) = (Array.listArray (0, pred n) (toList as'), Array.listArray (0, pred m) (toList bs'))
(!n, !m) = (length as', length bs')
-- Search an edit graph for the shortest edit script up to a given proposed edit distance, building on the results of previous searches.
searchUpToD !d !v =
let !endpoints = slideFrom . searchAlongK <$> [ k | k <- [-d, -d + 2 .. d], inRange (-m, n) k ] in
case find isComplete endpoints of
Just (Endpoint _ _ script) -> script
_ -> searchUpToD (succ d) (Array.array (-d, d) ((\ e@(Endpoint x y _) -> (x - y, e)) <$> endpoints))
where isComplete (Endpoint x y _) = x >= n && y >= m
-- Search an edit graph for the shortest edit script along a specific diagonal, moving onto a given diagonal from one of its in-bounds adjacent diagonals (if any).
searchAlongK !k
| k == -d = moveDownFrom (v ! succ k)
| k == d = moveRightFrom (v ! pred k)
| k == -m = moveDownFrom (v ! succ k)
| k == n = moveRightFrom (v ! pred k)
| otherwise =
let left = v ! pred k
up = v ! succ k in
if x left < x up then
moveDownFrom up
else
moveRightFrom left
-- | Move downward from a given vertex, inserting the element for the corresponding row.
moveDownFrom (Endpoint x y script) = Endpoint x (succ y) $ maybe script ((: script) . Insert) (bs !? y)
{-# INLINE moveDownFrom #-}
-- | Move rightward from a given vertex, deleting the element for the corresponding column.
moveRightFrom (Endpoint x y script) = Endpoint (succ x) y $ maybe script ((: script) . Delete) (as !? x)
{-# INLINE moveRightFrom #-}
-- | Slide down any diagonal edges from a given vertex.
slideFrom (Endpoint x y script)
| Just a <- as !? x
, Just b <- bs !? y
, a `eq` b = slideFrom (Endpoint (succ x) (succ y) (Compare a b : script))
| otherwise = Endpoint x y script
(!?) :: Ix i => Array.Array i a -> i -> Maybe a
v !? i | inRange (Array.bounds v) i, !a <- v ! i = Just a
| otherwise = Nothing
{-# INLINE (!?) #-}

80
src/Diffing/Interpreter.hs
View File

@ -1,80 +0,0 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Diffing.Interpreter
( diffTerms
, DiffTerms(..)
, stripDiff
) where
import Control.Algebra
import Control.Carrier.Cull.Church
import Control.Monad.IO.Class
import Data.Bifunctor
import qualified Data.Diff as Diff
import Data.Edit (Edit, edit)
import Data.Functor.Classes
import Data.Hashable.Lifted
import Data.Maybe
import Data.Term
import Diffing.Algorithm
import Diffing.Algorithm.RWS
-- | Diff two à la carte terms recursively.
diffTerms :: (Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax)
=> Term syntax ann1
-> Term syntax ann2
-> Diff.Diff syntax ann1 ann2
diffTerms t1 t2 = stripDiff (fromMaybe (Diff.comparing t1' t2') (run (runCullA (cull (runDiff (algorithmForTerms t1' t2'))))))
where (t1', t2') = ( defaultFeatureVectorDecorator t1
, defaultFeatureVectorDecorator t2)
-- | Strips the head annotation off a diff annotated with non-empty records.
stripDiff :: Functor syntax
=> Diff.Diff syntax (FeatureVector, ann1) (FeatureVector, ann2)
-> Diff.Diff syntax ann1 ann2
stripDiff = bimap snd snd
-- | The class of term types for which we can compute a diff.
class IsTerm term => DiffTerms term where
-- | Diff an 'Edit' of terms.
diffTermPair :: Edit (term ann1) (term ann2) -> Diff.Diff (Syntax term) ann1 ann2
instance (Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax) => DiffTerms (Term syntax) where
diffTermPair = edit Diff.deleting Diff.inserting diffTerms
-- | Run an 'Algorithm' to completion in an 'Alternative' context using the supplied comparability & equivalence relations.
runDiff :: Algorithm
(Term syntax (FeatureVector, ann1))
(Term syntax (FeatureVector, ann2))
(Diff.Diff syntax (FeatureVector, ann1) (FeatureVector, ann2))
(DiffC (Term syntax (FeatureVector, ann1)) (Term syntax (FeatureVector, ann2)) (Diff.Diff syntax (FeatureVector, ann1) (FeatureVector, ann2)) m)
result
-> m result
runDiff = runDiffC . runAlgorithm
newtype DiffC term1 term2 diff m a = DiffC { runDiffC :: m a }
deriving (Alternative, Applicative, Functor, Monad, MonadIO)
instance ( Alternative m
, Diffable syntax
, Eq1 syntax
, Has NonDet sig m
, Traversable syntax
)
=> Algebra
(Diff (Term syntax (FeatureVector, ann1)) (Term syntax (FeatureVector, ann2)) (Diff.Diff syntax (FeatureVector, ann1) (FeatureVector, ann2)) :+: sig)
(DiffC (Term syntax (FeatureVector, ann1)) (Term syntax (FeatureVector, ann2)) (Diff.Diff syntax (FeatureVector, ann1) (FeatureVector, ann2)) m) where
alg (L op) = case op of
Diff t1 t2 k -> runDiff (algorithmForTerms t1 t2) <|> pure (Diff.comparing t1 t2) >>= k
Linear (Term (In ann1 f1)) (Term (In ann2 f2)) k -> Diff.merge (ann1, ann2) <$> tryAlignWith (runDiff . diffEdit) f1 f2 >>= k
RWS as bs k -> traverse (runDiff . diffEdit) (rws comparableTerms equivalentTerms as bs) >>= k
Delete a k -> k (Diff.deleting a)
Insert b k -> k (Diff.inserting b)
Replace a b k -> k (Diff.comparing a b)
alg (R other) = DiffC . alg . handleCoercible $ other

44
src/Language/Go/Syntax.hs
View File

@ -18,14 +18,12 @@ import Data.Functor.Classes
import Data.Functor.Classes.Generic
import Data.Hashable.Lifted
import Data.ImportPath
import Data.JSON.Fields
import Data.List.NonEmpty (nonEmpty)
import qualified Data.Map as Map
import Data.Semigroup.App
import Data.Semigroup.Foldable
import Data.Text (Text)
import qualified Data.Text as T
import Diffing.Algorithm
import GHC.Generics (Generic1)
import qualified System.Path as Path
import System.FilePath.Posix
@ -61,7 +59,7 @@ resolveGoImport (ImportPath path NonRelative) = do
--
-- If the list of symbols is empty copy everything to the calling environment.
data Import a = Import { importFrom :: ImportPath, importWildcardToken :: !a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Import where liftEq = genericLiftEq
instance Ord1 Import where liftCompare = genericLiftCompare
@ -82,7 +80,7 @@ instance Evaluatable Import where
--
-- If the list of symbols is empty copy and qualify everything to the calling environment.
data QualifiedImport a = QualifiedImport { qualifiedImportFrom :: !ImportPath, qualifiedImportAlias :: !a}
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 QualifiedImport where liftEq = genericLiftEq
instance Ord1 QualifiedImport where liftCompare = genericLiftCompare
@ -115,7 +113,7 @@ instance Evaluatable QualifiedImport where
-- | Side effect only imports (no symbols made available to the calling environment).
data SideEffectImport a = SideEffectImport { sideEffectImportFrom :: !ImportPath, sideEffectImportToken :: !a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 SideEffectImport where liftEq = genericLiftEq
instance Ord1 SideEffectImport where liftCompare = genericLiftCompare
@ -131,7 +129,7 @@ instance Evaluatable SideEffectImport where
-- A composite literal in Go
data Composite a = Composite { compositeType :: !a, compositeElement :: !a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Composite where liftEq = genericLiftEq
instance Ord1 Composite where liftCompare = genericLiftCompare
@ -142,7 +140,7 @@ instance Evaluatable Composite
-- | A default pattern in a Go select or switch statement (e.g. `switch { default: s() }`).
newtype DefaultPattern a = DefaultPattern { defaultPatternBody :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 DefaultPattern where liftEq = genericLiftEq
instance Ord1 DefaultPattern where liftCompare = genericLiftCompare
@ -153,7 +151,7 @@ instance Evaluatable DefaultPattern
-- | A defer statement in Go (e.g. `defer x()`).
newtype Defer a = Defer { deferBody :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Defer where liftEq = genericLiftEq
instance Ord1 Defer where liftCompare = genericLiftCompare
@ -164,7 +162,7 @@ instance Evaluatable Defer
-- | A go statement (i.e. go routine) in Go (e.g. `go x()`).
newtype Go a = Go { goBody :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Go where liftEq = genericLiftEq
instance Ord1 Go where liftCompare = genericLiftCompare
@ -175,7 +173,7 @@ instance Evaluatable Go
-- | A label statement in Go (e.g. `label:continue`).
data Label a = Label { labelName :: !a, labelStatement :: !a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Label where liftEq = genericLiftEq
instance Ord1 Label where liftCompare = genericLiftCompare
@ -186,7 +184,7 @@ instance Evaluatable Label
-- | A rune literal in Go (e.g. `'⌘'`).
newtype Rune a = Rune { runeLiteral :: Text }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Rune where liftEq = genericLiftEq
instance Ord1 Rune where liftCompare = genericLiftCompare
@ -197,7 +195,7 @@ instance Evaluatable Rune
-- | A select statement in Go (e.g. `select { case x := <-c: x() }` where each case is a send or receive operation on channels).
newtype Select a = Select { selectCases :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Select where liftEq = genericLiftEq
instance Ord1 Select where liftCompare = genericLiftCompare
@ -208,7 +206,7 @@ instance Evaluatable Select
-- | A send statement in Go (e.g. `channel <- value`).
data Send a = Send { sendReceiver :: !a, sendValue :: !a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Send where liftEq = genericLiftEq
instance Ord1 Send where liftCompare = genericLiftCompare
@ -219,7 +217,7 @@ instance Evaluatable Send
-- | A slice expression in Go (e.g. `a[1:4:3]` where a is a list, 1 is the low bound, 4 is the high bound, and 3 is the max capacity).
data Slice a = Slice { sliceName :: !a, sliceLow :: !a, sliceHigh :: !a, sliceCapacity :: !a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Slice where liftEq = genericLiftEq
instance Ord1 Slice where liftCompare = genericLiftCompare
@ -230,7 +228,7 @@ instance Evaluatable Slice
-- | A type switch statement in Go (e.g. `switch x.(type) { // cases }`).
data TypeSwitch a = TypeSwitch { typeSwitchSubject :: !a, typeSwitchCases :: !a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 TypeSwitch where liftEq = genericLiftEq
instance Ord1 TypeSwitch where liftCompare = genericLiftCompare
@ -241,7 +239,7 @@ instance Evaluatable TypeSwitch
-- | A type switch guard statement in a Go type switch statement (e.g. `switch i := x.(type) { // cases}`).
newtype TypeSwitchGuard a = TypeSwitchGuard { typeSwitchGuardSubject :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 TypeSwitchGuard where liftEq = genericLiftEq
instance Ord1 TypeSwitchGuard where liftCompare = genericLiftCompare
@ -252,7 +250,7 @@ instance Evaluatable TypeSwitchGuard
-- | A receive statement in a Go select statement (e.g. `case value := <-channel` )
data Receive a = Receive { receiveSubject :: !a, receiveExpression :: !a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Receive where liftEq = genericLiftEq
instance Ord1 Receive where liftCompare = genericLiftCompare
@ -263,7 +261,7 @@ instance Evaluatable Receive
-- | A receive operator unary expression in Go (e.g. `<-channel` )
newtype ReceiveOperator a = ReceiveOperator { value :: a}
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 ReceiveOperator where liftEq = genericLiftEq
instance Ord1 ReceiveOperator where liftCompare = genericLiftCompare
@ -274,7 +272,7 @@ instance Evaluatable ReceiveOperator
-- | A field declaration in a Go struct type declaration.
data Field a = Field { fieldContext :: ![a], fieldName :: !a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Field where liftEq = genericLiftEq
instance Ord1 Field where liftCompare = genericLiftCompare
@ -284,7 +282,7 @@ instance Show1 Field where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Field
data Package a = Package { packageName :: !a, packageContents :: ![a] }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Package where liftEq = genericLiftEq
instance Ord1 Package where liftCompare = genericLiftCompare
@ -295,7 +293,7 @@ instance Evaluatable Package where
-- | A type assertion in Go (e.g. `x.(T)` where the value of `x` is not nil and is of type `T`).
data TypeAssertion a = TypeAssertion { typeAssertionSubject :: !a, typeAssertionType :: !a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 TypeAssertion where liftEq = genericLiftEq
instance Ord1 TypeAssertion where liftCompare = genericLiftCompare
@ -306,7 +304,7 @@ instance Evaluatable TypeAssertion
-- | A type conversion expression in Go (e.g. `T(x)` where `T` is a type and `x` is an expression that can be converted to type `T`).
data TypeConversion a = TypeConversion { typeConversionType :: !a, typeConversionSubject :: !a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 TypeConversion where liftEq = genericLiftEq
instance Ord1 TypeConversion where liftCompare = genericLiftCompare
@ -317,7 +315,7 @@ instance Evaluatable TypeConversion
-- | Variadic arguments and parameters in Go (e.g. parameter: `param ...Type`, argument: `Type...`).
data Variadic a = Variadic { variadicContext :: [a], variadicIdentifier :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Variadic where liftEq = genericLiftEq
instance Ord1 Variadic where liftCompare = genericLiftCompare

8
src/Language/Go/Term.hs
View File

@ -7,8 +7,6 @@ module Language.Go.Term
import Control.Lens.Lens
import Data.Abstract.Declarations
import Data.Abstract.FreeVariables
import Data.Aeson (ToJSON)
import Data.Bifunctor
import Data.Bitraversable
import Data.Coerce
import Data.Foldable (fold)
@ -24,7 +22,6 @@ import qualified Data.Syntax.Statement as Statement
import qualified Data.Syntax.Type as Type
import qualified Data.Term as Term
import Data.Traversable
import Diffing.Interpreter
import Language.Go.Syntax as Go.Syntax
import Language.Go.Type as Go.Type
import Source.Loc
@ -137,7 +134,7 @@ type Syntax =
newtype Term ann = Term { getTerm :: Term.TermF (Sum.Sum Syntax) ann (Term ann) }
deriving (Eq, Declarations, FreeVariables, Ord, Show, ToJSON)
deriving (Eq, Declarations, FreeVariables, Ord, Show)
instance Term.IsTerm Term where
type Syntax Term = Sum.Sum Syntax
@ -161,9 +158,6 @@ instance Syntax.HasErrors Term where
maybe (fold syntax) (pure . Syntax.unError span) (Sum.project syntax)
instance DiffTerms Term where
diffTermPair = diffTermPair . bimap (cata Term.Term) (cata Term.Term)
type instance Base (Term ann) = Term.TermF (Sum.Sum Syntax) ann
instance Recursive (Term ann) where

8
src/Language/Go/Type.hs
View File

@ -7,13 +7,11 @@ module Language.Go.Type (module Language.Go.Type) where
import Data.Abstract.Evaluatable
import Data.Functor.Classes.Generic
import Data.Hashable.Lifted
import Data.JSON.Fields
import Diffing.Algorithm
import GHC.Generics (Generic1)
-- | A Bidirectional channel in Go (e.g. `chan`).
newtype BidirectionalChannel a = BidirectionalChannel { value :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 BidirectionalChannel where liftEq = genericLiftEq
instance Ord1 BidirectionalChannel where liftCompare = genericLiftCompare
@ -24,7 +22,7 @@ instance Evaluatable BidirectionalChannel
-- | A Receive channel in Go (e.g. `<-chan`).
newtype ReceiveChannel a = ReceiveChannel { value :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 ReceiveChannel where liftEq = genericLiftEq
instance Ord1 ReceiveChannel where liftCompare = genericLiftCompare
@ -35,7 +33,7 @@ instance Evaluatable ReceiveChannel
-- | A Send channel in Go (e.g. `chan<-`).
newtype SendChannel a = SendChannel { value :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 SendChannel where liftEq = genericLiftEq
instance Ord1 SendChannel where liftCompare = genericLiftCompare

114
src/Language/PHP/Syntax.hs
View File

@ -21,14 +21,12 @@ import Data.Abstract.Evaluatable as Abstract
import Data.Abstract.Module
import Data.Abstract.Path
import qualified Data.Abstract.ScopeGraph as ScopeGraph
import Data.JSON.Fields
import qualified Data.Language as Language
import Diffing.Algorithm
import Source.Span
import qualified System.Path as Path
newtype Text a = Text { value :: T.Text }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Text where liftEq = genericLiftEq
instance Ord1 Text where liftCompare = genericLiftCompare
@ -37,7 +35,7 @@ instance Show1 Text where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Text
newtype VariableName a = VariableName { value :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 VariableName where liftEq = genericLiftEq
instance Ord1 VariableName where liftCompare = genericLiftCompare
@ -93,7 +91,7 @@ include eval pathTerm f = do
pure v
newtype Require a = Require { value :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Require where liftEq = genericLiftEq
instance Ord1 Require where liftCompare = genericLiftCompare
@ -104,7 +102,7 @@ instance Evaluatable Require where
newtype RequireOnce a = RequireOnce { value :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 RequireOnce where liftEq = genericLiftEq
instance Ord1 RequireOnce where liftCompare = genericLiftCompare
@ -114,7 +112,7 @@ instance Evaluatable RequireOnce where
eval eval _ (RequireOnce path) = include eval path require
newtype Include a = Include { value :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Include where liftEq = genericLiftEq
instance Ord1 Include where liftCompare = genericLiftCompare
@ -124,7 +122,7 @@ instance Evaluatable Include where
eval eval _ (Include path) = include eval path load
newtype IncludeOnce a = IncludeOnce { value :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 IncludeOnce where liftEq = genericLiftEq
instance Ord1 IncludeOnce where liftCompare = genericLiftCompare
@ -134,7 +132,7 @@ instance Evaluatable IncludeOnce where
eval eval _ (IncludeOnce path) = include eval path require
newtype ArrayElement a = ArrayElement { value :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 ArrayElement where liftEq = genericLiftEq
instance Ord1 ArrayElement where liftCompare = genericLiftCompare
@ -143,7 +141,7 @@ instance Show1 ArrayElement where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable ArrayElement
newtype GlobalDeclaration a = GlobalDeclaration { values :: [a] }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 GlobalDeclaration where liftEq = genericLiftEq
instance Ord1 GlobalDeclaration where liftCompare = genericLiftCompare
@ -152,7 +150,7 @@ instance Show1 GlobalDeclaration where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable GlobalDeclaration
newtype SimpleVariable a = SimpleVariable { value :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 SimpleVariable where liftEq = genericLiftEq
instance Ord1 SimpleVariable where liftCompare = genericLiftCompare
@ -161,7 +159,7 @@ instance Show1 SimpleVariable where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable SimpleVariable
data Concat a = Concat { lhs :: a, rhs :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Concat where liftEq = genericLiftEq
instance Ord1 Concat where liftCompare = genericLiftCompare
@ -171,7 +169,7 @@ instance Evaluatable Concat
-- | TODO: Unify with TypeScript's PredefinedType
newtype CastType a = CastType { _castType :: T.Text }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 CastType where liftEq = genericLiftEq
instance Ord1 CastType where liftCompare = genericLiftCompare
@ -180,7 +178,7 @@ instance Show1 CastType where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable CastType
newtype ErrorControl a = ErrorControl { value :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 ErrorControl where liftEq = genericLiftEq
instance Ord1 ErrorControl where liftCompare = genericLiftCompare
@ -189,7 +187,7 @@ instance Show1 ErrorControl where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable ErrorControl
newtype Clone a = Clone { value :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Clone where liftEq = genericLiftEq
instance Ord1 Clone where liftCompare = genericLiftCompare
@ -198,7 +196,7 @@ instance Show1 Clone where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Clone
newtype ShellCommand a = ShellCommand { value :: T.Text }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 ShellCommand where liftEq = genericLiftEq
instance Ord1 ShellCommand where liftCompare = genericLiftCompare
@ -208,7 +206,7 @@ instance Evaluatable ShellCommand
-- | TODO: Combine with TypeScript update expression.
newtype Update a = Update { _updateSubject :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Update where liftEq = genericLiftEq
instance Ord1 Update where liftCompare = genericLiftCompare
@ -216,7 +214,7 @@ instance Show1 Update where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Update
newtype NewVariable a = NewVariable { values :: [a] }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 NewVariable where liftEq = genericLiftEq
instance Ord1 NewVariable where liftCompare = genericLiftCompare
@ -225,7 +223,7 @@ instance Show1 NewVariable where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable NewVariable
newtype RelativeScope a = RelativeScope { value :: T.Text }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 RelativeScope where liftEq = genericLiftEq
instance Ord1 RelativeScope where liftCompare = genericLiftCompare
@ -234,7 +232,7 @@ instance Show1 RelativeScope where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable RelativeScope
data QualifiedName a = QualifiedName { name :: a, identifier :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 QualifiedName where liftEq = genericLiftEq
instance Ord1 QualifiedName where liftCompare = genericLiftCompare
@ -262,7 +260,7 @@ instance Evaluatable QualifiedName where
unit
newtype NamespaceName a = NamespaceName { names :: NonEmpty a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Traversable)
instance Eq1 NamespaceName where liftEq = genericLiftEq
instance Ord1 NamespaceName where liftCompare = genericLiftCompare
@ -273,7 +271,7 @@ instance Hashable1 NamespaceName where liftHashWithSalt = foldl
instance Evaluatable NamespaceName
newtype ConstDeclaration a = ConstDeclaration { values :: [a] }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 ConstDeclaration where liftEq = genericLiftEq
instance Ord1 ConstDeclaration where liftCompare = genericLiftCompare
@ -282,7 +280,7 @@ instance Show1 ConstDeclaration where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable ConstDeclaration
data ClassConstDeclaration a = ClassConstDeclaration { visibility :: a, elements :: [a] }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 ClassConstDeclaration where liftEq = genericLiftEq
instance Ord1 ClassConstDeclaration where liftCompare = genericLiftCompare
@ -291,7 +289,7 @@ instance Show1 ClassConstDeclaration where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable ClassConstDeclaration
newtype ClassInterfaceClause a = ClassInterfaceClause { values :: [a] }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 ClassInterfaceClause where liftEq = genericLiftEq
instance Ord1 ClassInterfaceClause where liftCompare = genericLiftCompare
@ -300,7 +298,7 @@ instance Show1 ClassInterfaceClause where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable ClassInterfaceClause
newtype ClassBaseClause a = ClassBaseClause { value :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 ClassBaseClause where liftEq = genericLiftEq
instance Ord1 ClassBaseClause where liftCompare = genericLiftCompare
@ -309,7 +307,7 @@ instance Show1 ClassBaseClause where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable ClassBaseClause
newtype UseClause a = UseClause { values :: [a] }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 UseClause where liftEq = genericLiftEq
instance Ord1 UseClause where liftCompare = genericLiftCompare
@ -318,7 +316,7 @@ instance Show1 UseClause where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable UseClause
newtype ReturnType a = ReturnType { value :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 ReturnType where liftEq = genericLiftEq
instance Ord1 ReturnType where liftCompare = genericLiftCompare
@ -327,7 +325,7 @@ instance Show1 ReturnType where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable ReturnType
newtype TypeDeclaration a = TypeDeclaration { value :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 TypeDeclaration where liftEq = genericLiftEq
instance Ord1 TypeDeclaration where liftCompare = genericLiftCompare
@ -336,7 +334,7 @@ instance Show1 TypeDeclaration where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable TypeDeclaration
newtype BaseTypeDeclaration a = BaseTypeDeclaration { value :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 BaseTypeDeclaration where liftEq = genericLiftEq
instance Ord1 BaseTypeDeclaration where liftCompare = genericLiftCompare
@ -344,7 +342,7 @@ instance Show1 BaseTypeDeclaration where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable BaseTypeDeclaration
newtype ScalarType a = ScalarType { value :: T.Text }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 ScalarType where liftEq = genericLiftEq
instance Ord1 ScalarType where liftCompare = genericLiftCompare
@ -353,7 +351,7 @@ instance Show1 ScalarType where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable ScalarType
newtype EmptyIntrinsic a = EmptyIntrinsic { value :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 EmptyIntrinsic where liftEq = genericLiftEq
instance Ord1 EmptyIntrinsic where liftCompare = genericLiftCompare
@ -362,7 +360,7 @@ instance Show1 EmptyIntrinsic where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable EmptyIntrinsic
newtype ExitIntrinsic a = ExitIntrinsic { value :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 ExitIntrinsic where liftEq = genericLiftEq
instance Ord1 ExitIntrinsic where liftCompare = genericLiftCompare
@ -371,7 +369,7 @@ instance Show1 ExitIntrinsic where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable ExitIntrinsic
newtype IssetIntrinsic a = IssetIntrinsic { value :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 IssetIntrinsic where liftEq = genericLiftEq
instance Ord1 IssetIntrinsic where liftCompare = genericLiftCompare
@ -380,7 +378,7 @@ instance Show1 IssetIntrinsic where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable IssetIntrinsic
newtype EvalIntrinsic a = EvalIntrinsic { value :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 EvalIntrinsic where liftEq = genericLiftEq
instance Ord1 EvalIntrinsic where liftCompare = genericLiftCompare
@ -389,7 +387,7 @@ instance Show1 EvalIntrinsic where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable EvalIntrinsic
newtype PrintIntrinsic a = PrintIntrinsic { value :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 PrintIntrinsic where liftEq = genericLiftEq
instance Ord1 PrintIntrinsic where liftCompare = genericLiftCompare
@ -398,7 +396,7 @@ instance Show1 PrintIntrinsic where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable PrintIntrinsic
newtype NamespaceAliasingClause a = NamespaceAliasingClause { value :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 NamespaceAliasingClause where liftEq = genericLiftEq
instance Ord1 NamespaceAliasingClause where liftCompare = genericLiftCompare
@ -406,7 +404,7 @@ instance Show1 NamespaceAliasingClause where liftShowsPrec = genericLiftShowsPre
instance Evaluatable NamespaceAliasingClause
newtype NamespaceUseDeclaration a = NamespaceUseDeclaration { values :: [a] }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 NamespaceUseDeclaration where liftEq = genericLiftEq
instance Ord1 NamespaceUseDeclaration where liftCompare = genericLiftCompare
@ -415,7 +413,7 @@ instance Show1 NamespaceUseDeclaration where liftShowsPrec = genericLiftShowsPre
instance Evaluatable NamespaceUseDeclaration
newtype NamespaceUseClause a = NamespaceUseClause { values :: [a] }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 NamespaceUseClause where liftEq = genericLiftEq
instance Ord1 NamespaceUseClause where liftCompare = genericLiftCompare
@ -424,7 +422,7 @@ instance Show1 NamespaceUseClause where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable NamespaceUseClause
newtype NamespaceUseGroupClause a = NamespaceUseGroupClause { values :: [a] }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 NamespaceUseGroupClause where liftEq = genericLiftEq
instance Ord1 NamespaceUseGroupClause where liftCompare = genericLiftCompare
@ -433,7 +431,7 @@ instance Show1 NamespaceUseGroupClause where liftShowsPrec = genericLiftShowsPre
instance Evaluatable NamespaceUseGroupClause
data Namespace a = Namespace { namespaceName :: [a], namespaceBody :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Namespace where liftEq = genericLiftEq
instance Ord1 Namespace where liftCompare = genericLiftCompare
@ -442,7 +440,7 @@ instance Show1 Namespace where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Namespace
data TraitDeclaration a = TraitDeclaration { traitName :: a, traitStatements :: [a] }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 TraitDeclaration where liftEq = genericLiftEq
instance Ord1 TraitDeclaration where liftCompare = genericLiftCompare
@ -451,7 +449,7 @@ instance Show1 TraitDeclaration where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable TraitDeclaration
data AliasAs a = AliasAs { aliasAsName :: a, aliasAsModifier :: a, aliasAsClause :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 AliasAs where liftEq = genericLiftEq
instance Ord1 AliasAs where liftCompare = genericLiftCompare
@ -460,7 +458,7 @@ instance Show1 AliasAs where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable AliasAs
data InsteadOf a = InsteadOf { left :: a, right :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 InsteadOf where liftEq = genericLiftEq
instance Ord1 InsteadOf where liftCompare = genericLiftCompare
@ -469,7 +467,7 @@ instance Show1 InsteadOf where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable InsteadOf
newtype TraitUseSpecification a = TraitUseSpecification { values :: [a] }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 TraitUseSpecification where liftEq = genericLiftEq
instance Ord1 TraitUseSpecification where liftCompare = genericLiftCompare
@ -478,7 +476,7 @@ instance Show1 TraitUseSpecification where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable TraitUseSpecification
data TraitUseClause a = TraitUseClause { namespace :: [a], alias :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 TraitUseClause where liftEq = genericLiftEq
instance Ord1 TraitUseClause where liftCompare = genericLiftCompare
@ -487,7 +485,7 @@ instance Show1 TraitUseClause where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable TraitUseClause
data DestructorDeclaration a = DestructorDeclaration { body:: [a], name :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 DestructorDeclaration where liftEq = genericLiftEq
instance Ord1 DestructorDeclaration where liftCompare = genericLiftCompare
@ -496,7 +494,7 @@ instance Show1 DestructorDeclaration where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable DestructorDeclaration
newtype Static a = Static { value :: T.Text }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Static where liftEq = genericLiftEq
instance Ord1 Static where liftCompare = genericLiftCompare
@ -505,7 +503,7 @@ instance Show1 Static where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Static
newtype ClassModifier a = ClassModifier { value :: T.Text }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 ClassModifier where liftEq = genericLiftEq
instance Ord1 ClassModifier where liftCompare = genericLiftCompare
@ -514,7 +512,7 @@ instance Show1 ClassModifier where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable ClassModifier
data ConstructorDeclaration a = ConstructorDeclaration { modifiers :: [a], parameters :: [a], body :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 ConstructorDeclaration where liftEq = genericLiftEq
instance Ord1 ConstructorDeclaration where liftCompare = genericLiftCompare
@ -522,7 +520,7 @@ instance Show1 ConstructorDeclaration where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable ConstructorDeclaration
data PropertyDeclaration a = PropertyDeclaration { modifier :: a, elements :: [a] }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 PropertyDeclaration where liftEq = genericLiftEq
instance Ord1 PropertyDeclaration where liftCompare = genericLiftCompare
@ -531,7 +529,7 @@ instance Show1 PropertyDeclaration where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable PropertyDeclaration
data PropertyModifier a = PropertyModifier { visibility :: a , static :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 PropertyModifier where liftEq = genericLiftEq
instance Ord1 PropertyModifier where liftCompare = genericLiftCompare
@ -540,7 +538,7 @@ instance Show1 PropertyModifier where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable PropertyModifier
data InterfaceDeclaration a = InterfaceDeclaration { name :: a, base :: a, declarations :: [a] }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 InterfaceDeclaration where liftEq = genericLiftEq
instance Ord1 InterfaceDeclaration where liftCompare = genericLiftCompare
@ -549,7 +547,7 @@ instance Show1 InterfaceDeclaration where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable InterfaceDeclaration
newtype InterfaceBaseClause a = InterfaceBaseClause { values :: [a] }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 InterfaceBaseClause where liftEq = genericLiftEq
instance Ord1 InterfaceBaseClause where liftCompare = genericLiftCompare
@ -558,7 +556,7 @@ instance Show1 InterfaceBaseClause where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable InterfaceBaseClause
newtype Echo a = Echo { value :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Echo where liftEq = genericLiftEq
instance Ord1 Echo where liftCompare = genericLiftCompare
@ -567,7 +565,7 @@ instance Show1 Echo where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Echo
newtype Unset a = Unset { value :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Unset where liftEq = genericLiftEq
instance Ord1 Unset where liftCompare = genericLiftCompare
@ -576,7 +574,7 @@ instance Show1 Unset where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Unset
data Declare a = Declare { left :: a, right :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Declare where liftEq = genericLiftEq
instance Ord1 Declare where liftCompare = genericLiftCompare
@ -585,7 +583,7 @@ instance Show1 Declare where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Declare
newtype DeclareDirective a = DeclareDirective { value :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 DeclareDirective where liftEq = genericLiftEq
instance Ord1 DeclareDirective where liftCompare = genericLiftCompare
@ -594,7 +592,7 @@ instance Show1 DeclareDirective where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable DeclareDirective
newtype LabeledStatement a = LabeledStatement { _labeledStatementIdentifier :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 LabeledStatement where liftEq = genericLiftEq
instance Ord1 LabeledStatement where liftCompare = genericLiftCompare

8
src/Language/PHP/Term.hs
View File

@ -7,8 +7,6 @@ module Language.PHP.Term
import Control.Lens.Lens
import Data.Abstract.Declarations
import Data.Abstract.FreeVariables
import Data.Aeson (ToJSON)
import Data.Bifunctor
import Data.Bitraversable
import Data.Coerce
import Data.Foldable (fold)
@ -24,7 +22,6 @@ import qualified Data.Syntax.Statement as Statement
import qualified Data.Syntax.Type as Type
import qualified Data.Term as Term
import Data.Traversable
import Diffing.Interpreter
import qualified Language.PHP.Syntax as Syntax
import Source.Loc
import Source.Span
@ -157,7 +154,7 @@ type Syntax =
newtype Term ann = Term { getTerm :: Term.TermF (Sum.Sum Syntax) ann (Term ann) }
deriving (Eq, Declarations, FreeVariables, Ord, Show, ToJSON)
deriving (Eq, Declarations, FreeVariables, Ord, Show)
instance Term.IsTerm Term where
type Syntax Term = Sum.Sum Syntax
@ -181,9 +178,6 @@ instance Syntax.HasErrors Term where
maybe (fold syntax) (pure . Syntax.unError span) (Sum.project syntax)
instance DiffTerms Term where
diffTermPair = diffTermPair . bimap (cata Term.Term) (cata Term.Term)
type instance Base (Term ann) = Term.TermF (Sum.Sum Syntax) ann
instance Recursive (Term ann) where

16
src/Language/Python/Syntax.hs
View File

@ -30,9 +30,7 @@ import Data.Abstract.BaseError
import Data.Abstract.Evaluatable
import Data.Abstract.Module
import qualified Data.Abstract.ScopeGraph as ScopeGraph
import Data.JSON.Fields
import qualified Data.Language as Language
import Diffing.Algorithm
import Source.Span
import qualified System.Path as Path
@ -104,7 +102,7 @@ resolvePythonModules q = do
maybeM (throwResolutionError $ NotFoundError (Path.absRel path) searchPaths Language.Python) modulePath
data Alias a = Alias { aliasValue :: a, aliasName :: a}
deriving (Generic1, Diffable, Foldable, FreeVariables1, Functor, Hashable1, ToJSONFields1, Traversable)
deriving (Generic1, Foldable, FreeVariables1, Functor, Hashable1, Traversable)
instance Eq1 Alias where liftEq = genericLiftEq
instance Ord1 Alias where liftCompare = genericLiftCompare
@ -120,14 +118,14 @@ instance Evaluatable Alias where
--
-- If the list of symbols is empty copy everything to the calling environment.
data Import a = Import { importFrom :: QualifiedName, importSymbols :: ![a] }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Import where liftEq = genericLiftEq
instance Ord1 Import where liftCompare = genericLiftCompare
instance Show1 Import where liftShowsPrec = genericLiftShowsPrec
newtype FutureImport a = FutureImport { futureImportSymbols :: [a] }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 FutureImport where liftEq = genericLiftEq
instance Ord1 FutureImport where liftCompare = genericLiftCompare
@ -199,7 +197,7 @@ instance Evaluatable Import where
unit
newtype QualifiedImport a = QualifiedImport { qualifiedImportFrom :: NonEmpty a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Traversable)
instance Eq1 QualifiedImport where liftEq = genericLiftEq
instance Ord1 QualifiedImport where liftCompare = genericLiftCompare
@ -242,7 +240,7 @@ instance Evaluatable QualifiedImport where
fun (Map.singleton moduleScope moduleFrame)
data QualifiedAliasedImport a = QualifiedAliasedImport { qualifiedAliasedImportFrom :: QualifiedName, qualifiedAliasedImportAlias :: !a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 QualifiedAliasedImport where liftEq = genericLiftEq
instance Ord1 QualifiedAliasedImport where liftCompare = genericLiftCompare
@ -272,7 +270,7 @@ instance Evaluatable QualifiedAliasedImport where
-- | Ellipsis (used in splice expressions and alternatively can be used as a fill in expression, like `undefined` in Haskell)
data Ellipsis a = Ellipsis
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Ellipsis where liftEq = genericLiftEq
instance Ord1 Ellipsis where liftCompare = genericLiftCompare
@ -282,7 +280,7 @@ instance Show1 Ellipsis where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Ellipsis
data Redirect a = Redirect { lhs :: a, rhs :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Redirect where liftEq = genericLiftEq
instance Ord1 Redirect where liftCompare = genericLiftCompare

8
src/Language/Python/Term.hs
View File

@ -7,8 +7,6 @@ module Language.Python.Term
import Control.Lens.Lens
import Data.Abstract.Declarations
import Data.Abstract.FreeVariables
import Data.Aeson (ToJSON)
import Data.Bifunctor
import Data.Bitraversable
import Data.Coerce
import Data.Foldable (fold)
@ -24,7 +22,6 @@ import qualified Data.Syntax.Statement as Statement
import qualified Data.Syntax.Type as Type
import qualified Data.Term as Term
import Data.Traversable
import Diffing.Interpreter
import Language.Python.Syntax as Python.Syntax
import Source.Loc
import Source.Span
@ -112,7 +109,7 @@ type Syntax =
newtype Term ann = Term { getTerm :: Term.TermF (Sum.Sum Syntax) ann (Term ann) }
deriving (Eq, Declarations, FreeVariables, Ord, Show, ToJSON)
deriving (Eq, Declarations, FreeVariables, Ord, Show)
instance Term.IsTerm Term where
type Syntax Term = Sum.Sum Syntax
@ -136,9 +133,6 @@ instance Syntax.HasErrors Term where
maybe (fold syntax) (pure . Syntax.unError span) (Sum.project syntax)
instance DiffTerms Term where
diffTermPair = diffTermPair . bimap (cata Term.Term) (cata Term.Term)
type instance Base (Term ann) = Term.TermF (Sum.Sum Syntax) ann
instance Recursive (Term ann) where

23
src/Language/Ruby/Syntax.hs
View File

@ -20,7 +20,6 @@ import qualified Data.Abstract.ScopeGraph as ScopeGraph
import Data.Functor.Classes
import Data.Functor.Classes.Generic
import Data.Hashable.Lifted
import Data.JSON.Fields
import qualified Data.Language as Language
import Data.List.NonEmpty (nonEmpty)
import qualified Data.Map.Strict as Map
@ -30,7 +29,6 @@ import Data.Semigroup.Foldable
import Data.Text (Text)
import qualified Data.Text as T
import Data.Traversable (for)
import Diffing.Algorithm
import GHC.Generics (Generic1)
import qualified System.Path as Path
@ -67,7 +65,7 @@ cleanNameOrPath :: Text -> Path.AbsRelFile
cleanNameOrPath = Path.absRel . T.unpack . dropRelativePrefix . stripQuotes
data Send a = Send { sendReceiver :: Maybe a, sendSelector :: Maybe a, sendArgs :: [a], sendBlock :: Maybe a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Send where liftEq = genericLiftEq
instance Ord1 Send where liftCompare = genericLiftCompare
@ -94,7 +92,7 @@ instance Evaluatable Send where
maybe callFunction (`withScopeAndFrame` callFunction) lhsFrame
data Require a = Require { requireRelative :: Bool, requirePath :: !a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Require where liftEq = genericLiftEq
instance Ord1 Require where liftCompare = genericLiftCompare
@ -123,7 +121,7 @@ doRequire path = do
data Load a = Load { loadPath :: a, loadWrap :: Maybe a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Load where liftEq = genericLiftEq
instance Ord1 Load where liftCompare = genericLiftCompare
@ -166,15 +164,12 @@ doLoad path shouldWrap = do
-- TODO: autoload
data Class a = Class { classIdentifier :: !a, classSuperClass :: !(Maybe a), classBody :: !a }
deriving (Foldable, Traversable, Functor, Generic1, Hashable1, FreeVariables1, ToJSONFields1)
deriving (Foldable, Traversable, Functor, Generic1, Hashable1, FreeVariables1)
instance Eq1 Class where liftEq = genericLiftEq
instance Ord1 Class where liftCompare = genericLiftCompare
instance Show1 Class where liftShowsPrec = genericLiftShowsPrec
instance Diffable Class where
equivalentBySubterm = Just . classIdentifier
instance Evaluatable Class where
eval eval _ Class{..} = do
(name, relation) <- case declaredName classIdentifier of
@ -226,7 +221,7 @@ instance Declarations1 Class where
data Module a = Module { moduleIdentifier :: !a, moduleStatements :: ![a] }
deriving (Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Module where liftEq = genericLiftEq
instance Ord1 Module where liftCompare = genericLiftCompare
@ -273,7 +268,7 @@ instance Declarations1 Module where
data LowPrecedenceAnd a = LowPrecedenceAnd { lhs :: a, rhs :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 LowPrecedenceAnd where liftEq = genericLiftEq
instance Ord1 LowPrecedenceAnd where liftCompare = genericLiftCompare
@ -288,7 +283,7 @@ instance Evaluatable LowPrecedenceAnd where
data LowPrecedenceOr a = LowPrecedenceOr { lhs :: a, rhs :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 LowPrecedenceOr where liftEq = genericLiftEq
instance Ord1 LowPrecedenceOr where liftCompare = genericLiftCompare
@ -302,7 +297,7 @@ instance Evaluatable LowPrecedenceOr where
ifthenelse cond (pure cond) b
data Assignment a = Assignment { assignmentContext :: ![a], assignmentTarget :: !a, assignmentValue :: !a }
deriving (Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Assignment where liftEq = genericLiftEq
instance Ord1 Assignment where liftCompare = genericLiftCompare
@ -342,7 +337,7 @@ instance Evaluatable Assignment where
-- the semantics of invoking @super()@ but implicitly passing the current function's
-- arguments to the @super()@ invocation.
data ZSuper a = ZSuper
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 ZSuper where liftEq = genericLiftEq
instance Ord1 ZSuper where liftCompare = genericLiftCompare

8
src/Language/Ruby/Term.hs
View File

@ -7,8 +7,6 @@ module Language.Ruby.Term
import Control.Lens.Lens
import Data.Abstract.Declarations
import Data.Abstract.FreeVariables
import Data.Aeson (ToJSON)
import Data.Bifunctor
import Data.Bitraversable
import Data.Coerce
import Data.Foldable (fold)
@ -24,7 +22,6 @@ import qualified Data.Syntax.Literal as Literal
import qualified Data.Syntax.Statement as Statement
import qualified Data.Term as Term
import Data.Traversable
import Diffing.Interpreter
import qualified Language.Ruby.Syntax as Ruby.Syntax
import Source.Loc
import Source.Span
@ -122,7 +119,7 @@ type Syntax =
newtype Term ann = Term { getTerm :: Term.TermF (Sum.Sum Syntax) ann (Term ann) }
deriving (Eq, Declarations, FreeVariables, Ord, Show, ToJSON)
deriving (Eq, Declarations, FreeVariables, Ord, Show)
instance Term.IsTerm Term where
type Syntax Term = Sum.Sum Syntax
@ -146,9 +143,6 @@ instance Syntax.HasErrors Term where
maybe (fold syntax) (pure . Syntax.unError span) (Sum.project syntax)
instance DiffTerms Term where
diffTermPair = diffTermPair . bimap (cata Term.Term) (cata Term.Term)
type instance Base (Term ann) = Term.TermF (Sum.Sum Syntax) ann
instance Recursive (Term ann) where

20
src/Language/TSX/Syntax/JSX.hs
View File

@ -7,14 +7,12 @@ module Language.TSX.Syntax.JSX (module Language.TSX.Syntax.JSX) where
import Data.Abstract.Evaluatable
import Data.Functor.Classes.Generic
import Data.Hashable.Lifted
import Data.JSON.Fields
import qualified Data.Text as T
import Diffing.Algorithm
import GHC.Generics (Generic1)
data JsxElement a = JsxElement { jsxOpeningElement :: !a, jsxElements :: ![a], jsxClosingElement :: !a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 JsxElement where liftEq = genericLiftEq
instance Ord1 JsxElement where liftCompare = genericLiftCompare
@ -23,7 +21,7 @@ instance Show1 JsxElement where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable JsxElement
newtype JsxText a = JsxText { contents :: T.Text }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 JsxText where liftEq = genericLiftEq
instance Ord1 JsxText where liftCompare = genericLiftCompare
@ -32,7 +30,7 @@ instance Show1 JsxText where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable JsxText
newtype JsxExpression a = JsxExpression { jsxExpression :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 JsxExpression where liftEq = genericLiftEq
instance Ord1 JsxExpression where liftCompare = genericLiftCompare
@ -41,7 +39,7 @@ instance Show1 JsxExpression where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable JsxExpression
data JsxOpeningElement a = JsxOpeningElement { jsxOpeningElementIdentifier :: !a, jsxOpeningElementTypeArguments :: a, jsxAttributes :: ![a] }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 JsxOpeningElement where liftEq = genericLiftEq
instance Ord1 JsxOpeningElement where liftCompare = genericLiftCompare
@ -50,7 +48,7 @@ instance Show1 JsxOpeningElement where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable JsxOpeningElement
newtype JsxClosingElement a = JsxClosingElement { jsxClosingElementIdentifier :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 JsxClosingElement where liftEq = genericLiftEq
instance Ord1 JsxClosingElement where liftCompare = genericLiftCompare
@ -59,7 +57,7 @@ instance Show1 JsxClosingElement where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable JsxClosingElement
data JsxSelfClosingElement a = JsxSelfClosingElement { jsxSelfClosingElementIdentifier :: !a, jsxSelfClosingElementAttributes :: ![a] }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 JsxSelfClosingElement where liftEq = genericLiftEq
instance Ord1 JsxSelfClosingElement where liftCompare = genericLiftCompare
@ -68,7 +66,7 @@ instance Show1 JsxSelfClosingElement where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable JsxSelfClosingElement
data JsxAttribute a = JsxAttribute { jsxAttributeTarget :: !a, jsxAttributeValue :: !a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 JsxAttribute where liftEq = genericLiftEq
instance Ord1 JsxAttribute where liftCompare = genericLiftCompare
@ -77,7 +75,7 @@ instance Show1 JsxAttribute where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable JsxAttribute
newtype JsxFragment a = JsxFragment { terms :: [a] }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 JsxFragment where liftEq = genericLiftEq
instance Ord1 JsxFragment where liftCompare = genericLiftCompare
@ -86,7 +84,7 @@ instance Show1 JsxFragment where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable JsxFragment
data JsxNamespaceName a = JsxNamespaceName { left :: a, right :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 JsxNamespaceName where liftEq = genericLiftEq
instance Ord1 JsxNamespaceName where liftCompare = genericLiftCompare

8
src/Language/TSX/Term.hs
View File

@ -7,8 +7,6 @@ module Language.TSX.Term
import Control.Lens.Lens
import Data.Abstract.Declarations
import Data.Abstract.FreeVariables
import Data.Aeson (ToJSON)
import Data.Bifunctor
import Data.Bitraversable
import Data.Coerce
import Data.Foldable (fold)
@ -24,7 +22,6 @@ import qualified Data.Syntax.Statement as Statement
import qualified Data.Syntax.Type as Type
import qualified Data.Term as Term
import Data.Traversable
import Diffing.Interpreter
import qualified Language.TSX.Syntax as TSX.Syntax
import Source.Loc
import Source.Span
@ -202,7 +199,7 @@ type Syntax =
newtype Term ann = Term { getTerm :: Term.TermF (Sum.Sum Syntax) ann (Term ann) }
deriving (Eq, Declarations, FreeVariables, Ord, Show, ToJSON)
deriving (Eq, Declarations, FreeVariables, Ord, Show)
instance Term.IsTerm Term where
type Syntax Term = Sum.Sum Syntax
@ -226,9 +223,6 @@ instance Syntax.HasErrors Term where
maybe (fold syntax) (pure . Syntax.unError span) (Sum.project syntax)
instance DiffTerms Term where
diffTermPair = diffTermPair . bimap (cata Term.Term) (cata Term.Term)
type instance Base (Term ann) = Term.TermF (Sum.Sum Syntax) ann
instance Recursive (Term ann) where

20
src/Language/TypeScript/Syntax/Import.hs
View File

@ -17,15 +17,13 @@ import Data.Foldable
import Data.Functor.Classes.Generic
import Data.Hashable
import Data.Hashable.Lifted
import Data.JSON.Fields
import qualified Data.Map.Strict as Map
import Diffing.Algorithm
import GHC.Generics (Generic, Generic1)
import Language.TypeScript.Resolution
import Source.Span
data Import a = Import { importSymbols :: ![Alias], importFrom :: ImportPath }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Import where liftEq = genericLiftEq
instance Ord1 Import where liftCompare = genericLiftCompare
@ -58,7 +56,7 @@ instance Evaluatable Import where
unit
data QualifiedAliasedImport a = QualifiedAliasedImport { qualifiedAliasedImportAlias :: !a, qualifiedAliasedImportFrom :: ImportPath }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 QualifiedAliasedImport where liftEq = genericLiftEq
instance Ord1 QualifiedAliasedImport where liftCompare = genericLiftCompare
@ -80,7 +78,7 @@ instance Evaluatable QualifiedAliasedImport where
unit
newtype SideEffectImport a = SideEffectImport { sideEffectImportFrom :: ImportPath }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 SideEffectImport where liftEq = genericLiftEq
instance Ord1 SideEffectImport where liftCompare = genericLiftCompare
@ -94,7 +92,7 @@ instance Evaluatable SideEffectImport where
-- | Qualified Export declarations
newtype QualifiedExport a = QualifiedExport { qualifiedExportSymbols :: [Alias] }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 QualifiedExport where liftEq = genericLiftEq
instance Ord1 QualifiedExport where liftCompare = genericLiftCompare
@ -123,7 +121,7 @@ toTuple Alias{..} = (aliasValue, aliasName)
-- | Qualified Export declarations that export from another module.
data QualifiedExportFrom a = QualifiedExportFrom { qualifiedExportFrom :: ImportPath, qualifiedExportFromSymbols :: ![Alias]}
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 QualifiedExportFrom where liftEq = genericLiftEq
instance Ord1 QualifiedExportFrom where liftCompare = genericLiftCompare
@ -148,7 +146,7 @@ instance Evaluatable QualifiedExportFrom where
unit
newtype DefaultExport a = DefaultExport { defaultExport :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 DefaultExport where liftEq = genericLiftEq
instance Ord1 DefaultExport where liftCompare = genericLiftCompare
@ -174,7 +172,7 @@ instance Evaluatable DefaultExport where
unit
data ImportRequireClause a = ImportRequireClause { importRequireIdentifier :: !a, importRequireSubject :: !a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 ImportRequireClause where liftEq = genericLiftEq
instance Ord1 ImportRequireClause where liftCompare = genericLiftCompare
@ -183,7 +181,7 @@ instance Show1 ImportRequireClause where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable ImportRequireClause
newtype ImportClause a = ImportClause { importClauseElements :: [a] }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 ImportClause where liftEq = genericLiftEq
instance Ord1 ImportClause where liftCompare = genericLiftCompare
@ -192,7 +190,7 @@ instance Show1 ImportClause where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable ImportClause
data ImportAlias a = ImportAlias { importAliasSubject :: !a, importAlias :: !a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 ImportAlias where liftEq = genericLiftEq
instance Ord1 ImportAlias where liftCompare = genericLiftCompare

22
src/Language/TypeScript/Syntax/JavaScript.hs
View File

@ -12,14 +12,12 @@ import Data.Abstract.Evaluatable
import qualified Data.Abstract.ScopeGraph as ScopeGraph
import Data.Functor.Classes.Generic
import Data.Hashable.Lifted
import Data.JSON.Fields
import qualified Data.Map.Strict as Map
import Diffing.Algorithm
import GHC.Generics (Generic1)
import Language.TypeScript.Resolution
newtype ImplementsClause a = ImplementsClause { implementsClauseTypes :: [a] }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 ImplementsClause where liftEq = genericLiftEq
instance Ord1 ImplementsClause where liftCompare = genericLiftCompare
@ -28,7 +26,7 @@ instance Show1 ImplementsClause where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable ImplementsClause
data OptionalParameter a = OptionalParameter { optionalParameterContext :: ![a], optionalParameterSubject :: !a, optionalParameterAccessControl :: AccessControl }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 OptionalParameter where liftEq = genericLiftEq
instance Ord1 OptionalParameter where liftCompare = genericLiftCompare
@ -37,7 +35,7 @@ instance Show1 OptionalParameter where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable OptionalParameter
data RequiredParameter a = RequiredParameter { requiredParameterContext :: [a], requiredParameterSubject :: a, requiredParameterValue :: a, requiredParameterAccessControl :: AccessControl }
deriving (Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 RequiredParameter where liftEq = genericLiftEq
instance Ord1 RequiredParameter where liftCompare = genericLiftCompare
@ -69,7 +67,7 @@ instance Evaluatable RequiredParameter where
pure rhs
data RestParameter a = RestParameter { restParameterContext :: ![a], restParameterSubject :: !a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 RestParameter where liftEq = genericLiftEq
instance Ord1 RestParameter where liftCompare = genericLiftCompare
@ -79,7 +77,7 @@ instance Evaluatable RestParameter
data JavaScriptRequire a = JavaScriptRequire { javascriptRequireIden :: !a, javascriptRequireFrom :: ImportPath }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 JavaScriptRequire where liftEq = genericLiftEq
instance Ord1 JavaScriptRequire where liftCompare = genericLiftCompare
@ -105,7 +103,7 @@ instance Evaluatable JavaScriptRequire where
unit
data Debugger a = Debugger
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Debugger where liftEq = genericLiftEq
instance Ord1 Debugger where liftCompare = genericLiftCompare
@ -114,7 +112,7 @@ instance Show1 Debugger where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Debugger
data Super a = Super
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Super where liftEq = genericLiftEq
instance Ord1 Super where liftCompare = genericLiftCompare
@ -123,7 +121,7 @@ instance Show1 Super where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Super
data Undefined a = Undefined
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Undefined where liftEq = genericLiftEq
instance Ord1 Undefined where liftCompare = genericLiftCompare
@ -132,7 +130,7 @@ instance Show1 Undefined where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Undefined
data With a = With { withExpression :: !a, withBody :: !a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 With where liftEq = genericLiftEq
instance Ord1 With where liftCompare = genericLiftCompare
@ -142,7 +140,7 @@ instance Evaluatable With
-- | A sequence expression such as Javascript or C's comma operator.
data AnnotatedExpression a = AnnotatedExpression { expression :: !a, typeAnnotation :: !a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 AnnotatedExpression where liftEq = genericLiftEq
instance Ord1 AnnotatedExpression where liftCompare = genericLiftCompare

56
src/Language/TypeScript/Syntax/TypeScript.hs
View File

@ -15,7 +15,6 @@ import qualified Data.Abstract.ScopeGraph as ScopeGraph
import Data.Foldable
import Data.Functor.Classes.Generic
import Data.Hashable.Lifted
import Data.JSON.Fields
import Data.List.NonEmpty (nonEmpty)
import qualified Data.Map.Strict as Map
import Data.Maybe.Exts
@ -23,12 +22,11 @@ import Data.Semigroup.App
import Data.Semigroup.Foldable
import qualified Data.Text as T
import Data.Traversable
import Diffing.Algorithm
import GHC.Generics (Generic1)
-- | ShorthandPropertyIdentifier used in object patterns such as var baz = { foo } to mean var baz = { foo: foo }
newtype ShorthandPropertyIdentifier a = ShorthandPropertyIdentifier { contents :: T.Text }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 ShorthandPropertyIdentifier where liftEq = genericLiftEq
instance Ord1 ShorthandPropertyIdentifier where liftCompare = genericLiftCompare
@ -37,7 +35,7 @@ instance Show1 ShorthandPropertyIdentifier where liftShowsPrec = genericLiftShow
instance Evaluatable ShorthandPropertyIdentifier
data Union a = Union { unionLeft :: !a, unionRight :: !a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Union where liftEq = genericLiftEq
instance Ord1 Union where liftCompare = genericLiftCompare
@ -46,7 +44,7 @@ instance Show1 Union where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Language.TypeScript.Syntax.TypeScript.Union
data Intersection a = Intersection { intersectionLeft :: !a, intersectionRight :: !a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Intersection where liftEq = genericLiftEq
instance Ord1 Intersection where liftCompare = genericLiftCompare
@ -55,7 +53,7 @@ instance Show1 Intersection where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Intersection
data AmbientFunction a = AmbientFunction { ambientFunctionContext :: ![a], ambientFunctionIdentifier :: !a, ambientFunctionParameters :: ![a] }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 AmbientFunction where liftEq = genericLiftEq
instance Ord1 AmbientFunction where liftCompare = genericLiftCompare
@ -64,7 +62,7 @@ instance Show1 AmbientFunction where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable AmbientFunction
newtype Tuple a = Tuple { tupleElements :: [a] }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Tuple where liftEq = genericLiftEq
instance Ord1 Tuple where liftCompare = genericLiftCompare
@ -74,7 +72,7 @@ instance Show1 Tuple where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Tuple
data Constructor a = Constructor { constructorTypeParameters :: !a, constructorFormalParameters :: ![a], constructorType :: !a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Constructor where liftEq = genericLiftEq
instance Ord1 Constructor where liftCompare = genericLiftCompare
@ -84,7 +82,7 @@ instance Evaluatable Language.TypeScript.Syntax.TypeScript.Constructor
newtype Annotation a = Annotation { annotationType :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Annotation where liftEq = genericLiftEq
instance Ord1 Annotation where liftCompare = genericLiftCompare
@ -93,7 +91,7 @@ instance Show1 Annotation where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Annotation
newtype Decorator a = Decorator { decoratorTerm :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Decorator where liftEq = genericLiftEq
instance Ord1 Decorator where liftCompare = genericLiftCompare
@ -102,7 +100,7 @@ instance Show1 Decorator where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Decorator
newtype ComputedPropertyName a = ComputedPropertyName { propertyName :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 ComputedPropertyName where liftEq = genericLiftEq
instance Ord1 ComputedPropertyName where liftCompare = genericLiftCompare
@ -111,7 +109,7 @@ instance Show1 ComputedPropertyName where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable ComputedPropertyName
newtype Constraint a = Constraint { constraintType :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Constraint where liftEq = genericLiftEq
instance Ord1 Constraint where liftCompare = genericLiftCompare
@ -120,7 +118,7 @@ instance Show1 Constraint where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Constraint
data NestedIdentifier a = NestedIdentifier { left :: !a, right :: !a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 NestedIdentifier where liftEq = genericLiftEq
instance Ord1 NestedIdentifier where liftCompare = genericLiftCompare
@ -129,7 +127,7 @@ instance Show1 NestedIdentifier where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable NestedIdentifier
newtype AmbientDeclaration a = AmbientDeclaration { ambientDeclarationBody :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 AmbientDeclaration where liftEq = genericLiftEq
instance Ord1 AmbientDeclaration where liftCompare = genericLiftCompare
@ -139,7 +137,7 @@ instance Evaluatable AmbientDeclaration where
eval eval _ (AmbientDeclaration body) = eval body
data EnumDeclaration a = EnumDeclaration { enumDeclarationIdentifier :: !a, enumDeclarationBody :: ![a] }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 EnumDeclaration where liftEq = genericLiftEq
instance Ord1 EnumDeclaration where liftCompare = genericLiftCompare
@ -151,7 +149,7 @@ instance Declarations a => Declarations (EnumDeclaration a) where
declaredName EnumDeclaration{..} = declaredName enumDeclarationIdentifier
newtype ExtendsClause a = ExtendsClause { extendsClauses :: [a] }
deriving (Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 ExtendsClause where liftEq = genericLiftEq
instance Ord1 ExtendsClause where liftCompare = genericLiftCompare
@ -169,7 +167,7 @@ instance Evaluatable ExtendsClause where
unit
data PropertySignature a = PropertySignature { modifiers :: [a], propertySignaturePropertyName :: a, propertySignatureAccessControl :: AccessControl }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 PropertySignature where liftEq = genericLiftEq
instance Ord1 PropertySignature where liftCompare = genericLiftCompare
@ -178,7 +176,7 @@ instance Show1 PropertySignature where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable PropertySignature
data CallSignature a = CallSignature { callSignatureTypeParameters :: !a, callSignatureParameters :: ![a], callSignatureType :: !a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 CallSignature where liftEq = genericLiftEq
instance Ord1 CallSignature where liftCompare = genericLiftCompare
@ -188,7 +186,7 @@ instance Evaluatable CallSignature
-- | Todo: Move type params and type to context
data ConstructSignature a = ConstructSignature { constructSignatureTypeParameters :: !a, constructSignatureParameters :: ![a], constructSignatureType :: !a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 ConstructSignature where liftEq = genericLiftEq
instance Ord1 ConstructSignature where liftCompare = genericLiftCompare
@ -197,7 +195,7 @@ instance Show1 ConstructSignature where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable ConstructSignature
data IndexSignature a = IndexSignature { subject :: a, subjectType :: a, typeAnnotation :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 IndexSignature where liftEq = genericLiftEq
instance Ord1 IndexSignature where liftCompare = genericLiftCompare
@ -206,7 +204,7 @@ instance Show1 IndexSignature where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable IndexSignature
data AbstractMethodSignature a = AbstractMethodSignature { abstractMethodSignatureContext :: ![a], abstractMethodSignatureName :: a, abstractMethodSignatureParameters :: [a], abstractMethodAccessControl :: AccessControl }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 AbstractMethodSignature where liftEq = genericLiftEq
instance Ord1 AbstractMethodSignature where liftCompare = genericLiftCompare
@ -215,7 +213,7 @@ instance Show1 AbstractMethodSignature where liftShowsPrec = genericLiftShowsPre
instance Evaluatable AbstractMethodSignature
data ForOf a = ForOf { forOfBinding :: !a, forOfSubject :: !a, forOfBody :: !a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 ForOf where liftEq = genericLiftEq
instance Ord1 ForOf where liftCompare = genericLiftCompare
@ -224,7 +222,7 @@ instance Show1 ForOf where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable ForOf
data LabeledStatement a = LabeledStatement { labeledStatementIdentifier :: !a, labeledStatementSubject :: !a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 LabeledStatement where liftEq = genericLiftEq
instance Ord1 LabeledStatement where liftCompare = genericLiftCompare
@ -233,7 +231,7 @@ instance Show1 LabeledStatement where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable LabeledStatement
newtype Update a = Update { updateSubject :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Update where liftEq = genericLiftEq
instance Ord1 Update where liftCompare = genericLiftCompare
@ -242,7 +240,7 @@ instance Show1 Update where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable Update
data Module a = Module { moduleIdentifier :: !a, moduleStatements :: ![a] }
deriving (Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 Module where liftEq = genericLiftEq
instance Ord1 Module where liftCompare = genericLiftCompare
@ -313,7 +311,7 @@ instance Declarations1 Module where
liftDeclaredName declaredName = declaredName . moduleIdentifier
data InternalModule a = InternalModule { internalModuleIdentifier :: !a, internalModuleStatements :: ![a] }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 InternalModule where liftEq = genericLiftEq
instance Ord1 InternalModule where liftCompare = genericLiftCompare
@ -327,7 +325,7 @@ instance Declarations a => Declarations (InternalModule a) where
declaredName InternalModule{..} = declaredName internalModuleIdentifier
data ClassHeritage a = ClassHeritage { classHeritageExtendsClause :: !a, implementsClause :: !a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 ClassHeritage where liftEq = genericLiftEq
instance Ord1 ClassHeritage where liftCompare = genericLiftCompare
@ -336,7 +334,7 @@ instance Show1 ClassHeritage where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable ClassHeritage
data AbstractClass a = AbstractClass { abstractClassIdentifier :: !a, abstractClassTypeParameters :: !a, classHeritage :: ![a], classBody :: !a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 AbstractClass where liftEq = genericLiftEq
instance Ord1 AbstractClass where liftCompare = genericLiftCompare
@ -377,7 +375,7 @@ instance Evaluatable AbstractClass where
unit
data MetaProperty a = MetaProperty
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 MetaProperty where liftEq = genericLiftEq
instance Ord1 MetaProperty where liftCompare = genericLiftCompare

42
src/Language/TypeScript/Syntax/Types.hs
View File

@ -11,14 +11,12 @@ import Data.Abstract.Evaluatable as Evaluatable
import qualified Data.Abstract.ScopeGraph as ScopeGraph
import Data.Functor.Classes.Generic
import Data.Hashable.Lifted
import Data.JSON.Fields
import qualified Data.Text as T
import Diffing.Algorithm
import GHC.Generics (Generic1)
-- | Lookup type for a type-level key in a typescript map.
data LookupType a = LookupType { lookupTypeIdentifier :: a, lookupTypeKey :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 LookupType where liftEq = genericLiftEq
instance Ord1 LookupType where liftCompare = genericLiftCompare
@ -27,7 +25,7 @@ instance Show1 LookupType where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable LookupType
data FunctionType a = FunctionType { functionTypeParameters :: !a, functionFormalParameters :: ![a], functionType :: !a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 FunctionType where liftEq = genericLiftEq
instance Ord1 FunctionType where liftCompare = genericLiftCompare
@ -36,7 +34,7 @@ instance Show1 FunctionType where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable FunctionType
data TypeParameter a = TypeParameter { typeParameter :: !a, typeParameterConstraint :: !a, typeParameterDefaultType :: !a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 TypeParameter where liftEq = genericLiftEq
instance Ord1 TypeParameter where liftCompare = genericLiftCompare
@ -45,7 +43,7 @@ instance Show1 TypeParameter where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable TypeParameter
data TypeAssertion a = TypeAssertion { typeAssertionParameters :: !a, typeAssertionExpression :: !a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 TypeAssertion where liftEq = genericLiftEq
instance Ord1 TypeAssertion where liftCompare = genericLiftCompare
@ -54,7 +52,7 @@ instance Show1 TypeAssertion where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable TypeAssertion
newtype DefaultType a = DefaultType { defaultType :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 DefaultType where liftEq = genericLiftEq
instance Ord1 DefaultType where liftCompare = genericLiftCompare
@ -63,7 +61,7 @@ instance Show1 DefaultType where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable DefaultType
newtype ParenthesizedType a = ParenthesizedType { parenthesizedType :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 ParenthesizedType where liftEq = genericLiftEq
instance Ord1 ParenthesizedType where liftCompare = genericLiftCompare
@ -72,7 +70,7 @@ instance Show1 ParenthesizedType where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable ParenthesizedType
newtype PredefinedType a = PredefinedType { predefinedType :: T.Text }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 PredefinedType where liftEq = genericLiftEq
instance Ord1 PredefinedType where liftCompare = genericLiftCompare
@ -82,7 +80,7 @@ instance Show1 PredefinedType where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable PredefinedType
newtype TypeIdentifier a = TypeIdentifier { contents :: T.Text }
deriving (Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 TypeIdentifier where liftEq = genericLiftEq
instance Ord1 TypeIdentifier where liftCompare = genericLiftCompare
@ -100,7 +98,7 @@ instance Evaluatable TypeIdentifier where
unit
data NestedTypeIdentifier a = NestedTypeIdentifier { left :: !a, right :: !a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 NestedTypeIdentifier where liftEq = genericLiftEq
instance Ord1 NestedTypeIdentifier where liftCompare = genericLiftCompare
@ -109,7 +107,7 @@ instance Show1 NestedTypeIdentifier where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable NestedTypeIdentifier
data GenericType a = GenericType { genericTypeIdentifier :: !a, genericTypeArguments :: !a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 GenericType where liftEq = genericLiftEq
instance Ord1 GenericType where liftCompare = genericLiftCompare
@ -118,7 +116,7 @@ instance Show1 GenericType where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable GenericType
data TypePredicate a = TypePredicate { typePredicateIdentifier :: !a, typePredicateType :: !a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 TypePredicate where liftEq = genericLiftEq
instance Ord1 TypePredicate where liftCompare = genericLiftCompare
@ -127,7 +125,7 @@ instance Show1 TypePredicate where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable TypePredicate
newtype ObjectType a = ObjectType { objectTypeElements :: [a] }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 ObjectType where liftEq = genericLiftEq
instance Ord1 ObjectType where liftCompare = genericLiftCompare
@ -136,7 +134,7 @@ instance Show1 ObjectType where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable ObjectType
newtype ArrayType a = ArrayType { arrayType :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 ArrayType where liftEq = genericLiftEq
instance Ord1 ArrayType where liftCompare = genericLiftCompare
@ -145,7 +143,7 @@ instance Show1 ArrayType where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable ArrayType
newtype FlowMaybeType a = FlowMaybeType { flowMaybeType :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 FlowMaybeType where liftEq = genericLiftEq
instance Ord1 FlowMaybeType where liftCompare = genericLiftCompare
@ -154,7 +152,7 @@ instance Show1 FlowMaybeType where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable FlowMaybeType
newtype TypeQuery a = TypeQuery { typeQuerySubject :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 TypeQuery where liftEq = genericLiftEq
instance Ord1 TypeQuery where liftCompare = genericLiftCompare
@ -163,7 +161,7 @@ instance Show1 TypeQuery where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable TypeQuery
newtype IndexTypeQuery a = IndexTypeQuery { indexTypeQuerySubject :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 IndexTypeQuery where liftEq = genericLiftEq
instance Ord1 IndexTypeQuery where liftCompare = genericLiftCompare
@ -172,7 +170,7 @@ instance Show1 IndexTypeQuery where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable IndexTypeQuery
newtype TypeArguments a = TypeArguments { typeArguments :: [a] }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 TypeArguments where liftEq = genericLiftEq
instance Ord1 TypeArguments where liftCompare = genericLiftCompare
@ -181,7 +179,7 @@ instance Show1 TypeArguments where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable TypeArguments
newtype ThisType a = ThisType { contents :: T.Text }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 ThisType where liftEq = genericLiftEq
instance Ord1 ThisType where liftCompare = genericLiftCompare
@ -190,7 +188,7 @@ instance Show1 ThisType where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable ThisType
newtype ExistentialType a = ExistentialType { contents :: T.Text }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 ExistentialType where liftEq = genericLiftEq
instance Ord1 ExistentialType where liftCompare = genericLiftCompare
@ -199,7 +197,7 @@ instance Show1 ExistentialType where liftShowsPrec = genericLiftShowsPrec
instance Evaluatable ExistentialType
newtype LiteralType a = LiteralType { literalTypeSubject :: a }
deriving (Declarations1, Diffable, Foldable, FreeVariables1, Functor, Generic1, Hashable1, ToJSONFields1, Traversable)
deriving (Declarations1, Foldable, FreeVariables1, Functor, Generic1, Hashable1, Traversable)
instance Eq1 LiteralType where liftEq = genericLiftEq
instance Ord1 LiteralType where liftCompare = genericLiftCompare

8
src/Language/TypeScript/Term.hs
View File

@ -7,8 +7,6 @@ module Language.TypeScript.Term
import Control.Lens.Lens
import Data.Abstract.Declarations
import Data.Abstract.FreeVariables
import Data.Aeson (ToJSON)
import Data.Bifunctor
import Data.Bitraversable
import Data.Coerce
import Data.Foldable (fold)
@ -24,7 +22,6 @@ import qualified Data.Syntax.Statement as Statement
import qualified Data.Syntax.Type as Type
import qualified Data.Term as Term
import Data.Traversable
import Diffing.Interpreter
import qualified Language.TypeScript.Syntax as TypeScript.Syntax
import Source.Loc
import Source.Span
@ -193,7 +190,7 @@ type Syntax =
newtype Term ann = Term { getTerm :: Term.TermF (Sum.Sum Syntax) ann (Term ann) }
deriving (Eq, Declarations, FreeVariables, Ord, Show, ToJSON)
deriving (Eq, Declarations, FreeVariables, Ord, Show)
instance Term.IsTerm Term where
type Syntax Term = Sum.Sum Syntax
@ -217,9 +214,6 @@ instance Syntax.HasErrors Term where
maybe (fold syntax) (pure . Syntax.unError span) (Sum.project syntax)
instance DiffTerms Term where
diffTermPair = diffTermPair . bimap (cata Term.Term) (cata Term.Term)
type instance Base (Term ann) = Term.TermF (Sum.Sum Syntax) ann
instance Recursive (Term ann) where

34
src/Parsing/Parser.hs
View File

@ -38,7 +38,6 @@ module Parsing.Parser
-- * Canonical sets of parsers
, aLaCarteParsers
, preciseParsers
, allParsers
) where
import Assigning.Assignment
@ -263,36 +262,3 @@ preciseParsers = Map.fromList
, typescriptParserPrecise
, javaParser
]
-- | The canonical set of all parsers for the passed per-language modes.
allParsers
:: ( c GoALaCarte.Term
, c GoPrecise.Term
, c Java.Term
, c JSON.Term
, c PHPPrecise.Term
, c PythonALaCarte.Term
, c PythonPrecise.Term
, c CodeQLPrecise.Term
, c RubyALaCarte.Term
, c RubyPrecise.Term
, c TSXALaCarte.Term
, c TSXPrecise.Term
, c TypeScriptALaCarte.Term
, c TypeScriptPrecise.Term
)
=> PerLanguageModes
-> Map Language (SomeParser c Loc)
allParsers modes = Map.fromList
[ goParser modes
, javaParser
, javascriptParser modes
, jsonParser
, jsxParser modes
, phpParserPrecise
, pythonParser modes
, codeQLParserPrecise
, rubyParser modes
, tsxParser modes
, typescriptParser modes
]

134
src/Rendering/Graph.hs
View File

@ -1,134 +0,0 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE OverloadedStrings #-}
module Rendering.Graph
( renderTreeGraph
, termStyle
, diffStyle
, ToTreeGraph(..)
) where
import Algebra.Graph.Export.Dot
import Analysis.ConstructorName
import Control.Carrier.Fresh.Strict
import Control.Carrier.Reader
import Control.Carrier.State.Strict
import Control.Lens
import Data.Diff
import Data.Edit
import Data.Foldable
import Data.Functor.Foldable
import Data.Graph.Algebraic
import Data.ProtoLens (defMessage)
import Data.String (IsString (..))
import Data.Term
import Proto.Semantic as P
import Proto.Semantic_Fields as P
import Semantic.Api.Bridge
import Source.Loc as Loc
import qualified Data.Text as T
-- TODO: rename as this isn't a render
renderTreeGraph :: (Ord vertex, Recursive t, ToTreeGraph vertex (Base t)) => t -> Graph vertex
renderTreeGraph = simplify . runGraph . cata toTreeGraph
runGraph :: ReaderC (Graph vertex)
(FreshC Identity) (Graph vertex)
-> Graph vertex
runGraph = run . runFresh' . runReader mempty
where
-- NB: custom runFresh so that we count starting at 1 in order to avoid
-- default values for proto encoding.
runFresh' = evalState 1 . runFreshC
runFreshC (FreshC a) = a
-- | GraphViz styling for terms
termStyle :: (IsString string, Monoid string) => String -> Style TermVertex string
termStyle name = (defaultStyle (fromString . show . view vertexId))
{ graphName = fromString (quote name)
, vertexAttributes = vertexAttributes }
where quote a = "\"" <> a <> "\""
vertexAttributes v = ["label" := fromString (T.unpack (v^.term))]
-- | Graphviz styling for diffs
diffStyle :: (IsString string, Monoid string) => String -> Style DiffTreeVertex string
diffStyle name = (defaultStyle (fromString . show . view diffVertexId))
{ graphName = fromString (quote name)
, vertexAttributes = vertexAttributes }
where quote a = "\"" <> a <> "\""
vertexAttributes v = case v^.maybe'diffTerm of
Just (DiffTreeVertex'Deleted x) -> [ "label" := fromString (T.unpack (x^.term)), "color" := "red" ]
Just (DiffTreeVertex'Inserted x) -> [ "label" := fromString (T.unpack (x^.term)), "color" := "green" ]
Just (DiffTreeVertex'Replaced _) -> [ "label" := "Replacement", "color" := "orange", "style" := "dashed" ]
Just (DiffTreeVertex'Merged x) -> [ "label" := fromString (T.unpack (x^.term)) ]
_ -> []
class ToTreeGraph vertex t | t -> vertex where
toTreeGraph :: (Has Fresh sig m, Has (Reader (Graph vertex)) sig m) => t (m (Graph vertex)) -> m (Graph vertex)
instance (ConstructorName syntax, Foldable syntax) =>
ToTreeGraph TermVertex (TermF syntax Loc) where
toTreeGraph = termAlgebra where
termAlgebra ::
( ConstructorName syntax
, Foldable syntax
, Has Fresh sig m
, Has (Reader (Graph TermVertex)) sig m
)
=> TermF syntax Loc (m (Graph TermVertex))
-> m (Graph TermVertex)
termAlgebra (In ann syntax) = do
i <- fresh
parent <- ask
let root = vertex $ defMessage
& P.vertexId .~ fromIntegral i
& P.term .~ T.pack (constructorName syntax)
& P.maybe'span .~ (converting #? Loc.span ann)
subGraph <- foldl' (\acc x -> overlay <$> acc <*> local (const root) x) (pure mempty) syntax
pure (parent `connect` root `overlay` subGraph)
instance (ConstructorName syntax, Foldable syntax) =>
ToTreeGraph DiffTreeVertex (DiffF syntax Loc Loc) where
toTreeGraph d = case d of
Merge t@(In (a1, a2) syntax) -> diffAlgebra t . DiffTreeVertex'Merged $ defMessage
& P.term .~ T.pack (constructorName syntax)
& P.maybe'beforeSpan .~ ann a1
& P.maybe'afterSpan .~ ann a2
Patch (Delete t1@(In a1 syntax)) -> diffAlgebra t1 . DiffTreeVertex'Deleted $ defMessage
& P.term .~ T.pack (constructorName syntax)
& P.maybe'span .~ ann a1
Patch (Insert t2@(In a2 syntax)) -> diffAlgebra t2 . DiffTreeVertex'Inserted $ defMessage
& P.term .~ T.pack (constructorName syntax)
& P.maybe'span .~ ann a2
Patch (Compare t1@(In a1 syntax1) t2@(In a2 syntax2)) -> do
i <- fresh
parent <- ask
let (beforeName, beforeSpan) = (T.pack (constructorName syntax1), ann a1)
let (afterName, afterSpan) = (T.pack (constructorName syntax2), ann a2)
let replace = vertex $ defMessage
& P.diffVertexId .~ fromIntegral i
& P.maybe'replaced ?~ (defMessage
& P.beforeTerm .~ beforeName
& P.maybe'beforeSpan .~ beforeSpan
& P.afterTerm .~ afterName
& P.maybe'afterSpan .~ afterSpan)
graph <- local (const replace) (overlay <$> diffAlgebra t1 (DiffTreeVertex'Deleted (defMessage & P.term .~ beforeName & P.maybe'span .~ beforeSpan)) <*> diffAlgebra t2 (DiffTreeVertex'Inserted (defMessage & P.term .~ afterName & P.maybe'span .~ afterSpan)))
pure (parent `connect` replace `overlay` graph)
where
ann a = converting #? Loc.span a
diffAlgebra ::
( Foldable f
, Has Fresh sig m
, Has (Reader (Graph DiffTreeVertex)) sig m
) => f (m (Graph DiffTreeVertex)) -> DiffTreeVertex'DiffTerm -> m (Graph DiffTreeVertex)
diffAlgebra syntax a = do
i <- fresh
parent <- ask
let root = vertex $ defMessage
& P.diffVertexId .~ fromIntegral i
& P.maybe'diffTerm ?~ a
subGraph <- foldl' (\acc x -> overlay <$> acc <*> local (const root) x) (pure mempty) syntax
pure (parent `connect` root `overlay` subGraph)

129
src/Rendering/JSON.hs
View File

@ -1,129 +0,0 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module Rendering.JSON
( JSON(..)
, renderJSONDiff
, renderJSONAdjDiff
, renderJSONTerm
, renderJSONAdjTerm
, renderJSONAST
, renderSymbolTerms
, renderJSONError
, renderJSONSymbolError
, renderJSONDiffError
, SomeJSON(..)
) where
import Data.Aeson as A
import Data.Blob
import Data.Foldable (fold)
import Data.JSON.Fields
import Data.Text (pack)
import GHC.TypeLits
newtype JSON (key :: Symbol) a = JSON { unJSON :: [a] }
deriving (Eq, Monoid, Semigroup, Show)
instance (KnownSymbol key, ToJSON a) => ToJSON (JSON key a) where
toJSON (JSON as) = object [ pack (symbolVal @key undefined) .= as ]
toEncoding (JSON as) = pairs (pack (symbolVal @key undefined) .= as)
-- | Render a diff to a value representing its JSON.
renderJSONDiff :: ToJSON a => BlobPair -> a -> JSON "diffs" SomeJSON
renderJSONDiff blobs diff = JSON [ SomeJSON (JSONDiff (JSONStat blobs) diff) ]
data JSONDiff a = JSONDiff { jsonDiffStat :: JSONStat, jsonDiff :: a }
deriving (Eq, Show)
instance ToJSON a => ToJSON (JSONDiff a) where
toJSON JSONDiff{..} = object [ "diff" .= jsonDiff, "stat" .= jsonDiffStat ]
toEncoding JSONDiff{..} = pairs ("diff" .= jsonDiff <> "stat" .= jsonDiffStat)
-- | Render a diff to a value representing its JSON.
renderJSONAdjDiff :: ToJSON a => BlobPair -> a -> JSON "diffs" SomeJSON
renderJSONAdjDiff blobs diff = JSON [ SomeJSON (JSONAdjDiff (JSONStat blobs) diff) ]
data JSONAdjDiff a = JSONAdjDiff { jsonAdjDiffStat :: JSONStat, jsonAdjDiff :: a }
deriving (Eq, Show)
instance ToJSON a => ToJSON (JSONAdjDiff a) where
toJSON JSONAdjDiff{..} = object [ "graph" .= jsonAdjDiff, "stat" .= jsonAdjDiffStat ]
toEncoding JSONAdjDiff{..} = pairs ("graph" .= jsonAdjDiff <> "stat" .= jsonAdjDiffStat)
newtype JSONStat = JSONStat { jsonStatBlobs :: BlobPair }
deriving (Eq, Show)
instance ToJSON JSONStat where
toJSON JSONStat{..} = object ("path" .= pathKeyForBlobPair jsonStatBlobs : toJSONFields jsonStatBlobs)
toEncoding JSONStat{..} = pairs (fold ("path" .= pathKeyForBlobPair jsonStatBlobs : toJSONFields jsonStatBlobs))
-- | Render a term to a value representing its JSON.
renderJSONTerm :: ToJSON a => Blob -> a -> JSON "trees" SomeJSON
renderJSONTerm blob content = JSON [ SomeJSON (JSONTerm blob content) ]
data JSONTerm a = JSONTerm { jsonTermBlob :: Blob, jsonTerm :: a }
deriving (Eq, Show)
instance ToJSON a => ToJSON (JSONTerm a) where
toJSON JSONTerm{..} = object ("tree" .= jsonTerm : toJSONFields jsonTermBlob)
toEncoding JSONTerm{..} = pairs (fold ("tree" .= jsonTerm : toJSONFields jsonTermBlob))
renderJSONAdjTerm :: ToJSON a => Blob -> a -> JSON "trees" SomeJSON
renderJSONAdjTerm blob content = JSON [ SomeJSON (JSONAdjTerm blob content) ]
data JSONAdjTerm a = JSONAdjTerm { jsonAdjTermBlob :: Blob, jsonAdjTerm :: a }
deriving (Eq, Show)
instance ToJSON a => ToJSON (JSONAdjTerm a) where
toJSON JSONAdjTerm{..} = object ("graph" .= jsonAdjTerm : toJSONFields jsonAdjTermBlob)
toEncoding JSONAdjTerm{..} = pairs (fold ("graph" .= jsonAdjTerm : toJSONFields jsonAdjTermBlob))
renderJSONAST :: ToJSON a => Blob -> a -> JSON "trees" SomeJSON
renderJSONAST blob content = JSON [ SomeJSON (JSONAST blob content) ]
data JSONAST a = JSONAST { jsonASTBlob :: Blob, jsonAST :: a }
deriving (Eq, Show)
instance ToJSON a => ToJSON (JSONAST a) where
toJSON JSONAST{..} = object ("ast" .= jsonAST : toJSONFields jsonASTBlob)
toEncoding JSONAST{..} = pairs (fold ("ast" .= jsonAST : toJSONFields jsonASTBlob))
-- | Render terms to final JSON structure.
renderSymbolTerms :: ToJSON a => [a] -> JSON "files" SomeJSON
renderSymbolTerms = JSON . map SomeJSON
-- | Render an error for symbols.
renderJSONSymbolError :: Blob -> String -> JSON "files" SomeJSON
renderJSONSymbolError blob e = JSON [ renderError blob e ]
-- | Render an error for terms.
renderJSONError :: Blob -> String -> JSON "trees" SomeJSON
renderJSONError blob e = JSON [ renderError blob e ]
-- | Render an error for a particular blob.
renderError :: ToJSON a => Blob -> a -> SomeJSON
renderError b e = SomeJSON $ object
[ "error" .= e
, "path" .= blobFilePath b
, "language" .= blobLanguage b
]
-- | Render an error for diffs.
renderJSONDiffError :: BlobPair -> String -> JSON "diffs" SomeJSON
renderJSONDiffError pair e = JSON [ SomeJSON (object [ "error" .= err ]) ]
where err = object ["message" .= e, "stat" .= toJSON (JSONStat pair)]
data SomeJSON where
SomeJSON :: ToJSON a => a -> SomeJSON
instance ToJSON SomeJSON where
toJSON (SomeJSON a) = toJSON a
toEncoding (SomeJSON a) = toEncoding a

5
src/Semantic/Api.hs
View File

@ -1,13 +1,10 @@
module Semantic.Api
(
module DiffsAPI
, module SymbolsAPI
( module SymbolsAPI
, module StackGraphAPI
, module TermsAPI
, module Types
) where
import Semantic.Api.Diffs as DiffsAPI
import Semantic.Api.Symbols as SymbolsAPI
import Semantic.Api.StackGraph as StackGraphAPI
import Semantic.Api.Terms as TermsAPI

168
src/Semantic/Api/Diffs.hs
View File

@ -1,168 +0,0 @@
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE UndecidableInstances #-}
module Semantic.Api.Diffs
( parseDiffBuilder
, DiffOutputFormat(..)
, diffTerms
, diffGraph
) where
import Analysis.ConstructorName (ConstructorName)
import Control.Effect.Error
import Control.Effect.Parse
import Control.Effect.Reader
import Control.Exception
import Control.Lens
import Control.Monad
import Control.Monad.IO.Class
import Data.Bifoldable
import Data.Blob
import Data.ByteString.Builder
import Data.Diff
import Data.Edit
import Data.Foldable
import Data.Functor.Classes
import Data.Graph.Algebraic
import Data.JSON.Fields (ToJSONFields1)
import Data.Language
import Data.Map.Strict (Map)
import Data.ProtoLens (defMessage)
import Data.Term (IsTerm (..))
import qualified Data.Text as T
import Diffing.Interpreter (DiffTerms (..))
import Parsing.Parser
import Proto.Semantic as P hiding (Blob)
import Proto.Semantic_Fields as P
import Proto.Semantic_JSON ()
import Rendering.Graph
import Rendering.JSON hiding (JSON)
import qualified Rendering.JSON
import Semantic.Api.Bridge
import Semantic.Config
import Semantic.Task as Task
import Semantic.Telemetry as Stat
import Serializing.Format hiding (JSON)
import qualified Serializing.Format as Format
import Source.Loc
import qualified System.Path as Path
data DiffOutputFormat
= DiffJSONTree
| DiffJSONGraph
| DiffSExpression
| DiffShow
| DiffDotGraph
deriving (Eq, Show)
parseDiffBuilder :: (Traversable t, Has (Error SomeException) sig m, Has (Reader Config) sig m, Has Telemetry sig m, Has Distribute sig m, Has Parse sig m, MonadIO m) => DiffOutputFormat -> t BlobPair -> m Builder
parseDiffBuilder DiffJSONTree = distributeFoldMap jsonDiff >=> serialize Format.JSON -- NB: Serialize happens at the top level for these two JSON formats to collect results of multiple blob pairs.
parseDiffBuilder DiffJSONGraph = diffGraph >=> serialize Format.JSON
parseDiffBuilder DiffSExpression = distributeFoldMap (parsePairWith diffParsers sexprDiff)
parseDiffBuilder DiffShow = distributeFoldMap (parsePairWith diffParsers showDiff)
parseDiffBuilder DiffDotGraph = distributeFoldMap (parsePairWith diffParsers dotGraphDiff)
jsonDiff :: (Has (Error SomeException) sig m, Has Telemetry sig m, Has Parse sig m, MonadIO m) => BlobPair -> m (Rendering.JSON.JSON "diffs" SomeJSON)
jsonDiff blobPair = parsePairWith diffParsers jsonTreeDiff blobPair `catchError` jsonError blobPair
jsonError :: Applicative m => BlobPair -> SomeException -> m (Rendering.JSON.JSON "diffs" SomeJSON)
jsonError blobPair (SomeException e) = pure $ renderJSONDiffError blobPair (show e)
diffGraph :: (Traversable t, Has (Error SomeException) sig m, Has Telemetry sig m, Has Distribute sig m, Has Parse sig m, MonadIO m) => t BlobPair -> m DiffTreeGraphResponse
diffGraph blobs = do
graph <- distributeFor blobs go
pure $ defMessage & P.files .~ toList graph
where
go :: (Has (Error SomeException) sig m, Has Telemetry sig m, Has Parse sig m, MonadIO m) => BlobPair -> m DiffTreeFileGraph
go blobPair = parsePairWith diffParsers jsonGraphDiff blobPair
`catchError` \(SomeException e) ->
pure $ defMessage
& P.path .~ path
& P.language .~ lang
& P.vertices .~ mempty
& P.edges .~ mempty
& P.errors .~ [defMessage & P.error .~ T.pack (show e)]
where
path = T.pack . Path.toString $ pathForBlobPair blobPair
lang = bridging # languageForBlobPair blobPair
class DOTGraphDiff term where
dotGraphDiff :: (Has (Reader Config) sig m, Has Telemetry sig m, MonadIO m) => Edit (Blob, term Loc) (Blob, term Loc) -> m Builder
instance (DiffTerms term, ConstructorName (Syntax term), Foldable (Syntax term), Functor (Syntax term)) => DOTGraphDiff term where
dotGraphDiff = serialize (DOT (diffStyle "diffs")) . renderTreeGraph <=< diffTerms
class JSONGraphDiff term where
jsonGraphDiff :: (Has Telemetry sig m, MonadIO m) => Edit (Blob, term Loc) (Blob, term Loc) -> m DiffTreeFileGraph
instance (DiffTerms term, ConstructorName (Syntax term), Foldable (Syntax term), Functor (Syntax term)) => JSONGraphDiff term where
jsonGraphDiff terms = do
diff <- diffTerms terms
let blobPair = bimap fst fst terms
graph = renderTreeGraph diff
toEdge (Edge (a, b)) = defMessage & P.source .~ a^.diffVertexId & P.target .~ b^.diffVertexId
path = T.pack . Path.toString $ pathForBlobPair blobPair
lang = bridging # languageForBlobPair blobPair
pure $! defMessage
& P.path .~ path
& P.language .~ lang
& P.vertices .~ vertexList graph
& P.edges .~ fmap toEdge (edgeList graph)
& P.errors .~ mempty
class JSONTreeDiff term where
jsonTreeDiff :: (Has Telemetry sig m, MonadIO m) => Edit (Blob, term Loc) (Blob, term Loc) -> m (Rendering.JSON.JSON "diffs" SomeJSON)
instance (DiffTerms term, Foldable (Syntax term), ToJSONFields1 (Syntax term)) => JSONTreeDiff term where
jsonTreeDiff terms = renderJSONDiff (bimap fst fst terms) <$> diffTerms terms
class SExprDiff term where
sexprDiff :: (Has (Reader Config) sig m, Has Telemetry sig m, MonadIO m) => Edit (Blob, term Loc) (Blob, term Loc) -> m Builder
instance (DiffTerms term, ConstructorName (Syntax term), Foldable (Syntax term), Functor (Syntax term)) => SExprDiff term where
sexprDiff = serialize (SExpression ByConstructorName) <=< diffTerms
class ShowDiff term where
showDiff :: (Has (Reader Config) sig m, Has Telemetry sig m, MonadIO m) => Edit (Blob, term Loc) (Blob, term Loc) -> m Builder
instance (DiffTerms term, Foldable (Syntax term), Show1 (Syntax term)) => ShowDiff term where
showDiff = serialize Show <=< diffTerms
diffTerms :: (DiffTerms term, Foldable (Syntax term), Has Telemetry sig m, MonadIO m)
=> Edit (Blob, term ann) (Blob, term ann) -> m (Diff (Syntax term) ann ann)
diffTerms terms = time "diff" languageTag $ do
let diff = diffTermPair (bimap snd snd terms)
diff <$ writeStat (Stat.count "diff.nodes" (bilength diff) languageTag)
where languageTag = languageTagForBlobPair blobs
blobs = bimap fst fst terms
diffParsers :: Map Language (SomeParser Anything Loc)
diffParsers = aLaCarteParsers
class
( DiffTerms term
, ConstructorName (Syntax term)
, Foldable (Syntax term)
, Functor (Syntax term)
, Show1 (Syntax term)
, ToJSONFields1 (Syntax term)
) => Anything term
instance
( DiffTerms term
, ConstructorName (Syntax term)
, Foldable (Syntax term)
, Functor (Syntax term)
, Show1 (Syntax term)
, ToJSONFields1 (Syntax term)
) => Anything term

221
src/Semantic/Api/Terms.hs
View File

@ -11,103 +11,56 @@
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -freduction-depth=0 #-}
module Semantic.Api.Terms
( termGraph
, parseTermBuilder
( parseTermBuilder
, TermOutputFormat(..)
) where
import Control.Effect.Error
import Control.Effect.Parse
import Control.Effect.Reader
import Control.Lens
import Control.Monad
import Control.Monad.IO.Class
import Data.Aeson (ToJSON)
import Data.Blob
import Data.ByteString.Builder
import Data.Either
import Data.Foldable
import Data.Functor.Classes
import Data.Functor.Foldable
import Data.Graph.Algebraic (Edge (..), edgeList, vertexList)
import Data.Language
import Data.Map.Strict (Map)
import Data.ProtoLens (defMessage)
import Data.Quieterm
import Data.Term
import qualified Data.Text as T
import Parsing.Parser
import Proto.Semantic as P hiding (Blob)
import Proto.Semantic_Fields as P
import Proto.Semantic_JSON ()
import Rendering.Graph
import Rendering.JSON hiding (JSON)
import qualified Rendering.JSON
import Semantic.Api.Bridge
import Semantic.Config
import Semantic.Task
import Serializing.Format hiding (JSON)
import qualified Serializing.Format as Format
import Control.Effect.Error
import Control.Effect.Parse
import Control.Effect.Reader
import Control.Monad
import Control.Monad.IO.Class
import Data.Blob
import Data.ByteString.Builder
import Data.Either
import Data.Functor.Classes
import Data.Functor.Foldable
import Data.Language
import Data.Map.Strict (Map)
import Data.Quieterm
import Data.Term
import qualified Language.CodeQL as CodeQL
import qualified Language.Go as Go
import qualified Language.JSON as JSON
import qualified Language.Java as Java
import qualified Language.PHP as PHP
import qualified Language.Python as Python
import qualified Language.Ruby as Ruby
import qualified Language.TSX as TSX
import qualified Language.TypeScript as TypeScript
import Parsing.Parser
import Semantic.Config
import Semantic.Task
import Serializing.Format hiding (JSON)
import qualified Serializing.SExpression as SExpr
import qualified Serializing.SExpression.Precise as SExpr.Precise (serializeSExpression)
import Source.Loc
import Source.Loc
import qualified Language.Go as GoPrecise
import qualified Language.Java as Java
import qualified Language.JSON as JSON
import qualified Language.PHP as PHPPrecise
import qualified Language.CodeQL as CodeQLPrecise
import qualified Language.Python as PythonPrecise
import qualified Language.Ruby as RubyPrecise
import qualified Language.TSX as TSXPrecise
import qualified Language.TypeScript as TypeScriptPrecise
termGraph :: (Traversable t, Has Distribute sig m, Has (Error SomeException) sig m, Has Parse sig m) => t Blob -> m ParseTreeGraphResponse
termGraph blobs = do
terms <- distributeFor blobs go
pure $ defMessage
& P.files .~ toList terms
where
go :: (Has (Error SomeException) sig m, Has Parse sig m) => Blob -> m ParseTreeFileGraph
go blob = parseWith jsonGraphTermParsers (pure . jsonGraphTerm blob) blob
`catchError` \(SomeException e) ->
pure $ defMessage
& P.path .~ path
& P.language .~ lang
& P.vertices .~ mempty
& P.edges .~ mempty
& P.errors .~ [defMessage & P.error .~ T.pack (show e)]
where
path = T.pack $ blobFilePath blob
lang = bridging # blobLanguage blob
data TermOutputFormat
= TermJSONTree
| TermJSONGraph
| TermSExpression
| TermDotGraph
= TermSExpression
| TermShow
| TermQuiet
deriving (Eq, Show)
parseTermBuilder :: (Traversable t, Has Distribute sig m, Has (Error SomeException) sig m, Has (Reader PerLanguageModes) sig m, Has Parse sig m, Has (Reader Config) sig m, MonadIO m)
parseTermBuilder :: (Traversable t, Has Distribute sig m, Has (Error SomeException) sig m, Has Parse sig m, Has (Reader Config) sig m, MonadIO m)
=> TermOutputFormat -> t Blob -> m Builder
parseTermBuilder TermJSONTree = distributeFoldMap jsonTerm >=> serialize Format.JSON -- NB: Serialize happens at the top level for these two JSON formats to collect results of multiple blobs.
parseTermBuilder TermJSONGraph = termGraph >=> serialize Format.JSON
parseTermBuilder TermSExpression = distributeFoldMap (\ blob -> asks sexprTermParsers >>= \ parsers -> parseWith parsers (pure . sexprTerm) blob)
parseTermBuilder TermDotGraph = distributeFoldMap (parseWith dotGraphTermParsers dotGraphTerm)
parseTermBuilder TermShow = distributeFoldMap (\ blob -> asks showTermParsers >>= \ parsers -> parseWith parsers showTerm blob)
parseTermBuilder TermSExpression = distributeFoldMap (parseWith sexprTermParsers (pure . sexprTerm))
parseTermBuilder TermShow = distributeFoldMap (parseWith showTermParsers showTerm)
parseTermBuilder TermQuiet = distributeFoldMap quietTerm
jsonTerm :: (Has (Error SomeException) sig m, Has Parse sig m) => Blob -> m (Rendering.JSON.JSON "trees" SomeJSON)
jsonTerm blob = parseWith jsonTreeTermParsers (pure . jsonTreeTerm blob) blob `catchError` jsonError blob
jsonError :: Applicative m => Blob -> SomeException -> m (Rendering.JSON.JSON "trees" SomeJSON)
jsonError blob (SomeException e) = pure $ renderJSONError blob (show e)
quietTerm :: (Has (Error SomeException) sig m, Has (Reader PerLanguageModes) sig m, Has Parse sig m, Has (Reader Config) sig m, MonadIO m) => Blob -> m Builder
quietTerm blob = showTiming blob <$> time' ( asks showTermParsers >>= \ parsers -> parseWith parsers (fmap (const (Right ())) . showTerm) blob `catchError` timingError )
quietTerm :: (Has (Error SomeException) sig m, Has Parse sig m, Has (Reader Config) sig m, MonadIO m) => Blob -> m Builder
quietTerm blob = showTiming blob <$> time' (parseWith showTermParsers (fmap (const (Right ())) . showTerm) blob `catchError` timingError)
where
timingError (SomeException e) = pure (Left (show e))
showTiming Blob{..} (res, duration) =
@ -115,8 +68,8 @@ quietTerm blob = showTiming blob <$> time' ( asks showTermParsers >>= \ parsers
in stringUtf8 (status <> "\t" <> show (blobLanguage blob) <> "\t" <> blobFilePath blob <> "\t" <> show duration <> " ms\n")
showTermParsers :: PerLanguageModes -> Map Language (SomeParser ShowTerm Loc)
showTermParsers = allParsers
showTermParsers :: Map Language (SomeParser ShowTerm Loc)
showTermParsers = preciseParsers
class ShowTerm term where
showTerm :: (Has (Reader Config) sig m) => term Loc -> m Builder
@ -127,8 +80,8 @@ instance (TermMode term ~ strategy, ShowTermBy strategy term) => ShowTerm term w
class ShowTermBy (strategy :: LanguageMode) term where
showTermBy :: (Has (Reader Config) sig m) => term Loc -> m Builder
instance ShowTermBy 'Precise GoPrecise.Term where
showTermBy = serialize Show . void . GoPrecise.getTerm
instance ShowTermBy 'Precise Go.Term where
showTermBy = serialize Show . void . Go.getTerm
instance ShowTermBy 'Precise Java.Term where
showTermBy = serialize Show . void . Java.getTerm
@ -136,30 +89,30 @@ instance ShowTermBy 'Precise Java.Term where
instance ShowTermBy 'Precise JSON.Term where
showTermBy = serialize Show . void . JSON.getTerm
instance ShowTermBy 'Precise PHPPrecise.Term where
showTermBy = serialize Show . void . PHPPrecise.getTerm
instance ShowTermBy 'Precise PHP.Term where
showTermBy = serialize Show . void . PHP.getTerm
instance ShowTermBy 'Precise PythonPrecise.Term where
showTermBy = serialize Show . void . PythonPrecise.getTerm
instance ShowTermBy 'Precise Python.Term where
showTermBy = serialize Show . void . Python.getTerm
instance ShowTermBy 'Precise CodeQLPrecise.Term where
showTermBy = serialize Show . void . CodeQLPrecise.getTerm
instance ShowTermBy 'Precise CodeQL.Term where
showTermBy = serialize Show . void . CodeQL.getTerm
instance ShowTermBy 'Precise RubyPrecise.Term where
showTermBy = serialize Show . void . RubyPrecise.getTerm
instance ShowTermBy 'Precise Ruby.Term where
showTermBy = serialize Show . void . Ruby.getTerm
instance ShowTermBy 'Precise TSXPrecise.Term where
showTermBy = serialize Show . void . TSXPrecise.getTerm
instance ShowTermBy 'Precise TSX.Term where
showTermBy = serialize Show . void . TSX.getTerm
instance ShowTermBy 'Precise TypeScriptPrecise.Term where
showTermBy = serialize Show . void . TypeScriptPrecise.getTerm
instance ShowTermBy 'Precise TypeScript.Term where
showTermBy = serialize Show . void . TypeScript.getTerm
instance (Recursive (term Loc), Show1 syntax, Base (term Loc) ~ TermF syntax Loc) => ShowTermBy 'ALaCarte term where
showTermBy = serialize Show . quieterm
sexprTermParsers :: PerLanguageModes -> Map Language (SomeParser SExprTerm Loc)
sexprTermParsers = allParsers
sexprTermParsers :: Map Language (SomeParser SExprTerm Loc)
sexprTermParsers = preciseParsers
class SExprTerm term where
sexprTerm :: term Loc -> Builder
@ -170,8 +123,8 @@ instance (TermMode term ~ strategy, SExprTermBy strategy term) => SExprTerm term
class SExprTermBy (strategy :: LanguageMode) term where
sexprTermBy :: term Loc -> Builder
instance SExprTermBy 'Precise GoPrecise.Term where
sexprTermBy = SExpr.Precise.serializeSExpression . GoPrecise.getTerm
instance SExprTermBy 'Precise Go.Term where
sexprTermBy = SExpr.Precise.serializeSExpression . Go.getTerm
instance SExprTermBy 'Precise Java.Term where
sexprTermBy = SExpr.Precise.serializeSExpression . Java.getTerm
@ -179,63 +132,23 @@ instance SExprTermBy 'Precise Java.Term where
instance SExprTermBy 'Precise JSON.Term where
sexprTermBy = SExpr.Precise.serializeSExpression . JSON.getTerm
instance SExprTermBy 'Precise PHPPrecise.Term where
sexprTermBy = SExpr.Precise.serializeSExpression . PHPPrecise.getTerm
instance SExprTermBy 'Precise PHP.Term where
sexprTermBy = SExpr.Precise.serializeSExpression . PHP.getTerm
instance SExprTermBy 'Precise PythonPrecise.Term where
sexprTermBy = SExpr.Precise.serializeSExpression . PythonPrecise.getTerm
instance SExprTermBy 'Precise Python.Term where
sexprTermBy = SExpr.Precise.serializeSExpression . Python.getTerm
instance SExprTermBy 'Precise CodeQLPrecise.Term where
sexprTermBy = SExpr.Precise.serializeSExpression . CodeQLPrecise.getTerm
instance SExprTermBy 'Precise CodeQL.Term where
sexprTermBy = SExpr.Precise.serializeSExpression . CodeQL.getTerm
instance SExprTermBy 'Precise RubyPrecise.Term where
sexprTermBy = SExpr.Precise.serializeSExpression . RubyPrecise.getTerm
instance SExprTermBy 'Precise Ruby.Term where
sexprTermBy = SExpr.Precise.serializeSExpression . Ruby.getTerm
instance SExprTermBy 'Precise TSXPrecise.Term where
sexprTermBy = SExpr.Precise.serializeSExpression . TSXPrecise.getTerm
instance SExprTermBy 'Precise TSX.Term where
sexprTermBy = SExpr.Precise.serializeSExpression . TSX.getTerm
instance SExprTermBy 'Precise TypeScriptPrecise.Term where
sexprTermBy = SExpr.Precise.serializeSExpression . TypeScriptPrecise.getTerm
instance SExprTermBy 'Precise TypeScript.Term where
sexprTermBy = SExpr.Precise.serializeSExpression . TypeScript.getTerm
instance (Recursive (term Loc), SExpr.ToSExpression (Base (term Loc))) => SExprTermBy 'ALaCarte term where
sexprTermBy = SExpr.serializeSExpression ByConstructorName
dotGraphTermParsers :: Map Language (SomeParser DOTGraphTerm Loc)
dotGraphTermParsers = aLaCarteParsers
class DOTGraphTerm term where
dotGraphTerm :: (Has (Reader Config) sig m) => term Loc -> m Builder
instance (Recursive (term Loc), ToTreeGraph TermVertex (Base (term Loc))) => DOTGraphTerm term where
dotGraphTerm = serialize (DOT (termStyle "terms")) . renderTreeGraph
jsonTreeTermParsers :: Map Language (SomeParser JSONTreeTerm Loc)
jsonTreeTermParsers = aLaCarteParsers
class JSONTreeTerm term where
jsonTreeTerm :: Blob -> term Loc -> Rendering.JSON.JSON "trees" SomeJSON
instance ToJSON (term Loc) => JSONTreeTerm term where
jsonTreeTerm = renderJSONTerm
jsonGraphTermParsers :: Map Language (SomeParser JSONGraphTerm Loc)
jsonGraphTermParsers = aLaCarteParsers
class JSONGraphTerm term where
jsonGraphTerm :: Blob -> term Loc -> ParseTreeFileGraph
instance (Recursive (term Loc), ToTreeGraph TermVertex (Base (term Loc))) => JSONGraphTerm term where
jsonGraphTerm blob t
= let graph = renderTreeGraph t
toEdge (Edge (a, b)) = defMessage & P.source .~ a^.vertexId & P.target .~ b^.vertexId
path = T.pack $ blobFilePath blob
lang = bridging # blobLanguage blob
in defMessage
& P.path .~ path
& P.language .~ lang
& P.vertices .~ vertexList graph
& P.edges .~ fmap toEdge (edgeList graph)
& P.errors .~ mempty

83
src/Semantic/CLI.hs
View File

@ -3,23 +3,16 @@
module Semantic.CLI (main) where
import qualified Analysis.File as File
import Analysis.Project
import qualified Control.Carrier.Parse.Measured as Parse
import Control.Carrier.Reader
import Control.Exception
import Control.Monad.IO.Class
import Data.Blob.IO
import Data.Either
import qualified Data.Flag as Flag
import Data.Foldable
import Data.Handle
import qualified Data.Language as Language
import Data.List (intercalate)
import Data.Maybe.Exts
import Options.Applicative hiding (style)
import Semantic.Api hiding (File)
import Semantic.Config
import qualified Semantic.Graph as Graph
import qualified Semantic.Task as Task
import Semantic.Task.Files
import Semantic.Telemetry
@ -83,38 +76,19 @@ optionsParser = do
argumentsParser :: Parser (Parse.ParseC Task.TaskC ())
argumentsParser = do
subparser <- hsubparser (diffCommand <> parseCommand <> graphCommand)
subparser <- hsubparser parseCommand
output <- ToPath <$> pathOption (long "output" <> short 'o' <> help "Output path, defaults to stdout") <|> pure (ToHandle stdout)
pure $ subparser >>= Task.write output
diffCommand :: Mod CommandFields (Parse.ParseC Task.TaskC Builder)
diffCommand = command "diff" (info diffArgumentsParser (progDesc "Compute changes between paths"))
where
diffArgumentsParser = do
renderer <- flag (parseDiffBuilder DiffSExpression) (parseDiffBuilder DiffSExpression) (long "sexpression" <> help "Output s-expression diff tree (default)")
<|> flag' (parseDiffBuilder DiffJSONTree) (long "json" <> help "Output JSON diff trees")
<|> flag' (parseDiffBuilder DiffJSONGraph) (long "json-graph" <> help "Output JSON diff trees")
<|> flag' (parseDiffBuilder DiffDotGraph) (long "dot" <> help "Output the diff as a DOT graph")
<|> flag' (parseDiffBuilder DiffShow) (long "show" <> help "Output using the Show instance (debug only, format subject to change without notice)")
filesOrStdin <- Right <$> some ((,) <$> argument filePathReader (metavar "FILE_A") <*> argument filePathReader (metavar "FILE_B")) <|> pure (Left stdin)
pure $ Task.readBlobPairs filesOrStdin >>= runReader Language.aLaCarteLanguageModes . renderer
parseCommand :: Mod CommandFields (Parse.ParseC Task.TaskC Builder)
parseCommand = command "parse" (info parseArgumentsParser (progDesc "Generate parse trees for path(s)"))
where
parseArgumentsParser = do
languageModes <- languageModes
renderer
<- flag (parseTermBuilder TermSExpression)
(parseTermBuilder TermSExpression)
( long "sexpression"
<> help "Output s-expression parse trees (default)")
<|> flag' (parseTermBuilder TermJSONTree)
( long "json"
<> help "Output JSON parse trees")
<|> flag' (parseTermBuilder TermJSONGraph)
( long "json-graph"
<> help "Output JSON adjacency list")
<|> flag' (parseSymbolsBuilder JSON)
( long "symbols"
<> long "json-symbols"
@ -122,9 +96,6 @@ parseCommand = command "parse" (info parseArgumentsParser (progDesc "Generate pa
<|> flag' (parseSymbolsBuilder Proto)
( long "proto-symbols"
<> help "Output protobufs symbol list")
<|> flag' (parseTermBuilder TermDotGraph)
( long "dot"
<> help "Output DOT graph parse trees")
<|> flag' (parseTermBuilder TermShow)
( long "show"
<> help "Output using the Show instance (debug only, format subject to change without notice)")
@ -133,57 +104,7 @@ parseCommand = command "parse" (info parseArgumentsParser (progDesc "Generate pa
<> help "Don't produce output, but show timing stats")
filesOrStdin <- FilesFromPaths <$> some (argument filePathReader (metavar "FILES..."))
<|> pure (FilesFromHandle stdin)
pure $ Task.readBlobs filesOrStdin >>= runReader languageModes . renderer
graphCommand :: Mod CommandFields (Parse.ParseC Task.TaskC Builder)
graphCommand = command "graph" (info graphArgumentsParser (progDesc "Compute a graph for a directory or from a top-level entry point module"))
where
graphArgumentsParser = makeGraphTask
<$> graphType
<*> switch (long "packages" <> help "Include a vertex for the package, with edges from it to each module")
<*> serializer
<*> (readProjectRecursively <|> readProjectFromPaths)
graphType = flag Graph.ImportGraph Graph.ImportGraph (long "imports" <> help "Compute an import graph (default)")
<|> flag' Graph.CallGraph (long "calls" <> help "Compute a call graph")
serializer = flag (Task.serialize (DOT Graph.style)) (Task.serialize (DOT Graph.style)) (long "dot" <> help "Output in DOT graph format (default)")
<|> flag' (Task.serialize JSON) (long "json" <> help "Output JSON graph")
<|> flag' (Task.serialize Show) (long "show" <> help "Output using the Show instance (debug only, format subject to change without notice)")
readProjectFromPaths = makeReadProjectFromPathsTask
<$> ( Just <$> some (strArgument (metavar "FILES..."))
<|> flag' Nothing (long "stdin" <> help "Read a list of newline-separated paths to analyze from stdin."))
makeReadProjectFromPathsTask maybePaths = do
strPaths <- maybeM (liftIO (many getLine)) maybePaths
let paths = rights (Path.parse <$> strPaths)
blobs <- traverse readBlobFromPath paths
case paths of
(x:_) -> pure $! Project (Path.takeDirectory x) blobs (Language.forPath x) mempty
_ -> pure $! Project (Path.toAbsRel Path.rootDir) mempty Language.Unknown mempty
allLanguages = intercalate "|" . fmap show $ [Language.Go .. maxBound]
readProjectRecursively = makeReadProjectRecursivelyTask
<$> option auto (long "language" <> help "The language for the analysis." <> metavar allLanguages)
<*> optional (pathOption (long "root" <> help "Root directory of project. Optional, defaults to entry file/directory." <> metavar "DIR"))
<*> many (pathOption (long "exclude-dir" <> help "Exclude a directory (e.g. vendor)" <> metavar "DIR"))
<*> argument path (metavar "PATH")
makeReadProjectRecursivelyTask language rootDir excludeDirs dir = Task.readProject rootDir dir language excludeDirs
makeGraphTask graphType includePackages serializer projectTask = projectTask >>= Graph.runGraph graphType includePackages >>= serializer
languageModes :: Parser Language.PerLanguageModes
languageModes = Language.PerLanguageModes
<$> languageModeOption "python" "Python"
<*> languageModeOption "ruby" "Ruby"
<*> languageModeOption "go" "Go"
<*> languageModeOption "typescript" "TypeScript"
<*> languageModeOption "tsx" "TSX"
<*> languageModeOption "javascript" "JavaScript"
<*> languageModeOption "jsx" "JSX"
where
languageModeOption shortName fullName
= option auto ( long (shortName <> "-mode")
<> help ("The AST representation to use for " <> fullName <> " sources")
<> metavar "ALaCarte|Precise"
<> value Language.Precise
<> showDefault)
pure $ Task.readBlobs filesOrStdin >>= renderer
filePathReader :: ReadM (File.File Language.Language)
filePathReader = File.fromPath <$> path

10
src/Serializing/SExpression.hs
View File

@ -11,8 +11,6 @@ module Serializing.SExpression
import Analysis.ConstructorName
import Data.ByteString.Builder
import Data.Diff
import Data.Edit
import Data.Functor.Foldable
import Data.Term
@ -41,11 +39,3 @@ class ToSExpression base where
instance (ConstructorName syntax, Foldable syntax, Show ann) => ToSExpression (TermF syntax ann) where
toSExpression options term n = nl n <> pad n <> namedBranch options term n
instance (ConstructorName syntax, Foldable syntax, Show ann1, Show ann2) => ToSExpression (DiffF syntax ann1 ann2) where
toSExpression options diff n = case diff of
Patch (Delete term) -> nl n <> pad (n - 1) <> "{-" <> namedBranch options term n <> "-}"
Patch (Insert term) -> nl n <> pad (n - 1) <> "{+" <> namedBranch options term n <> "+}"
Patch (Compare term1 term2) -> nl n <> pad (n - 1) <> "{ " <> namedBranch options term1 n
<> nl (n + 1) <> pad (n - 1) <> "->" <> namedBranch options term2 n <> " }"
Merge term -> nl n <> pad n <> namedBranch options term n

12
test/Data/Diff/Spec.hs
View File

@ -1,12 +0,0 @@
{-# LANGUAGE DataKinds #-}
module Data.Diff.Spec (spec) where
import Data.Diff
import Data.Functor.Listable (ListableSyntax)
import Test.Hspec
import Test.Hspec.LeanCheck
spec :: Spec
spec = do
prop "equality is reflexive" $
\ diff -> diff `shouldBe` (diff :: Diff ListableSyntax () ())

24
test/Data/Functor/Listable.hs
View File

@ -19,7 +19,6 @@ module Data.Functor.Listable
import qualified Analysis.Name as Name
import Data.Abstract.ScopeGraph (AccessControl(..))
import Data.Bifunctor.Join
import Data.Diff
import Data.Edit
import qualified Data.Language as Language
import Data.List.NonEmpty
@ -56,13 +55,6 @@ tiers2 :: (Listable a, Listable b, Listable2 l) => [Tier (l a b)]
tiers2 = liftTiers2 tiers tiers
class Listable3 l where
liftTiers3 :: [Tier a] -> [Tier b] -> [Tier c] -> [Tier (l a b c)]
tiers3 :: (Listable3 l, Listable a, Listable b, Listable c) => [Tier (l a b c)]
tiers3 = liftTiers3 tiers tiers tiers
-- | Lifts a unary constructor to a list of tiers, given a list of tiers for its argument.
--
-- Commonly used in the definition of 'Listable1' and 'Listable2' instances.
@ -136,25 +128,9 @@ instance Listable1 f => Listable1 (Term f) where
instance (Listable1 f, Listable a) => Listable (Term f a) where
tiers = tiers1
instance (Listable1 syntax) => Listable3 (DiffF syntax) where
liftTiers3 ann1Tiers ann2Tiers recurTiers
= liftCons1 (liftTiers2 (liftTiers2 ann1Tiers recurTiers) (liftTiers2 ann2Tiers recurTiers)) Patch
\/ liftCons1 (liftTiers2 (liftTiers2 ann1Tiers ann2Tiers) recurTiers) Merge
instance (Listable1 syntax, Listable ann1, Listable ann2, Listable recur) => Listable (DiffF syntax ann1 ann2 recur) where
tiers = tiers3
instance Listable AccessControl where
tiers = cons0 Public \/ cons0 Protected \/ cons0 Private
instance Listable1 f => Listable2 (Diff f) where
liftTiers2 annTiers1 annTiers2 = go where go = liftCons1 (liftTiers3 annTiers1 annTiers2 go) Diff
instance (Listable1 syntax, Listable ann1, Listable ann2) => Listable (Diff syntax ann1 ann2) where
tiers = tiers2
instance Listable2 Edit where
liftTiers2 t1 t2 = liftCons1 t2 Insert \/ liftCons1 t1 Delete \/ liftCons2 t1 t2 Compare

46
test/Diffing/Algorithm/RWS/Spec.hs
View File

@ -1,46 +0,0 @@
{-# LANGUAGE DataKinds, OverloadedStrings, TypeOperators #-}
module Diffing.Algorithm.RWS.Spec (spec) where
import Data.Bifunctor
import Data.Diff
import Data.Sum
import qualified Data.Syntax as Syntax
import Data.Term
import Diffing.Algorithm (comparableTerms)
import Diffing.Interpreter (stripDiff)
import Diffing.Algorithm.RWS
import Diffing.Interpreter.Spec (afterTerm, beforeTerm)
import Test.Hspec.LeanCheck
import SpecHelpers
spec :: Spec
spec = do
let positively = succ . abs
describe "pqGramDecorator" $ do
prop "produces grams with stems of the specified length" $
\ (term, p, q) -> pqGramDecorator (positively p) (positively q) (term :: Term ListableSyntax ()) `shouldSatisfy` all ((== positively p) . length . stem . fst)
prop "produces grams with bases of the specified width" $
\ (term, p, q) -> pqGramDecorator (positively p) (positively q) (term :: Term ListableSyntax ()) `shouldSatisfy` all ((== positively q) . length . base . fst)
describe "rws" $ do
prop "produces correct diffs" $
\ (as, bs) -> let tas = decorate <$> (as :: [Term ListableSyntax ()])
tbs = decorate <$> (bs :: [Term ListableSyntax ()])
wrap = termIn emptyAnnotation . inject
diff = merge (emptyAnnotation, emptyAnnotation) (inject (stripDiff . diffEdit <$> rws comparableTerms (equalTerms comparableTerms) tas tbs)) in
(beforeTerm diff, afterTerm diff) `shouldBe` (Just (wrap (stripTerm <$> tas)), Just (wrap (stripTerm <$> tbs)))
it "produces unbiased insertions within branches" $
let (a, b) = (decorate (termIn emptyAnnotation (inject [ termIn emptyAnnotation (inject (Syntax.Identifier "a")) ])), decorate (termIn emptyAnnotation (inject [ termIn emptyAnnotation (inject (Syntax.Identifier "b")) ]))) in
fmap (bimap stripTerm stripTerm) (rws comparableTerms (equalTerms comparableTerms) [ b ] [ a, b ]) `shouldBe` fmap (bimap stripTerm stripTerm) [ Insert a, Compare b b ]
where decorate = defaultFeatureVectorDecorator
diffEdit = edit deleting inserting comparing
stripTerm :: Functor f => Term f (FeatureVector, ()) -> Term f ()
stripTerm = fmap snd
emptyAnnotation :: ()
emptyAnnotation = ()

24
test/Diffing/Algorithm/SES/Spec.hs
View File

@ -1,24 +0,0 @@
module Diffing.Algorithm.SES.Spec (spec) where
import Data.Edit
import Diffing.Algorithm.SES
import Test.Hspec
import Test.Hspec.LeanCheck
spec :: Spec
spec = do
describe "ses" $ do
prop "returns equal lists in Compare" $
\ as -> (ses (==) as as :: [Edit Char Char]) `shouldBe` zipWith Compare as as
prop "returns deletions in Delete" $
\ as -> (ses (==) as [] :: [Edit Char Char]) `shouldBe` fmap Delete as
prop "returns insertions in Insert" $
\ bs -> (ses (==) [] bs :: [Edit Char Char]) `shouldBe` fmap Insert bs
prop "returns all elements individually for disjoint inputs" $
\ as bs -> length (ses (==) ((,) 0 <$> as :: [(Int, Char)]) ((,) 1 <$> bs :: [(Int, Char)])) `shouldBe` length as + length bs
prop "is lossless w.r.t. both input elements & ordering" $
\ as bs -> foldr (\ each (as, bs) -> edit (flip (,) bs. (:as)) ((,) as . (:bs)) (\ a b -> (a:as, b:bs)) each) ([], []) (ses (==) as bs :: [Edit Char Char]) `shouldBe` (as, bs)

91
test/Diffing/Interpreter/Spec.hs
View File

@ -1,91 +0,0 @@
{-# LANGUAGE DataKinds, OverloadedStrings, TypeApplications #-}
module Diffing.Interpreter.Spec (spec, afterTerm, beforeTerm) where
import Control.Applicative ((<|>))
import Data.Diff
import Data.Foldable (asum)
import Data.Functor.Foldable (cata)
import Data.Functor.Listable
import Data.Maybe
import Data.Mergeable
import Data.Sum
import Data.Term
import Diffing.Interpreter
import qualified Data.Syntax as Syntax
import Test.Hspec (Spec, describe, it)
import Test.Hspec.Expectations
import Test.Hspec.LeanCheck
import Test.LeanCheck.Core
import SpecHelpers (Edit(..), edit)
spec :: Spec
spec = do
describe "diffTerms" $ do
it "returns a replacement when comparing two unicode equivalent terms" $
let termA = termIn emptyAnnotation (inject (Syntax.Identifier "t\776"))
termB = termIn emptyAnnotation (inject (Syntax.Identifier "\7831")) in
diffTerms termA termB `shouldBe` comparing termA (termB :: Term ListableSyntax ())
prop "produces correct diffs" $
\ a b -> let diff = diffTerms a b :: Diff ListableSyntax () () in
(beforeTerm diff, afterTerm diff) `shouldBe` (Just a, Just b)
prop "produces identity diffs for equal terms " $
\ a -> let diff = diffTerms a a :: Diff ListableSyntax () () in
length (diffPatches diff) `shouldBe` 0
it "produces unbiased insertions within branches" $
let term s = termIn emptyAnnotation (inject [ termIn emptyAnnotation (inject (Syntax.Identifier s)) ]) :: Term ListableSyntax ()
wrap = termIn emptyAnnotation . inject in
diffTerms (wrap [ term "b" ]) (wrap [ term "a", term "b" ]) `shouldBe` merge (emptyAnnotation, emptyAnnotation) (inject [ inserting (term "a"), merging (term "b") ])
let noContext :: Term ListableSyntax a -> Bool
noContext = isNothing . project @Syntax.Context . termOut
prop "compares nodes against context" . forAll (filterT (noContext . fst) tiers) $
\ (a, b) -> diffTerms a (termIn emptyAnnotation (inject (Syntax.Context (pure b) a))) `shouldBe` insertF (In emptyAnnotation (inject (Syntax.Context (pure (inserting b)) (merging (a :: Term ListableSyntax ())))))
prop "diffs forward permutations as changes" $
\ a -> let wrap = termIn emptyAnnotation . inject
b = wrap [a]
c = wrap [a, b] in
diffTerms (wrap [a, b, c]) (wrap [c, a, b :: Term ListableSyntax ()]) `shouldBe` merge (emptyAnnotation, emptyAnnotation) (inject [ inserting c, merging a, merging b, deleting c ])
prop "diffs backward permutations as changes" $
\ a -> let wrap = termIn emptyAnnotation . inject
b = wrap [a]
c = wrap [a, b] in
diffTerms (wrap [a, b, c]) (wrap [b, c, a :: Term ListableSyntax ()]) `shouldBe` merge (emptyAnnotation, emptyAnnotation) (inject [ deleting a, merging b, merging c, inserting a ])
describe "diffTermPair" $ do
prop "produces an Insert when the first term is missing" $ do
\ after -> let diff = diffTermPair (Insert after) :: Diff ListableSyntax () () in
diff `shouldBe` inserting after
prop "produces a Delete when the second term is missing" $ do
\ before -> let diff = diffTermPair (Delete before) :: Diff ListableSyntax () () in
diff `shouldBe` deleting before
-- | Recover the before state of a diff.
beforeTerm :: (Foldable syntax, Mergeable syntax) => Diff syntax ann1 ann2 -> Maybe (Term syntax ann1)
beforeTerm = cata $ \ diff -> case diff of
Patch patch -> (before patch >>= \ (In a l) -> termIn a <$> sequenceAlt l) <|> (after patch >>= asum)
Merge (In (a, _) l) -> termIn a <$> sequenceAlt l
-- | Recover the after state of a diff.
afterTerm :: (Foldable syntax, Mergeable syntax) => Diff syntax ann1 ann2 -> Maybe (Term syntax ann2)
afterTerm = cata $ \ diff -> case diff of
Patch patch -> (after patch >>= \ (In b r) -> termIn b <$> sequenceAlt r) <|> (before patch >>= asum)
Merge (In (_, b) r) -> termIn b <$> sequenceAlt r
-- | Return the item from the after side of the patch.
after :: Edit l r -> Maybe r
after = edit (const Nothing) Just (\ _ b -> Just b)
-- | Return the item from the before side of the patch.
before :: Edit l r -> Maybe l
before = edit Just (const Nothing) (\ a _ -> Just a)
emptyAnnotation :: ()
emptyAnnotation = ()

95
test/Examples.hs
View File

@ -18,7 +18,7 @@ import Control.Monad
import Data.Blob
import Data.Foldable
import Data.Int
import Data.Language (LanguageMode (..), PerLanguageModes (..), aLaCarteLanguageModes, preciseLanguageModes)
import Data.Language (LanguageMode (..), PerLanguageModes (..), preciseLanguageModes)
import Data.List
import qualified Data.Text as Text
import Data.Traversable
@ -162,21 +162,9 @@ buildExamples session lang tsDir = do
files <- globDir1 (compile (languageExtension lang)) (Path.toString tsDir)
let paths = filter (\x -> Path.takeDirectory x `notElem` dirSkips) . filter (`notElem` fileSkips) $ Path.relFile <$> files
trees <- for paths $ \file -> do
pure . HUnit.testCaseSteps (Path.toString file) $ \step -> do
-- Use alacarte language mode
step "a la carte"
alacarte <- runTask session (runParse (parseSymbolsFilePath aLaCarteLanguageModes file))
assertOK "a la carte" alacarte
-- Test out precise language mode
step "precise"
pure . HUnit.testCase (Path.toString file) $ do
precise <- runTask session (runParse (parseSymbolsFilePath preciseLanguageModes file))
assertOK "precise" precise
-- Compare the two
step "compare"
assertMatch alacarte precise
pure (Tasty.testGroup (languageName lang) trees)
where
@ -185,88 +173,10 @@ buildExamples session lang tsDir = do
[x] | (e:_) <- toList (x^.errors) -> HUnit.assertFailure (msg <> " parse errors " <> show e)
_ -> pure ()
assertMatch a b = case (a, b) of
(Right a, Right b) -> case (toList (a^.files), toList (b^.files)) of
([x], [y]) | e1:_ <- toList (x^.errors)
, e2:_ <- toList (y^.errors)
-> HUnit.assertFailure ("Parse errors (both) " <> show e1 <> show e2)
(_, [y]) | e:_ <- toList (y^.errors)
-> HUnit.assertFailure ("Parse errors (precise) " <> show e)
([x], _) | e:_ <- toList (x^.errors)
-> HUnit.assertFailure ("Parse errors (a la carte) " <> show e)
([x], [y]) -> do
-- Check paths
HUnit.assertEqual "Expected paths to be equal" (x^.path) (y^.path)
-- Check symbols
let aLaCarteSymbols = sort . filterALaCarteSymbols (languageName lang) $ toListOf (symbols . traverse . symbol) x
preciseSymbols = sort . filterALaCarteSymbols (languageName lang) $ toListOf (symbols . traverse . symbol) y
delta = aLaCarteSymbols \\ preciseSymbols
invDelta = preciseSymbols \\ aLaCarteSymbols
msg = "Found in a la carte, but not precise: "
<> show delta
<> "\n"
<> "Found in precise but not a la carte: "
<> show invDelta
<> "\n"
<> "Expected: " <> show aLaCarteSymbols <> "\n"
<> "But got:" <> show preciseSymbols
HUnit.assertBool ("Expected symbols to be equal.\n" <> msg) (null delta)
HUnit.assertBool ("Expected symbols to be equal.\n" <> msg) (null invDelta)
-- Check details
let aLaCarteSymbols = sortOn sSym . filter (okALaCarteSymbol (languageName lang) . view symbol) $ toList (x^.symbols)
preciseSymbols = sortOn sSym . filter (okALaCarteSymbol (languageName lang) . view symbol) $ toList (y^.symbols)
for_ (zip aLaCarteSymbols preciseSymbols) $ \ (left, right) -> do
let lineNo = ":" <> show (left^.P.span^.start^.line)
-- lSpan = " [" <> show (startRow left) <> ", " <> show (left^.P.span^.start^.column) <> "]"
-- rSpan = " [" <> show (startRow right) <> ", " <> show (right^.P.span^.start^.column) <> "]"
HUnit.assertEqual (Text.unpack (x^.path) <> lineNo) (left^.symbol) (right^.symbol)
HUnit.assertEqual (Text.unpack (x^.path) <> lineNo) (Text.unpack (left^.symbol) <> span left) (Text.unpack (right^.symbol) <> span right)
-- HUnit.assertEqual (Text.unpack (x^.path) <> lineNo) (left^.line) (right^.line)
-- HUnit.assertBool (Text.unpack (x^.path) <> lineNo) (Text.isPrefixOf (left^.line) (right^.line))
-- if left^.kind == "Method"
-- then HUnit.assertEqual (Text.unpack (x^.path) <> lineNo) (left^.line) (right^.line)
-- -- -- then HUnit.assertBool (Text.unpack (x^.path) <> lineNo) (Text.isPrefixOf (left^.line) (right^.line))
-- else pure ()
_ -> HUnit.assertFailure "Expected 1 file in each response"
(Left e1, Left e2) -> HUnit.assertFailure ("Unable to parse (both)" <> show (displayException e1) <> show (displayException e2))
(_, Left e) -> HUnit.assertFailure ("Unable to parse (precise)" <> show (displayException e))
(Left e, _) -> HUnit.assertFailure ("Unable to parse (a la carte)" <> show (displayException e))
sSym x = SortableSymbol (x^.symbol) (x^.P.span^.start^.line) (x^.P.span^.start^.column) (x^.P.span^.end^.line) (x^.P.span^.end^.column)
span x = " [" <> show (x^.P.span^.start^.line) <> ", " <> show (x^.P.span^.start^.column) <>
" - " <> show (x^.P.span^.end^.line) <> ", " <> show (x^.P.span^.end^.column) <> "]"
data SortableSymbol = SortableSymbol Text.Text Int32 Int32 Int32 Int32
deriving (Eq, Show, Ord)
okALaCarteSymbol :: String -> Text.Text -> Bool
okALaCarteSymbol "typescript" symbol = symbol `notElem` blacklist
where
blacklist = ["require"]
okALaCarteSymbol "ruby" symbol = not (instanceVariable symbol || builtInMethod symbol)
where
instanceVariable = Text.isPrefixOf "@"
builtInMethod x = x `elem` blacklist
blacklist =
[ "alias"
, "load"
, "require_relative"
, "require"
, "super"
, "undef"
, "defined?"
, "lambda"
]
okALaCarteSymbol _ _ = True
filterALaCarteSymbols :: String -> [Text.Text] -> [Text.Text]
filterALaCarteSymbols lang = filter (okALaCarteSymbol lang)
testOptions :: Config.Options
testOptions = defaultOptions
{ optionsFailOnWarning = flag FailOnWarning True
@ -274,6 +184,7 @@ testOptions = defaultOptions
}
main :: IO ()
-- main = putStrLn "nothing"
main = withOptions testOptions $ \ config logger statter -> do
void $ Process.system "script/clone-example-repos"

19
test/Integration/Spec.hs
View File

@ -28,19 +28,11 @@ testsForLanguage language = do
localOption (mkTimeout 3000000) $ testGroup (Path.toString language) $ fmap testForExample items
{-# NOINLINE testsForLanguage #-}
data Example = DiffExample Path.RelFile Path.RelFile Path.RelFile
| ParseExample Path.RelFile Path.RelFile
data Example = ParseExample Path.RelFile Path.RelFile
deriving (Eq, Show)
testForExample :: (?session :: TaskSession) => Example -> TestTree
testForExample = \case
DiffExample fileA fileB diffOutput ->
goldenVsStringDiff
("diffs " <> Path.toString diffOutput)
(\ref new -> ["git", "diff", ref, new])
(Path.toString diffOutput)
(BL.fromStrict <$> diffFilePaths ?session fileA fileB)
ParseExample file parseOutput ->
testForExample (ParseExample file parseOutput) =
goldenVsStringDiff
("parses " <> Path.toString parseOutput)
(\ref new -> ["git", "diff", ref, new])
@ -65,17 +57,12 @@ examples directory = do
bs <- globFor "*.B.*"
sExpAs <- globFor "*.parseA.txt"
sExpBs <- globFor "*.parseB.txt"
sExpDiffsAB <- globFor "*.diffA-B.txt"
sExpDiffsBA <- globFor "*.diffB-A.txt"
let exampleDiff lefts rights out name = DiffExample (lookupNormalized name lefts) (lookupNormalized name rights) out
let exampleParse files out name = ParseExample (lookupNormalized name files) out
let keys = (normalizeName <$> as) `union` (normalizeName <$> bs)
pure $ merge [ getExamples (exampleParse as) sExpAs keys
, getExamples (exampleParse bs) sExpBs keys
, getExamples (exampleDiff as bs) sExpDiffsAB keys
, getExamples (exampleDiff bs as) sExpDiffsBA keys ]
, getExamples (exampleParse bs) sExpBs keys ]
where
merge = concat . transpose
-- Only returns examples if they exist

23
test/Semantic/CLI/Spec.hs
View File

@ -19,8 +19,7 @@ import Test.Tasty.Golden
testTree :: TestTree
testTree = testGroup "Semantic.CLI"
[ testGroup "parseDiffBuilder" $ fmap testForDiffFixture diffFixtures
, testGroup "parseTermBuilder" $ fmap testForParseFixture parseFixtures
[ testGroup "parseTermBuilder" $ fmap testForParseFixture parseFixtures
]
-- We provide this function to the golden tests so as to have better
@ -36,14 +35,6 @@ renderDiff ref new = unsafePerformIO $ do
else ["git", "diff", ref, new]
{-# NOINLINE renderDiff #-}
testForDiffFixture :: (String, [BlobPair] -> ParseC TaskC Builder, [(File Language, File Language)], Path.RelFile) -> TestTree
testForDiffFixture (diffRenderer, runDiff, files, expected) =
goldenVsStringDiff
("diff fixture renders to " <> diffRenderer <> " " <> show files)
renderDiff
(Path.toString expected)
(fmap toLazyByteString . runTaskOrDie $ readBlobPairs (Right files) >>= runDiff)
testForParseFixture :: (String, [Blob] -> ParseC TaskC Builder, [File Language], Path.RelFile) -> TestTree
testForParseFixture (format, runParse, files, expected) =
goldenVsStringDiff
@ -55,22 +46,10 @@ testForParseFixture (format, runParse, files, expected) =
parseFixtures :: [(String, [Blob] -> ParseC TaskC Builder, [File Language], Path.RelFile)]
parseFixtures =
[ ("s-expression", run . parseTermBuilder TermSExpression, path, Path.relFile "test/fixtures/ruby/corpus/and-or.parseA.txt")
, ("json", run . parseTermBuilder TermJSONTree, path, prefix </> Path.file "parse-tree.json")
, ("json", run . parseTermBuilder TermJSONTree, path', prefix </> Path.file "parse-trees.json")
, ("json", run . parseTermBuilder TermJSONTree, [], prefix </> Path.file "parse-tree-empty.json")
, ("symbols", run . parseSymbolsBuilder Serializing.Format.JSON, path'', prefix </> Path.file "parse-tree.symbols.json")
, ("protobuf symbols", run . parseSymbolsBuilder Serializing.Format.Proto, path'', prefix </> Path.file "parse-tree.symbols.protobuf.bin")
]
where path = [File (Path.absRel "test/fixtures/ruby/corpus/and-or.A.rb") lowerBound Ruby]
path' = [File (Path.absRel "test/fixtures/ruby/corpus/and-or.A.rb") lowerBound Ruby, File (Path.absRel"test/fixtures/ruby/corpus/and-or.B.rb") lowerBound Ruby]
path'' = [File (Path.absRel "test/fixtures/ruby/corpus/method-declaration.A.rb") lowerBound Ruby]
prefix = Path.relDir "test/fixtures/cli"
run = runReader defaultLanguageModes
diffFixtures :: [(String, [BlobPair] -> ParseC TaskC Builder, [(File Language, File Language)], Path.RelFile)]
diffFixtures =
[ ("json diff", parseDiffBuilder DiffJSONTree, pathMode, prefix </> Path.file "diff-tree.json")
, ("s-expression diff", parseDiffBuilder DiffSExpression, pathMode, Path.relFile "test/fixtures/ruby/corpus/method-declaration.diffA-B.txt")
]
where pathMode = [(File (Path.absRel "test/fixtures/ruby/corpus/method-declaration.A.rb") lowerBound Ruby, File (Path.absRel "test/fixtures/ruby/corpus/method-declaration.B.rb") lowerBound Ruby)]
prefix = Path.relDir "test/fixtures/cli"

4
test/Semantic/Spec.hs
View File

@ -19,10 +19,6 @@ spec = do
describe "parseBlob" $ do
let methodsBlob = Blob.fromSource (Path.relFile "methods.rb") Ruby "def foo\nend\n"
it "returns error if given an unknown language (json)" $ do
output <- fmap runBuilder . runTaskOrDie . runReader defaultLanguageModes $ parseTermBuilder TermJSONTree [ setBlobLanguage Unknown methodsBlob ]
output `shouldBe` "{\"trees\":[{\"path\":\"methods.rb\",\"error\":\"NoLanguageForBlob (currentDir </> relPath \\\"methods.rb\\\")\",\"language\":\"Unknown\"}]}\n"
it "throws if given an unknown language for sexpression output" $ do
res <- runTaskWithOptions defaultOptions (runReader defaultLanguageModes (runParseWithConfig (parseTermBuilder TermSExpression [setBlobLanguage Unknown methodsBlob])))
case res of

8
test/Spec.hs
View File

@ -9,7 +9,6 @@ import qualified Analysis.Ruby.Spec
import qualified Analysis.TypeScript.Spec
import qualified Assigning.Assignment.Spec
import qualified Control.Abstract.Evaluator.Spec
import qualified Data.Diff.Spec
import qualified Data.Abstract.Name.Spec
import qualified Data.Abstract.Path.Spec
import qualified Data.Functor.Classes.Generic.Spec
@ -18,9 +17,6 @@ import qualified Data.Language.Spec
import qualified Data.Scientific.Spec
import qualified Data.Semigroup.App.Spec
import qualified Data.Term.Spec
import qualified Diffing.Algorithm.RWS.Spec
import qualified Diffing.Algorithm.SES.Spec
import qualified Diffing.Interpreter.Spec
import qualified Graphing.Calls.Spec
import qualified Integration.Spec
import qualified Numeric.Spec
@ -70,15 +66,11 @@ legacySpecs = parallel $ do
describe "Analysis.TypeScript" Analysis.TypeScript.Spec.spec
describe "Assigning.Assignment" Assigning.Assignment.Spec.spec
describe "Control.Abstract.Evaluator" Control.Abstract.Evaluator.Spec.spec
describe "Data.Diff" Data.Diff.Spec.spec
describe "Data.Graph" Data.Graph.Spec.spec
describe "Data.Abstract.Path" Data.Abstract.Path.Spec.spec
describe "Data.Abstract.Name" Data.Abstract.Name.Spec.spec
describe "Data.Functor.Classes.Generic" Data.Functor.Classes.Generic.Spec.spec
describe "Data.Term" Data.Term.Spec.spec
describe "Diffing.Algorithm.RWS" Diffing.Algorithm.RWS.Spec.spec
describe "Diffing.Algorithm.SES" Diffing.Algorithm.SES.Spec.spec
describe "Diffing.Interpreter" Diffing.Interpreter.Spec.spec
describe "Graphing.Calls" Graphing.Calls.Spec.spec
describe "Tags.Spec" Tags.Spec.spec
describe "Semantic" Semantic.Spec.spec

8
test/SpecHelpers.hs
View File

@ -5,7 +5,6 @@
module SpecHelpers
( module X
, runBuilder
, diffFilePaths
, parseFilePath
, readFilePathPair
, runTaskOrDie
@ -91,13 +90,6 @@ instance Lower X.Span where
runBuilder :: Builder -> ByteString
runBuilder = toStrict . toLazyByteString
-- | Returns an s-expression formatted diff for the specified FilePath pair.
diffFilePaths :: TaskSession -> Path.RelFile -> Path.RelFile -> IO ByteString
diffFilePaths session p1 p2 = do
blobs <- readFilePathPair p1 p2
builder <- runTask session (runParse (configTreeSitterParseTimeout (config session)) (parseDiffBuilder DiffSExpression [ blobs ]))
either (die . displayException) (pure . runBuilder) builder
-- | Returns an s-expression parse tree for the specified path.
parseFilePath :: TaskSession -> Path.RelFile -> IO (Either SomeException ByteString)
parseFilePath session path = do

1
test/fixtures/cli/parse-tree-empty.json vendored
View File

@ -1 +0,0 @@
{"trees":[]}

1
test/fixtures/cli/parse-tree.json vendored
View File

@ -1 +0,0 @@
{"trees":[{"tree":{"term":"Statements","statements":[{"term":"LowPrecedenceAnd","lhs":{"term":"Send","sendArgs":[],"sendBlock":null,"sendReceiver":null,"sendSelector":{"term":"Identifier","name":"foo","sourceRange":[0,3],"sourceSpan":{"start":[1,1],"end":[1,4]}},"sourceRange":[0,3],"sourceSpan":{"start":[1,1],"end":[1,4]}},"rhs":{"term":"Send","sendArgs":[],"sendBlock":null,"sendReceiver":null,"sendSelector":{"term":"Identifier","name":"bar","sourceRange":[8,11],"sourceSpan":{"start":[1,9],"end":[1,12]}},"sourceRange":[8,11],"sourceSpan":{"start":[1,9],"end":[1,12]}},"sourceRange":[0,11],"sourceSpan":{"start":[1,1],"end":[1,12]}}],"sourceRange":[0,12],"sourceSpan":{"start":[1,1],"end":[2,1]}},"path":"test/fixtures/ruby/corpus/and-or.A.rb","language":"Ruby"}]}

1
test/fixtures/cli/parse-trees.json vendored
View File

@ -1 +0,0 @@
{"trees":[{"tree":{"term":"Statements","statements":[{"term":"LowPrecedenceAnd","lhs":{"term":"Send","sendArgs":[],"sendBlock":null,"sendReceiver":null,"sendSelector":{"term":"Identifier","name":"foo","sourceRange":[0,3],"sourceSpan":{"start":[1,1],"end":[1,4]}},"sourceRange":[0,3],"sourceSpan":{"start":[1,1],"end":[1,4]}},"rhs":{"term":"Send","sendArgs":[],"sendBlock":null,"sendReceiver":null,"sendSelector":{"term":"Identifier","name":"bar","sourceRange":[8,11],"sourceSpan":{"start":[1,9],"end":[1,12]}},"sourceRange":[8,11],"sourceSpan":{"start":[1,9],"end":[1,12]}},"sourceRange":[0,11],"sourceSpan":{"start":[1,1],"end":[1,12]}}],"sourceRange":[0,12],"sourceSpan":{"start":[1,1],"end":[2,1]}},"path":"test/fixtures/ruby/corpus/and-or.A.rb","language":"Ruby"},{"tree":{"term":"Statements","statements":[{"term":"LowPrecedenceOr","lhs":{"term":"Send","sendArgs":[],"sendBlock":null,"sendReceiver":null,"sendSelector":{"term":"Identifier","name":"foo","sourceRange":[0,3],"sourceSpan":{"start":[1,1],"end":[1,4]}},"sourceRange":[0,3],"sourceSpan":{"start":[1,1],"end":[1,4]}},"rhs":{"term":"Send","sendArgs":[],"sendBlock":null,"sendReceiver":null,"sendSelector":{"term":"Identifier","name":"bar","sourceRange":[7,10],"sourceSpan":{"start":[1,8],"end":[1,11]}},"sourceRange":[7,10],"sourceSpan":{"start":[1,8],"end":[1,11]}},"sourceRange":[0,10],"sourceSpan":{"start":[1,1],"end":[1,11]}},{"term":"LowPrecedenceAnd","lhs":{"term":"LowPrecedenceOr","lhs":{"term":"Send","sendArgs":[],"sendBlock":null,"sendReceiver":null,"sendSelector":{"term":"Identifier","name":"a","sourceRange":[11,12],"sourceSpan":{"start":[2,1],"end":[2,2]}},"sourceRange":[11,12],"sourceSpan":{"start":[2,1],"end":[2,2]}},"rhs":{"term":"Send","sendArgs":[],"sendBlock":null,"sendReceiver":null,"sendSelector":{"term":"Identifier","name":"b","sourceRange":[16,17],"sourceSpan":{"start":[2,6],"end":[2,7]}},"sourceRange":[16,17],"sourceSpan":{"start":[2,6],"end":[2,7]}},"sourceRange":[11,17],"sourceSpan":{"start":[2,1],"end":[2,7]}},"rhs":{"term":"Send","sendArgs":[],"sendBlock":null,"sendReceiver":null,"sendSelector":{"term":"Identifier","name":"c","sourceRange":[22,23],"sourceSpan":{"start":[2,12],"end":[2,13]}},"sourceRange":[22,23],"sourceSpan":{"start":[2,12],"end":[2,13]}},"sourceRange":[11,23],"sourceSpan":{"start":[2,1],"end":[2,13]}}],"sourceRange":[0,24],"sourceSpan":{"start":[1,1],"end":[3,1]}},"path":"test/fixtures/ruby/corpus/and-or.B.rb","language":"Ruby"}]}