balsoft/ligo
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

[WIP] Conversion to descent-based parser

Browse Source
This commit is contained in:
Kirill Andreev 2020-07-20 01:04:01 +04:00
parent 3233270dba
commit b5e5bc25a1
No known key found for this signature in database
GPG Key ID: CF7DA79DE4785A47
35 changed files with 1395 additions and 2589 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
src/test/contracts/annotation.ligo
View File

@ -1,6 +1,6 @@
(* Test that a string is cast to an address given a type annotation *) (* Test that a string is cast to an address given a type annotation *)
const lst : list (int) = list [] const lst : list (int) = list [1;2;3]
const my_address : address = const my_address : address =
("tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx" : address) ("tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx" : address)

2
src/test/contracts/arithmetic.ligo
View File

@ -1,3 +1,5 @@
// this is a
// function!!1
function mod_op (const n : int) : nat is n mod 42 function mod_op (const n : int) : nat is n mod 42
function plus_op (const n : int) : int is n + 42 function plus_op (const n : int) : int is n + 42
function minus_op (const n : int) : int is n - 42 function minus_op (const n : int) : int is n - 42

11
src/test/contracts/coase.ligo
View File

@ -123,7 +123,16 @@ function buy_single (const action : action_buy_single;
function main (const action : parameter; const s : storage) : return is function main (const action : parameter; const s : storage) : return is
case action of case action of
Buy_single (bs) -> buy_single (bs, s)
| Sell_single (as) -> sell_single (as, s) | Sell_single (as) -> sell_single (as, s)
| Transfer_single (at) -> transfer_single (at, s) | Transfer_single (at) -> transfer_single (at, s)
| None -> (failwith (""))
| Some (x) -> skip
| Buy_single (bs) -> buy_single (bs, s)
| Ex -> Ex(Ex)
end end
type parameter is
Buy_single of action_buy_single
| Sell_single of action_sell_single
| Transfer_single of action_transfer_single

2
src/test/contracts/deep_access.ligo
View File

@ -30,3 +30,5 @@ function nested_record (var nee : nested_record_t) : string is
Some (s) -> s Some (s) -> s
| None -> (failwith ("Should not happen.") : string) | None -> (failwith ("Should not happen.") : string)
end end
const tuple : int * (int * (int * int)) = (0,(1,(2,3)))

5
src/test/contracts/double_michelson_or.ligo
View File

@ -1,5 +1,3 @@
type storage is michelson_or (int,"foo",string,"bar")
type foobar is michelson_or (int,"baz",int,"fooo")
type return is list (operation) * storage type return is list (operation) * storage
@ -9,3 +7,6 @@ block {
const bar : foobar = (M_right (1) : foobar) const bar : foobar = (M_right (1) : foobar)
} with } with
((nil : list (operation)), (foo : storage)) ((nil : list (operation)), (foo : storage))
type storage is michelson_or (int,"foo",string,"bar")
type foobar is michelson_pair (int,"baz",int,"fooo")

2
src/test/contracts/entrypoints.ligo
View File

@ -16,3 +16,5 @@ function cbo (const a : address; const s : storage) : return is
| None -> (failwith ("cbo: Entrypoint not found.") : contract (unit)) | None -> (failwith ("cbo: Entrypoint not found.") : contract (unit))
end end
} with (list [Tezos.transaction (unit, 0tez, c)], s) } with (list [Tezos.transaction (unit, 0tez, c)], s)
const x : option (int) = 1

4
src/test/contracts/failwith.ligo
View File

@ -39,5 +39,7 @@ function foobar (const i : int) : int is
end end
function failer (const p : int) : int is block { function failer (const p : int) : int is block {
if p = 1 then failwith (42) else skip if p = 1 then failwith (42) else {
skip
}
} with p } with p

3
src/test/contracts/heap.ligo
View File

@ -99,5 +99,6 @@ function pop (const h : heap) : heap * heap_elt * nat is
h[left] := tmp h[left] := tmp
} else skip } else skip
} else skip } else skip
} };
while False block { skip; }
} with (h, result, c) } with (h, result, c)

2
src/test/contracts/list.ligo
View File

@ -31,3 +31,5 @@ function map_op (const s : list (int)) : list (int) is
block { block {
function increment (const i : int) : int is i+1 function increment (const i : int) : int is i+1
} with List.map (increment, s) } with List.map (increment, s)
const fb2 : foobar = 144 # fb

12
src/test/contracts/loop.ligo
View File

@ -195,3 +195,15 @@ function inner_capture_in_conditional_block (var nee : unit) : bool * int is
count := count + 1 count := count + 1
} }
} with (ret, count) } with (ret, count)
const m : unit = set [1; 2; 3]
const m : unit = map [1 -> 1; 2 -> 2; 3 -> 3]
function for_sum_step (var n : nat) : int is
block {
var acc : int := 0;
for i := 1 to int (2n*n) step 2 block {
acc := acc + i
}
} with acc

2
src/test/contracts/loop_bugs.ligo
View File

@ -16,5 +16,5 @@ function shadowing_assigned_in_body (var nee : unit) : string is block {
var st : string := "ta"; var st : string := "ta";
st := st ^ x; st := st ^ x;
} }
} with st } with st ^ 1
(* should be "toto" ??? *) (* should be "toto" ??? *)

1
src/test/contracts/match.ligo
View File

@ -34,4 +34,5 @@ function match_expr_list (const l : list (int)) : int is
case l of case l of
nil -> -1 nil -> -1
| hd # tl -> hd | hd # tl -> hd
| list [1; 2; foo] -> foo
end end

5
src/test/contracts/multisig.ligo
View File

@ -63,4 +63,7 @@ function check_message (const param : check_message_pt;
} with (message (unit), s) } with (message (unit), s)
function main (const param : parameter; const s : storage) : return is function main (const param : parameter; const s : storage) : return is
case param of CheckMessage (p) -> check_message (p,s) end case param of
| CheckMessage (p) -> check_message (p,s)
| a # b -> b
end

2
src/test/contracts/namespaces.ligo
View File

@ -8,3 +8,5 @@ const cards : cards = record [cards = cards]
const cards : cards = cards with record [cards = cards] const cards : cards = cards with record [cards = cards]
const cards : cards = cards.cards const cards : cards = cards.cards
const cards : cards = cards with record [cards.foo.0.bar = cards]

7
src/test/contracts/set_arithmetic.ligo
View File

@ -25,3 +25,10 @@ function patch_op_deep (var s : set (string) * nat) : set (string) * nat is
function mem_op (const s : set (string)) : bool is function mem_op (const s : set (string)) : bool is
set_mem ("foobar", s) set_mem ("foobar", s)
function patch_op_deep (var s : set (string) * nat) : set (string) * nat is
block {
patch s.0 with set ["foobar"];
remove "foobar" from set s.0
} with s

216
tools/lsp/pascaligo/grammar.js
View File

@ -56,7 +56,7 @@ module.exports = grammar({
extras: $ => [$.ocaml_comment, $.comment, /\s/], extras: $ => [$.ocaml_comment, $.comment, /\s/],
rules: { rules: {
contract: $ => sepBy(optional(';'), field("declaration", $._declaration)), Start: $ => sepBy(optional(';'), field("declaration", $._declaration)),
_declaration: $ => _declaration: $ =>
choice( choice(
@ -80,30 +80,31 @@ module.exports = grammar({
field("typeValue", $._type_expr), field("typeValue", $._type_expr),
), ),
type_expr : $ => $._type_expr,
_type_expr: $ => _type_expr: $ =>
choice( choice(
$.fun_type, $._fun_type,
$.sum_type, $.sum_type,
$.record_type, $.record_type,
), ),
fun_type: $ => _fun_type: $ =>
choice( choice(
field("domain", $.cartesian), $.fun_type,
$.cartesian
),
fun_type: $ =>
seq( seq(
field("domain", $.cartesian), field("domain", $.cartesian),
'->', '->',
field("codomain", $.fun_type), field("codomain", $._fun_type),
),
), ),
cartesian: $ => cartesian: $ =>
sepBy1('*', sepBy1('*',
choice( choice(
field("element", $._core_type), field("element", $._core_type),
par(field("element", $.type_expr)), par(field("element", $._type_expr)),
), ),
), ),
@ -112,17 +113,47 @@ module.exports = grammar({
$.TypeName, $.TypeName,
$.invokeBinary, $.invokeBinary,
$.invokeUnary, $.invokeUnary,
$.michelsonTypeOr,
$.michelsonTypeAnd,
),
michelsonTypeOr: $ =>
seq(
"michelson_or",
"(",
field("left_type", $._type_expr),
",",
field("left_type_name", $.String),
",",
field("right_type", $._type_expr),
",",
field("right_type_name", $.String),
")",
),
michelsonTypeAnd: $ =>
seq(
"michelson_pair",
"(",
field("left_type", $._type_expr),
",",
field("left_type_name", $.String),
",",
field("right_type", $._type_expr),
",",
field("right_type_name", $.String),
")",
), ),
invokeBinary: $ => invokeBinary: $ =>
seq( seq(
field("typeConstr", choice('map', 'big_map', $.TypeName)), field("typeConstr", choice('map', 'big_map')),
field("arguments", $.type_tuple), field("arguments", $.type_tuple),
), ),
invokeUnary: $ => invokeUnary: $ =>
seq( seq(
field("typeConstr", choice('list', 'set')), field("typeConstr", choice('list', 'set', 'option', 'contract')),
par(field("arguments", $._type_expr)), par(field("arguments", $._type_expr)),
), ),
@ -145,7 +176,7 @@ module.exports = grammar({
seq( seq(
field("constructor", $.constr), field("constructor", $.constr),
'of', 'of',
field("arguments", $.fun_type) field("arguments", $._fun_type)
), ),
), ),
@ -185,33 +216,36 @@ module.exports = grammar({
':', ':',
field("type", $._type_expr), field("type", $._type_expr),
'is', 'is',
field("body", $.let_expr), field("body", $._let_expr),
), ),
), ),
let_expr: $ => _let_expr: $ =>
choice( choice(
$.let_expr,
$._expr,
),
let_expr: $ =>
seq( seq(
field("locals", $.block), field("locals", $.block),
'with', 'with',
field("body", $._expr), field("body", $._expr),
), ),
field("body", $._expr),
),
parameters: $ => par(sepBy(';', field("parameter", $.param_decl))), parameters: $ => par(sepBy(';', field("parameter", $.param_decl))),
param_decl: $ => param_decl: $ =>
seq( seq(
field("access", $.access), field("access", $._access),
field("name", $.Name), field("name", $.Name),
':', ':',
field("type", $._param_type), field("type", $._param_type),
), ),
access: $ => choice('var', 'const'), _access: $ => choice('var', 'const'),
_param_type: $ => $.fun_type, _param_type: $ => $._fun_type,
_statement: $ => _statement: $ =>
choice( choice(
@ -252,7 +286,7 @@ module.exports = grammar({
$.conditional, $.conditional,
$.case_instr, $.case_instr,
$.assignment, $.assignment,
$.loop, $._loop,
$._proc_call, $._proc_call,
$.skip, $.skip,
$.record_patch, $.record_patch,
@ -268,7 +302,7 @@ module.exports = grammar({
field("key", $._expr), field("key", $._expr),
'from', 'from',
'set', 'set',
field("container", $.path), field("container", $._path),
), ),
map_remove: $ => map_remove: $ =>
@ -277,13 +311,13 @@ module.exports = grammar({
field("key", $._expr), field("key", $._expr),
'from', 'from',
'map', 'map',
field("container", $.path), field("container", $._path),
), ),
set_patch: $ => set_patch: $ =>
seq( seq(
'patch', 'patch',
field("container", $.path), field("container", $._path),
'with', 'with',
ne_injection('set', field("key", $._expr)), ne_injection('set', field("key", $._expr)),
), ),
@ -291,7 +325,7 @@ module.exports = grammar({
map_patch: $ => map_patch: $ =>
seq( seq(
'patch', 'patch',
field("container", $.path), field("container", $._path),
'with', 'with',
ne_injection('map', field("binding", $.binding)), ne_injection('map', field("binding", $.binding)),
), ),
@ -306,7 +340,7 @@ module.exports = grammar({
record_patch: $ => record_patch: $ =>
seq( seq(
'patch', 'patch',
field("container", $.path), field("container", $._path),
'with', 'with',
ne_injection('record', field("binding", $.field_assignment)), ne_injection('record', field("binding", $.field_assignment)),
), ),
@ -319,13 +353,13 @@ module.exports = grammar({
'if', 'if',
field("selector", $._expr), field("selector", $._expr),
'then', 'then',
field("then", $.if_clause), field("then", $._if_clause),
optional(';'), optional(';'),
'else', 'else',
field("else", $.if_clause), field("else", $._if_clause),
), ),
if_clause: $ => _if_clause: $ =>
choice( choice(
$._instruction, $._instruction,
$.clause_block, $.clause_block,
@ -375,9 +409,9 @@ module.exports = grammar({
case_clause_instr: $ => case_clause_instr: $ =>
seq( seq(
field("pattern", $.pattern), field("pattern", $._pattern),
'->', '->',
field("body", $.if_clause), field("body", $._if_clause),
), ),
assignment: $ => assignment: $ =>
@ -388,9 +422,9 @@ module.exports = grammar({
), ),
_rhs: $ => $._expr, _rhs: $ => $._expr,
_lhs: $ => choice($.path, $.map_lookup), _lhs: $ => choice($._path, $.map_lookup),
loop: $ => choice($.while_loop, $.for_loop), _loop: $ => choice($.while_loop, $._for_loop),
while_loop: $ => while_loop: $ =>
seq( seq(
@ -399,8 +433,13 @@ module.exports = grammar({
field("body", $.block), field("body", $.block),
), ),
for_loop: $ => _for_loop: $ =>
choice( choice(
$.for_cycle,
$.for_box,
),
for_cycle: $ =>
seq( seq(
'for', 'for',
field("name", $.Name), field("name", $.Name),
@ -408,20 +447,25 @@ module.exports = grammar({
field("begin", $._rhs), field("begin", $._rhs),
'to', 'to',
field("end", $._expr), field("end", $._expr),
optional(seq(
"step",
field("step", $._expr),
)),
field("body", $.block), field("body", $.block),
), ),
for_box: $ =>
seq( seq(
'for', 'for',
field("key", $.Name), field("key", $.Name),
optional(seq('->', field("value", $.Name))), optional(seq('->', field("value", $.Name))),
'in', 'in',
field("kind", $.collection), field("kind", $._collection),
field("collection", $._expr), field("collection", $._expr),
field("body", $.block), field("body", $.block),
), ),
),
collection: $ => choice('map', 'set', 'list'), _collection: $ => choice('map', 'set', 'list'),
interactive_expr: $ => $._expr, interactive_expr: $ => $._expr,
@ -429,7 +473,7 @@ module.exports = grammar({
choice( choice(
$.case_expr, $.case_expr,
$.cond_expr, $.cond_expr,
$.op_expr, $._op_expr,
$.fun_expr, $.fun_expr,
), ),
@ -456,7 +500,7 @@ module.exports = grammar({
case_clause_expr: $ => case_clause_expr: $ =>
seq( seq(
field("pattern", $.pattern), field("pattern", $._pattern),
'->', '->',
field("body", $._expr), field("body", $._expr),
), ),
@ -472,20 +516,27 @@ module.exports = grammar({
field("else", $._expr), field("else", $._expr),
), ),
op_expr: $ => _op_expr: $ =>
choice( choice(
field("the", $._core_expr), $._core_expr,
prec.left (0, seq(field("arg1", $.op_expr), field("op", 'or'), field("arg2", $.op_expr))), $.binop,
prec.left (1, seq(field("arg1", $.op_expr), field("op", 'and'), field("arg2", $.op_expr))), $.unop,
prec.right(2, seq(field("arg1", $._core_expr), field("op", 'contains'), field("arg2", $.op_expr))),
prec.left (3, seq(field("arg1", $.op_expr), field("op", $.comparison), field("arg2", $.op_expr))),
prec.right(4, seq(field("arg1", $.op_expr), field("op", '^'), field("arg2", $.op_expr))),
prec.right(5, seq(field("arg1", $.op_expr), field("op", '#'), field("arg2", $.op_expr))),
prec.left (6, seq(field("arg1", $.op_expr), field("op", $.adder), field("arg2", $.op_expr))),
prec.left (7, seq(field("arg1", $.op_expr), field("op", $.multiplier), field("arg2", $.op_expr))),
prec.right(8, seq(field("negate", $.negate), field("arg", $._core_expr))),
), ),
binop: $ =>
choice(
prec.left (0, seq(field("arg1", $._op_expr), field("op", 'or'), field("arg2", $._op_expr))),
prec.left (1, seq(field("arg1", $._op_expr), field("op", 'and'), field("arg2", $._op_expr))),
prec.right(2, seq(field("arg1", $._core_expr), field("op", 'contains'), field("arg2", $._op_expr))),
prec.left (3, seq(field("arg1", $._op_expr), field("op", $.comparison), field("arg2", $._op_expr))),
prec.right(4, seq(field("arg1", $._op_expr), field("op", '^'), field("arg2", $._op_expr))),
prec.right(5, seq(field("arg1", $._op_expr), field("op", '#'), field("arg2", $._op_expr))),
prec.left (6, seq(field("arg1", $._op_expr), field("op", $.adder), field("arg2", $._op_expr))),
prec.left (7, seq(field("arg1", $._op_expr), field("op", $.multiplier), field("arg2", $._op_expr))),
),
unop: $ => prec.right(8, seq(field("negate", $.negate), field("arg", $._core_expr))),
comparison: $ => choice('<', '<=', '>', '>=', '=', '=/='), comparison: $ => choice('<', '<=', '>', '>=', '=', '=/='),
adder: $ => choice('-', '+'), adder: $ => choice('-', '+'),
multiplier: $ => choice('/', '*', 'mod'), multiplier: $ => choice('/', '*', 'mod'),
@ -505,24 +556,28 @@ module.exports = grammar({
$.Unit, $.Unit,
$.annot_expr, $.annot_expr,
$.tuple_expr, $.tuple_expr,
$.list_expr, $._list_expr,
$.None, $.None,
$._fun_call_or_par_or_projection, $._fun_call_or_par_or_projection,
$._map_expr, $._map_expr,
$.set_expr, $.set_expr,
$.record_expr, $.record_expr,
$.update_record, $.update_record,
$.constr_call, $._constr_use,
$.Some_call, $.Some_call,
), ),
_constr_use: $ =>
choice(
$.constr_call,
$.constr
),
constr_call: $ => constr_call: $ =>
seq( seq(
field("constr", $.constr), field("constr", $.constr),
optional(
field("arguments", $.arguments) field("arguments", $.arguments)
), ),
),
Some_call: $ => Some_call: $ =>
seq( seq(
@ -535,22 +590,23 @@ module.exports = grammar({
$.par_call, $.par_call,
$.projection_call, $.projection_call,
$.fun_call, $.fun_call,
$._projection,
), ),
par_call: $ => par_call: $ =>
prec.right(1, seq( prec.right(1, seq(
par(field("f", $._expr)), par(field("f", $._expr)),
optional(field("arguments", $.arguments)) field("arguments", $.arguments),
)), )),
projection_call: $ => seq( projection_call: $ => prec(1, seq(
field("f", $._projection), field("f", $._projection),
optional(field("arguments", $.arguments)), field("arguments", $.arguments),
), )),
annot_expr: $ => annot_expr: $ =>
par(seq( par(seq(
field("subject", $.op_expr), field("subject", $._op_expr),
':', ':',
field("type", $._type_expr) field("type", $._type_expr)
)), )),
@ -569,13 +625,13 @@ module.exports = grammar({
map_lookup: $ => map_lookup: $ =>
seq( seq(
field("container", $.path), field("container", $._path),
brackets(field("index", $._expr)), brackets(field("index", $._expr)),
), ),
path: $ => choice($.Name, $._projection), _path: $ => choice($.Name, $._projection),
fpath: $ => choice($.FieldName, $._projection), _fpath: $ => choice($.FieldName, $._projection),
module_field: $ => module_field: $ =>
seq( seq(
@ -606,7 +662,7 @@ module.exports = grammar({
data_projection: $ => seq( data_projection: $ => seq(
field("struct", $.Name), field("struct", $.Name),
'.', '.',
sepBy1('.', field("index", $.selection)), sepBy1('.', field("index", $._selection)),
), ),
module_projection: $ => module_projection: $ =>
@ -615,10 +671,10 @@ module.exports = grammar({
'.', '.',
field("index", $.Name), field("index", $.Name),
'.', '.',
sepBy1('.', field("index", $.selection)), sepBy1('.', field("index", $._selection)),
), ),
selection: $ => choice($.FieldName, $.Int), _selection: $ => choice($.FieldName, $.Int),
record_expr: $ => record_expr: $ =>
choice( choice(
@ -637,7 +693,7 @@ module.exports = grammar({
update_record: $ => update_record: $ =>
seq( seq(
field("record", $.path), field("record", $._path),
'with', 'with',
ne_injection('record', field("assignment", $.field_path_assignment)), ne_injection('record', field("assignment", $.field_path_assignment)),
), ),
@ -651,7 +707,7 @@ module.exports = grammar({
field_path_assignment: $ => field_path_assignment: $ =>
seq( seq(
field("lhs", $.fpath), field("lhs", $._fpath),
'=', '=',
field("_rhs", $._expr), field("_rhs", $._expr),
), ),
@ -665,14 +721,14 @@ module.exports = grammar({
tuple_expr: $ => par(sepBy1(',', field("element", $._expr))), tuple_expr: $ => par(sepBy1(',', field("element", $._expr))),
arguments: $ => par(sepBy(',', field("argument", $._expr))), arguments: $ => par(sepBy(',', field("argument", $._expr))),
list_expr: $ => choice($._list_injection, 'nil'), _list_expr: $ => choice($.list_injection, 'nil'),
_list_injection: $ => injection('list', field("element", $._expr)), list_injection: $ => injection('list', field("element", $._expr)),
pattern: $ => _pattern: $ =>
choice( choice(
$._cons_pattern, $.cons_pattern,
field("the", $._core_pattern), $._core_pattern,
), ),
_core_pattern: $ => _core_pattern: $ =>
@ -682,26 +738,28 @@ module.exports = grammar({
$.Int, $.Int,
$.Nat, $.Nat,
$.String, $.String,
$.list_pattern, $._list_pattern,
$.tuple_pattern, $.tuple_pattern,
$._constr_pattern, $._constr_pattern,
), ),
list_pattern: $ => _list_pattern: $ =>
choice( choice(
injection("list", field("element", $.pattern)), $.list_pattern,
'nil', 'nil',
), ),
_cons_pattern: $ => list_pattern: $ => injection("list", field("element", $._pattern)),
cons_pattern: $ =>
seq( seq(
field("head", $._core_pattern), field("head", $._core_pattern),
'#', '#',
field("tail", $.pattern), field("tail", $._pattern),
), ),
tuple_pattern: $ => tuple_pattern: $ =>
par(sepBy1(',', field("element", $.pattern))), par(sepBy1(',', field("element", $._pattern))),
_constr_pattern: $ => choice( _constr_pattern: $ => choice(
$.Unit, $.Unit,
@ -715,7 +773,7 @@ module.exports = grammar({
Some_pattern: $ => Some_pattern: $ =>
seq( seq(
field("constr", 'Some'), field("constr", 'Some'),
par(field("arg", $.pattern)), par(field("arg", $._pattern)),
), ),
user_constr_pattern: $ => user_constr_pattern: $ =>
@ -744,7 +802,7 @@ module.exports = grammar({
include: $ => seq('#include', field("filename", $.String)), include: $ => seq('#include', field("filename", $.String)),
String: $ => /\"(\\.|[^"])*\"/, String: $ => choice(/\"(\\.|[^"])*\"/, /{\|(\\.|[^\|])*\|}/),
Int: $ => /-?([1-9][0-9_]*|0)/, Int: $ => /-?([1-9][0-9_]*|0)/,
Nat: $ => /([1-9][0-9_]*|0)n/, Nat: $ => /([1-9][0-9_]*|0)n/,
Tez: $ => /([1-9][0-9_]*|0)(\.[0-9_]+)?(tz|tez|mutez)/, Tez: $ => /([1-9][0-9_]*|0)(\.[0-9_]+)?(tz|tez|mutez)/,

413
tools/lsp/squirrel/app/Main.hs
View File

@ -6,7 +6,7 @@ import Control.Lens
import Control.Monad import Control.Monad
import Data.Default import Data.Default
-- import Data.Foldable import Data.Foldable
import qualified Data.Text as Text import qualified Data.Text as Text
import Data.Text (Text) import Data.Text (Text)
import Data.String (fromString) import Data.String (fromString)
@ -30,232 +30,233 @@ import Range
import Product import Product
import AST hiding (def) import AST hiding (def)
import qualified AST.Find as Find import qualified AST.Find as Find
import Error -- import Error
main :: IO () main :: IO ()
main = do main = do
-- for_ [1.. 100] \_ -> do
-- print =<< runParser contract example
errCode <- mainLoop
exit errCode
mainLoop :: IO Int
mainLoop = do
chan <- atomically newTChan :: IO (TChan FromClientMessage)
let
callbacks = Core.InitializeCallbacks
{ Core.onInitialConfiguration = const $ Right ()
, Core.onConfigurationChange = const $ Right ()
, Core.onStartup = \lFuns -> do
_ <- forkIO $ eventLoop lFuns chan
return Nothing
}
Core.setupLogger (Just "log.txt") [] L.INFO
CTRL.run callbacks (lspHandlers chan) lspOptions (Just "log.txt")
`catches`
[ Handler \(e :: SomeException) -> do
print e
return 1
]
syncOptions :: J.TextDocumentSyncOptions
syncOptions = J.TextDocumentSyncOptions
{ J._openClose = Just True
, J._change = Just J.TdSyncIncremental
, J._willSave = Just False
, J._willSaveWaitUntil = Just False
, J._save = Just $ J.SaveOptions $ Just False
}
lspOptions :: Core.Options
lspOptions = def
{ Core.textDocumentSync = Just syncOptions
, Core.executeCommandCommands = Just ["lsp-hello-command"]
}
lspHandlers :: TChan FromClientMessage -> Core.Handlers
lspHandlers rin = def
{ Core.initializedHandler = Just $ passHandler rin NotInitialized
, Core.definitionHandler = Just $ passHandler rin ReqDefinition
, Core.referencesHandler = Just $ passHandler rin ReqFindReferences
, Core.didOpenTextDocumentNotificationHandler = Just $ passHandler rin NotDidOpenTextDocument
, Core.didSaveTextDocumentNotificationHandler = Just $ passHandler rin NotDidSaveTextDocument
, Core.didChangeTextDocumentNotificationHandler = Just $ passHandler rin NotDidChangeTextDocument
, Core.didCloseTextDocumentNotificationHandler = Just $ passHandler rin NotDidCloseTextDocument
, Core.cancelNotificationHandler = Just $ passHandler rin NotCancelRequestFromClient
, Core.responseHandler = Just $ responseHandlerCb rin
, Core.codeActionHandler = Just $ passHandler rin ReqCodeAction
, Core.executeCommandHandler = Just $ passHandler rin ReqExecuteCommand
}
passHandler :: TChan FromClientMessage -> (a -> FromClientMessage) -> Core.Handler a
passHandler rin c notification = do
atomically $ writeTChan rin (c notification)
responseHandlerCb :: TChan FromClientMessage -> Core.Handler J.BareResponseMessage
responseHandlerCb _rin resp = do
U.logs $ "******** got ResponseMessage, ignoring:" ++ show resp
send :: Core.LspFuncs () -> FromServerMessage -> IO ()
send = Core.sendFunc
nextID :: Core.LspFuncs () -> IO J.LspId
nextID = Core.getNextReqId
eventLoop :: Core.LspFuncs () -> TChan FromClientMessage -> IO ()
eventLoop funs chan = do
forever do
msg <- atomically (readTChan chan)
U.logs [i|Client: ${msg}|]
case msg of
RspFromClient {} -> do
return () return ()
for_ [1.. 100] \_ -> do
print . length . show =<< sample' "../../../src/test/contracts/loop.ligo"
-- errCode <- mainLoop
-- exit errCode
NotInitialized _notif -> do -- mainLoop :: IO Int
let -- mainLoop = do
registration = J.Registration -- chan <- atomically newTChan :: IO (TChan FromClientMessage)
"lsp-haskell-registered"
J.WorkspaceExecuteCommand
Nothing
registrations = J.RegistrationParams $ J.List [registration]
rid <- nextID funs -- let
send funs -- callbacks = Core.InitializeCallbacks
$ ReqRegisterCapability -- { Core.onInitialConfiguration = const $ Right ()
$ fmServerRegisterCapabilityRequest rid registrations -- , Core.onConfigurationChange = const $ Right ()
-- , Core.onStartup = \lFuns -> do
-- _ <- forkIO $ eventLoop lFuns chan
-- return Nothing
-- }
NotDidOpenTextDocument notif -> do -- Core.setupLogger (Just "log.txt") [] L.INFO
let -- CTRL.run callbacks (lspHandlers chan) lspOptions (Just "log.txt")
doc = notif -- `catches`
^.J.params -- [ Handler \(e :: SomeException) -> do
.J.textDocument -- print e
.J.uri -- return 1
-- ]
ver = notif -- syncOptions :: J.TextDocumentSyncOptions
^.J.params -- syncOptions = J.TextDocumentSyncOptions
.J.textDocument -- { J._openClose = Just True
.J.version -- , J._change = Just J.TdSyncIncremental
-- , J._willSave = Just False
-- , J._willSaveWaitUntil = Just False
-- , J._save = Just $ J.SaveOptions $ Just False
-- }
collectErrors funs -- lspOptions :: Core.Options
(J.toNormalizedUri doc) -- lspOptions = def
(J.uriToFilePath doc) -- { Core.textDocumentSync = Just syncOptions
(Just ver) -- , Core.executeCommandCommands = Just ["lsp-hello-command"]
-- }
NotDidChangeTextDocument notif -> do -- lspHandlers :: TChan FromClientMessage -> Core.Handlers
let -- lspHandlers rin = def
doc = notif -- { Core.initializedHandler = Just $ passHandler rin NotInitialized
^.J.params -- , Core.definitionHandler = Just $ passHandler rin ReqDefinition
.J.textDocument -- , Core.referencesHandler = Just $ passHandler rin ReqFindReferences
.J.uri -- , Core.didOpenTextDocumentNotificationHandler = Just $ passHandler rin NotDidOpenTextDocument
-- , Core.didSaveTextDocumentNotificationHandler = Just $ passHandler rin NotDidSaveTextDocument
-- , Core.didChangeTextDocumentNotificationHandler = Just $ passHandler rin NotDidChangeTextDocument
-- , Core.didCloseTextDocumentNotificationHandler = Just $ passHandler rin NotDidCloseTextDocument
-- , Core.cancelNotificationHandler = Just $ passHandler rin NotCancelRequestFromClient
-- , Core.responseHandler = Just $ responseHandlerCb rin
-- , Core.codeActionHandler = Just $ passHandler rin ReqCodeAction
-- , Core.executeCommandHandler = Just $ passHandler rin ReqExecuteCommand
-- }
collectErrors funs -- passHandler :: TChan FromClientMessage -> (a -> FromClientMessage) -> Core.Handler a
(J.toNormalizedUri doc) -- passHandler rin c notification = do
(J.uriToFilePath doc) -- atomically $ writeTChan rin (c notification)
(Just 0)
ReqDefinition req -> do -- responseHandlerCb :: TChan FromClientMessage -> Core.Handler J.BareResponseMessage
stopDyingAlready funs req do -- responseHandlerCb _rin resp = do
let uri = req^.J.params.J.textDocument.J.uri -- U.logs $ "******** got ResponseMessage, ignoring:" ++ show resp
let pos = posToRange $ req^.J.params.J.position
tree <- loadByURI uri
case Find.definitionOf pos tree of
Just defPos -> do
respondWith funs req RspDefinition $ J.MultiLoc [J.Location uri $ rangeToLoc defPos]
Nothing -> do
respondWith funs req RspDefinition $ J.MultiLoc []
ReqFindReferences req -> do -- send :: Core.LspFuncs () -> FromServerMessage -> IO ()
stopDyingAlready funs req do -- send = Core.sendFunc
let uri = req^.J.params.J.textDocument.J.uri
let pos = posToRange $ req^.J.params.J.position
tree <- loadFromVFS funs uri
case Find.referencesOf pos tree of
Just refs -> do
let locations = J.Location uri . rangeToLoc <$> refs
respondWith funs req RspFindReferences $ J.List locations
Nothing -> do
respondWith funs req RspFindReferences $ J.List []
_ -> U.logs "unknown msg" -- nextID :: Core.LspFuncs () -> IO J.LspId
-- nextID = Core.getNextReqId
respondWith -- eventLoop :: Core.LspFuncs () -> TChan FromClientMessage -> IO ()
:: Core.LspFuncs () -- eventLoop funs chan = do
-> J.RequestMessage J.ClientMethod req rsp -- forever do
-> (J.ResponseMessage rsp -> FromServerMessage) -- msg <- atomically (readTChan chan)
-> rsp
-> IO ()
respondWith funs req wrap rsp = Core.sendFunc funs $ wrap $ Core.makeResponseMessage req rsp
stopDyingAlready :: Core.LspFuncs () -> J.RequestMessage m a b -> IO () -> IO () -- U.logs [i|Client: ${msg}|]
stopDyingAlready funs req = flip catch \(e :: SomeException) -> do
Core.sendErrorResponseS (Core.sendFunc funs) (req^.J.id.to J.responseId) J.InternalError
$ fromString
$ "this happened: " ++ show e
posToRange :: J.Position -> Range -- case msg of
posToRange (J.Position l c) = Range (l + 1, c + 1, 0) (l + 1, c + 1, 0) "" -- RspFromClient {} -> do
-- return ()
rangeToLoc :: Range -> J.Range -- NotInitialized _notif -> do
rangeToLoc (Range (a, b, _) (c, d, _) _) = -- let
J.Range -- registration = J.Registration
(J.Position (a - 1) (b - 1)) -- "lsp-haskell-registered"
(J.Position (c - 1) (d - 1)) -- J.WorkspaceExecuteCommand
-- Nothing
-- registrations = J.RegistrationParams $ J.List [registration]
loadFromVFS -- rid <- nextID funs
:: Core.LspFuncs () -- send funs
-> J.Uri -- $ ReqRegisterCapability
-> IO (Pascal (Product [[ScopedDecl], Maybe Category, Range, [Text]])) -- $ fmServerRegisterCapabilityRequest rid registrations
loadFromVFS funs uri = do
Just vf <- Core.getVirtualFileFunc funs $ J.toNormalizedUri uri
let txt = virtualFileText vf
let Just fin = J.uriToFilePath uri
(tree, _) <- runParser contract (Text fin txt)
return $ addLocalScopes tree
loadByURI -- NotDidOpenTextDocument notif -> do
:: J.Uri -- let
-> IO (Pascal (Product [[ScopedDecl], Maybe Category, Range, [Text]])) -- doc = notif
loadByURI uri = do -- ^.J.params
case J.uriToFilePath uri of -- .J.textDocument
Just fin -> do -- .J.uri
(tree, _) <- runParser contract (Path fin)
return $ addLocalScopes tree
Nothing -> do
error $ "uriToFilePath " ++ show uri ++ " has failed. We all are doomed."
collectErrors -- ver = notif
:: Core.LspFuncs () -- ^.J.params
-> J.NormalizedUri -- .J.textDocument
-> Maybe FilePath -- .J.version
-> Maybe Int
-> IO ()
collectErrors funs uri path version = do
case path of
Just fin -> do
(tree, errs) <- runParser contract (Path fin)
Core.publishDiagnosticsFunc funs 100 uri version
$ partitionBySource
$ map errorToDiag (errs <> errors tree)
Nothing -> error "TODO: implement URI file loading" -- collectErrors funs
-- (J.toNormalizedUri doc)
-- (J.uriToFilePath doc)
-- (Just ver)
errorToDiag :: Error ASTInfo -> J.Diagnostic -- NotDidChangeTextDocument notif -> do
errorToDiag (Expected what _ (getRange -> (Range (sl, sc, _) (el, ec, _) _))) = -- let
J.Diagnostic -- doc = notif
(J.Range begin end) -- ^.J.params
(Just J.DsError) -- .J.textDocument
Nothing -- .J.uri
(Just "ligo-lsp")
(Text.pack [i|Expected #{what}|])
(Just $ J.List[])
where
begin = J.Position (sl - 1) (sc - 1)
end = J.Position (el - 1) (ec - 1)
exit :: Int -> IO () -- collectErrors funs
exit 0 = exitSuccess -- (J.toNormalizedUri doc)
exit n = exitWith (ExitFailure n) -- (J.uriToFilePath doc)
-- (Just 0)
-- ReqDefinition req -> do
-- stopDyingAlready funs req do
-- let uri = req^.J.params.J.textDocument.J.uri
-- let pos = posToRange $ req^.J.params.J.position
-- tree <- loadByVFS funs uri
-- case Find.definitionOf pos tree of
-- Just defPos -> do
-- respondWith funs req RspDefinition $ J.MultiLoc [J.Location uri $ rangeToLoc defPos]
-- Nothing -> do
-- respondWith funs req RspDefinition $ J.MultiLoc []
-- ReqFindReferences req -> do
-- stopDyingAlready funs req do
-- let uri = req^.J.params.J.textDocument.J.uri
-- let pos = posToRange $ req^.J.params.J.position
-- tree <- loadFromVFS funs uri
-- case Find.referencesOf pos tree of
-- Just refs -> do
-- let locations = J.Location uri . rangeToLoc <$> refs
-- respondWith funs req RspFindReferences $ J.List locations
-- Nothing -> do
-- respondWith funs req RspFindReferences $ J.List []
-- _ -> U.logs "unknown msg"
-- respondWith
-- :: Core.LspFuncs ()
-- -> J.RequestMessage J.ClientMethod req rsp
-- -> (J.ResponseMessage rsp -> FromServerMessage)
-- -> rsp
-- -> IO ()
-- respondWith funs req wrap rsp = Core.sendFunc funs $ wrap $ Core.makeResponseMessage req rsp
-- stopDyingAlready :: Core.LspFuncs () -> J.RequestMessage m a b -> IO () -> IO ()
-- stopDyingAlready funs req = flip catch \(e :: SomeException) -> do
-- Core.sendErrorResponseS (Core.sendFunc funs) (req^.J.id.to J.responseId) J.InternalError
-- $ fromString
-- $ "this happened: " ++ show e
-- posToRange :: J.Position -> Range
-- posToRange (J.Position l c) = Range (l + 1, c + 1, 0) (l + 1, c + 1, 0) ""
-- rangeToLoc :: Range -> J.Range
-- rangeToLoc (Range (a, b, _) (c, d, _) _) =
-- J.Range
-- (J.Position (a - 1) (b - 1))
-- (J.Position (c - 1) (d - 1))
-- loadFromVFS
-- :: Core.LspFuncs ()
-- -> J.Uri
-- -> IO (Pascal (Product [[ScopedDecl], Maybe Category, Range, [Text]]))
-- loadFromVFS funs uri = do
-- Just vf <- Core.getVirtualFileFunc funs $ J.toNormalizedUri uri
-- let txt = virtualFileText vf
-- let Just fin = J.uriToFilePath uri
-- (tree, _) <- runParser contract (Text fin txt)
-- return $ addLocalScopes tree
-- loadByURI
-- :: J.Uri
-- -> IO (Pascal (Product [[ScopedDecl], Maybe Category, Range, [Text]]))
-- loadByURI uri = do
-- case J.uriToFilePath uri of
-- Just fin -> do
-- (tree, _) <- runParser contract (Path fin)
-- return $ addLocalScopes tree
-- Nothing -> do
-- error $ "uriToFilePath " ++ show uri ++ " has failed. We all are doomed."
-- collectErrors
-- :: Core.LspFuncs ()
-- -> J.NormalizedUri
-- -> Maybe FilePath
-- -> Maybe Int
-- -> IO ()
-- collectErrors funs uri path version = do
-- case path of
-- Just fin -> do
-- (tree, errs) <- runParser contract (Path fin)
-- Core.publishDiagnosticsFunc funs 100 uri version
-- $ partitionBySource
-- $ map errorToDiag (errs <> errors tree)
-- Nothing -> error "TODO: implement URI file loading"
-- errorToDiag :: Error ASTInfo -> J.Diagnostic
-- errorToDiag (Expected what _ (getRange -> (Range (sl, sc, _) (el, ec, _) _))) =
-- J.Diagnostic
-- (J.Range begin end)
-- (Just J.DsError)
-- Nothing
-- (Just "ligo-lsp")
-- (Text.pack [i|Expected #{what}|])
-- (Just $ J.List[])
-- where
-- begin = J.Position (sl - 1) (sc - 1)
-- end = J.Position (el - 1) (ec - 1)
-- exit :: Int -> IO ()
-- exit 0 = exitSuccess
-- exit n = exitWith (ExitFailure n)

1
tools/lsp/squirrel/examples/sanity.ligo
View File

@ -1 +0,0 @@
function foo (var x : int) is 1

8
tools/lsp/squirrel/package.yaml
View File

@ -5,13 +5,16 @@ dependencies:
- bytestring - bytestring
- containers - containers
- data-default - data-default
- duplo
- exceptions - exceptions
- fastsum - fastsum
- filepath - filepath
- ghc-prim - ghc-prim
- interpolate
- mtl - mtl
- pretty - pretty
- text - text
- transformers
- tree-sitter - tree-sitter
default-extensions: default-extensions:
@ -21,6 +24,7 @@ default-extensions:
- BlockArguments - BlockArguments
- ConstraintKinds - ConstraintKinds
- DataKinds - DataKinds
- DeriveAnyClass
- DeriveFoldable - DeriveFoldable
- DeriveFunctor - DeriveFunctor
- DeriveTraversable - DeriveTraversable
@ -46,7 +50,7 @@ default-extensions:
- UndecidableInstances - UndecidableInstances
- ViewPatterns - ViewPatterns
ghc-options: -freverse-errors -Wall -threaded ghc-options: -freverse-errors -Wall
library: library:
source-dirs: source-dirs:
@ -72,3 +76,5 @@ executables:
source-dirs: source-dirs:
- app/ - app/
ghc-options: -threaded

116
tools/lsp/squirrel/src/AST/Find.hs
View File

@ -1,70 +1,70 @@
module AST.Find where module AST.Find where
import Control.Monad -- import Control.Monad
import AST.Types -- import AST.Types
import AST.Scope -- import AST.Scope
import AST.Parser -- import AST.Parser
import Tree -- import Tree
import Range -- import Range
import Pretty -- import Pretty
import Product -- import Product
import Data.Text (Text) -- import Data.Text (Text)
-- import Debug.Trace -- -- import Debug.Trace
type CanSearch xs = -- type CanSearch xs =
( Contains [ScopedDecl] xs -- ( Contains [ScopedDecl] xs
, Contains Range xs -- , Contains Range xs
, Contains (Maybe Category) xs -- , Contains (Maybe Category) xs
, Contains [Text] xs -- , Contains [Text] xs
, Pretty (Product xs) -- , Pretty (Product xs)
) -- )
findScopedDecl -- findScopedDecl
:: CanSearch xs -- :: CanSearch xs
=> Range -- => Range
-> Pascal (Product xs) -- -> Pascal (Product xs)
-> Maybe ScopedDecl -- -> Maybe ScopedDecl
findScopedDecl pos tree = do -- findScopedDecl pos tree = do
pt <- lookupTree pos tree -- pt <- lookupTree pos tree
let info = infoOf pt -- let info = infoOf pt
let fullEnv = getElem info -- let fullEnv = getElem info
do -- do
categ <- getElem info -- categ <- getElem info
let filtered = filter (ofCategory categ) fullEnv -- let filtered = filter (ofCategory categ) fullEnv
lookupEnv (ppToText $ void pt) filtered -- lookupEnv (ppToText $ void pt) filtered
definitionOf -- definitionOf
:: CanSearch xs -- :: CanSearch xs
=> Range -- => Range
-> Pascal (Product xs) -- -> Pascal (Product xs)
-> Maybe Range -- -> Maybe Range
definitionOf pos tree = -- definitionOf pos tree =
_sdOrigin <$> findScopedDecl pos tree -- _sdOrigin <$> findScopedDecl pos tree
typeOf -- typeOf
:: CanSearch xs -- :: CanSearch xs
=> Range -- => Range
-> Pascal (Product xs) -- -> Pascal (Product xs)
-> Maybe (Either (Pascal ()) Kind) -- -> Maybe (Either (Pascal ()) Kind)
typeOf pos tree = -- typeOf pos tree =
_sdType =<< findScopedDecl pos tree -- _sdType =<< findScopedDecl pos tree
implementationOf -- implementationOf
:: CanSearch xs -- :: CanSearch xs
=> Range -- => Range
-> Pascal (Product xs) -- -> Pascal (Product xs)
-> Maybe Range -- -> Maybe Range
implementationOf pos tree = -- implementationOf pos tree =
_sdBody =<< findScopedDecl pos tree -- _sdBody =<< findScopedDecl pos tree
referencesOf -- referencesOf
:: CanSearch xs -- :: CanSearch xs
=> Range -- => Range
-> Pascal (Product xs) -- -> Pascal (Product xs)
-> Maybe [Range] -- -> Maybe [Range]
referencesOf pos tree = -- referencesOf pos tree =
_sdRefs <$> findScopedDecl pos tree -- _sdRefs <$> findScopedDecl pos tree

1194
tools/lsp/squirrel/src/AST/Parser.hs
View File

File diff suppressed because it is too large Load Diff

515
tools/lsp/squirrel/src/AST/Scope.hs
View File

@ -23,318 +23,319 @@ import Data.Maybe (listToMaybe)
import Data.Sum (Element, Apply, Sum) import Data.Sum (Element, Apply, Sum)
import Data.Text (Text) import Data.Text (Text)
import Duplo.Lattice
import Duplo.Pretty
import Duplo.Tree
-- import AST.Parser -- import AST.Parser
import AST.Types import AST.Types
-- import Comment -- import Comment
import Lattice
-- import Parser -- import Parser
import Pretty
import Product import Product
import Range import Range
import Tree
-- import Debug.Trace -- import Debug.Trace
type CollectM = State (Product [FullEnv, [Range]]) -- type CollectM = State (Product [FullEnv, [Range]])
type FullEnv = Product ["vars" := Env, "types" := Env] -- type FullEnv = Product ["vars" := Env, "types" := Env]
type Env = Map Range [ScopedDecl] -- type Env = Map Range [ScopedDecl]
data Category = Variable | Type -- data Category = Variable | Type
-- | The type/value declaration. -- -- | The type/value declaration.
data ScopedDecl = ScopedDecl -- data ScopedDecl = ScopedDecl
{ _sdName :: Pascal () -- { _sdName :: Pascal ()
, _sdOrigin :: Range -- , _sdOrigin :: Range
, _sdBody :: Maybe Range -- , _sdBody :: Maybe Range
, _sdType :: Maybe (Either (Pascal ()) Kind) -- , _sdType :: Maybe (Either (Pascal ()) Kind)
, _sdRefs :: [Range] -- , _sdRefs :: [Range]
} -- }
deriving Show via PP ScopedDecl -- deriving Show via PP ScopedDecl
-- | The kind. -- -- | The kind.
data Kind = Star -- data Kind = Star
deriving Show via PP Kind -- deriving Show via PP Kind
emptyEnv :: FullEnv -- emptyEnv :: FullEnv
emptyEnv -- emptyEnv
= Cons (Tag Map.empty) -- = Cons (Tag Map.empty)
$ Cons (Tag Map.empty) -- $ Cons (Tag Map.empty)
Nil -- Nil
with :: Category -> FullEnv -> (Env -> Env) -> FullEnv -- with :: Category -> FullEnv -> (Env -> Env) -> FullEnv
with Variable env f = modTag @"vars" f env -- with Variable env f = modTag @"vars" f env
with Type env f = modTag @"types" f env -- with Type env f = modTag @"types" f env
ofCategory :: Category -> ScopedDecl -> Bool -- ofCategory :: Category -> ScopedDecl -> Bool
ofCategory Variable ScopedDecl { _sdType = Just (Right Star) } = False -- ofCategory Variable ScopedDecl { _sdType = Just (Right Star) } = False
ofCategory Variable _ = True -- ofCategory Variable _ = True
ofCategory Type ScopedDecl { _sdType = Just (Right Star) } = True -- ofCategory Type ScopedDecl { _sdType = Just (Right Star) } = True
ofCategory _ _ = False -- ofCategory _ _ = False
-- | Calculate scopes and attach to all tree points declarations that are -- -- | Calculate scopes and attach to all tree points declarations that are
-- visible there. -- -- visible there.
-- -- --
addLocalScopes -- addLocalScopes
:: Contains Range xs -- :: Contains Range xs
=> Pascal (Product xs) -- => Pascal (Product xs)
-> Pascal (Product ([ScopedDecl] : Maybe Category : xs)) -- -> Pascal (Product ([ScopedDecl] : Maybe Category : xs))
addLocalScopes tree = -- addLocalScopes tree =
fmap (\xs -> Cons (fullEnvAt envWithREfs (getRange xs)) xs) tree1 -- fmap (\xs -> Cons (fullEnvAt envWithREfs (getRange xs)) xs) tree1
where -- where
tree1 = addNameCategories tree -- tree1 = addNameCategories tree
envWithREfs = getEnvTree tree -- envWithREfs = getEnvTree tree
addNameCategories -- addNameCategories
:: Contains Range xs -- :: Contains Range xs
=> Pascal (Product xs) -- => Pascal (Product xs)
-> Pascal (Product (Maybe Category : xs)) -- -> Pascal (Product (Maybe Category : xs))
addNameCategories tree = flip evalState emptyEnv do -- addNameCategories tree = flip evalState emptyEnv do
traverseMany -- traverseMany
[ Visit \r (Name t) -> do -- [ Visit \r (Name t) -> do
modify $ getRange r `addRef` (Variable, t) -- modify $ getRange r `addRef` (Variable, t)
return $ (Cons (Just Variable) r, Name t) -- return $ (Cons (Just Variable) r, Name t)
, Visit \r (TypeName t) -> do -- , Visit \r (TypeName t) -> do
modify $ getRange r `addRef` (Type, t) -- modify $ getRange r `addRef` (Type, t)
return $ (Cons (Just Type) r, TypeName t) -- return $ (Cons (Just Type) r, TypeName t)
] -- ]
(Cons Nothing) -- (Cons Nothing)
tree -- tree
getEnvTree -- getEnvTree
:: ( UpdateOver CollectM (Sum fs) (Tree fs b) -- :: ( Scoped CollectM (Sum fs) (Tree fs b)
, Apply Foldable fs -- , Apply Foldable fs
, Apply Functor fs -- , Apply Functor fs
, Apply Traversable fs -- , Apply Traversable fs
, HasRange b -- , HasRange b
, Element Name fs -- , Element Name fs
, Element TypeName fs -- , Element TypeName fs
) -- )
=> Tree fs b -- => Tree fs b
-> FullEnv -- -> FullEnv
getEnvTree tree = envWithREfs -- getEnvTree tree = envWithREfs
where -- where
envWithREfs = flip execState env do -- envWithREfs = flip execState env do
traverseMany -- traverseMany
[ Visit \r (Name t) -> do -- [ Visit \r (Name t) -> do
modify $ getRange r `addRef` (Variable, t) -- modify $ getRange r `addRef` (Variable, t)
return $ (r, Name t) -- return $ (r, Name t)
, Visit \r (TypeName t) -> do -- , Visit \r (TypeName t) -> do
modify $ getRange r `addRef` (Type, t) -- modify $ getRange r `addRef` (Type, t)
return $ (r, TypeName t) -- return $ (r, TypeName t)
] -- ]
id -- id
tree -- tree
env -- env
= execCollectM -- = execCollectM
$ traverseTree pure tree -- $ traverseTree pure tree
fullEnvAt :: FullEnv -> Range -> [ScopedDecl] -- fullEnvAt :: FullEnv -> Range -> [ScopedDecl]
fullEnvAt fe r = envAt (getTag @"types" fe) r <> envAt (getTag @"vars" fe) r -- fullEnvAt fe r = envAt (getTag @"types" fe) r <> envAt (getTag @"vars" fe) r
envAt :: Env -> Range -> [ScopedDecl] -- envAt :: Env -> Range -> [ScopedDecl]
envAt env pos = -- envAt env pos =
Map.elems scopes -- Map.elems scopes
where -- where
ranges = List.sortBy partOrder $ filter isCovering $ Map.keys env -- ranges = List.sortBy partOrder $ filter isCovering $ Map.keys env
scopes = Map.unions $ (map.foldMap) toScopeMap $ map (env Map.!) ranges -- scopes = Map.unions $ (map.foldMap) toScopeMap $ map (env Map.!) ranges
isCovering = (pos <?) -- isCovering = (pos <?)
toScopeMap sd@ScopedDecl {_sdName} = Map.singleton (ppToText _sdName) sd -- toScopeMap sd@ScopedDecl {_sdName} = Map.singleton (ppToText _sdName) sd
addRef :: Range -> (Category, Text) -> FullEnv -> FullEnv -- addRef :: Range -> (Category, Text) -> FullEnv -> FullEnv
addRef r (categ, n) env = -- addRef r (categ, n) env =
with categ env \slice -> -- with categ env \slice ->
Map.union -- Map.union
(go slice $ range slice) -- (go slice $ range slice)
slice -- slice
where -- where
go slice (r' : rest) = -- go slice (r' : rest) =
let decls = slice Map.! r' -- let decls = slice Map.! r'
in -- in
case updateOnly n r addRefToDecl decls of -- case updateOnly n r addRefToDecl decls of
(True, decls') -> Map.singleton r' decls' -- (True, decls') -> Map.singleton r' decls'
(False, decls') -> Map.insert r' decls' (go slice rest) -- (False, decls') -> Map.insert r' decls' (go slice rest)
go _ [] = Map.empty -- go _ [] = Map.empty
range slice -- range slice
= List.sortBy partOrder -- = List.sortBy partOrder
$ filter (r <?) -- $ filter (r <?)
$ Map.keys slice -- $ Map.keys slice
addRefToDecl sd = sd -- addRefToDecl sd = sd
{ _sdRefs = r : _sdRefs sd -- { _sdRefs = r : _sdRefs sd
} -- }
updateOnly -- updateOnly
:: Text -- :: Text
-> Range -- -> Range
-> (ScopedDecl -> ScopedDecl) -- -> (ScopedDecl -> ScopedDecl)
-> [ScopedDecl] -- -> [ScopedDecl]
-> (Bool, [ScopedDecl]) -- -> (Bool, [ScopedDecl])
updateOnly name r f = go -- updateOnly name r f = go
where -- where
go = \case -- go = \case
d : ds -- d : ds
| ppToText (_sdName d) == name -> -- | ppToText (_sdName d) == name ->
if r == _sdOrigin d -- if r == _sdOrigin d
then (True, d : ds) -- then (True, d : ds)
else (True, f d : ds) -- else (True, f d : ds)
| otherwise -> second (d :) (go ds) -- | otherwise -> second (d :) (go ds)
[] -> (False, []) -- [] -> (False, [])
enter :: Range -> CollectM () -- enter :: Range -> CollectM ()
enter r = do -- enter r = do
modify $ modElem (r :) -- modify $ modElem (r :)
define :: Category -> ScopedDecl -> CollectM () -- define :: Category -> ScopedDecl -> CollectM ()
define categ sd = do -- define categ sd = do
r <- gets (head . getElem @[Range]) -- r <- gets (head . getElem @[Range])
modify -- modify
$ modElem @FullEnv \env -> -- $ modElem @FullEnv \env ->
with categ env -- with categ env
$ Map.insertWith (++) r [sd] -- $ Map.insertWith (++) r [sd]
leave :: CollectM () -- leave :: CollectM ()
leave = modify $ modElem @[Range] tail -- leave = modify $ modElem @[Range] tail
-- | Run the computation with scope starting from empty scope. -- -- | Run the computation with scope starting from empty scope.
execCollectM :: CollectM a -> FullEnv -- execCollectM :: CollectM a -> FullEnv
execCollectM action = getElem $ execState action $ Cons emptyEnv (Cons [] Nil) -- execCollectM action = getElem $ execState action $ Cons emptyEnv (Cons [] Nil)
instance {-# OVERLAPS #-} Pretty FullEnv where -- instance {-# OVERLAPS #-} Pretty FullEnv where
pp = block . map aux . Map.toList . mergeFE -- pp = block . map aux . Map.toList . mergeFE
where -- where
aux (r, fe) = -- aux (r, fe) =
pp r `indent` block fe -- pp r `indent` block fe
mergeFE fe = getTag @"vars" @Env fe <> getTag @"types" fe -- mergeFE fe = getTag @"vars" @Env fe <> getTag @"types" fe
instance Pretty ScopedDecl where -- instance Pretty ScopedDecl where
pp (ScopedDecl n o _ t refs) = color 3 (pp n) <+> pp o <+> ":" <+> color 4 (maybe "?" (either pp pp) t) <+> "=" <+> pp refs -- pp (ScopedDecl n o _ t refs) = color 3 (pp n) <+> pp o <+> ":" <+> color 4 (maybe "?" (either pp pp) t) <+> "=" <+> pp refs
instance Pretty Kind where -- instance Pretty Kind where
pp _ = "TYPE" -- pp _ = "TYPE"
instance Pretty Category where -- instance Pretty Category where
pp Variable = "Variable" -- pp Variable = "Variable"
pp Type = "Type" -- pp Type = "Type"
-- | Search for a name inside a local scope. -- -- | Search for a name inside a local scope.
lookupEnv :: Text -> [ScopedDecl] -> Maybe ScopedDecl -- lookupEnv :: Text -> [ScopedDecl] -> Maybe ScopedDecl
lookupEnv name = listToMaybe . filter ((name ==) . ppToText . _sdName) -- lookupEnv name = listToMaybe . filter ((name ==) . ppToText . _sdName)
-- | Add a type declaration to the current scope. -- -- | Add a type declaration to the current scope.
defType :: HasRange a => Pascal a -> Kind -> Pascal a -> CollectM () -- defType :: HasRange a => Pascal a -> Kind -> Pascal a -> CollectM ()
defType name kind body = do -- defType name kind body = do
define Type -- define Type
$ ScopedDecl -- $ ScopedDecl
(void name) -- (void name)
(getRange $ infoOf name) -- (getRange $ infoOf name)
(Just $ getRange $ infoOf body) -- (Just $ getRange $ infoOf body)
(Just (Right kind)) -- (Just (Right kind))
[] -- []
-- observe :: Pretty i => Pretty res => Text -> i -> res -> res -- -- observe :: Pretty i => Pretty res => Text -> i -> res -> res
-- observe msg i res -- -- observe msg i res
-- = traceShow (pp msg, "INPUT", pp i) -- -- = traceShow (pp msg, "INPUT", pp i)
-- $ traceShow (pp msg, "OUTPUT", pp res) -- -- $ traceShow (pp msg, "OUTPUT", pp res)
-- $ res -- -- $ res
-- | Add a value declaration to the current scope. -- -- | Add a value declaration to the current scope.
def -- def
:: HasRange a -- :: HasRange a
=> Pascal a -- => Pascal a
-> Maybe (Pascal a) -- -> Maybe (Pascal a)
-> Maybe (Pascal a) -- -> Maybe (Pascal a)
-> CollectM () -- -> CollectM ()
def name ty body = do -- def name ty body = do
define Variable -- define Variable
$ ScopedDecl -- $ ScopedDecl
(void name) -- (void name)
(getRange $ infoOf name) -- (getRange $ infoOf name)
((getRange . infoOf) <$> body) -- ((getRange . infoOf) <$> body)
((Left . void) <$> ty) -- ((Left . void) <$> ty)
[] -- []
instance UpdateOver CollectM Contract (Pascal a) where -- instance UpdateOver CollectM Contract (Pascal a) where
before r _ = enter r -- before r _ = enter r
after _ _ = skip -- after _ _ = skip
instance HasRange a => UpdateOver CollectM Declaration (Pascal a) where -- instance HasRange a => UpdateOver CollectM Declaration (Pascal a) where
before _ = \case -- before _ = \case
TypeDecl ty body -> defType ty Star body -- TypeDecl ty body -> defType ty Star body
_ -> skip -- _ -> skip
instance HasRange a => UpdateOver CollectM Binding (Pascal a) where -- instance HasRange a => UpdateOver CollectM Binding (Pascal a) where
before r = \case -- before r = \case
Function recur name _args ty body -> do -- Function recur name _args ty body -> do
when recur do -- when recur do
def name (Just ty) (Just body) -- def name (Just ty) (Just body)
enter r -- enter r
_ -> enter r -- _ -> enter r
after _ = \case -- after _ = \case
Irrefutable name body -> do leave; def name Nothing (Just body) -- Irrefutable name body -> do leave; def name Nothing (Just body)
Var name ty body -> do leave; def name (Just ty) (Just body) -- Var name ty body -> do leave; def name (Just ty) (Just body)
Const name ty body -> do leave; def name (Just ty) (Just body) -- Const name ty body -> do leave; def name (Just ty) (Just body)
Function recur name _args ty body -> do -- Function recur name _args ty body -> do
leave -- leave
unless recur do -- unless recur do
def name (Just ty) (Just body) -- def name (Just ty) (Just body)
instance HasRange a => UpdateOver CollectM VarDecl (Pascal a) where -- instance HasRange a => UpdateOver CollectM VarDecl (Pascal a) where
after _ (Decl _ name ty) = def name (Just ty) Nothing -- after _ (Decl _ name ty) = def name (Just ty) Nothing
instance UpdateOver CollectM Mutable (Pascal a) -- instance UpdateOver CollectM Mutable (Pascal a)
instance UpdateOver CollectM Type (Pascal a) -- instance UpdateOver CollectM Type (Pascal a)
instance UpdateOver CollectM Variant (Pascal a) -- instance UpdateOver CollectM Variant (Pascal a)
instance UpdateOver CollectM TField (Pascal a) -- instance UpdateOver CollectM TField (Pascal a)
instance HasRange a => UpdateOver CollectM Expr (Pascal a) where -- instance HasRange a => UpdateOver CollectM Expr (Pascal a) where
before r = \case -- before r = \case
Let {} -> enter r -- Let {} -> enter r
Lambda {} -> enter r -- Lambda {} -> enter r
ForLoop k _ _ _ -> do -- ForLoop k _ _ _ -> do
enter r -- enter r
def k Nothing Nothing -- def k Nothing Nothing
ForBox k mv _ _ _ -> do -- ForBox k mv _ _ _ -> do
enter r -- enter r
def k Nothing Nothing -- def k Nothing Nothing
maybe skip (\v -> def v Nothing Nothing) mv -- maybe skip (\v -> def v Nothing Nothing) mv
_ -> skip -- _ -> skip
after _ = \case -- after _ = \case
Let {} -> leave -- Let {} -> leave
Lambda {} -> leave -- Lambda {} -> leave
ForLoop {} -> leave -- ForLoop {} -> leave
ForBox {} -> leave -- ForBox {} -> leave
_ -> skip -- _ -> skip
instance HasRange a => UpdateOver CollectM Alt (Pascal a) where -- instance HasRange a => UpdateOver CollectM Alt (Pascal a) where
before r _ = enter r -- before r _ = enter r
after _ _ = leave -- after _ _ = leave
instance UpdateOver CollectM LHS (Pascal a) -- instance UpdateOver CollectM LHS (Pascal a)
instance UpdateOver CollectM MapBinding (Pascal a) -- instance UpdateOver CollectM MapBinding (Pascal a)
instance UpdateOver CollectM Assignment (Pascal a) -- instance UpdateOver CollectM Assignment (Pascal a)
instance UpdateOver CollectM FieldAssignment (Pascal a) -- instance UpdateOver CollectM FieldAssignment (Pascal a)
instance UpdateOver CollectM Constant (Pascal a) -- instance UpdateOver CollectM Constant (Pascal a)
instance HasRange a => UpdateOver CollectM Pattern (Pascal a) where -- instance HasRange a => UpdateOver CollectM Pattern (Pascal a) where
before _ = \case -- before _ = \case
IsVar n -> def n Nothing Nothing -- IsVar n -> def n Nothing Nothing
_ -> skip -- _ -> skip
instance UpdateOver CollectM QualifiedName (Pascal a) -- instance UpdateOver CollectM QualifiedName (Pascal a)
instance UpdateOver CollectM Path (Pascal a) -- instance UpdateOver CollectM Path (Pascal a)
instance UpdateOver CollectM Name (Pascal a) -- instance UpdateOver CollectM Name (Pascal a)
instance UpdateOver CollectM TypeName (Pascal a) -- instance UpdateOver CollectM TypeName (Pascal a)
instance UpdateOver CollectM FieldName (Pascal a) -- instance UpdateOver CollectM FieldName (Pascal a)

135
tools/lsp/squirrel/src/AST/Types.hs
View File

@ -7,9 +7,11 @@
module AST.Types where module AST.Types where
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as Text
import Pretty import Duplo.Pretty
import Tree import Duplo.Tree
import Duplo.Error
-- import Debug.Trace -- import Debug.Trace
@ -17,34 +19,57 @@ import Tree
-- --
-- TODO: Rename; add stuff if CamlLIGO/ReasonLIGO needs something. -- TODO: Rename; add stuff if CamlLIGO/ReasonLIGO needs something.
-- --
type Pascal = Tree type LIGO = Tree RawLigoList
type RawLigoList =
[ Name, Path, QualifiedName, Pattern, Constant, FieldAssignment, Assignment [ Name, Path, QualifiedName, Pattern, Constant, FieldAssignment, Assignment
, MapBinding, LHS, Alt, Expr, TField, Variant, Type, Mutable, VarDecl, Binding , MapBinding, LHS, Alt, Expr, TField, Variant, Type, Mutable, VarDecl, Binding
, Declaration, Contract, TypeName, FieldName , RawContract, TypeName, FieldName, Language
, Err Text, Parameters, Ctor
] ]
data Undefined it
= Undefined Text
deriving (Show) via PP (Undefined it)
deriving stock (Functor, Foldable, Traversable)
data Language it
= Language Lang it
deriving (Show) via PP (Language it)
deriving stock (Functor, Foldable, Traversable)
data Lang
= Pascal
| Caml
| Reason
-- deriving (Show) via PP Lang
data Contract it data Contract it
= ContractEnd = ContractEnd
| ContractCons it it -- ^ Declaration | ContractCons it it -- ^ Declaration
deriving (Show) via PP (Contract it) deriving (Show) via PP (Contract it)
deriving stock (Functor, Foldable, Traversable) deriving stock (Functor, Foldable, Traversable)
data Declaration it data RawContract it
= ValueDecl it -- ^ Binding = RawContract [it] -- ^ Declaration
| TypeDecl it it -- ^ Name Type deriving (Show) via PP (RawContract it)
| Action it -- ^ Expr
| Include Text it
deriving (Show) via PP (Declaration it)
deriving stock (Functor, Foldable, Traversable) deriving stock (Functor, Foldable, Traversable)
data Binding it data Binding it
= Irrefutable it it -- ^ (Pattern) (Expr) = Irrefutable it it -- ^ (Pattern) (Expr)
| Function Bool it [it] it it -- ^ (Name) [VarDecl] (Type) (Expr) | Function Bool it it it it -- ^ (Name) Parameters (Type) (Expr)
| Var it it it -- ^ (Name) (Type) (Expr) | Var it it it -- ^ (Name) (Type) (Expr)
| Const it it it -- ^ (Name) (Type) (Expr) | Const it it it -- ^ (Name) (Type) (Expr)
| TypeDecl it it -- ^ Name Type
| Include it
deriving (Show) via PP (Binding it) deriving (Show) via PP (Binding it)
deriving stock (Functor, Foldable, Traversable) deriving stock (Functor, Foldable, Traversable)
data Parameters it
= Parameters [it]
deriving (Show) via PP (Parameters it)
deriving stock (Functor, Foldable, Traversable)
data VarDecl it data VarDecl it
= Decl it it it -- ^ (Mutable) (Name) (Type) = Decl it it it -- ^ (Mutable) (Name) (Type)
deriving (Show) via PP (VarDecl it) deriving (Show) via PP (VarDecl it)
@ -63,7 +88,10 @@ data Type it
| TVar it -- ^ (Name) | TVar it -- ^ (Name)
| TSum [it] -- ^ [Variant] | TSum [it] -- ^ [Variant]
| TProduct [it] -- ^ [Type] | TProduct [it] -- ^ [Type]
| TApply it [it] -- (Name) [Type] | TApply it it -- (Name) [Type]
| TTuple [it]
| TOr it it it it
| TAnd it it it it
deriving (Show) via PP (Type it) deriving (Show) via PP (Type it)
deriving stock (Functor, Foldable, Traversable) deriving stock (Functor, Foldable, Traversable)
@ -79,12 +107,13 @@ data TField it
-- | TODO: break onto smaller types? Literals -> Constant; mapOps; mmove Annots to Decls. -- | TODO: break onto smaller types? Literals -> Constant; mapOps; mmove Annots to Decls.
data Expr it data Expr it
= Let it it -- Declaration (Expr) = Let it it -- Declaration Expr
| Apply it [it] -- (Expr) [Expr] | Apply it it -- (Expr) [Expr]
| Constant it -- (Constant) | Constant it -- (Constant)
| Ident it -- (QualifiedName) | Ident it -- (QualifiedName)
| BinOp it Text it -- (Expr) Text (Expr) | BinOp it it it -- (Expr) Text (Expr)
| UnOp Text it -- (Expr) | UnOp it it -- (Expr)
| Op Text
| Record [it] -- [Assignment] | Record [it] -- [Assignment]
| If it it it -- (Expr) (Expr) (Expr) | If it it it -- (Expr) (Expr) (Expr)
| Assign it it -- (LHS) (Expr) | Assign it it -- (LHS) (Expr)
@ -92,7 +121,7 @@ data Expr it
| Set [it] -- [Expr] | Set [it] -- [Expr]
| Tuple [it] -- [Expr] | Tuple [it] -- [Expr]
| Annot it it -- (Expr) (Type) | Annot it it -- (Expr) (Type)
| Attrs [Text] | Attrs [it]
| BigMap [it] -- [MapBinding] | BigMap [it] -- [MapBinding]
| Map [it] -- [MapBinding] | Map [it] -- [MapBinding]
| MapRemove it it -- (Expr) (QualifiedName) | MapRemove it it -- (Expr) (QualifiedName)
@ -100,11 +129,11 @@ data Expr it
| Indexing it it -- (QualifiedName) (Expr) | Indexing it it -- (QualifiedName) (Expr)
| Case it [it] -- (Expr) [Alt] | Case it [it] -- (Expr) [Alt]
| Skip | Skip
| ForLoop it it it it -- (Name) (Expr) (Expr) (Expr) | ForLoop it it it (Maybe it) it -- (Name) (Expr) (Expr) (Expr)
| WhileLoop it it -- (Expr) (Expr) | WhileLoop it it -- (Expr) (Expr)
| Seq [it] -- [Declaration] | Seq [it] -- [Declaration]
| Lambda [it] it it -- [VarDecl] (Type) (Expr) | Lambda it it it -- [VarDecl] (Type) (Expr)
| ForBox it (Maybe it) Text it it -- (Name) (Maybe (Name)) Text (Expr) (Expr) | ForBox it (Maybe it) it it it -- (Name) (Maybe (Name)) Text (Expr) (Expr)
| MapPatch it [it] -- (QualifiedName) [MapBinding] | MapPatch it [it] -- (QualifiedName) [MapBinding]
| SetPatch it [it] -- (QualifiedName) [Expr] | SetPatch it [it] -- (QualifiedName) [Expr]
| RecordUpd it [it] -- (QualifiedName) [FieldAssignment] | RecordUpd it [it] -- (QualifiedName) [FieldAssignment]
@ -181,29 +210,39 @@ newtype TypeName it = TypeName Text
deriving (Show) via PP (TypeName it) deriving (Show) via PP (TypeName it)
deriving stock (Functor, Foldable, Traversable) deriving stock (Functor, Foldable, Traversable)
newtype Ctor it = Ctor Text
deriving (Show) via PP (Ctor it)
deriving stock (Functor, Foldable, Traversable)
newtype FieldName it = FieldName Text newtype FieldName it = FieldName Text
deriving (Show) via PP (TypeName it) deriving (Show) via PP (TypeName it)
deriving stock (Functor, Foldable, Traversable) deriving stock (Functor, Foldable, Traversable)
instance Pretty1 Language where
pp1 = \case
Language _ p -> p
instance Pretty1 Undefined where
pp1 = \case
Undefined mess -> "{{{" <.> pp (Text.take 20 mess) <.> "}}}"
instance Pretty1 Contract where instance Pretty1 Contract where
pp1 = \case pp1 = \case
ContractEnd -> "(* end *)" ContractEnd -> "(* end *)"
ContractCons x xs -> x $$ " " $$ xs ContractCons x xs -> x $$ " " $$ xs
instance Pretty1 Declaration where instance Pretty1 RawContract where
pp1 = \case pp1 = \case
ValueDecl binding -> binding RawContract xs -> "(* begin *)" `indent` sparseBlock xs `above` "(* end *)"
TypeDecl n ty -> "type" <+> n <+> "=" `indent` ty
Action e -> e
Include f t ->
"(* module" <+> pp f <+> "*)"
`indent` pp t
`above` "(* end" <+> pp f <+> "*)"
instance Pretty1 Binding where instance Pretty1 Binding where
pp1 = \case pp1 = \case
Irrefutable pat expr -> "irref" <+> pat <+> "=" `indent` expr Irrefutable pat expr -> "irref" <+> pat <+> "=" `indent` expr
TypeDecl n ty -> "type" <+> n <+> "=" `indent` ty
Var name ty value -> "var" <+> name <+> ":" <+> ty <+> ":=" `indent` value
Const name ty body -> "const" <+> name <+> ":" <+> ty <+> "=" `indent` body
Include fname -> "#include" <+> fname
Function isRec name params ty body -> Function isRec name params ty body ->
( (
( (
@ -211,13 +250,15 @@ instance Pretty1 Binding where
<+> "function" <+> "function"
<+> name <+> name
) )
`indent` tuple params `indent` params
) )
`indent` (":" <+> ty <+> "is") `indent` (":" <+> ty `above` "is")
) )
`indent` body `indent` body
Var name ty value -> "var" <+> name <+> ":" <+> ty <+> ":=" `indent` value
Const name ty body -> "const" <+> name <+> ":" <+> ty <+> "=" `indent` body instance Pretty1 Parameters where
pp1 = \case
Parameters them -> tuple them
instance Pretty1 VarDecl where instance Pretty1 VarDecl where
pp1 = \case pp1 = \case
@ -235,7 +276,10 @@ instance Pretty1 Type where
TVar name -> name TVar name -> name
TSum variants -> block variants TSum variants -> block variants
TProduct elements -> train " *" elements TProduct elements -> train " *" elements
TApply f xs -> f <> tuple xs TApply f xs -> f <+> xs
TTuple xs -> tuple xs
TOr l n r m -> "michelson_or" <+> tuple [l, n, r, m]
TAnd l n r m -> "michelson_pair" <+> tuple [l, n, r, m]
instance Pretty1 Variant where instance Pretty1 Variant where
pp1 = \case pp1 = \case
@ -244,12 +288,13 @@ instance Pretty1 Variant where
instance Pretty1 Expr where instance Pretty1 Expr where
pp1 = \case pp1 = \case
Let decl body -> "block {" `indent` decl `above` "}" <+> "with" `indent` body Let decl body -> decl `above` "with" `indent` body
Apply f xs -> f <+> tuple xs Apply f xs -> f <+> xs
Constant constant -> constant Constant constant -> constant
Ident qname -> qname Ident qname -> qname
BinOp l o r -> parens (l <+> pp o <+> r) BinOp l o r -> parens (l <+> pp o <+> r)
UnOp o r -> parens (pp o <+> r) UnOp o r -> parens (pp o <+> r)
Op o -> pp o
Record az -> "record" <+> list az Record az -> "record" <+> list az
If b t e -> fsep ["if" `indent` b, "then" `indent` t, "else" `indent` e] If b t e -> fsep ["if" `indent` b, "then" `indent` t, "else" `indent` e]
Assign l r -> l <+> ":=" `indent` r Assign l r -> l <+> ":=" `indent` r
@ -262,14 +307,14 @@ instance Pretty1 Expr where
Map bs -> "map" <+> list bs Map bs -> "map" <+> list bs
MapRemove k m -> "remove" `indent` k `above` "from" <+> "map" `indent` m MapRemove k m -> "remove" `indent` k `above` "from" <+> "map" `indent` m
SetRemove k s -> "remove" `indent` k `above` "from" <+> "set" `indent` s SetRemove k s -> "remove" `indent` k `above` "from" <+> "set" `indent` s
Indexing a j -> a <> list [j] Indexing a j -> a <.> list [j]
Case s az -> "case" <+> s <+> "of" `indent` block az Case s az -> "case" <+> s <+> "of" `indent` block az
Skip -> "skip" Skip -> "skip"
ForLoop j s f b -> "for" <+> j <+> ":=" <+> s <+> "to" <+> f `indent` b ForLoop j s f d b -> "for" <+> j <+> ":=" <+> s <+> "to" <+> f <+> mb ("step" <+>) d `indent` b
ForBox k mv t z b -> "for" <+> k <+> mb ("->" <+>) mv <+> "in" <+> pp t <+> z `indent` b ForBox k mv t z b -> "for" <+> k <+> mb ("->" <+>) mv <+> "in" <+> pp t <+> z `indent` b
WhileLoop f b -> "while" <+> f `indent` b WhileLoop f b -> "while" <+> f `indent` b
Seq es -> "block {" `indent` sparseBlock es `above` "}" Seq es -> "block {" `indent` block es `above` "}"
Lambda ps ty b -> (("function" `indent` tuple ps) `indent` (":" <+> ty)) `indent` b Lambda ps ty b -> (("function" `indent` ps) `indent` (":" <+> ty)) `indent` b
MapPatch z bs -> "patch" `indent` z `above` "with" <+> "map" `indent` list bs MapPatch z bs -> "patch" `indent` z `above` "with" <+> "map" `indent` list bs
SetPatch z bs -> "patch" `indent` z `above` "with" <+> "set" `indent` list bs SetPatch z bs -> "patch" `indent` z `above` "with" <+> "set" `indent` list bs
RecordUpd r up -> r `indent` "with" <+> "record" `indent` list up RecordUpd r up -> r `indent` "with" <+> "record" `indent` list up
@ -301,7 +346,7 @@ instance Pretty1 Constant where
instance Pretty1 QualifiedName where instance Pretty1 QualifiedName where
pp1 = \case pp1 = \case
QualifiedName src path -> src <> sepByDot path QualifiedName src path -> src <.> sepByDot path
instance Pretty1 Pattern where instance Pretty1 Pattern where
pp1 = \case pp1 = \case
@ -326,6 +371,10 @@ instance Pretty1 FieldName where
pp1 = \case pp1 = \case
FieldName raw -> pp raw FieldName raw -> pp raw
instance Pretty1 Ctor where
pp1 = \case
Ctor raw -> pp raw
instance Pretty1 Path where instance Pretty1 Path where
pp1 = \case pp1 = \case
At n -> n At n -> n
@ -333,8 +382,8 @@ instance Pretty1 Path where
instance Pretty1 TField where instance Pretty1 TField where
pp1 = \case pp1 = \case
TField n t -> n <> ":" `indent` t TField n t -> n <.> ":" `indent` t
instance Pretty1 LHS where instance Pretty1 LHS where
pp1 = \case pp1 = \case
LHS qn mi -> qn <> foldMap brackets mi LHS qn mi -> qn <.> foldMap brackets mi

3
tools/lsp/squirrel/src/Comment.hs
View File

@ -11,7 +11,8 @@ module Comment
import qualified Data.Text as Text import qualified Data.Text as Text
import Data.Text (Text) import Data.Text (Text)
import Pretty import Duplo.Pretty
import Product import Product
-- | Ability to contain comments. -- | Ability to contain comments.

58
tools/lsp/squirrel/src/Error.hs
View File

@ -1,58 +0,0 @@
{- | Parsing Errors and utilities.
-}
module Error
( Error(..)
, HasErrors (..)
, Stubbed (..)
)
where
import Control.Monad.Catch
import Data.Text (Text, pack)
import Data.Typeable
import Pretty
-- | Parse Error.
data Error info
= Expected
{ eMsg :: Text -- ^ Description of what was expected.
, eWhole :: Text -- ^ Offending text.
, eInfo :: info -- ^ Location of the Error.
}
deriving (Show) via PP (Error info)
deriving stock (Eq, Functor, Foldable, Traversable)
instance (Pretty i, Typeable i) => Exception (Error i)
instance Pretty1 Error where
pp1 (Expected msg found r) = "░" <> pp msg <> r <> "▒" <> pp found <> "▓"
-- | Ability to contain `Error`s.
class HasErrors h info | h -> info where
errors :: h -> [Error info]
-- | For types that have a default replacer with an `Error`.
class Stubbed a i where
stub :: Error i -> a
instance Pretty i => Stubbed Text i where
stub = pack . show
-- | This is bad, but I had to.
--
-- TODO: Find a way to remove this instance.
-- I probably need a wrapper around '[]'.
--
-- Or I need a @fields@ parser combinator.
--
instance Stubbed [a] i where
stub = const []
-- | Is `Just` `.` @stubbing@.
instance Stubbed a i => Stubbed (Maybe a) i where
stub = Just . stub

26
tools/lsp/squirrel/src/Lattice.hs
View File

@ -1,26 +0,0 @@
{- | The property the @Tree@ @info@ should abide.
-}
module Lattice
( Lattice(..)
, partOrder
)
where
-- | A range should have this property to be used for navigation.
class Lattice l where
(?>) :: l -> l -> Bool
(<?) :: l -> l -> Bool
(?>) = flip (<?)
(<?) = flip (?>)
{-# minimal (?>) | (<?) #-}
partOrder :: Lattice l => l -> l -> Ordering
partOrder a b | a <? b && b <? a = EQ
partOrder a b | a <? b = LT
partOrder a b | b <? a = GT
partOrder _ _ = error "partOrder: Non-orderable"

79
tools/lsp/squirrel/src/ParseTree.hs
View File

@ -10,11 +10,13 @@
module ParseTree module ParseTree
( -- * Tree/Forest ( -- * Tree/Forest
ParseTree(..) ParseTree(..)
, ParseForest(..)
, Source(..) , Source(..)
, RawTree
, RawInfo
-- * Invoke the TreeSitter and get the tree it outputs -- * Invoke the TreeSitter and get the tree it outputs
, toParseTree , toParseTree
-- , example
) )
where where
@ -27,7 +29,7 @@ import Data.Text (Text)
import Data.Traversable (for) import Data.Traversable (for)
import TreeSitter.Parser import TreeSitter.Parser
import TreeSitter.Tree import TreeSitter.Tree hiding (Tree)
import TreeSitter.Language import TreeSitter.Language
import TreeSitter.Node import TreeSitter.Node
import Foreign.C.String (peekCString) import Foreign.C.String (peekCString)
@ -42,12 +44,16 @@ import Foreign.Storable ( peek
) )
import Control.Monad ((>=>)) import Control.Monad ((>=>))
import System.FilePath import System.FilePath (takeFileName)
import Text.PrettyPrint hiding ((<>)) import System.IO.Unsafe (unsafePerformIO)
import Duplo.Pretty
import Duplo.Tree
import Range import Range
import Pretty import Product
import Debouncer
foreign import ccall unsafe tree_sitter_PascaLigo :: Ptr Language foreign import ccall unsafe tree_sitter_PascaLigo :: Ptr Language
@ -62,44 +68,34 @@ srcToBytestring = \case
Text _ t -> return $ Text.encodeUtf8 t Text _ t -> return $ Text.encodeUtf8 t
ByteString _ s -> return s ByteString _ s -> return s
type RawTree = Tree '[ParseTree] RawInfo
type RawInfo = Product [Range, Text]
instance Modifies RawInfo where
ascribe (r :> n :> _) d = color 3 (pp n) <+> pp r `indent` pp d
-- | The tree tree-sitter produces. -- | The tree tree-sitter produces.
data ParseTree = ParseTree data ParseTree self = ParseTree
{ ptID :: Int -- ^ Unique number, for fast comparison. { ptName :: Text -- ^ Name of the node.
, ptName :: Text -- ^ Name of the node. , ptChildren :: [self] -- ^ Subtrees.
, ptRange :: Range -- ^ Range of the node.
, ptChildren :: ParseForest -- ^ Subtrees.
, ptSource :: ~Text -- ^ Range of the node. , ptSource :: ~Text -- ^ Range of the node.
} }
deriving (Show) via PP ParseTree deriving stock (Functor, Foldable, Traversable)
-- | The forest we work with. instance Pretty1 ParseTree where
data ParseForest = Forest pp1 (ParseTree n forest _) =
{ pfID :: Int -- ^ Unique number for comparison.
, pfGrove :: [(Text, ParseTree)] -- ^ Subtrees.
, pfRange :: Range -- ^ Full range of the forest.
}
deriving (Show) via PP ParseForest
instance Pretty ParseTree where
pp (ParseTree _ n r forest _) =
parens parens
( hang ( hang
(quotes (text (Text.unpack n)) <+> pp r) (quotes (text (Text.unpack n)))
2 2
(pp forest) (pp forest)
) )
instance Pretty ParseForest where
pp = vcat . map ppPair . pfGrove
where
ppPair (field, tree) =
if field == Text.empty
then nest 2 $ pp tree
else hang (text (Text.unpack field) <> ": ") 2 (pp tree)
-- | Feed file contents into PascaLIGO grammar recogniser. -- | Feed file contents into PascaLIGO grammar recogniser.
toParseTree :: Source -> IO ParseForest toParseTree :: Source -> IO RawTree
toParseTree fin = do toParseTree = unsafePerformIO $ debounced inner
where
inner fin = do
parser <- ts_parser_new parser <- ts_parser_new
True <- ts_parser_set_language parser tree_sitter_PascaLigo True <- ts_parser_set_language parser tree_sitter_PascaLigo
@ -109,8 +105,7 @@ toParseTree fin = do
BS.useAsCStringLen src \(str, len) -> do BS.useAsCStringLen src \(str, len) -> do
tree <- ts_parser_parse_string parser nullPtr str len tree <- ts_parser_parse_string parser nullPtr str len
finalTree <- withRootNode tree (peek >=> go src idCounter) withRootNode tree (peek >=> go src idCounter)
return $ Forest 0 [("", finalTree)] (ptRange finalTree)
where where
nextID :: IORef Int -> IO Int nextID :: IORef Int -> IO Int
@ -118,7 +113,7 @@ toParseTree fin = do
modifyIORef' ref (+ 1) modifyIORef' ref (+ 1)
readIORef ref readIORef ref
go :: ByteString -> IORef Int -> Node -> IO ParseTree go :: ByteString -> IORef Int -> Node -> IO RawTree
go src idCounter node = do go src idCounter node = do
let count = fromIntegral $ nodeChildCount node let count = fromIntegral $ nodeChildCount node
allocaArray count \children -> do allocaArray count \children -> do
@ -129,12 +124,12 @@ toParseTree fin = do
peekElemOff children i peekElemOff children i
trees <- for nodes \node' -> do trees <- for nodes \node' -> do
tree <- go src idCounter node' (only -> (r :> _, tree :: ParseTree RawTree)) <- go src idCounter node'
field <- field <-
if nodeFieldName node' == nullPtr if nodeFieldName node' == nullPtr
then return "" then return ""
else peekCString $ nodeFieldName node' else peekCString $ nodeFieldName node'
return (Text.pack field, tree) return $ make (r :> Text.pack field :> Nil, tree)
ty <- peekCString $ nodeType node ty <- peekCString $ nodeType node
@ -162,10 +157,8 @@ toParseTree fin = do
, rFile = takeFileName $ srcPath fin , rFile = takeFileName $ srcPath fin
} }
return $ ParseTree return $ make (range :> "" :> Nil, ParseTree
{ ptID = treeID { ptName = Text.pack ty
, ptName = Text.pack ty , ptChildren = trees
, ptRange = range
, ptChildren = Forest fID trees range
, ptSource = cutOut range src , ptSource = cutOut range src
} })

554
tools/lsp/squirrel/src/Parser.hs
View File

@ -1,448 +1,158 @@
{- | module Parser where
The thing that can untangle the mess that TreeSitter produces.
In presence of serious errors, it /will/ be a mess, anyway. import Control.Arrow
The AST you are building must be the @Tree@ in each point.
I recommend, in your tree-sitter grammar, to add `field("foo", ...)`
to each sub-rule, that has `$.` in front of it - in a rule, that doesn't
start with `_` in its name.
As a general rule of thumb, make each significant part a separate rule,
even if it is a keyword. Then, apply previous advice.
Only make rule start with `_` if it is a pure choice.
> ('block'
> ...
> a: <a>
> ...
> b: <b>
> ...)
->
> block = do
> subtree "block" do
> ranged do
> pure Block
> <*> inside "a" a
> <*> inside "b" b
-}
module Parser
( -- * Parser type
Parser
, runParser
, runParser'
, debugParser
-- * Combinators
, subtree
, anything
, token
, stubbed
, getInfo
, inside
, restart
-- * Error
, die
-- * Replacement for `Alternative`, because reasons
, many
, some
, (<|>)
, optional
, select
-- * Debug
, dump
-- * Comments and ranges
, ASTInfo
, Source(..)
, module ParseTree
) where
import Control.Monad.Writer hiding (Product)
import Control.Monad.State
import Control.Monad.Catch import Control.Monad.Catch
import qualified Control.Monad.Reader as MTL import Control.Monad.RWS hiding (Product)
import Control.Monad.Trans.Maybe
import Data.Functor ((<&>)) import Data.String.Interpolate (i)
import Data.Foldable
import Data.Text (Text) import Data.Text (Text)
import qualified Data.Text as Text import qualified Data.Text as Text
import qualified Data.Set as Set
import System.FilePath import Duplo.Tree
import Duplo.Error
import Duplo.Pretty
import ParseTree import ParseTree
import Range import Range
import Pretty
import Error
import Product import Product
import Debug.Trace import Debug.Trace
-- | Parser of tree-sitter-made tree. {-
-- Comment grabber has 2 buffers: 1 and 2.
-- TODO: separate state. Polysemy?
--
type Parser =
WriterT [Error ASTInfo]
(StateT (Product PList)
IO)
type PList = [ParseForest, [Text], FilePath, Set.Set FilePath] 1) We collect all comments before the node and append them into buffer 1.
2) We collect all comments after the node and put them into buffer 2.
3) `grabComments` takes all comments from buffer 1.
4) On leaving, move move comments from 2 to 1.
-}
-- | Auto-accumulated information to be put into AST being build. runParserM :: ParserM a -> IO (a, [Err Text ()])
type ASTInfo = Product [Range, [Text]] runParserM p = (\(a, _, errs) -> (a, errs)) <$> runRWST p () ([], [])
runParser runParserM1 :: [RawTree] -> ParserM1 a -> ParserM (Maybe a)
:: Stubbed a ASTInfo runParserM1 cs p = do
=> Parser a s <- get
-> Source (a, s1, w) <- lift $ runRWST (runMaybeT p) cs s
-> IO (a, [Error ASTInfo]) tell w
runParser parser fin = do put s1
pforest <- toParseTree fin
let dir = takeDirectory $ srcPath fin
runWriterT parser `evalStateT`
Cons pforest
(Cons []
(Cons dir
(Cons Set.empty
Nil)))
`catch` \(e :: Error ASTInfo) -> do
return $ (stub e, [])
runParser'
:: Stubbed a ASTInfo
=> Parser a
-> Source
-> IO a
runParser' parser fin = fst <$> runParser parser fin
restart :: Stubbed a ASTInfo => Parser a -> FilePath -> Parser a
restart p fin = do
dir <- get' @FilePath
let full = dir </> fin
set <- get' @(Set.Set FilePath)
if Set.member full set
then do
fallback "recusive imports"
else do
(a, errs) <- liftIO do
flip runParser (Path full) do
put' (Set.insert full set)
p
tell errs
return a return a
get' :: forall x. Contains x PList => Parser x type ParserM = RWST () [Err Text ()] ([Text], [Text]) IO
get' = gets getElem type ParserM1 = MaybeT (RWST [RawTree] [Err Text ()] ([Text], [Text]) IO)
gets' :: forall x a. Contains x PList => (x -> a) -> Parser a data Failure = Failure String
gets' f = gets (f . getElem) deriving stock (Show)
deriving anyclass (Exception)
put' :: forall x. Contains x PList => x -> Parser () instance Scoped (Product [Range, Text]) ParserM RawTree ParseTree where
put' x = modify $ modElem $ const x enter (_ :> _ :> _) (ParseTree ty cs s) = do
let (comms, rest) = allComments cs
let (comms1, _) = allComments $ reverse rest
modify $ first (++ comms)
modify $ second (++ reverse comms1)
mod' :: forall x. Contains x PList => (x -> x) -> Parser () let errs = allErrors cs
mod' = modify . modElem tell $ fmap Err errs
-- | Generate error originating at current location. leave _ _ = do
makeError :: Text -> Parser (Error ASTInfo) modify \(x, y) -> (y, [])
makeError msg = do
rng <- getInfo
makeError' msg rng
-- | Generate error originating at given location. grabComments :: ParserM [Text]
makeError' :: Text -> info -> Parser (Error info)
makeError' msg i = do
src <- gets' pfGrove <&> \case
[] -> ""
(,) _ ParseTree { ptSource } : _ -> ptSource
return Expected
{ eMsg = msg
, eWhole = src
, eInfo = i
}
-- | Pick next tree in a forest or die with msg.
takeNext :: Text -> Parser ParseTree
takeNext msg = do
gets' pfGrove >>= \case
[] -> die msg
(_, t) : f -> do
if "comment" `Text.isSuffixOf` ptName t
then do
mod' (ptSource t :)
takeNext msg
else do
mod' \st -> st
{ pfRange = diffRange (pfRange st) (ptRange t)
, pfGrove = f
}
return t
--fields :: Text -> Parser a -> Parser [a]
--fields name parser = do
-- (fs, rest) <- gets $ splitForest name . fst
-- res <- for fs \f -> do
-- put f
-- parser
--
-- put rest
-- return res
--
--splitForest :: Text -> ParseForest -> [ParseForest]
--splitForest name = go . pfGrove
-- where
-- go [] acc fs = (fs, acc)
-- go ((tName, tree) : other) acc fs =
-- if tName == name
-- then go other [] (reverse (tree : acc) : fs)
-- else go other (tree : acc) fs
-- | Pick a tree with that /field name/ or die with name as msg.
--
-- Will erase all subtrees with different names on the path!
--
field :: Text -> Parser a -> Parser a
field name parser = do
gets' pfGrove >>= \case
(name', t) : _
| name == name' -> do
sandbox True t
grove -> do
case lookup name grove of
Just tree -> sandbox False tree
Nothing -> die name
where
sandbox firstOne tree@ParseTree {ptID, ptRange} = do
st@Forest {pfGrove = grove, pfRange = rng} <- get'
let (errs, new_comments, grove') = delete name grove
mod' (++ new_comments)
put' Forest
{ pfID = ptID
, pfGrove = [(name, tree)]
, pfRange = ptRange
}
res <- parser
put' st
{ pfGrove = grove'
, pfRange = if firstOne then diffRange rng ptRange else rng
}
put' @[Text] []
for_ errs (tell . pure . unexpected)
return res
fallback :: Stubbed a ASTInfo => Text -> Parser a
fallback msg = pure . stub =<< makeError msg
-- | Produce "expected ${X}" error at this point.
die :: Text -> Parser a
die msg = throwM =<< makeError msg
die' ::Text -> ASTInfo -> Parser a
die' msg rng = throwM =<< makeError' msg rng
-- | When tree-sitter found something it was unable to process.
unexpected :: ParseTree -> Error ASTInfo
unexpected ParseTree { ptSource, ptRange } =
Expected "not that" ptSource (Cons ptRange $ Cons [] Nil)
-- | If a parser fails, return stub with error originating here.
stubbed :: Stubbed a ASTInfo => Text -> Parser a -> Parser a
stubbed msg parser = do
parser <|> fallback msg
-- | The forest must start with tree of that name. Its subtrees become new
-- forest. Otherwise, it dies with name as msg.
subtree :: Text -> Parser a -> Parser a
subtree msg parser = do
ParseTree {ptChildren, ptName} <- takeNext msg
if ptName == msg
then do
save <- get' @ParseForest
put' ptChildren
rest <- gets' pfGrove
collectErrors rest
parser <* put' save
else do
die msg
-- | Because `ExceptT` requires error to be `Monoid` for `Alternative`.
(<|>) :: Parser a -> Parser a -> Parser a
l <|> r = do
s <- get' @ParseForest
c <- get' @[Text]
l `catch` \(_ :: Error ASTInfo) -> do
put' s
put' c
r
-- | Custom @foldl1 (<|>)@.
select :: [Parser a] -> Parser a
select = foldl1 (<|>)
-- | Custom @optionMaybe@.
optional :: Parser a -> Parser (Maybe a)
optional p = fmap Just p <|> return Nothing
-- | Custom `Alternative.many`.
--
-- TODO: remove, replace with `fields` combinator.
--
many :: Parser a -> Parser [a]
many p = many'
where
many' = some' <|> pure []
some' = do
x <- p
xs <- many'
return (x : xs)
-- | Custom `Alternative.some`.
--
some :: Parser a -> Parser [a]
some p = some'
where
many' = some' <|> pure []
some' = do
x <- p
xs <- many'
return (x : xs)
-- | Run parser on given file and pretty-print stuff.
--
debugParser :: (Show a, Stubbed a ASTInfo) => Parser a -> Source -> IO ()
debugParser parser fin = do
(res, errs) <- runParser parser fin
putStrLn "Result:"
print res
MTL.unless (null errs) do
putStrLn ""
putStrLn "Errors:"
for_ errs (print . nest 2 . pp)
-- | Consume next tree if it has the given name. Or die.
token :: Text -> Parser Text
token node = do
i <- getInfo
ParseTree {ptName, ptSource} <- takeNext node
if ptName == node
then return ptSource
else die' node i
-- | Consume next tree, return its textual representation.
anything :: Parser Text
anything = do
tree <- takeNext "anything"
return $ ptSource tree
-- | Get range of the current tree (or forest) before the parser was run.
range :: Parser a -> Parser (a, Range)
range parser =
get' >>= \case
Forest {pfGrove = [(,) _ ParseTree {ptRange}]} -> do
a <- parser
return (a, ptRange)
Forest {pfRange} -> do
a <- parser
return (a, pfRange)
-- | Get current range.
currentRange :: Parser Range
currentRange = snd <$> range (return ())
-- | Remove all keys until given key is found; remove the latter as well.
--
-- Also returns all ERROR-nodes.
--
-- TODO: rename.
--
-- Notice: this works differently from `Prelude.remove`!
--
delete :: Text -> [(Text, ParseTree)] -> ([ParseTree], [Text], [(Text, ParseTree)])
delete _ [] = ([], [], [])
delete k ((k', v) : rest) =
if k == k'
then (addIfError v [], addIfComment v [], rest)
else (addIfError v vs, addIfComment v cs, remains)
where
(vs, cs, remains) = delete k rest
addIfError v' =
if ptName v' == "ERROR"
then (:) v'
else id
addIfComment v' =
if "comment" `Text.isSuffixOf` ptName v'
then (ptSource v' :)
else id
-- | Report all ERRORs from the list.
collectErrors :: [(Text, ParseTree)] -> Parser ()
collectErrors vs =
for_ vs \(_, v) -> do
MTL.when (ptName v == "ERROR") do
tell [unexpected v]
-- | Universal accessor.
--
-- Usage:
--
-- > inside "$field:$treename"
-- > inside "$field"
-- > inside ":$treename" -- don't, use "subtree"
--
inside :: Stubbed a ASTInfo => Text -> Parser a -> Parser a
inside sig parser = do
let (f, st') = Text.breakOn ":" sig
let st = Text.drop 1 st'
if Text.null f
then do
-- The order is important.
subtree st do
stubbed f do
parser
else do
field f do
stubbed f do
if Text.null st
then do
parser
else do
subtree st do
parser
-- | Equip given constructor with info.
getInfo :: Parser ASTInfo
getInfo = Cons <$> currentRange <*> do Cons <$> grabComments <*> pure Nil
-- | Take the accumulated comments, clean the accumulator.
grabComments :: Parser [Text]
grabComments = do grabComments = do
comms <- get' ls <- gets fst
mod' @[Text] $ const [] modify \(x, y) -> ([], y)
return comms return ls
-- | /Actual/ debug pring. allComments :: [RawTree] -> ([Text], [RawTree])
dump :: Parser () allComments = first (map getBody . filter isComment) . break isMeaningful
dump = gets' pfGrove >>= traceShowM where
isMeaningful :: RawTree -> Bool
isMeaningful (extract -> _ :> "" :> _) = False
isMeaningful _ = True
isComment :: RawTree -> Bool
isComment (gist -> ParseTree ty _ _) = "comment" `Text.isSuffixOf` ty
allErrors :: [RawTree] -> [Text]
allErrors = map getBody . filter isUnnamedError
where
isUnnamedError :: RawTree -> Bool
isUnnamedError tree = case only tree of
(r :> "" :> _, ParseTree "ERROR" _ _) -> True
_ -> False
getBody (gist -> f) = ptSource f
field :: Text -> ParserM1 RawTree
field name =
fieldOpt name
>>= maybe (throwM $ Failure [i|Cannot find field #{name}|]) return
fieldOpt :: Text -> ParserM1 (Maybe RawTree)
fieldOpt name = ask >>= go
where
go (tree@(extract -> _ :> n :> _) : rest)
| n == name = return (Just tree)
| otherwise = go rest
go [] = return Nothing
fields :: Text -> ParserM1 [RawTree]
fields name = ask >>= go
where
go (tree@(extract -> _ :> n :> _) : rest) =
(if n == name then ((tree :) <$>) else id)
$ go rest
go [] = return []
data ShowRange
= Y | N
deriving stock Eq
type Info = Product [[Text], Range, ShowRange]
type PreInfo = Product [Range, ShowRange]
instance Modifies Info where
ascribe (comms :> r :> pin :> _) = ascribeRange r pin . ascribeComms comms
ascribeComms comms
| null comms = id
| otherwise = \d ->
block $ map (pp . Text.init) comms ++ [d]
ascribeRange r Y = (pp r $$)
ascribeRange _ _ = id
withComments :: ParserM (Maybe (Product xs, a)) -> ParserM (Maybe (Product ([Text] : xs), a))
withComments act = do
comms <- grabComments
res <- act
return $ fmap (first (comms :>)) res
boilerplate
:: (Text -> ParserM1 (f RawTree))
-> (RawInfo, ParseTree RawTree)
-> ParserM (Maybe (Info, f RawTree))
boilerplate f (r :> _, ParseTree ty cs _) = do
withComments do
mbf <- runParserM1 cs $ f ty
return do
f <- mbf
return $ (r :> N :> Nil, f)
boilerplate'
:: ((Text, Text) -> ParserM1 (f RawTree))
-> (RawInfo, ParseTree RawTree)
-> ParserM (Maybe (Info, f RawTree))
boilerplate' f (r :> _, ParseTree ty cs src) = do
withComments do
mbf <- runParserM1 cs $ f (ty, src)
return do
f <- mbf
return $ (r :> N :> Nil, f)
fallthrough :: MonadFail m => m a
fallthrough = fail ""

142
tools/lsp/squirrel/src/Pretty.hs
View File

@ -1,142 +0,0 @@
{- |
Pretty printer, a small extension of GHC `pretty` package.
-}
module Pretty
( -- * Output `Text`
ppToText
-- * `Show` instance generator
, PP(..)
-- * Interfaces
, Pretty(..)
, Pretty1(..)
-- * Helpers
, tuple
, list
, indent
, above
, train
, block
, sepByDot
, mb
, sparseBlock
, color
-- * Full might of pretty printing
, module Text.PrettyPrint
)
where
import Data.Sum
import qualified Data.Text as Text
import Data.Text (Text, pack)
import Text.PrettyPrint hiding ((<>))
import Product
-- | Pretty-print to `Text`. Through `String`. Yep.
ppToText :: Pretty a => a -> Text
ppToText = pack . show . pp
-- | With this, one can `data X = ...; derive Show via PP X`
newtype PP a = PP { unPP :: a }
instance Pretty a => Show (PP a) where
show = show . pp . unPP
-- | Pretty-printable types.
class Pretty p where
pp :: p -> Doc
-- | Pretty-printable `Functors`.
class Pretty1 p where
pp1 :: p Doc -> Doc
instance Pretty1 (Sum '[]) where
pp1 = error "Sum.empty"
instance (Pretty1 f, Pretty1 (Sum fs)) => Pretty1 (Sum (f : fs)) where
pp1 = either pp1 pp1 . decompose
instance Pretty () where
pp _ = "-"
instance (Pretty1 p, Functor p, Pretty a) => Pretty (p a) where
pp = pp1 . fmap pp
instance Pretty1 [] where
pp1 = list
instance Pretty1 Maybe where
pp1 = maybe empty pp
instance {-# OVERLAPS #-} (Pretty a, Pretty b) => Pretty (Either a b) where
pp = either pp pp
instance Pretty Int where
pp = int
-- | Common instance.
instance Pretty Text where
pp = text . Text.unpack
-- | Common instance.
instance Pretty Doc where
pp = id
-- | Decorate list of stuff as a tuple.
tuple :: Pretty p => [p] -> Doc
tuple = parens . train ","
-- | Decorate list of stuff as a list.
list :: Pretty p => [p] -> Doc
list = brackets . train ";"
infixr 2 `indent`
-- | First argument is a header to an indented second one.
indent :: Doc -> Doc -> Doc
indent a b = hang a 2 b
infixr 1 `above`
-- | Horisontal composition.
above :: Doc -> Doc -> Doc
above a b = hang a 0 b
-- | Pretty print as a sequence with given separator.
train :: Pretty p => Doc -> [p] -> Doc
train sep' = fsep . punctuate sep' . map pp
-- | Pretty print as a vertical block.
block :: Pretty p => [p] -> Doc
block = foldr ($+$) empty . map pp
-- | For pretty-printing qualified names.
sepByDot :: Pretty p => [p] -> Doc
sepByDot = cat . map (("." <>) . pp)
-- | For pretty-printing `Maybe`s.
mb :: Pretty a => (Doc -> Doc) -> Maybe a -> Doc
mb f = maybe empty (f . pp)
-- | Pretty print as a vertical with elements separated by newline.
sparseBlock :: Pretty a => [a] -> Doc
sparseBlock = vcat . punctuate "\n" . map (($$ empty) . pp)
type Color = Int
color :: Color -> Doc -> Doc
color c d = zeroWidthText begin <> d <> zeroWidthText end
where
begin = "\x1b[" ++ show (30 + c) ++ "m"
end = "\x1b[0m"
instance Pretty (Product '[]) where
pp _ = "{}"
instance (Pretty x, Pretty (Product xs)) => Pretty (Product (x : xs)) where
pp (Cons x xs) = pp x <+> "&" <+> pp xs

38
tools/lsp/squirrel/src/Product.hs
View File

@ -6,11 +6,15 @@ module Product where
import GHC.Types import GHC.Types
import Duplo.Pretty
-- | `Product xs` contains elements of each of the types from the `xs` list. -- | `Product xs` contains elements of each of the types from the `xs` list.
data Product xs where data Product xs where
Cons :: x -> Product xs -> Product (x : xs) (:>) :: x -> Product xs -> Product (x : xs)
Nil :: Product '[] Nil :: Product '[]
infixr 5 :>
-- | Find/modify the element with a given type. -- | Find/modify the element with a given type.
-- --
-- If you want to have same-types, use newtype wrappers. -- If you want to have same-types, use newtype wrappers.
@ -20,12 +24,12 @@ class Contains x xs where
modElem :: (x -> x) -> Product xs -> Product xs modElem :: (x -> x) -> Product xs -> Product xs
instance {-# OVERLAPS #-} Contains x (x : xs) where instance {-# OVERLAPS #-} Contains x (x : xs) where
getElem (Cons x _) = x getElem (x :> _) = x
modElem f (Cons x xs) = Cons (f x) xs modElem f (x :> xs) = f x :> xs
instance Contains x xs => Contains x (y : xs) where instance Contains x xs => Contains x (y : xs) where
getElem (Cons _ xs) = getElem xs getElem (_ :> xs) = getElem xs
modElem f (Cons x xs) = Cons x (modElem f xs) modElem f (x :> xs) = x :> modElem f xs
-- | Add a name to the type. -- | Add a name to the type.
-- --
@ -44,3 +48,27 @@ modTag
=> (t -> t) => (t -> t)
-> Product xs -> Product xs -> Product xs -> Product xs
modTag f = modElem @(s := t) (Tag . f . unTag) modTag f = modElem @(s := t) (Tag . f . unTag)
instance Eq (Product '[]) where
_ == _ = True
instance (Eq x, Eq (Product xs)) => Eq (Product (x : xs)) where
x :> xs == y :> ys = and [x == y, xs == ys]
-- instance Modifies (Product xs) where
-- ascribe _ = id
class PrettyProd xs where
ppProd :: Product xs -> Doc
instance {-# OVERLAPS #-} Pretty x => PrettyProd '[x] where
ppProd (x :> Nil) = pp x
instance (Pretty x, PrettyProd xs) => PrettyProd (x : xs) where
ppProd (x :> xs) = pp x <.> "," <+> ppProd xs
instance Pretty (Product '[]) where
pp Nil = "{}"
instance PrettyProd xs => Pretty (Product xs) where
pp = braces . ppProd

21
tools/lsp/squirrel/src/Range.hs
View File

@ -16,8 +16,9 @@ import Data.ByteString (ByteString)
import Data.Text (Text) import Data.Text (Text)
import Data.Text.Encoding import Data.Text.Encoding
import Pretty import Duplo.Lattice
import Lattice import Duplo.Pretty
import Product import Product
point :: Int -> Int -> Range point :: Int -> Int -> Range
@ -40,11 +41,11 @@ instance Pretty Range where
pp (Range (ll, lc, _) (rl, rc, _) f) = pp (Range (ll, lc, _) (rl, rc, _) f) =
color 2 do color 2 do
brackets do brackets do
text f <> ":" text f <.> ":"
<> int ll <> ":" <.> int ll <.> ":"
<> int lc <> "-" <.> int lc <.> "-"
<> int rl <> ":" <.> int rl <.> ":"
<> int rc <.> int rc
-- | Ability to get range out of something. -- | Ability to get range out of something.
class HasRange a where class HasRange a where
@ -65,10 +66,14 @@ cutOut (Range (_, _, s) (_, _, f) _) bs =
bs bs
instance Lattice Range where instance Lattice Range where
Range (ll1, lc1, _) (ll2, lc2, _) _ <? Range (rl1, rc1, _) (rl2, rc2, _) _ = Range (ll1, lc1, _) (ll2, lc2, _) _
`leq` Range (rl1, rc1, _) (rl2, rc2, _) _ =
(rl1 < ll1 || rl1 == ll1 && rc1 <= lc1) && (rl1 < ll1 || rl1 == ll1 && rc1 <= lc1) &&
(rl2 > ll2 || rl2 == ll2 && rc2 >= lc2) (rl2 > ll2 || rl2 == ll2 && rc2 >= lc2)
instance Eq Range where instance Eq Range where
Range (l, c, _) (r, d, _) f == Range (l1, c1, _) (r1, d1, _) f1 = Range (l, c, _) (r, d, _) f == Range (l1, c1, _) (r1, d1, _) f1 =
(l, c, r, d, f) == (l1, c1, r1, d1, f1) (l, c, r, d, f) == (l1, c1, r1, d1, f1)
instance (Contains Range xs, Eq (Product xs)) => Lattice (Product xs) where
a `leq` b = getElem @Range a `leq` getElem @Range b

242
tools/lsp/squirrel/src/Tree.hs
View File

@ -1,242 +0,0 @@
{- | The carrier type for AST.
"Untypedness" of the tree is a payoff to ablity to stop and navigate
anywhere, not just inside the expression context.
Is a `Functor` and `Foldable` over its @info@ parameter.
Is not `Traversable`, because this will definitely not preserve scope.
Use `updateTree` instead of `traverse`/`for`.
-}
module Tree
-- ( -- * Tree type
-- Tree
-- , lookupTree
-- , traverseTree
-- , mk
-- , infoOf
-- -- * Callbacks on update
-- , UpdateOver (..)
-- , skip
-- )
where
import Data.Foldable
-- import Data.List
import Data.Sum
import Data.Monoid (First(..), getFirst)
import Lattice
import Comment
import Pretty
import Error
import Range
import Debug.Trace
-- | A tree, where each layer is one of @layers@ `Functor`s.
--
-- Is equipped with @info@.
--
-- Can contain `Error` instead of all the above.
--
newtype Tree layers info = Tree
{ unTree :: Either (Error info) (info, Sum layers (Tree layers info))
}
dumpTree
:: (Apply Functor layers, Apply Foldable layers, HasComments info, Pretty1 (Sum layers), Pretty info)
=> Tree layers info
-> Doc
dumpTree (Tree tree) =
case tree of
Left _ -> "ERR"
Right (_, ls) ->
pp (Tree tree) `indent` block (dumpTree <$> toList ls)
instance Apply Functor layers => Functor (Tree layers) where
fmap f = go
where
go (Tree (Left err)) = Tree $ Left $ fmap f err
go (Tree (Right (a, rest))) = Tree $ Right (f a, fmap go rest)
instance Apply Foldable layers => Foldable (Tree layers) where
foldMap f = go
where
go (Tree (Left err)) = foldMap f err
go (Tree (Right (a, rest))) = f a <> foldMap go rest
instance
( Apply Traversable layers
, Apply Foldable layers
, Apply Functor layers
)
=>
Traversable (Tree layers)
where
traverse f = go
where
go (Tree (Left err)) = (Tree . Left) <$> traverse f err
go (Tree (Right (a, rest))) = do
a' <- f a
rest' <- (traverse.traverse) f rest
return $ Tree $ Right (a', rest')
instance
( Apply Functor layers
, HasComments info
, Pretty1 (Sum layers)
, Pretty info
)
=>
Show (Tree layers info)
where
show = show . pp
instance {-# OVERLAPS #-}
( HasComments info
, Apply Functor fs
, Pretty1 (Sum fs)
, Pretty info
)
=>
Pretty (Tree fs info)
where
pp = go
where
go (Tree (Left err)) = pp err
go (Tree (Right (info, fTree))) = c info $ pp fTree
-- | Return all subtrees that cover the range, ascending in size.
lookupTree
:: forall fs info
. ( Apply Foldable fs
, Apply Functor fs
, HasRange info
-- , HasComments info
-- , Pretty1 (Sum fs)
-- , Pretty info
)
=> Range
-> Tree fs info
-> Maybe (Tree fs info)
lookupTree target = go
where
go :: Tree fs info -> Maybe (Tree fs info)
go tree = do
if target <? getRange (infoOf tree)
then getFirst $ foldMap (First . go) (layers tree) <> First (Just tree)
else Nothing
layers :: (Apply Foldable fs) => Tree fs info -> [Tree fs info]
layers (Tree (Right (_, ls))) = toList ls
layers _ = []
-- | Traverse the tree over some monad that exports its methods.
--
-- For each tree piece, will call `before` and `after` callbacks.
--
traverseTree
:: ( UpdateOver m (Sum fs) (Tree fs a)
, Apply Foldable fs
, Apply Functor fs
, Apply Traversable fs
, HasRange a
)
=> (a -> m b) -> Tree fs a -> m (Tree fs b)
traverseTree act = go
where
go (Tree (Right (a, union))) = do
b <- act a
before (getRange a) union
union' <- traverse go union
after (getRange a) union
return (Tree (Right (b, union')))
go (Tree (Left err)) = do
err' <- traverse act err
return (Tree (Left err'))
data Visit fs a b m where
Visit
:: (Element f fs, Traversable f)
=> (a -> f (Tree fs a) -> m (b, f (Tree fs a)))
-> Visit fs a b m
traverseMany
:: ( Apply Functor fs
, Apply Foldable fs
, Apply Traversable fs
, Monad m
)
=> [Visit fs a b m]
-> (a -> b)
-> Tree fs a
-> m (Tree fs b)
traverseMany visitors orElse = go
where
go tree = aux visitors
where
aux (Visit visitor : rest) = do
case match tree of
Just (r, fa) -> do
(r', fa') <- visitor r fa
fa'' <- traverse go fa'
return $ mk r' fa''
Nothing -> do
aux rest
aux [] = do
case tree of
Tree (Right (r, union)) -> do
union' <- traverse go union
return $ Tree $ Right (orElse r, union')
Tree (Left err) -> do
return $ Tree $ Left $ fmap orElse err
-- | Make a tree out of a layer and an info.
mk :: (Functor f, Element f fs) => info -> f (Tree fs info) -> Tree fs info
mk i fx = Tree $ Right (i, inject fx)
match
:: (Functor f, Element f fs)
=> Tree fs info
-> Maybe (info, f (Tree fs info))
match (Tree (Left _)) = Nothing
match (Tree (Right (r, it))) = do
f <- project it
return (r, f)
-- | Get info from the tree.
infoOf :: Tree fs info -> info
infoOf = either eInfo fst . unTree
instance Stubbed (Tree fs info) info where
stub = Tree . Left
instance Apply Foldable fs => HasErrors (Tree fs info) info where
errors = go
where
go (Tree (Left err)) = pure err
go (Tree (Right (_, rest))) = foldMap go rest
-- | Update callbacks for a @f a@ while working inside monad @m@.
class Monad m => UpdateOver m f a where
before :: Range -> f a -> m ()
after :: Range -> f a -> m ()
before _ _ = skip
after _ _ = skip
-- | Do nothing.
skip :: Monad m => m ()
skip = return ()
instance Monad m => UpdateOver m (Sum '[]) a where
before = error "Sum.empty"
after = error "Sum.empty"
instance (UpdateOver m f a, UpdateOver m (Sum fs) a) => UpdateOver m (Sum (f : fs)) a where
before r = either (before r) (before r) . decompose
after r = either (after r) (after r) . decompose

4
tools/lsp/squirrel/stack.yaml
View File

@ -40,8 +40,8 @@ extra-deps:
- lingo-0.3.2.0@sha256:80b9ded65f2ddc0272a2872d9c3fc43c37934accae076d3e547dfc6c6b6e16d3,1899 - lingo-0.3.2.0@sha256:80b9ded65f2ddc0272a2872d9c3fc43c37934accae076d3e547dfc6c6b6e16d3,1899
- semilattices-0.0.0.4@sha256:333707e460923711d1edbdd02ebe1c3957d4e0808eab9886747b52ee3e443639,1909 - semilattices-0.0.0.4@sha256:333707e460923711d1edbdd02ebe1c3957d4e0808eab9886747b52ee3e443639,1909
- fastsum-0.1.1.1 - fastsum-0.1.1.1
- git: https://github.com/Heimdell/dual-effects.git - git: https://github.com/serokell/duplo.git
commit: dc3e8bcd0aa00b9264e86293ec42c0b5835e930c commit: 8fb7a22d0e6ff75ec049c36c6f767ee14e841446
# - acme-missiles-0.3 # - acme-missiles-0.3
# - git: https://github.com/commercialhaskell/stack.git # - git: https://github.com/commercialhaskell/stack.git
# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a # commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a

17
tools/lsp/squirrel/stack.yaml.lock
View File

@ -40,19 +40,16 @@ packages:
original: original:
hackage: fastsum-0.1.1.1 hackage: fastsum-0.1.1.1
- completed: - completed:
cabal-file: name: duplo
size: 1569
sha256: 828a5bc60b97347d491038b435da664ae281a6dab26e9beb261d319c2601c4dc
name: eff
version: 0.0.0 version: 0.0.0
git: https://github.com/Heimdell/dual-effects.git git: https://github.com/serokell/duplo.git
pantry-tree: pantry-tree:
size: 972 size: 557
sha256: 4443705f2fc31929822a3cda4036f9a93950686f4729cd28280253e981828391 sha256: b5d8c86a8a26bc2efc0f86314317fa36b5f57c5d44cb889bee58f10782767037
commit: dc3e8bcd0aa00b9264e86293ec42c0b5835e930c commit: 8fb7a22d0e6ff75ec049c36c6f767ee14e841446
original: original:
git: https://github.com/Heimdell/dual-effects.git git: https://github.com/serokell/duplo.git
commit: dc3e8bcd0aa00b9264e86293ec42c0b5835e930c commit: 8fb7a22d0e6ff75ec049c36c6f767ee14e841446
snapshots: snapshots:
- completed: - completed:
size: 493124 size: 493124