[WIP] Conversion to descent-based parser
This commit is contained in:
Kirill Andreev
parent
3233270dba
commit
b5e5bc25a1
@ -1,6 +1,6 @@
|
||||
(* 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 =
|
||||
("tz1KqTpEZ7Yob7QbPE4Hy4Wo8fHG8LhKxZSx" : address)
|
||||
|
||||
@ -1,3 +1,5 @@
|
||||
// this is a
|
||||
// function!!1
|
||||
function mod_op (const n : int) : nat is n mod 42
|
||||
function plus_op (const n : int) : int is n + 42
|
||||
function minus_op (const n : int) : int is n - 42
|
||||
|
||||
@ -123,7 +123,16 @@ function buy_single (const action : action_buy_single;
|
||||
|
||||
function main (const action : parameter; const s : storage) : return is
|
||||
case action of
|
||||
Buy_single (bs) -> buy_single (bs, s)
|
||||
| Sell_single (as) -> sell_single (as, s)
|
||||
| Transfer_single (at) -> transfer_single (at, s)
|
||||
| None -> (failwith (""))
|
||||
| Some (x) -> skip
|
||||
| Buy_single (bs) -> buy_single (bs, s)
|
||||
| Ex -> Ex(Ex)
|
||||
end
|
||||
|
||||
type parameter is
|
||||
Buy_single of action_buy_single
|
||||
| Sell_single of action_sell_single
|
||||
| Transfer_single of action_transfer_single
|
||||
|
||||
|
||||
@ -30,3 +30,5 @@ function nested_record (var nee : nested_record_t) : string is
|
||||
Some (s) -> s
|
||||
| None -> (failwith ("Should not happen.") : string)
|
||||
end
|
||||
|
||||
const tuple : int * (int * (int * int)) = (0,(1,(2,3)))
|
||||
@ -1,11 +1,12 @@
|
||||
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
|
||||
|
||||
function main (const action : unit; const store : storage) : return is
|
||||
block {
|
||||
block {
|
||||
const foo : storage = (M_right ("one") : storage);
|
||||
const bar : foobar = (M_right (1) : foobar)
|
||||
} 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")
|
||||
|
||||
@ -16,3 +16,5 @@ function cbo (const a : address; const s : storage) : return is
|
||||
| None -> (failwith ("cbo: Entrypoint not found.") : contract (unit))
|
||||
end
|
||||
} with (list [Tezos.transaction (unit, 0tez, c)], s)
|
||||
|
||||
const x : option (int) = 1
|
||||
@ -39,5 +39,7 @@ function foobar (const i : int) : int is
|
||||
end
|
||||
|
||||
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
|
||||
|
||||
@ -99,5 +99,6 @@ function pop (const h : heap) : heap * heap_elt * nat is
|
||||
h[left] := tmp
|
||||
} else skip
|
||||
} else skip
|
||||
}
|
||||
} with (h, result, c)
|
||||
};
|
||||
while False block { skip; }
|
||||
} with (h, result, c)
|
||||
|
||||
@ -31,3 +31,5 @@ function map_op (const s : list (int)) : list (int) is
|
||||
block {
|
||||
function increment (const i : int) : int is i+1
|
||||
} with List.map (increment, s)
|
||||
|
||||
const fb2 : foobar = 144 # fb
|
||||
|
||||
@ -195,3 +195,15 @@ function inner_capture_in_conditional_block (var nee : unit) : bool * int is
|
||||
count := count + 1
|
||||
}
|
||||
} 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
|
||||
|
||||
|
||||
@ -16,5 +16,5 @@ function shadowing_assigned_in_body (var nee : unit) : string is block {
|
||||
var st : string := "ta";
|
||||
st := st ^ x;
|
||||
}
|
||||
} with st
|
||||
} with st ^ 1
|
||||
(* should be "toto" ??? *)
|
||||
|
||||
@ -34,4 +34,5 @@ function match_expr_list (const l : list (int)) : int is
|
||||
case l of
|
||||
nil -> -1
|
||||
| hd # tl -> hd
|
||||
| list [1; 2; foo] -> foo
|
||||
end
|
||||
|
||||
@ -63,4 +63,7 @@ function check_message (const param : check_message_pt;
|
||||
} with (message (unit), s)
|
||||
|
||||
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
|
||||
|
||||
@ -8,3 +8,5 @@ const cards : cards = record [cards = cards]
|
||||
const cards : cards = cards with record [cards = cards]
|
||||
|
||||
const cards : cards = cards.cards
|
||||
|
||||
const cards : cards = cards with record [cards.foo.0.bar = cards]
|
||||
|
||||
@ -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
|
||||
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
|
||||
|
||||
|
||||
@ -56,7 +56,7 @@ module.exports = grammar({
|
||||
extras: $ => [$.ocaml_comment, $.comment, /\s/],
|
||||
|
||||
rules: {
|
||||
contract: $ => sepBy(optional(';'), field("declaration", $._declaration)),
|
||||
Start: $ => sepBy(optional(';'), field("declaration", $._declaration)),
|
||||
|
||||
_declaration: $ =>
|
||||
choice(
|
||||
@ -80,30 +80,31 @@ module.exports = grammar({
|
||||
field("typeValue", $._type_expr),
|
||||
),
|
||||
|
||||
type_expr : $ => $._type_expr,
|
||||
|
||||
_type_expr: $ =>
|
||||
choice(
|
||||
$.fun_type,
|
||||
$._fun_type,
|
||||
$.sum_type,
|
||||
$.record_type,
|
||||
),
|
||||
|
||||
fun_type: $ =>
|
||||
_fun_type: $ =>
|
||||
choice(
|
||||
$.fun_type,
|
||||
$.cartesian
|
||||
),
|
||||
|
||||
fun_type: $ =>
|
||||
seq(
|
||||
field("domain", $.cartesian),
|
||||
seq(
|
||||
field("domain", $.cartesian),
|
||||
'->',
|
||||
field("codomain", $.fun_type),
|
||||
),
|
||||
'->',
|
||||
field("codomain", $._fun_type),
|
||||
),
|
||||
|
||||
cartesian: $ =>
|
||||
sepBy1('*',
|
||||
choice(
|
||||
field("element", $._core_type),
|
||||
par(field("element", $.type_expr)),
|
||||
par(field("element", $._type_expr)),
|
||||
),
|
||||
),
|
||||
|
||||
@ -112,17 +113,47 @@ module.exports = grammar({
|
||||
$.TypeName,
|
||||
$.invokeBinary,
|
||||
$.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: $ =>
|
||||
seq(
|
||||
field("typeConstr", choice('map', 'big_map', $.TypeName)),
|
||||
field("typeConstr", choice('map', 'big_map')),
|
||||
field("arguments", $.type_tuple),
|
||||
),
|
||||
|
||||
invokeUnary: $ =>
|
||||
seq(
|
||||
field("typeConstr", choice('list', 'set')),
|
||||
field("typeConstr", choice('list', 'set', 'option', 'contract')),
|
||||
par(field("arguments", $._type_expr)),
|
||||
),
|
||||
|
||||
@ -145,7 +176,7 @@ module.exports = grammar({
|
||||
seq(
|
||||
field("constructor", $.constr),
|
||||
'of',
|
||||
field("arguments", $.fun_type)
|
||||
field("arguments", $._fun_type)
|
||||
),
|
||||
),
|
||||
|
||||
@ -185,17 +216,20 @@ module.exports = grammar({
|
||||
':',
|
||||
field("type", $._type_expr),
|
||||
'is',
|
||||
field("body", $.let_expr),
|
||||
field("body", $._let_expr),
|
||||
),
|
||||
),
|
||||
|
||||
let_expr: $ =>
|
||||
_let_expr: $ =>
|
||||
choice(
|
||||
seq(
|
||||
field("locals", $.block),
|
||||
'with',
|
||||
field("body", $._expr),
|
||||
),
|
||||
$.let_expr,
|
||||
$._expr,
|
||||
),
|
||||
|
||||
let_expr: $ =>
|
||||
seq(
|
||||
field("locals", $.block),
|
||||
'with',
|
||||
field("body", $._expr),
|
||||
),
|
||||
|
||||
@ -203,15 +237,15 @@ module.exports = grammar({
|
||||
|
||||
param_decl: $ =>
|
||||
seq(
|
||||
field("access", $.access),
|
||||
field("access", $._access),
|
||||
field("name", $.Name),
|
||||
':',
|
||||
field("type", $._param_type),
|
||||
),
|
||||
|
||||
access: $ => choice('var', 'const'),
|
||||
_access: $ => choice('var', 'const'),
|
||||
|
||||
_param_type: $ => $.fun_type,
|
||||
_param_type: $ => $._fun_type,
|
||||
|
||||
_statement: $ =>
|
||||
choice(
|
||||
@ -252,7 +286,7 @@ module.exports = grammar({
|
||||
$.conditional,
|
||||
$.case_instr,
|
||||
$.assignment,
|
||||
$.loop,
|
||||
$._loop,
|
||||
$._proc_call,
|
||||
$.skip,
|
||||
$.record_patch,
|
||||
@ -268,7 +302,7 @@ module.exports = grammar({
|
||||
field("key", $._expr),
|
||||
'from',
|
||||
'set',
|
||||
field("container", $.path),
|
||||
field("container", $._path),
|
||||
),
|
||||
|
||||
map_remove: $ =>
|
||||
@ -277,13 +311,13 @@ module.exports = grammar({
|
||||
field("key", $._expr),
|
||||
'from',
|
||||
'map',
|
||||
field("container", $.path),
|
||||
field("container", $._path),
|
||||
),
|
||||
|
||||
set_patch: $ =>
|
||||
seq(
|
||||
'patch',
|
||||
field("container", $.path),
|
||||
field("container", $._path),
|
||||
'with',
|
||||
ne_injection('set', field("key", $._expr)),
|
||||
),
|
||||
@ -291,7 +325,7 @@ module.exports = grammar({
|
||||
map_patch: $ =>
|
||||
seq(
|
||||
'patch',
|
||||
field("container", $.path),
|
||||
field("container", $._path),
|
||||
'with',
|
||||
ne_injection('map', field("binding", $.binding)),
|
||||
),
|
||||
@ -306,7 +340,7 @@ module.exports = grammar({
|
||||
record_patch: $ =>
|
||||
seq(
|
||||
'patch',
|
||||
field("container", $.path),
|
||||
field("container", $._path),
|
||||
'with',
|
||||
ne_injection('record', field("binding", $.field_assignment)),
|
||||
),
|
||||
@ -319,13 +353,13 @@ module.exports = grammar({
|
||||
'if',
|
||||
field("selector", $._expr),
|
||||
'then',
|
||||
field("then", $.if_clause),
|
||||
field("then", $._if_clause),
|
||||
optional(';'),
|
||||
'else',
|
||||
field("else", $.if_clause),
|
||||
field("else", $._if_clause),
|
||||
),
|
||||
|
||||
if_clause: $ =>
|
||||
_if_clause: $ =>
|
||||
choice(
|
||||
$._instruction,
|
||||
$.clause_block,
|
||||
@ -375,9 +409,9 @@ module.exports = grammar({
|
||||
|
||||
case_clause_instr: $ =>
|
||||
seq(
|
||||
field("pattern", $.pattern),
|
||||
field("pattern", $._pattern),
|
||||
'->',
|
||||
field("body", $.if_clause),
|
||||
field("body", $._if_clause),
|
||||
),
|
||||
|
||||
assignment: $ =>
|
||||
@ -388,9 +422,9 @@ module.exports = grammar({
|
||||
),
|
||||
|
||||
_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: $ =>
|
||||
seq(
|
||||
@ -399,29 +433,39 @@ module.exports = grammar({
|
||||
field("body", $.block),
|
||||
),
|
||||
|
||||
for_loop: $ =>
|
||||
_for_loop: $ =>
|
||||
choice(
|
||||
seq(
|
||||
'for',
|
||||
field("name", $.Name),
|
||||
':=',
|
||||
field("begin", $._rhs),
|
||||
'to',
|
||||
field("end", $._expr),
|
||||
field("body", $.block),
|
||||
),
|
||||
seq(
|
||||
'for',
|
||||
field("key", $.Name),
|
||||
optional(seq('->', field("value", $.Name))),
|
||||
'in',
|
||||
field("kind", $.collection),
|
||||
field("collection", $._expr),
|
||||
field("body", $.block),
|
||||
),
|
||||
$.for_cycle,
|
||||
$.for_box,
|
||||
),
|
||||
|
||||
collection: $ => choice('map', 'set', 'list'),
|
||||
for_cycle: $ =>
|
||||
seq(
|
||||
'for',
|
||||
field("name", $.Name),
|
||||
':=',
|
||||
field("begin", $._rhs),
|
||||
'to',
|
||||
field("end", $._expr),
|
||||
optional(seq(
|
||||
"step",
|
||||
field("step", $._expr),
|
||||
)),
|
||||
field("body", $.block),
|
||||
),
|
||||
|
||||
for_box: $ =>
|
||||
seq(
|
||||
'for',
|
||||
field("key", $.Name),
|
||||
optional(seq('->', field("value", $.Name))),
|
||||
'in',
|
||||
field("kind", $._collection),
|
||||
field("collection", $._expr),
|
||||
field("body", $.block),
|
||||
),
|
||||
|
||||
_collection: $ => choice('map', 'set', 'list'),
|
||||
|
||||
interactive_expr: $ => $._expr,
|
||||
|
||||
@ -429,7 +473,7 @@ module.exports = grammar({
|
||||
choice(
|
||||
$.case_expr,
|
||||
$.cond_expr,
|
||||
$.op_expr,
|
||||
$._op_expr,
|
||||
$.fun_expr,
|
||||
),
|
||||
|
||||
@ -456,7 +500,7 @@ module.exports = grammar({
|
||||
|
||||
case_clause_expr: $ =>
|
||||
seq(
|
||||
field("pattern", $.pattern),
|
||||
field("pattern", $._pattern),
|
||||
'->',
|
||||
field("body", $._expr),
|
||||
),
|
||||
@ -472,20 +516,27 @@ module.exports = grammar({
|
||||
field("else", $._expr),
|
||||
),
|
||||
|
||||
op_expr: $ =>
|
||||
_op_expr: $ =>
|
||||
choice(
|
||||
field("the", $._core_expr),
|
||||
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))),
|
||||
prec.right(8, seq(field("negate", $.negate), field("arg", $._core_expr))),
|
||||
$._core_expr,
|
||||
$.binop,
|
||||
$.unop,
|
||||
),
|
||||
|
||||
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('<', '<=', '>', '>=', '=', '=/='),
|
||||
adder: $ => choice('-', '+'),
|
||||
multiplier: $ => choice('/', '*', 'mod'),
|
||||
@ -505,23 +556,27 @@ module.exports = grammar({
|
||||
$.Unit,
|
||||
$.annot_expr,
|
||||
$.tuple_expr,
|
||||
$.list_expr,
|
||||
$._list_expr,
|
||||
$.None,
|
||||
$._fun_call_or_par_or_projection,
|
||||
$._map_expr,
|
||||
$.set_expr,
|
||||
$.record_expr,
|
||||
$.update_record,
|
||||
$.constr_call,
|
||||
$._constr_use,
|
||||
$.Some_call,
|
||||
),
|
||||
|
||||
_constr_use: $ =>
|
||||
choice(
|
||||
$.constr_call,
|
||||
$.constr
|
||||
),
|
||||
|
||||
constr_call: $ =>
|
||||
seq(
|
||||
field("constr", $.constr),
|
||||
optional(
|
||||
field("arguments", $.arguments)
|
||||
),
|
||||
field("arguments", $.arguments)
|
||||
),
|
||||
|
||||
Some_call: $ =>
|
||||
@ -535,22 +590,23 @@ module.exports = grammar({
|
||||
$.par_call,
|
||||
$.projection_call,
|
||||
$.fun_call,
|
||||
$._projection,
|
||||
),
|
||||
|
||||
par_call: $ =>
|
||||
prec.right(1, seq(
|
||||
par(field("f", $._expr)),
|
||||
optional(field("arguments", $.arguments))
|
||||
field("arguments", $.arguments),
|
||||
)),
|
||||
|
||||
projection_call: $ => seq(
|
||||
projection_call: $ => prec(1, seq(
|
||||
field("f", $._projection),
|
||||
optional(field("arguments", $.arguments)),
|
||||
),
|
||||
field("arguments", $.arguments),
|
||||
)),
|
||||
|
||||
annot_expr: $ =>
|
||||
par(seq(
|
||||
field("subject", $.op_expr),
|
||||
field("subject", $._op_expr),
|
||||
':',
|
||||
field("type", $._type_expr)
|
||||
)),
|
||||
@ -569,13 +625,13 @@ module.exports = grammar({
|
||||
|
||||
map_lookup: $ =>
|
||||
seq(
|
||||
field("container", $.path),
|
||||
field("container", $._path),
|
||||
brackets(field("index", $._expr)),
|
||||
),
|
||||
|
||||
path: $ => choice($.Name, $._projection),
|
||||
_path: $ => choice($.Name, $._projection),
|
||||
|
||||
fpath: $ => choice($.FieldName, $._projection),
|
||||
_fpath: $ => choice($.FieldName, $._projection),
|
||||
|
||||
module_field: $ =>
|
||||
seq(
|
||||
@ -606,7 +662,7 @@ module.exports = grammar({
|
||||
data_projection: $ => seq(
|
||||
field("struct", $.Name),
|
||||
'.',
|
||||
sepBy1('.', field("index", $.selection)),
|
||||
sepBy1('.', field("index", $._selection)),
|
||||
),
|
||||
|
||||
module_projection: $ =>
|
||||
@ -615,10 +671,10 @@ module.exports = grammar({
|
||||
'.',
|
||||
field("index", $.Name),
|
||||
'.',
|
||||
sepBy1('.', field("index", $.selection)),
|
||||
sepBy1('.', field("index", $._selection)),
|
||||
),
|
||||
|
||||
selection: $ => choice($.FieldName, $.Int),
|
||||
_selection: $ => choice($.FieldName, $.Int),
|
||||
|
||||
record_expr: $ =>
|
||||
choice(
|
||||
@ -637,7 +693,7 @@ module.exports = grammar({
|
||||
|
||||
update_record: $ =>
|
||||
seq(
|
||||
field("record", $.path),
|
||||
field("record", $._path),
|
||||
'with',
|
||||
ne_injection('record', field("assignment", $.field_path_assignment)),
|
||||
),
|
||||
@ -651,7 +707,7 @@ module.exports = grammar({
|
||||
|
||||
field_path_assignment: $ =>
|
||||
seq(
|
||||
field("lhs", $.fpath),
|
||||
field("lhs", $._fpath),
|
||||
'=',
|
||||
field("_rhs", $._expr),
|
||||
),
|
||||
@ -665,14 +721,14 @@ module.exports = grammar({
|
||||
tuple_expr: $ => par(sepBy1(',', field("element", $._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(
|
||||
$._cons_pattern,
|
||||
field("the", $._core_pattern),
|
||||
$.cons_pattern,
|
||||
$._core_pattern,
|
||||
),
|
||||
|
||||
_core_pattern: $ =>
|
||||
@ -682,26 +738,28 @@ module.exports = grammar({
|
||||
$.Int,
|
||||
$.Nat,
|
||||
$.String,
|
||||
$.list_pattern,
|
||||
$._list_pattern,
|
||||
$.tuple_pattern,
|
||||
$._constr_pattern,
|
||||
),
|
||||
|
||||
list_pattern: $ =>
|
||||
_list_pattern: $ =>
|
||||
choice(
|
||||
injection("list", field("element", $.pattern)),
|
||||
$.list_pattern,
|
||||
'nil',
|
||||
),
|
||||
|
||||
_cons_pattern: $ =>
|
||||
list_pattern: $ => injection("list", field("element", $._pattern)),
|
||||
|
||||
cons_pattern: $ =>
|
||||
seq(
|
||||
field("head", $._core_pattern),
|
||||
'#',
|
||||
field("tail", $.pattern),
|
||||
field("tail", $._pattern),
|
||||
),
|
||||
|
||||
tuple_pattern: $ =>
|
||||
par(sepBy1(',', field("element", $.pattern))),
|
||||
par(sepBy1(',', field("element", $._pattern))),
|
||||
|
||||
_constr_pattern: $ => choice(
|
||||
$.Unit,
|
||||
@ -715,7 +773,7 @@ module.exports = grammar({
|
||||
Some_pattern: $ =>
|
||||
seq(
|
||||
field("constr", 'Some'),
|
||||
par(field("arg", $.pattern)),
|
||||
par(field("arg", $._pattern)),
|
||||
),
|
||||
|
||||
user_constr_pattern: $ =>
|
||||
@ -744,7 +802,7 @@ module.exports = grammar({
|
||||
|
||||
include: $ => seq('#include', field("filename", $.String)),
|
||||
|
||||
String: $ => /\"(\\.|[^"])*\"/,
|
||||
String: $ => choice(/\"(\\.|[^"])*\"/, /{\|(\\.|[^\|])*\|}/),
|
||||
Int: $ => /-?([1-9][0-9_]*|0)/,
|
||||
Nat: $ => /([1-9][0-9_]*|0)n/,
|
||||
Tez: $ => /([1-9][0-9_]*|0)(\.[0-9_]+)?(tz|tez|mutez)/,
|
||||
|
||||
@ -6,7 +6,7 @@ import Control.Lens
|
||||
import Control.Monad
|
||||
|
||||
import Data.Default
|
||||
-- import Data.Foldable
|
||||
import Data.Foldable
|
||||
import qualified Data.Text as Text
|
||||
import Data.Text (Text)
|
||||
import Data.String (fromString)
|
||||
@ -30,232 +30,233 @@ import Range
|
||||
import Product
|
||||
import AST hiding (def)
|
||||
import qualified AST.Find as Find
|
||||
import Error
|
||||
-- import Error
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
-- for_ [1.. 100] \_ -> do
|
||||
-- print =<< runParser contract example
|
||||
errCode <- mainLoop
|
||||
exit errCode
|
||||
return ()
|
||||
for_ [1.. 100] \_ -> do
|
||||
print . length . show =<< sample' "../../../src/test/contracts/loop.ligo"
|
||||
-- errCode <- mainLoop
|
||||
-- exit errCode
|
||||
|
||||
mainLoop :: IO Int
|
||||
mainLoop = do
|
||||
chan <- atomically newTChan :: IO (TChan FromClientMessage)
|
||||
-- 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
|
||||
}
|
||||
-- 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
|
||||
]
|
||||
-- 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
|
||||
}
|
||||
-- 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"]
|
||||
}
|
||||
-- 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
|
||||
}
|
||||
-- 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)
|
||||
-- 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
|
||||
-- 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
|
||||
-- send :: Core.LspFuncs () -> FromServerMessage -> IO ()
|
||||
-- send = Core.sendFunc
|
||||
|
||||
nextID :: Core.LspFuncs () -> IO J.LspId
|
||||
nextID = Core.getNextReqId
|
||||
-- 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)
|
||||
-- eventLoop :: Core.LspFuncs () -> TChan FromClientMessage -> IO ()
|
||||
-- eventLoop funs chan = do
|
||||
-- forever do
|
||||
-- msg <- atomically (readTChan chan)
|
||||
|
||||
U.logs [i|Client: ${msg}|]
|
||||
-- U.logs [i|Client: ${msg}|]
|
||||
|
||||
case msg of
|
||||
RspFromClient {} -> do
|
||||
return ()
|
||||
-- case msg of
|
||||
-- RspFromClient {} -> do
|
||||
-- return ()
|
||||
|
||||
NotInitialized _notif -> do
|
||||
let
|
||||
registration = J.Registration
|
||||
"lsp-haskell-registered"
|
||||
J.WorkspaceExecuteCommand
|
||||
Nothing
|
||||
registrations = J.RegistrationParams $ J.List [registration]
|
||||
-- NotInitialized _notif -> do
|
||||
-- let
|
||||
-- registration = J.Registration
|
||||
-- "lsp-haskell-registered"
|
||||
-- J.WorkspaceExecuteCommand
|
||||
-- Nothing
|
||||
-- registrations = J.RegistrationParams $ J.List [registration]
|
||||
|
||||
rid <- nextID funs
|
||||
send funs
|
||||
$ ReqRegisterCapability
|
||||
$ fmServerRegisterCapabilityRequest rid registrations
|
||||
-- rid <- nextID funs
|
||||
-- send funs
|
||||
-- $ ReqRegisterCapability
|
||||
-- $ fmServerRegisterCapabilityRequest rid registrations
|
||||
|
||||
NotDidOpenTextDocument notif -> do
|
||||
let
|
||||
doc = notif
|
||||
^.J.params
|
||||
.J.textDocument
|
||||
.J.uri
|
||||
-- NotDidOpenTextDocument notif -> do
|
||||
-- let
|
||||
-- doc = notif
|
||||
-- ^.J.params
|
||||
-- .J.textDocument
|
||||
-- .J.uri
|
||||
|
||||
ver = notif
|
||||
^.J.params
|
||||
.J.textDocument
|
||||
.J.version
|
||||
-- ver = notif
|
||||
-- ^.J.params
|
||||
-- .J.textDocument
|
||||
-- .J.version
|
||||
|
||||
collectErrors funs
|
||||
(J.toNormalizedUri doc)
|
||||
(J.uriToFilePath doc)
|
||||
(Just ver)
|
||||
-- collectErrors funs
|
||||
-- (J.toNormalizedUri doc)
|
||||
-- (J.uriToFilePath doc)
|
||||
-- (Just ver)
|
||||
|
||||
NotDidChangeTextDocument notif -> do
|
||||
let
|
||||
doc = notif
|
||||
^.J.params
|
||||
.J.textDocument
|
||||
.J.uri
|
||||
-- NotDidChangeTextDocument notif -> do
|
||||
-- let
|
||||
-- doc = notif
|
||||
-- ^.J.params
|
||||
-- .J.textDocument
|
||||
-- .J.uri
|
||||
|
||||
collectErrors funs
|
||||
(J.toNormalizedUri doc)
|
||||
(J.uriToFilePath doc)
|
||||
(Just 0)
|
||||
-- collectErrors funs
|
||||
-- (J.toNormalizedUri doc)
|
||||
-- (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 <- 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 []
|
||||
-- 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 []
|
||||
-- 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"
|
||||
-- _ -> 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
|
||||
-- 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
|
||||
-- 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) ""
|
||||
-- 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))
|
||||
-- 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
|
||||
-- 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."
|
||||
-- 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)
|
||||
-- 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"
|
||||
-- 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)
|
||||
-- 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)
|
||||
-- exit :: Int -> IO ()
|
||||
-- exit 0 = exitSuccess
|
||||
-- exit n = exitWith (ExitFailure n)
|
||||
|
||||
@ -1 +0,0 @@
|
||||
function foo (var x : int) is 1
|
||||
@ -5,13 +5,16 @@ dependencies:
|
||||
- bytestring
|
||||
- containers
|
||||
- data-default
|
||||
- duplo
|
||||
- exceptions
|
||||
- fastsum
|
||||
- filepath
|
||||
- ghc-prim
|
||||
- interpolate
|
||||
- mtl
|
||||
- pretty
|
||||
- text
|
||||
- transformers
|
||||
- tree-sitter
|
||||
|
||||
default-extensions:
|
||||
@ -21,6 +24,7 @@ default-extensions:
|
||||
- BlockArguments
|
||||
- ConstraintKinds
|
||||
- DataKinds
|
||||
- DeriveAnyClass
|
||||
- DeriveFoldable
|
||||
- DeriveFunctor
|
||||
- DeriveTraversable
|
||||
@ -46,7 +50,7 @@ default-extensions:
|
||||
- UndecidableInstances
|
||||
- ViewPatterns
|
||||
|
||||
ghc-options: -freverse-errors -Wall -threaded
|
||||
ghc-options: -freverse-errors -Wall
|
||||
|
||||
library:
|
||||
source-dirs:
|
||||
@ -72,3 +76,5 @@ executables:
|
||||
|
||||
source-dirs:
|
||||
- app/
|
||||
|
||||
ghc-options: -threaded
|
||||
|
||||
@ -1,70 +1,70 @@
|
||||
|
||||
module AST.Find where
|
||||
|
||||
import Control.Monad
|
||||
-- import Control.Monad
|
||||
|
||||
import AST.Types
|
||||
import AST.Scope
|
||||
import AST.Parser
|
||||
-- import AST.Types
|
||||
-- import AST.Scope
|
||||
-- import AST.Parser
|
||||
|
||||
import Tree
|
||||
import Range
|
||||
import Pretty
|
||||
import Product
|
||||
-- import Tree
|
||||
-- import Range
|
||||
-- import Pretty
|
||||
-- import Product
|
||||
|
||||
import Data.Text (Text)
|
||||
-- import Debug.Trace
|
||||
-- import Data.Text (Text)
|
||||
-- -- import Debug.Trace
|
||||
|
||||
type CanSearch xs =
|
||||
( Contains [ScopedDecl] xs
|
||||
, Contains Range xs
|
||||
, Contains (Maybe Category) xs
|
||||
, Contains [Text] xs
|
||||
, Pretty (Product xs)
|
||||
)
|
||||
-- type CanSearch xs =
|
||||
-- ( Contains [ScopedDecl] xs
|
||||
-- , Contains Range xs
|
||||
-- , Contains (Maybe Category) xs
|
||||
-- , Contains [Text] xs
|
||||
-- , Pretty (Product xs)
|
||||
-- )
|
||||
|
||||
findScopedDecl
|
||||
:: CanSearch xs
|
||||
=> Range
|
||||
-> Pascal (Product xs)
|
||||
-> Maybe ScopedDecl
|
||||
findScopedDecl pos tree = do
|
||||
pt <- lookupTree pos tree
|
||||
let info = infoOf pt
|
||||
let fullEnv = getElem info
|
||||
do
|
||||
categ <- getElem info
|
||||
let filtered = filter (ofCategory categ) fullEnv
|
||||
lookupEnv (ppToText $ void pt) filtered
|
||||
-- findScopedDecl
|
||||
-- :: CanSearch xs
|
||||
-- => Range
|
||||
-- -> Pascal (Product xs)
|
||||
-- -> Maybe ScopedDecl
|
||||
-- findScopedDecl pos tree = do
|
||||
-- pt <- lookupTree pos tree
|
||||
-- let info = infoOf pt
|
||||
-- let fullEnv = getElem info
|
||||
-- do
|
||||
-- categ <- getElem info
|
||||
-- let filtered = filter (ofCategory categ) fullEnv
|
||||
-- lookupEnv (ppToText $ void pt) filtered
|
||||
|
||||
definitionOf
|
||||
:: CanSearch xs
|
||||
=> Range
|
||||
-> Pascal (Product xs)
|
||||
-> Maybe Range
|
||||
definitionOf pos tree =
|
||||
_sdOrigin <$> findScopedDecl pos tree
|
||||
-- definitionOf
|
||||
-- :: CanSearch xs
|
||||
-- => Range
|
||||
-- -> Pascal (Product xs)
|
||||
-- -> Maybe Range
|
||||
-- definitionOf pos tree =
|
||||
-- _sdOrigin <$> findScopedDecl pos tree
|
||||
|
||||
typeOf
|
||||
:: CanSearch xs
|
||||
=> Range
|
||||
-> Pascal (Product xs)
|
||||
-> Maybe (Either (Pascal ()) Kind)
|
||||
typeOf pos tree =
|
||||
_sdType =<< findScopedDecl pos tree
|
||||
-- typeOf
|
||||
-- :: CanSearch xs
|
||||
-- => Range
|
||||
-- -> Pascal (Product xs)
|
||||
-- -> Maybe (Either (Pascal ()) Kind)
|
||||
-- typeOf pos tree =
|
||||
-- _sdType =<< findScopedDecl pos tree
|
||||
|
||||
implementationOf
|
||||
:: CanSearch xs
|
||||
=> Range
|
||||
-> Pascal (Product xs)
|
||||
-> Maybe Range
|
||||
implementationOf pos tree =
|
||||
_sdBody =<< findScopedDecl pos tree
|
||||
-- implementationOf
|
||||
-- :: CanSearch xs
|
||||
-- => Range
|
||||
-- -> Pascal (Product xs)
|
||||
-- -> Maybe Range
|
||||
-- implementationOf pos tree =
|
||||
-- _sdBody =<< findScopedDecl pos tree
|
||||
|
||||
referencesOf
|
||||
:: CanSearch xs
|
||||
=> Range
|
||||
-> Pascal (Product xs)
|
||||
-> Maybe [Range]
|
||||
referencesOf pos tree =
|
||||
_sdRefs <$> findScopedDecl pos tree
|
||||
-- referencesOf
|
||||
-- :: CanSearch xs
|
||||
-- => Range
|
||||
-- -> Pascal (Product xs)
|
||||
-- -> Maybe [Range]
|
||||
-- referencesOf pos tree =
|
||||
-- _sdRefs <$> findScopedDecl pos tree
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
@ -23,318 +23,319 @@ import Data.Maybe (listToMaybe)
|
||||
import Data.Sum (Element, Apply, Sum)
|
||||
import Data.Text (Text)
|
||||
|
||||
import Duplo.Lattice
|
||||
import Duplo.Pretty
|
||||
import Duplo.Tree
|
||||
|
||||
-- import AST.Parser
|
||||
import AST.Types
|
||||
-- import Comment
|
||||
import Lattice
|
||||
-- import Parser
|
||||
import Pretty
|
||||
import Product
|
||||
import Range
|
||||
import Tree
|
||||
|
||||
-- import Debug.Trace
|
||||
|
||||
type CollectM = State (Product [FullEnv, [Range]])
|
||||
-- type CollectM = State (Product [FullEnv, [Range]])
|
||||
|
||||
type FullEnv = Product ["vars" := Env, "types" := Env]
|
||||
type Env = Map Range [ScopedDecl]
|
||||
-- type FullEnv = Product ["vars" := Env, "types" := Env]
|
||||
-- type Env = Map Range [ScopedDecl]
|
||||
|
||||
data Category = Variable | Type
|
||||
-- data Category = Variable | Type
|
||||
|
||||
-- | The type/value declaration.
|
||||
data ScopedDecl = ScopedDecl
|
||||
{ _sdName :: Pascal ()
|
||||
, _sdOrigin :: Range
|
||||
, _sdBody :: Maybe Range
|
||||
, _sdType :: Maybe (Either (Pascal ()) Kind)
|
||||
, _sdRefs :: [Range]
|
||||
}
|
||||
deriving Show via PP ScopedDecl
|
||||
-- -- | The type/value declaration.
|
||||
-- data ScopedDecl = ScopedDecl
|
||||
-- { _sdName :: Pascal ()
|
||||
-- , _sdOrigin :: Range
|
||||
-- , _sdBody :: Maybe Range
|
||||
-- , _sdType :: Maybe (Either (Pascal ()) Kind)
|
||||
-- , _sdRefs :: [Range]
|
||||
-- }
|
||||
-- deriving Show via PP ScopedDecl
|
||||
|
||||
-- | The kind.
|
||||
data Kind = Star
|
||||
deriving Show via PP Kind
|
||||
-- -- | The kind.
|
||||
-- data Kind = Star
|
||||
-- deriving Show via PP Kind
|
||||
|
||||
emptyEnv :: FullEnv
|
||||
emptyEnv
|
||||
= Cons (Tag Map.empty)
|
||||
$ Cons (Tag Map.empty)
|
||||
Nil
|
||||
-- emptyEnv :: FullEnv
|
||||
-- emptyEnv
|
||||
-- = Cons (Tag Map.empty)
|
||||
-- $ Cons (Tag Map.empty)
|
||||
-- Nil
|
||||
|
||||
with :: Category -> FullEnv -> (Env -> Env) -> FullEnv
|
||||
with Variable env f = modTag @"vars" f env
|
||||
with Type env f = modTag @"types" f env
|
||||
-- with :: Category -> FullEnv -> (Env -> Env) -> FullEnv
|
||||
-- with Variable env f = modTag @"vars" f env
|
||||
-- with Type env f = modTag @"types" f env
|
||||
|
||||
ofCategory :: Category -> ScopedDecl -> Bool
|
||||
ofCategory Variable ScopedDecl { _sdType = Just (Right Star) } = False
|
||||
ofCategory Variable _ = True
|
||||
ofCategory Type ScopedDecl { _sdType = Just (Right Star) } = True
|
||||
ofCategory _ _ = False
|
||||
-- ofCategory :: Category -> ScopedDecl -> Bool
|
||||
-- ofCategory Variable ScopedDecl { _sdType = Just (Right Star) } = False
|
||||
-- ofCategory Variable _ = True
|
||||
-- ofCategory Type ScopedDecl { _sdType = Just (Right Star) } = True
|
||||
-- ofCategory _ _ = False
|
||||
|
||||
-- | Calculate scopes and attach to all tree points declarations that are
|
||||
-- visible there.
|
||||
--
|
||||
addLocalScopes
|
||||
:: Contains Range xs
|
||||
=> Pascal (Product xs)
|
||||
-> Pascal (Product ([ScopedDecl] : Maybe Category : xs))
|
||||
addLocalScopes tree =
|
||||
fmap (\xs -> Cons (fullEnvAt envWithREfs (getRange xs)) xs) tree1
|
||||
where
|
||||
tree1 = addNameCategories tree
|
||||
envWithREfs = getEnvTree tree
|
||||
-- -- | Calculate scopes and attach to all tree points declarations that are
|
||||
-- -- visible there.
|
||||
-- --
|
||||
-- addLocalScopes
|
||||
-- :: Contains Range xs
|
||||
-- => Pascal (Product xs)
|
||||
-- -> Pascal (Product ([ScopedDecl] : Maybe Category : xs))
|
||||
-- addLocalScopes tree =
|
||||
-- fmap (\xs -> Cons (fullEnvAt envWithREfs (getRange xs)) xs) tree1
|
||||
-- where
|
||||
-- tree1 = addNameCategories tree
|
||||
-- envWithREfs = getEnvTree tree
|
||||
|
||||
addNameCategories
|
||||
:: Contains Range xs
|
||||
=> Pascal (Product xs)
|
||||
-> Pascal (Product (Maybe Category : xs))
|
||||
addNameCategories tree = flip evalState emptyEnv do
|
||||
traverseMany
|
||||
[ Visit \r (Name t) -> do
|
||||
modify $ getRange r `addRef` (Variable, t)
|
||||
return $ (Cons (Just Variable) r, Name t)
|
||||
-- addNameCategories
|
||||
-- :: Contains Range xs
|
||||
-- => Pascal (Product xs)
|
||||
-- -> Pascal (Product (Maybe Category : xs))
|
||||
-- addNameCategories tree = flip evalState emptyEnv do
|
||||
-- traverseMany
|
||||
-- [ Visit \r (Name t) -> do
|
||||
-- modify $ getRange r `addRef` (Variable, t)
|
||||
-- return $ (Cons (Just Variable) r, Name t)
|
||||
|
||||
, Visit \r (TypeName t) -> do
|
||||
modify $ getRange r `addRef` (Type, t)
|
||||
return $ (Cons (Just Type) r, TypeName t)
|
||||
]
|
||||
(Cons Nothing)
|
||||
tree
|
||||
-- , Visit \r (TypeName t) -> do
|
||||
-- modify $ getRange r `addRef` (Type, t)
|
||||
-- return $ (Cons (Just Type) r, TypeName t)
|
||||
-- ]
|
||||
-- (Cons Nothing)
|
||||
-- tree
|
||||
|
||||
getEnvTree
|
||||
:: ( UpdateOver CollectM (Sum fs) (Tree fs b)
|
||||
, Apply Foldable fs
|
||||
, Apply Functor fs
|
||||
, Apply Traversable fs
|
||||
, HasRange b
|
||||
, Element Name fs
|
||||
, Element TypeName fs
|
||||
)
|
||||
=> Tree fs b
|
||||
-> FullEnv
|
||||
getEnvTree tree = envWithREfs
|
||||
where
|
||||
envWithREfs = flip execState env do
|
||||
traverseMany
|
||||
[ Visit \r (Name t) -> do
|
||||
modify $ getRange r `addRef` (Variable, t)
|
||||
return $ (r, Name t)
|
||||
-- getEnvTree
|
||||
-- :: ( Scoped CollectM (Sum fs) (Tree fs b)
|
||||
-- , Apply Foldable fs
|
||||
-- , Apply Functor fs
|
||||
-- , Apply Traversable fs
|
||||
-- , HasRange b
|
||||
-- , Element Name fs
|
||||
-- , Element TypeName fs
|
||||
-- )
|
||||
-- => Tree fs b
|
||||
-- -> FullEnv
|
||||
-- getEnvTree tree = envWithREfs
|
||||
-- where
|
||||
-- envWithREfs = flip execState env do
|
||||
-- traverseMany
|
||||
-- [ Visit \r (Name t) -> do
|
||||
-- modify $ getRange r `addRef` (Variable, t)
|
||||
-- return $ (r, Name t)
|
||||
|
||||
, Visit \r (TypeName t) -> do
|
||||
modify $ getRange r `addRef` (Type, t)
|
||||
return $ (r, TypeName t)
|
||||
]
|
||||
id
|
||||
tree
|
||||
-- , Visit \r (TypeName t) -> do
|
||||
-- modify $ getRange r `addRef` (Type, t)
|
||||
-- return $ (r, TypeName t)
|
||||
-- ]
|
||||
-- id
|
||||
-- tree
|
||||
|
||||
env
|
||||
= execCollectM
|
||||
$ traverseTree pure tree
|
||||
-- env
|
||||
-- = execCollectM
|
||||
-- $ traverseTree pure tree
|
||||
|
||||
fullEnvAt :: FullEnv -> Range -> [ScopedDecl]
|
||||
fullEnvAt fe r = envAt (getTag @"types" fe) r <> envAt (getTag @"vars" fe) r
|
||||
-- fullEnvAt :: FullEnv -> Range -> [ScopedDecl]
|
||||
-- fullEnvAt fe r = envAt (getTag @"types" fe) r <> envAt (getTag @"vars" fe) r
|
||||
|
||||
envAt :: Env -> Range -> [ScopedDecl]
|
||||
envAt env pos =
|
||||
Map.elems scopes
|
||||
where
|
||||
ranges = List.sortBy partOrder $ filter isCovering $ Map.keys env
|
||||
scopes = Map.unions $ (map.foldMap) toScopeMap $ map (env Map.!) ranges
|
||||
-- envAt :: Env -> Range -> [ScopedDecl]
|
||||
-- envAt env pos =
|
||||
-- Map.elems scopes
|
||||
-- where
|
||||
-- ranges = List.sortBy partOrder $ filter isCovering $ Map.keys env
|
||||
-- scopes = Map.unions $ (map.foldMap) toScopeMap $ map (env Map.!) ranges
|
||||
|
||||
isCovering = (pos <?)
|
||||
toScopeMap sd@ScopedDecl {_sdName} = Map.singleton (ppToText _sdName) sd
|
||||
-- isCovering = (pos <?)
|
||||
-- toScopeMap sd@ScopedDecl {_sdName} = Map.singleton (ppToText _sdName) sd
|
||||
|
||||
addRef :: Range -> (Category, Text) -> FullEnv -> FullEnv
|
||||
addRef r (categ, n) env =
|
||||
with categ env \slice ->
|
||||
Map.union
|
||||
(go slice $ range slice)
|
||||
slice
|
||||
where
|
||||
go slice (r' : rest) =
|
||||
let decls = slice Map.! r'
|
||||
in
|
||||
case updateOnly n r addRefToDecl decls of
|
||||
(True, decls') -> Map.singleton r' decls'
|
||||
(False, decls') -> Map.insert r' decls' (go slice rest)
|
||||
go _ [] = Map.empty
|
||||
-- addRef :: Range -> (Category, Text) -> FullEnv -> FullEnv
|
||||
-- addRef r (categ, n) env =
|
||||
-- with categ env \slice ->
|
||||
-- Map.union
|
||||
-- (go slice $ range slice)
|
||||
-- slice
|
||||
-- where
|
||||
-- go slice (r' : rest) =
|
||||
-- let decls = slice Map.! r'
|
||||
-- in
|
||||
-- case updateOnly n r addRefToDecl decls of
|
||||
-- (True, decls') -> Map.singleton r' decls'
|
||||
-- (False, decls') -> Map.insert r' decls' (go slice rest)
|
||||
-- go _ [] = Map.empty
|
||||
|
||||
range slice
|
||||
= List.sortBy partOrder
|
||||
$ filter (r <?)
|
||||
$ Map.keys slice
|
||||
-- range slice
|
||||
-- = List.sortBy partOrder
|
||||
-- $ filter (r <?)
|
||||
-- $ Map.keys slice
|
||||
|
||||
addRefToDecl sd = sd
|
||||
{ _sdRefs = r : _sdRefs sd
|
||||
}
|
||||
-- addRefToDecl sd = sd
|
||||
-- { _sdRefs = r : _sdRefs sd
|
||||
-- }
|
||||
|
||||
updateOnly
|
||||
:: Text
|
||||
-> Range
|
||||
-> (ScopedDecl -> ScopedDecl)
|
||||
-> [ScopedDecl]
|
||||
-> (Bool, [ScopedDecl])
|
||||
updateOnly name r f = go
|
||||
where
|
||||
go = \case
|
||||
d : ds
|
||||
| ppToText (_sdName d) == name ->
|
||||
if r == _sdOrigin d
|
||||
then (True, d : ds)
|
||||
else (True, f d : ds)
|
||||
| otherwise -> second (d :) (go ds)
|
||||
-- updateOnly
|
||||
-- :: Text
|
||||
-- -> Range
|
||||
-- -> (ScopedDecl -> ScopedDecl)
|
||||
-- -> [ScopedDecl]
|
||||
-- -> (Bool, [ScopedDecl])
|
||||
-- updateOnly name r f = go
|
||||
-- where
|
||||
-- go = \case
|
||||
-- d : ds
|
||||
-- | ppToText (_sdName d) == name ->
|
||||
-- if r == _sdOrigin d
|
||||
-- then (True, d : ds)
|
||||
-- else (True, f d : ds)
|
||||
-- | otherwise -> second (d :) (go ds)
|
||||
|
||||
[] -> (False, [])
|
||||
-- [] -> (False, [])
|
||||
|
||||
enter :: Range -> CollectM ()
|
||||
enter r = do
|
||||
modify $ modElem (r :)
|
||||
-- enter :: Range -> CollectM ()
|
||||
-- enter r = do
|
||||
-- modify $ modElem (r :)
|
||||
|
||||
define :: Category -> ScopedDecl -> CollectM ()
|
||||
define categ sd = do
|
||||
r <- gets (head . getElem @[Range])
|
||||
modify
|
||||
$ modElem @FullEnv \env ->
|
||||
with categ env
|
||||
$ Map.insertWith (++) r [sd]
|
||||
-- define :: Category -> ScopedDecl -> CollectM ()
|
||||
-- define categ sd = do
|
||||
-- r <- gets (head . getElem @[Range])
|
||||
-- modify
|
||||
-- $ modElem @FullEnv \env ->
|
||||
-- with categ env
|
||||
-- $ Map.insertWith (++) r [sd]
|
||||
|
||||
leave :: CollectM ()
|
||||
leave = modify $ modElem @[Range] tail
|
||||
-- leave :: CollectM ()
|
||||
-- leave = modify $ modElem @[Range] tail
|
||||
|
||||
-- | Run the computation with scope starting from empty scope.
|
||||
execCollectM :: CollectM a -> FullEnv
|
||||
execCollectM action = getElem $ execState action $ Cons emptyEnv (Cons [] Nil)
|
||||
-- -- | Run the computation with scope starting from empty scope.
|
||||
-- execCollectM :: CollectM a -> FullEnv
|
||||
-- execCollectM action = getElem $ execState action $ Cons emptyEnv (Cons [] Nil)
|
||||
|
||||
instance {-# OVERLAPS #-} Pretty FullEnv where
|
||||
pp = block . map aux . Map.toList . mergeFE
|
||||
where
|
||||
aux (r, fe) =
|
||||
pp r `indent` block fe
|
||||
-- instance {-# OVERLAPS #-} Pretty FullEnv where
|
||||
-- pp = block . map aux . Map.toList . mergeFE
|
||||
-- where
|
||||
-- aux (r, 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
|
||||
pp (ScopedDecl n o _ t refs) = color 3 (pp n) <+> pp o <+> ":" <+> color 4 (maybe "?" (either pp pp) t) <+> "=" <+> pp refs
|
||||
-- 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
|
||||
|
||||
instance Pretty Kind where
|
||||
pp _ = "TYPE"
|
||||
-- instance Pretty Kind where
|
||||
-- pp _ = "TYPE"
|
||||
|
||||
instance Pretty Category where
|
||||
pp Variable = "Variable"
|
||||
pp Type = "Type"
|
||||
-- instance Pretty Category where
|
||||
-- pp Variable = "Variable"
|
||||
-- pp Type = "Type"
|
||||
|
||||
-- | Search for a name inside a local scope.
|
||||
lookupEnv :: Text -> [ScopedDecl] -> Maybe ScopedDecl
|
||||
lookupEnv name = listToMaybe . filter ((name ==) . ppToText . _sdName)
|
||||
-- -- | Search for a name inside a local scope.
|
||||
-- lookupEnv :: Text -> [ScopedDecl] -> Maybe ScopedDecl
|
||||
-- lookupEnv name = listToMaybe . filter ((name ==) . ppToText . _sdName)
|
||||
|
||||
-- | Add a type declaration to the current scope.
|
||||
defType :: HasRange a => Pascal a -> Kind -> Pascal a -> CollectM ()
|
||||
defType name kind body = do
|
||||
define Type
|
||||
$ ScopedDecl
|
||||
(void name)
|
||||
(getRange $ infoOf name)
|
||||
(Just $ getRange $ infoOf body)
|
||||
(Just (Right kind))
|
||||
[]
|
||||
-- -- | Add a type declaration to the current scope.
|
||||
-- defType :: HasRange a => Pascal a -> Kind -> Pascal a -> CollectM ()
|
||||
-- defType name kind body = do
|
||||
-- define Type
|
||||
-- $ ScopedDecl
|
||||
-- (void name)
|
||||
-- (getRange $ infoOf name)
|
||||
-- (Just $ getRange $ infoOf body)
|
||||
-- (Just (Right kind))
|
||||
-- []
|
||||
|
||||
-- observe :: Pretty i => Pretty res => Text -> i -> res -> res
|
||||
-- observe msg i res
|
||||
-- = traceShow (pp msg, "INPUT", pp i)
|
||||
-- $ traceShow (pp msg, "OUTPUT", pp res)
|
||||
-- $ res
|
||||
-- -- observe :: Pretty i => Pretty res => Text -> i -> res -> res
|
||||
-- -- observe msg i res
|
||||
-- -- = traceShow (pp msg, "INPUT", pp i)
|
||||
-- -- $ traceShow (pp msg, "OUTPUT", pp res)
|
||||
-- -- $ res
|
||||
|
||||
-- | Add a value declaration to the current scope.
|
||||
def
|
||||
:: HasRange a
|
||||
=> Pascal a
|
||||
-> Maybe (Pascal a)
|
||||
-> Maybe (Pascal a)
|
||||
-> CollectM ()
|
||||
def name ty body = do
|
||||
define Variable
|
||||
$ ScopedDecl
|
||||
(void name)
|
||||
(getRange $ infoOf name)
|
||||
((getRange . infoOf) <$> body)
|
||||
((Left . void) <$> ty)
|
||||
[]
|
||||
-- -- | Add a value declaration to the current scope.
|
||||
-- def
|
||||
-- :: HasRange a
|
||||
-- => Pascal a
|
||||
-- -> Maybe (Pascal a)
|
||||
-- -> Maybe (Pascal a)
|
||||
-- -> CollectM ()
|
||||
-- def name ty body = do
|
||||
-- define Variable
|
||||
-- $ ScopedDecl
|
||||
-- (void name)
|
||||
-- (getRange $ infoOf name)
|
||||
-- ((getRange . infoOf) <$> body)
|
||||
-- ((Left . void) <$> ty)
|
||||
-- []
|
||||
|
||||
instance UpdateOver CollectM Contract (Pascal a) where
|
||||
before r _ = enter r
|
||||
after _ _ = skip
|
||||
-- instance UpdateOver CollectM Contract (Pascal a) where
|
||||
-- before r _ = enter r
|
||||
-- after _ _ = skip
|
||||
|
||||
instance HasRange a => UpdateOver CollectM Declaration (Pascal a) where
|
||||
before _ = \case
|
||||
TypeDecl ty body -> defType ty Star body
|
||||
_ -> skip
|
||||
-- instance HasRange a => UpdateOver CollectM Declaration (Pascal a) where
|
||||
-- before _ = \case
|
||||
-- TypeDecl ty body -> defType ty Star body
|
||||
-- _ -> skip
|
||||
|
||||
instance HasRange a => UpdateOver CollectM Binding (Pascal a) where
|
||||
before r = \case
|
||||
Function recur name _args ty body -> do
|
||||
when recur do
|
||||
def name (Just ty) (Just body)
|
||||
enter r
|
||||
-- instance HasRange a => UpdateOver CollectM Binding (Pascal a) where
|
||||
-- before r = \case
|
||||
-- Function recur name _args ty body -> do
|
||||
-- when recur do
|
||||
-- def name (Just ty) (Just body)
|
||||
-- enter r
|
||||
|
||||
_ -> enter r
|
||||
-- _ -> enter r
|
||||
|
||||
after _ = \case
|
||||
Irrefutable name body -> do leave; def name Nothing (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)
|
||||
Function recur name _args ty body -> do
|
||||
leave
|
||||
unless recur do
|
||||
def name (Just ty) (Just body)
|
||||
-- after _ = \case
|
||||
-- Irrefutable name body -> do leave; def name Nothing (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)
|
||||
-- Function recur name _args ty body -> do
|
||||
-- leave
|
||||
-- unless recur do
|
||||
-- def name (Just ty) (Just body)
|
||||
|
||||
instance HasRange a => UpdateOver CollectM VarDecl (Pascal a) where
|
||||
after _ (Decl _ name ty) = def name (Just ty) Nothing
|
||||
-- instance HasRange a => UpdateOver CollectM VarDecl (Pascal a) where
|
||||
-- after _ (Decl _ name ty) = def name (Just ty) Nothing
|
||||
|
||||
instance UpdateOver CollectM Mutable (Pascal a)
|
||||
instance UpdateOver CollectM Type (Pascal a)
|
||||
instance UpdateOver CollectM Variant (Pascal a)
|
||||
instance UpdateOver CollectM TField (Pascal a)
|
||||
-- instance UpdateOver CollectM Mutable (Pascal a)
|
||||
-- instance UpdateOver CollectM Type (Pascal a)
|
||||
-- instance UpdateOver CollectM Variant (Pascal a)
|
||||
-- instance UpdateOver CollectM TField (Pascal a)
|
||||
|
||||
instance HasRange a => UpdateOver CollectM Expr (Pascal a) where
|
||||
before r = \case
|
||||
Let {} -> enter r
|
||||
Lambda {} -> enter r
|
||||
ForLoop k _ _ _ -> do
|
||||
enter r
|
||||
def k Nothing Nothing
|
||||
-- instance HasRange a => UpdateOver CollectM Expr (Pascal a) where
|
||||
-- before r = \case
|
||||
-- Let {} -> enter r
|
||||
-- Lambda {} -> enter r
|
||||
-- ForLoop k _ _ _ -> do
|
||||
-- enter r
|
||||
-- def k Nothing Nothing
|
||||
|
||||
ForBox k mv _ _ _ -> do
|
||||
enter r
|
||||
def k Nothing Nothing
|
||||
maybe skip (\v -> def v Nothing Nothing) mv
|
||||
-- ForBox k mv _ _ _ -> do
|
||||
-- enter r
|
||||
-- def k Nothing Nothing
|
||||
-- maybe skip (\v -> def v Nothing Nothing) mv
|
||||
|
||||
_ -> skip
|
||||
-- _ -> skip
|
||||
|
||||
after _ = \case
|
||||
Let {} -> leave
|
||||
Lambda {} -> leave
|
||||
ForLoop {} -> leave
|
||||
ForBox {} -> leave
|
||||
_ -> skip
|
||||
-- after _ = \case
|
||||
-- Let {} -> leave
|
||||
-- Lambda {} -> leave
|
||||
-- ForLoop {} -> leave
|
||||
-- ForBox {} -> leave
|
||||
-- _ -> skip
|
||||
|
||||
instance HasRange a => UpdateOver CollectM Alt (Pascal a) where
|
||||
before r _ = enter r
|
||||
after _ _ = leave
|
||||
-- instance HasRange a => UpdateOver CollectM Alt (Pascal a) where
|
||||
-- before r _ = enter r
|
||||
-- after _ _ = leave
|
||||
|
||||
instance UpdateOver CollectM LHS (Pascal a)
|
||||
instance UpdateOver CollectM MapBinding (Pascal a)
|
||||
instance UpdateOver CollectM Assignment (Pascal a)
|
||||
instance UpdateOver CollectM FieldAssignment (Pascal a)
|
||||
instance UpdateOver CollectM Constant (Pascal a)
|
||||
-- instance UpdateOver CollectM LHS (Pascal a)
|
||||
-- instance UpdateOver CollectM MapBinding (Pascal a)
|
||||
-- instance UpdateOver CollectM Assignment (Pascal a)
|
||||
-- instance UpdateOver CollectM FieldAssignment (Pascal a)
|
||||
-- instance UpdateOver CollectM Constant (Pascal a)
|
||||
|
||||
instance HasRange a => UpdateOver CollectM Pattern (Pascal a) where
|
||||
before _ = \case
|
||||
IsVar n -> def n Nothing Nothing
|
||||
_ -> skip
|
||||
-- instance HasRange a => UpdateOver CollectM Pattern (Pascal a) where
|
||||
-- before _ = \case
|
||||
-- IsVar n -> def n Nothing Nothing
|
||||
-- _ -> skip
|
||||
|
||||
instance UpdateOver CollectM QualifiedName (Pascal a)
|
||||
instance UpdateOver CollectM Path (Pascal a)
|
||||
instance UpdateOver CollectM Name (Pascal a)
|
||||
instance UpdateOver CollectM TypeName (Pascal a)
|
||||
instance UpdateOver CollectM FieldName (Pascal a)
|
||||
-- instance UpdateOver CollectM QualifiedName (Pascal a)
|
||||
-- instance UpdateOver CollectM Path (Pascal a)
|
||||
-- instance UpdateOver CollectM Name (Pascal a)
|
||||
-- instance UpdateOver CollectM TypeName (Pascal a)
|
||||
-- instance UpdateOver CollectM FieldName (Pascal a)
|
||||
|
||||
@ -7,9 +7,11 @@
|
||||
module AST.Types where
|
||||
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as Text
|
||||
|
||||
import Pretty
|
||||
import Tree
|
||||
import Duplo.Pretty
|
||||
import Duplo.Tree
|
||||
import Duplo.Error
|
||||
|
||||
-- import Debug.Trace
|
||||
|
||||
@ -17,34 +19,57 @@ import Tree
|
||||
--
|
||||
-- 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
|
||||
, 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
|
||||
= ContractEnd
|
||||
| ContractCons it it -- ^ Declaration
|
||||
deriving (Show) via PP (Contract it)
|
||||
deriving stock (Functor, Foldable, Traversable)
|
||||
|
||||
data Declaration it
|
||||
= ValueDecl it -- ^ Binding
|
||||
| TypeDecl it it -- ^ Name Type
|
||||
| Action it -- ^ Expr
|
||||
| Include Text it
|
||||
deriving (Show) via PP (Declaration it)
|
||||
data RawContract it
|
||||
= RawContract [it] -- ^ Declaration
|
||||
deriving (Show) via PP (RawContract it)
|
||||
deriving stock (Functor, Foldable, Traversable)
|
||||
|
||||
data Binding it
|
||||
= 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)
|
||||
| Const it it it -- ^ (Name) (Type) (Expr)
|
||||
| TypeDecl it it -- ^ Name Type
|
||||
| Include it
|
||||
deriving (Show) via PP (Binding it)
|
||||
deriving stock (Functor, Foldable, Traversable)
|
||||
|
||||
data Parameters it
|
||||
= Parameters [it]
|
||||
deriving (Show) via PP (Parameters it)
|
||||
deriving stock (Functor, Foldable, Traversable)
|
||||
|
||||
data VarDecl it
|
||||
= Decl it it it -- ^ (Mutable) (Name) (Type)
|
||||
deriving (Show) via PP (VarDecl it)
|
||||
@ -63,7 +88,10 @@ data Type it
|
||||
| TVar it -- ^ (Name)
|
||||
| TSum [it] -- ^ [Variant]
|
||||
| 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 stock (Functor, Foldable, Traversable)
|
||||
|
||||
@ -79,12 +107,13 @@ data TField it
|
||||
|
||||
-- | TODO: break onto smaller types? Literals -> Constant; mapOps; mmove Annots to Decls.
|
||||
data Expr it
|
||||
= Let it it -- Declaration (Expr)
|
||||
| Apply it [it] -- (Expr) [Expr]
|
||||
= Let it it -- Declaration Expr
|
||||
| Apply it it -- (Expr) [Expr]
|
||||
| Constant it -- (Constant)
|
||||
| Ident it -- (QualifiedName)
|
||||
| BinOp it Text it -- (Expr) Text (Expr)
|
||||
| UnOp Text it -- (Expr)
|
||||
| BinOp it it it -- (Expr) Text (Expr)
|
||||
| UnOp it it -- (Expr)
|
||||
| Op Text
|
||||
| Record [it] -- [Assignment]
|
||||
| If it it it -- (Expr) (Expr) (Expr)
|
||||
| Assign it it -- (LHS) (Expr)
|
||||
@ -92,7 +121,7 @@ data Expr it
|
||||
| Set [it] -- [Expr]
|
||||
| Tuple [it] -- [Expr]
|
||||
| Annot it it -- (Expr) (Type)
|
||||
| Attrs [Text]
|
||||
| Attrs [it]
|
||||
| BigMap [it] -- [MapBinding]
|
||||
| Map [it] -- [MapBinding]
|
||||
| MapRemove it it -- (Expr) (QualifiedName)
|
||||
@ -100,11 +129,11 @@ data Expr it
|
||||
| Indexing it it -- (QualifiedName) (Expr)
|
||||
| Case it [it] -- (Expr) [Alt]
|
||||
| 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)
|
||||
| Seq [it] -- [Declaration]
|
||||
| Lambda [it] it it -- [VarDecl] (Type) (Expr)
|
||||
| ForBox it (Maybe it) Text it it -- (Name) (Maybe (Name)) Text (Expr) (Expr)
|
||||
| Lambda it it it -- [VarDecl] (Type) (Expr)
|
||||
| ForBox it (Maybe it) it it it -- (Name) (Maybe (Name)) Text (Expr) (Expr)
|
||||
| MapPatch it [it] -- (QualifiedName) [MapBinding]
|
||||
| SetPatch it [it] -- (QualifiedName) [Expr]
|
||||
| RecordUpd it [it] -- (QualifiedName) [FieldAssignment]
|
||||
@ -159,7 +188,7 @@ data Pattern it
|
||||
|
||||
data QualifiedName it
|
||||
= QualifiedName
|
||||
{ qnSource :: it -- Name
|
||||
{ qnSource :: it -- Name
|
||||
, qnPath :: [it] -- [Path]
|
||||
}
|
||||
deriving (Show) via PP (QualifiedName it)
|
||||
@ -181,43 +210,55 @@ newtype TypeName it = TypeName Text
|
||||
deriving (Show) via PP (TypeName it)
|
||||
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
|
||||
deriving (Show) via PP (TypeName it)
|
||||
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
|
||||
pp1 = \case
|
||||
ContractEnd -> "(* end *)"
|
||||
ContractCons x xs -> x $$ " " $$ xs
|
||||
|
||||
instance Pretty1 Declaration where
|
||||
instance Pretty1 RawContract where
|
||||
pp1 = \case
|
||||
ValueDecl binding -> binding
|
||||
TypeDecl n ty -> "type" <+> n <+> "=" `indent` ty
|
||||
Action e -> e
|
||||
|
||||
Include f t ->
|
||||
"(* module" <+> pp f <+> "*)"
|
||||
`indent` pp t
|
||||
`above` "(* end" <+> pp f <+> "*)"
|
||||
RawContract xs -> "(* begin *)" `indent` sparseBlock xs `above` "(* end *)"
|
||||
|
||||
instance Pretty1 Binding where
|
||||
pp1 = \case
|
||||
Irrefutable pat expr -> "irref" <+> pat <+> "=" `indent` expr
|
||||
Function isRec name params ty body ->
|
||||
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 ->
|
||||
(
|
||||
(
|
||||
( (if isRec then "recursive" else empty)
|
||||
<+> "function"
|
||||
<+> name
|
||||
)
|
||||
`indent` tuple params
|
||||
`indent` params
|
||||
)
|
||||
`indent` (":" <+> ty <+> "is")
|
||||
`indent` (":" <+> ty `above` "is")
|
||||
)
|
||||
`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
|
||||
pp1 = \case
|
||||
@ -235,7 +276,10 @@ instance Pretty1 Type where
|
||||
TVar name -> name
|
||||
TSum variants -> block variants
|
||||
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
|
||||
pp1 = \case
|
||||
@ -244,12 +288,13 @@ instance Pretty1 Variant where
|
||||
|
||||
instance Pretty1 Expr where
|
||||
pp1 = \case
|
||||
Let decl body -> "block {" `indent` decl `above` "}" <+> "with" `indent` body
|
||||
Apply f xs -> f <+> tuple xs
|
||||
Let decl body -> decl `above` "with" `indent` body
|
||||
Apply f xs -> f <+> xs
|
||||
Constant constant -> constant
|
||||
Ident qname -> qname
|
||||
BinOp l o r -> parens (l <+> pp o <+> r)
|
||||
UnOp o r -> parens (pp o <+> r)
|
||||
Op o -> pp o
|
||||
Record az -> "record" <+> list az
|
||||
If b t e -> fsep ["if" `indent` b, "then" `indent` t, "else" `indent` e]
|
||||
Assign l r -> l <+> ":=" `indent` r
|
||||
@ -262,14 +307,14 @@ instance Pretty1 Expr where
|
||||
Map bs -> "map" <+> list bs
|
||||
MapRemove k m -> "remove" `indent` k `above` "from" <+> "map" `indent` m
|
||||
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
|
||||
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
|
||||
WhileLoop f b -> "while" <+> f `indent` b
|
||||
Seq es -> "block {" `indent` sparseBlock es `above` "}"
|
||||
Lambda ps ty b -> (("function" `indent` tuple ps) `indent` (":" <+> ty)) `indent` b
|
||||
Seq es -> "block {" `indent` block es `above` "}"
|
||||
Lambda ps ty b -> (("function" `indent` ps) `indent` (":" <+> ty)) `indent` b
|
||||
MapPatch z bs -> "patch" `indent` z `above` "with" <+> "map" `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
|
||||
@ -301,7 +346,7 @@ instance Pretty1 Constant where
|
||||
|
||||
instance Pretty1 QualifiedName where
|
||||
pp1 = \case
|
||||
QualifiedName src path -> src <> sepByDot path
|
||||
QualifiedName src path -> src <.> sepByDot path
|
||||
|
||||
instance Pretty1 Pattern where
|
||||
pp1 = \case
|
||||
@ -326,6 +371,10 @@ instance Pretty1 FieldName where
|
||||
pp1 = \case
|
||||
FieldName raw -> pp raw
|
||||
|
||||
instance Pretty1 Ctor where
|
||||
pp1 = \case
|
||||
Ctor raw -> pp raw
|
||||
|
||||
instance Pretty1 Path where
|
||||
pp1 = \case
|
||||
At n -> n
|
||||
@ -333,8 +382,8 @@ instance Pretty1 Path where
|
||||
|
||||
instance Pretty1 TField where
|
||||
pp1 = \case
|
||||
TField n t -> n <> ":" `indent` t
|
||||
TField n t -> n <.> ":" `indent` t
|
||||
|
||||
instance Pretty1 LHS where
|
||||
pp1 = \case
|
||||
LHS qn mi -> qn <> foldMap brackets mi
|
||||
LHS qn mi -> qn <.> foldMap brackets mi
|
||||
|
||||
@ -11,7 +11,8 @@ module Comment
|
||||
import qualified Data.Text as Text
|
||||
import Data.Text (Text)
|
||||
|
||||
import Pretty
|
||||
import Duplo.Pretty
|
||||
|
||||
import Product
|
||||
|
||||
-- | Ability to contain comments.
|
||||
|
||||
@ -36,4 +36,4 @@ test = debounced \s -> do
|
||||
threadDelay 2000000
|
||||
unless (odd (length s)) do
|
||||
error "even"
|
||||
return (length s)
|
||||
return (length s)
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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"
|
||||
|
||||
@ -10,11 +10,13 @@
|
||||
module ParseTree
|
||||
( -- * Tree/Forest
|
||||
ParseTree(..)
|
||||
, ParseForest(..)
|
||||
, Source(..)
|
||||
, RawTree
|
||||
, RawInfo
|
||||
|
||||
-- * Invoke the TreeSitter and get the tree it outputs
|
||||
, toParseTree
|
||||
-- , example
|
||||
)
|
||||
where
|
||||
|
||||
@ -27,7 +29,7 @@ import Data.Text (Text)
|
||||
import Data.Traversable (for)
|
||||
|
||||
import TreeSitter.Parser
|
||||
import TreeSitter.Tree
|
||||
import TreeSitter.Tree hiding (Tree)
|
||||
import TreeSitter.Language
|
||||
import TreeSitter.Node
|
||||
import Foreign.C.String (peekCString)
|
||||
@ -42,12 +44,16 @@ import Foreign.Storable ( peek
|
||||
)
|
||||
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 Pretty
|
||||
import Product
|
||||
import Debouncer
|
||||
|
||||
foreign import ccall unsafe tree_sitter_PascaLigo :: Ptr Language
|
||||
|
||||
@ -62,110 +68,97 @@ srcToBytestring = \case
|
||||
Text _ t -> return $ Text.encodeUtf8 t
|
||||
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.
|
||||
data ParseTree = ParseTree
|
||||
{ ptID :: Int -- ^ Unique number, for fast comparison.
|
||||
, ptName :: Text -- ^ Name of the node.
|
||||
, ptRange :: Range -- ^ Range of the node.
|
||||
, ptChildren :: ParseForest -- ^ Subtrees.
|
||||
data ParseTree self = ParseTree
|
||||
{ ptName :: Text -- ^ Name of the node.
|
||||
, ptChildren :: [self] -- ^ Subtrees.
|
||||
, ptSource :: ~Text -- ^ Range of the node.
|
||||
}
|
||||
deriving (Show) via PP ParseTree
|
||||
deriving stock (Functor, Foldable, Traversable)
|
||||
|
||||
-- | The forest we work with.
|
||||
data ParseForest = 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 _) =
|
||||
instance Pretty1 ParseTree where
|
||||
pp1 (ParseTree n forest _) =
|
||||
parens
|
||||
( hang
|
||||
(quotes (text (Text.unpack n)) <+> pp r)
|
||||
(quotes (text (Text.unpack n)))
|
||||
2
|
||||
(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.
|
||||
toParseTree :: Source -> IO ParseForest
|
||||
toParseTree fin = do
|
||||
parser <- ts_parser_new
|
||||
True <- ts_parser_set_language parser tree_sitter_PascaLigo
|
||||
|
||||
src <- srcToBytestring fin
|
||||
|
||||
idCounter <- newIORef 0
|
||||
|
||||
BS.useAsCStringLen src \(str, len) -> do
|
||||
tree <- ts_parser_parse_string parser nullPtr str len
|
||||
finalTree <- withRootNode tree (peek >=> go src idCounter)
|
||||
return $ Forest 0 [("", finalTree)] (ptRange finalTree)
|
||||
|
||||
toParseTree :: Source -> IO RawTree
|
||||
toParseTree = unsafePerformIO $ debounced inner
|
||||
where
|
||||
nextID :: IORef Int -> IO Int
|
||||
nextID ref = do
|
||||
modifyIORef' ref (+ 1)
|
||||
readIORef ref
|
||||
inner fin = do
|
||||
parser <- ts_parser_new
|
||||
True <- ts_parser_set_language parser tree_sitter_PascaLigo
|
||||
|
||||
go :: ByteString -> IORef Int -> Node -> IO ParseTree
|
||||
go src idCounter node = do
|
||||
let count = fromIntegral $ nodeChildCount node
|
||||
allocaArray count \children -> do
|
||||
alloca \tsNodePtr -> do
|
||||
poke tsNodePtr $ nodeTSNode node
|
||||
ts_node_copy_child_nodes tsNodePtr children
|
||||
nodes <- for [0.. count - 1] \i -> do
|
||||
peekElemOff children i
|
||||
src <- srcToBytestring fin
|
||||
|
||||
trees <- for nodes \node' -> do
|
||||
tree <- go src idCounter node'
|
||||
field <-
|
||||
if nodeFieldName node' == nullPtr
|
||||
then return ""
|
||||
else peekCString $ nodeFieldName node'
|
||||
return (Text.pack field, tree)
|
||||
idCounter <- newIORef 0
|
||||
|
||||
ty <- peekCString $ nodeType node
|
||||
BS.useAsCStringLen src \(str, len) -> do
|
||||
tree <- ts_parser_parse_string parser nullPtr str len
|
||||
withRootNode tree (peek >=> go src idCounter)
|
||||
|
||||
let
|
||||
start2D = nodeStartPoint node
|
||||
finish2D = nodeEndPoint node
|
||||
i = fromIntegral
|
||||
where
|
||||
nextID :: IORef Int -> IO Int
|
||||
nextID ref = do
|
||||
modifyIORef' ref (+ 1)
|
||||
readIORef ref
|
||||
|
||||
treeID <- nextID idCounter
|
||||
fID <- nextID idCounter
|
||||
go :: ByteString -> IORef Int -> Node -> IO RawTree
|
||||
go src idCounter node = do
|
||||
let count = fromIntegral $ nodeChildCount node
|
||||
allocaArray count \children -> do
|
||||
alloca \tsNodePtr -> do
|
||||
poke tsNodePtr $ nodeTSNode node
|
||||
ts_node_copy_child_nodes tsNodePtr children
|
||||
nodes <- for [0.. count - 1] \i -> do
|
||||
peekElemOff children i
|
||||
|
||||
let
|
||||
range = Range
|
||||
{ rStart =
|
||||
( i $ pointRow start2D + 1
|
||||
, i $ pointColumn start2D + 1
|
||||
, i $ nodeStartByte node
|
||||
)
|
||||
trees <- for nodes \node' -> do
|
||||
(only -> (r :> _, tree :: ParseTree RawTree)) <- go src idCounter node'
|
||||
field <-
|
||||
if nodeFieldName node' == nullPtr
|
||||
then return ""
|
||||
else peekCString $ nodeFieldName node'
|
||||
return $ make (r :> Text.pack field :> Nil, tree)
|
||||
|
||||
, rFinish =
|
||||
( i $ pointRow finish2D + 1
|
||||
, i $ pointColumn finish2D + 1
|
||||
, i $ nodeEndByte node
|
||||
)
|
||||
, rFile = takeFileName $ srcPath fin
|
||||
}
|
||||
ty <- peekCString $ nodeType node
|
||||
|
||||
return $ ParseTree
|
||||
{ ptID = treeID
|
||||
, ptName = Text.pack ty
|
||||
, ptRange = range
|
||||
, ptChildren = Forest fID trees range
|
||||
, ptSource = cutOut range src
|
||||
}
|
||||
let
|
||||
start2D = nodeStartPoint node
|
||||
finish2D = nodeEndPoint node
|
||||
i = fromIntegral
|
||||
|
||||
treeID <- nextID idCounter
|
||||
fID <- nextID idCounter
|
||||
|
||||
let
|
||||
range = Range
|
||||
{ rStart =
|
||||
( i $ pointRow start2D + 1
|
||||
, i $ pointColumn start2D + 1
|
||||
, i $ nodeStartByte node
|
||||
)
|
||||
|
||||
, rFinish =
|
||||
( i $ pointRow finish2D + 1
|
||||
, i $ pointColumn finish2D + 1
|
||||
, i $ nodeEndByte node
|
||||
)
|
||||
, rFile = takeFileName $ srcPath fin
|
||||
}
|
||||
|
||||
return $ make (range :> "" :> Nil, ParseTree
|
||||
{ ptName = Text.pack ty
|
||||
, ptChildren = trees
|
||||
, ptSource = cutOut range src
|
||||
})
|
||||
|
||||
@ -1,448 +1,158 @@
|
||||
|
||||
{- |
|
||||
The thing that can untangle the mess that TreeSitter produces.
|
||||
module Parser where
|
||||
|
||||
In presence of serious errors, it /will/ be a mess, anyway.
|
||||
|
||||
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.Arrow
|
||||
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.Foldable
|
||||
import Data.String.Interpolate (i)
|
||||
import Data.Text (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 Range
|
||||
import Pretty
|
||||
import Error
|
||||
import Product
|
||||
|
||||
import Debug.Trace
|
||||
|
||||
-- | Parser of tree-sitter-made tree.
|
||||
--
|
||||
-- TODO: separate state. Polysemy?
|
||||
--
|
||||
type Parser =
|
||||
WriterT [Error ASTInfo]
|
||||
(StateT (Product PList)
|
||||
IO)
|
||||
{-
|
||||
Comment grabber has 2 buffers: 1 and 2.
|
||||
|
||||
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.
|
||||
type ASTInfo = Product [Range, [Text]]
|
||||
runParserM :: ParserM a -> IO (a, [Err Text ()])
|
||||
runParserM p = (\(a, _, errs) -> (a, errs)) <$> runRWST p () ([], [])
|
||||
|
||||
runParser
|
||||
:: Stubbed a ASTInfo
|
||||
=> Parser a
|
||||
-> Source
|
||||
-> IO (a, [Error ASTInfo])
|
||||
runParser parser fin = do
|
||||
pforest <- toParseTree fin
|
||||
runParserM1 :: [RawTree] -> ParserM1 a -> ParserM (Maybe a)
|
||||
runParserM1 cs p = do
|
||||
s <- get
|
||||
(a, s1, w) <- lift $ runRWST (runMaybeT p) cs s
|
||||
tell w
|
||||
put s1
|
||||
return a
|
||||
|
||||
let dir = takeDirectory $ srcPath fin
|
||||
type ParserM = RWST () [Err Text ()] ([Text], [Text]) IO
|
||||
type ParserM1 = MaybeT (RWST [RawTree] [Err Text ()] ([Text], [Text]) IO)
|
||||
|
||||
runWriterT parser `evalStateT`
|
||||
Cons pforest
|
||||
(Cons []
|
||||
(Cons dir
|
||||
(Cons Set.empty
|
||||
Nil)))
|
||||
`catch` \(e :: Error ASTInfo) -> do
|
||||
return $ (stub e, [])
|
||||
data Failure = Failure String
|
||||
deriving stock (Show)
|
||||
deriving anyclass (Exception)
|
||||
|
||||
runParser'
|
||||
:: Stubbed a ASTInfo
|
||||
=> Parser a
|
||||
-> Source
|
||||
-> IO a
|
||||
runParser' parser fin = fst <$> runParser parser fin
|
||||
instance Scoped (Product [Range, Text]) ParserM RawTree ParseTree where
|
||||
enter (_ :> _ :> _) (ParseTree ty cs s) = do
|
||||
let (comms, rest) = allComments cs
|
||||
let (comms1, _) = allComments $ reverse rest
|
||||
modify $ first (++ comms)
|
||||
modify $ second (++ reverse comms1)
|
||||
|
||||
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)
|
||||
let errs = allErrors cs
|
||||
tell $ fmap Err errs
|
||||
|
||||
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
|
||||
leave _ _ = do
|
||||
modify \(x, y) -> (y, [])
|
||||
|
||||
get' :: forall x. Contains x PList => Parser x
|
||||
get' = gets getElem
|
||||
|
||||
gets' :: forall x a. Contains x PList => (x -> a) -> Parser a
|
||||
gets' f = gets (f . getElem)
|
||||
|
||||
put' :: forall x. Contains x PList => x -> Parser ()
|
||||
put' x = modify $ modElem $ const x
|
||||
|
||||
mod' :: forall x. Contains x PList => (x -> x) -> Parser ()
|
||||
mod' = modify . modElem
|
||||
|
||||
-- | Generate error originating at current location.
|
||||
makeError :: Text -> Parser (Error ASTInfo)
|
||||
makeError msg = do
|
||||
rng <- getInfo
|
||||
makeError' msg rng
|
||||
|
||||
-- | Generate error originating at given location.
|
||||
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 :: ParserM [Text]
|
||||
grabComments = do
|
||||
comms <- get'
|
||||
mod' @[Text] $ const []
|
||||
return comms
|
||||
ls <- gets fst
|
||||
modify \(x, y) -> ([], y)
|
||||
return ls
|
||||
|
||||
-- | /Actual/ debug pring.
|
||||
dump :: Parser ()
|
||||
dump = gets' pfGrove >>= traceShowM
|
||||
allComments :: [RawTree] -> ([Text], [RawTree])
|
||||
allComments = first (map getBody . filter isComment) . break isMeaningful
|
||||
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 ""
|
||||
|
||||
@ -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
|
||||
@ -6,11 +6,15 @@ module Product where
|
||||
|
||||
import GHC.Types
|
||||
|
||||
import Duplo.Pretty
|
||||
|
||||
-- | `Product xs` contains elements of each of the types from the `xs` list.
|
||||
data Product xs where
|
||||
Cons :: x -> Product xs -> Product (x : xs)
|
||||
(:>) :: x -> Product xs -> Product (x : xs)
|
||||
Nil :: Product '[]
|
||||
|
||||
infixr 5 :>
|
||||
|
||||
-- | Find/modify the element with a given type.
|
||||
--
|
||||
-- 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
|
||||
|
||||
instance {-# OVERLAPS #-} Contains x (x : xs) where
|
||||
getElem (Cons x _) = x
|
||||
modElem f (Cons x xs) = Cons (f x) xs
|
||||
getElem (x :> _) = x
|
||||
modElem f (x :> xs) = f x :> xs
|
||||
|
||||
instance Contains x xs => Contains x (y : xs) where
|
||||
getElem (Cons _ xs) = getElem xs
|
||||
modElem f (Cons x xs) = Cons x (modElem f xs)
|
||||
getElem (_ :> xs) = getElem xs
|
||||
modElem f (x :> xs) = x :> modElem f xs
|
||||
|
||||
-- | Add a name to the type.
|
||||
--
|
||||
@ -43,4 +47,28 @@ modTag
|
||||
. Contains (s := t) xs
|
||||
=> (t -> t)
|
||||
-> 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
|
||||
@ -16,8 +16,9 @@ import Data.ByteString (ByteString)
|
||||
import Data.Text (Text)
|
||||
import Data.Text.Encoding
|
||||
|
||||
import Pretty
|
||||
import Lattice
|
||||
import Duplo.Lattice
|
||||
import Duplo.Pretty
|
||||
|
||||
import Product
|
||||
|
||||
point :: Int -> Int -> Range
|
||||
@ -40,11 +41,11 @@ instance Pretty Range where
|
||||
pp (Range (ll, lc, _) (rl, rc, _) f) =
|
||||
color 2 do
|
||||
brackets do
|
||||
text f <> ":"
|
||||
<> int ll <> ":"
|
||||
<> int lc <> "-"
|
||||
<> int rl <> ":"
|
||||
<> int rc
|
||||
text f <.> ":"
|
||||
<.> int ll <.> ":"
|
||||
<.> int lc <.> "-"
|
||||
<.> int rl <.> ":"
|
||||
<.> int rc
|
||||
|
||||
-- | Ability to get range out of something.
|
||||
class HasRange a where
|
||||
@ -65,10 +66,14 @@ cutOut (Range (_, _, s) (_, _, f) _) bs =
|
||||
bs
|
||||
|
||||
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) &&
|
||||
(rl2 > ll2 || rl2 == ll2 && rc2 >= lc2)
|
||||
|
||||
instance Eq Range where
|
||||
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
|
||||
@ -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
|
||||
@ -40,8 +40,8 @@ extra-deps:
|
||||
- lingo-0.3.2.0@sha256:80b9ded65f2ddc0272a2872d9c3fc43c37934accae076d3e547dfc6c6b6e16d3,1899
|
||||
- semilattices-0.0.0.4@sha256:333707e460923711d1edbdd02ebe1c3957d4e0808eab9886747b52ee3e443639,1909
|
||||
- fastsum-0.1.1.1
|
||||
- git: https://github.com/Heimdell/dual-effects.git
|
||||
commit: dc3e8bcd0aa00b9264e86293ec42c0b5835e930c
|
||||
- git: https://github.com/serokell/duplo.git
|
||||
commit: 8fb7a22d0e6ff75ec049c36c6f767ee14e841446
|
||||
# - acme-missiles-0.3
|
||||
# - git: https://github.com/commercialhaskell/stack.git
|
||||
# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
|
||||
|
||||
@ -40,19 +40,16 @@ packages:
|
||||
original:
|
||||
hackage: fastsum-0.1.1.1
|
||||
- completed:
|
||||
cabal-file:
|
||||
size: 1569
|
||||
sha256: 828a5bc60b97347d491038b435da664ae281a6dab26e9beb261d319c2601c4dc
|
||||
name: eff
|
||||
name: duplo
|
||||
version: 0.0.0
|
||||
git: https://github.com/Heimdell/dual-effects.git
|
||||
git: https://github.com/serokell/duplo.git
|
||||
pantry-tree:
|
||||
size: 972
|
||||
sha256: 4443705f2fc31929822a3cda4036f9a93950686f4729cd28280253e981828391
|
||||
commit: dc3e8bcd0aa00b9264e86293ec42c0b5835e930c
|
||||
size: 557
|
||||
sha256: b5d8c86a8a26bc2efc0f86314317fa36b5f57c5d44cb889bee58f10782767037
|
||||
commit: 8fb7a22d0e6ff75ec049c36c6f767ee14e841446
|
||||
original:
|
||||
git: https://github.com/Heimdell/dual-effects.git
|
||||
commit: dc3e8bcd0aa00b9264e86293ec42c0b5835e930c
|
||||
git: https://github.com/serokell/duplo.git
|
||||
commit: 8fb7a22d0e6ff75ec049c36c6f767ee14e841446
|
||||
snapshots:
|
||||
- completed:
|
||||
size: 493124
|
||||
|
||||
Loading…
Reference in New Issue
Block a user