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

[WIP] Conversion to descent-based parser

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

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

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

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

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

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

@ -123,7 +123,16 @@ function buy_single (const action : action_buy_single;
function main (const action : parameter; const s : storage) : return is
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

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

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

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

@ -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")

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

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

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

@ -39,5 +39,7 @@ function foobar (const i : int) : int is
end
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

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

@ -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)

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

@ -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

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

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

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

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

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

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

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

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

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

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

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

@ -25,3 +25,10 @@ function patch_op_deep (var s : set (string) * nat) : set (string) * nat is
function mem_op (const s : set (string)) : bool is
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

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

@ -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)/,

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

@ -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
tools/lsp/squirrel/examples/sanity.ligo
View File

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

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

@ -5,13 +5,16 @@ dependencies:
- bytestring
- 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

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

@ -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

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

File diff suppressed because it is too large Load Diff

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

@ -23,318 +23,319 @@ import Data.Maybe (listToMaybe)
import Data.Sum (Element, Apply, Sum)
import Data.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)

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

@ -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

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

@ -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.

2
tools/lsp/squirrel/src/Debouncer.hs
View File

@ -36,4 +36,4 @@ test = debounced \s -> do
threadDelay 2000000
unless (odd (length s)) do
error "even"
return (length s)
return (length s)

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

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

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

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

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

@ -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
})

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

@ -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 ""

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

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

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

@ -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

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

@ -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

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

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

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

@ -40,8 +40,8 @@ extra-deps:
- lingo-0.3.2.0@sha256:80b9ded65f2ddc0272a2872d9c3fc43c37934accae076d3e547dfc6c6b6e16d3,1899
- 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

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

@ -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