Make parser recognise all src/tests/contracts
This commit is contained in:
Kirill Andreev
parent
b4e6231340
commit
e6299a50ff
@ -100,12 +100,16 @@ module.exports = grammar({
|
||||
),
|
||||
|
||||
cartesian: $ =>
|
||||
sepBy1('*', field("element", $._core_type)),
|
||||
sepBy1('*',
|
||||
choice(
|
||||
field("element", $._core_type),
|
||||
par(field("element", $.type_expr)),
|
||||
),
|
||||
),
|
||||
|
||||
_core_type: $ =>
|
||||
choice(
|
||||
$.Name,
|
||||
par($.type_expr),
|
||||
$.invokeBinary,
|
||||
$.invokeUnary,
|
||||
),
|
||||
@ -551,7 +555,7 @@ module.exports = grammar({
|
||||
field("type", $._type_expr)
|
||||
)),
|
||||
|
||||
set_expr: $ => injection('set', $._expr),
|
||||
set_expr: $ => injection('set', field("element", $._expr)),
|
||||
|
||||
_map_expr: $ =>
|
||||
choice(
|
||||
@ -645,7 +649,7 @@ module.exports = grammar({
|
||||
|
||||
field_path_assignment: $ =>
|
||||
seq(
|
||||
sepBy1('.', field("index", $.Name)),
|
||||
field("lhs", $.path),
|
||||
'=',
|
||||
field("_rhs", $._expr),
|
||||
),
|
||||
@ -663,7 +667,11 @@ module.exports = grammar({
|
||||
|
||||
_list_injection: $ => injection('list', field("element", $._expr)),
|
||||
|
||||
pattern: $ => sepBy1('#', field("arg", $._core_pattern)),
|
||||
pattern: $ =>
|
||||
choice(
|
||||
$._cons_pattern,
|
||||
field("the", $._core_pattern),
|
||||
),
|
||||
|
||||
_core_pattern: $ =>
|
||||
choice(
|
||||
@ -679,12 +687,11 @@ module.exports = grammar({
|
||||
|
||||
list_pattern: $ =>
|
||||
choice(
|
||||
injection("list", field("element", $._core_pattern)),
|
||||
injection("list", field("element", $.pattern)),
|
||||
'nil',
|
||||
par($.cons_pattern),
|
||||
),
|
||||
|
||||
cons_pattern: $ =>
|
||||
_cons_pattern: $ =>
|
||||
seq(
|
||||
field("head", $._core_pattern),
|
||||
'#',
|
||||
@ -692,7 +699,7 @@ module.exports = grammar({
|
||||
),
|
||||
|
||||
tuple_pattern: $ =>
|
||||
par(sepBy1(',', field("element", $._core_pattern))),
|
||||
par(sepBy1(',', field("element", $.pattern))),
|
||||
|
||||
_constr_pattern: $ => choice(
|
||||
$.Unit,
|
||||
@ -706,7 +713,7 @@ module.exports = grammar({
|
||||
Some_pattern: $ =>
|
||||
seq(
|
||||
field("constr", 'Some'),
|
||||
par(field("arg", $._core_pattern)),
|
||||
par(field("arg", $.pattern)),
|
||||
),
|
||||
|
||||
user_constr_pattern: $ =>
|
||||
@ -733,7 +740,7 @@ module.exports = grammar({
|
||||
'*)'
|
||||
),
|
||||
|
||||
include: $ => seq('#include', $.String),
|
||||
include: $ => seq('#include', field("filename", $.String)),
|
||||
|
||||
String: $ => /\"(\\.|[^"])*\"/,
|
||||
Int: $ => /-?([1-9][0-9_]*|0)/,
|
||||
|
||||
@ -1,6 +1,8 @@
|
||||
|
||||
import Data.Foldable (for_)
|
||||
|
||||
import Control.Monad (unless)
|
||||
|
||||
import ParseTree
|
||||
import Parser
|
||||
import AST
|
||||
@ -13,7 +15,9 @@ main = do
|
||||
[fin] <- getArgs
|
||||
toParseTree fin >>= print
|
||||
(res, errs) <- runParser contract fin
|
||||
putStrLn "----------------------"
|
||||
print (pp res)
|
||||
unless (null errs) do
|
||||
putStrLn ""
|
||||
putStrLn "Errors:"
|
||||
for_ errs (print . nest 2 . pp)
|
||||
@ -29,8 +29,14 @@ declaration
|
||||
= do ctor ValueDecl <*> binding
|
||||
<|> do ctor ValueDecl <*> vardecl
|
||||
<|> do ctor ValueDecl <*> constdecl
|
||||
<|> typedecl
|
||||
<|> do typedecl
|
||||
<|> do ctor Action <*> attributes
|
||||
<|> do include
|
||||
|
||||
include = do
|
||||
subtree "include" do
|
||||
ctor Include
|
||||
<*> inside "filename" do token "String"
|
||||
|
||||
typedecl :: Parser (Declaration ASTInfo)
|
||||
typedecl = do
|
||||
@ -42,10 +48,11 @@ typedecl = do
|
||||
vardecl :: Parser (Binding ASTInfo)
|
||||
vardecl = do
|
||||
subtree "var_decl" do
|
||||
dump
|
||||
ctor Var
|
||||
<*> inside "name:" name
|
||||
<*> inside "type:" type_
|
||||
<*> inside "value:" expr
|
||||
<*> inside "name" name
|
||||
<*> inside "type" type_
|
||||
<*> inside "value" expr
|
||||
|
||||
constdecl :: Parser (Binding ASTInfo)
|
||||
constdecl = do
|
||||
@ -63,17 +70,14 @@ binding = do
|
||||
<*> inside "name:" name
|
||||
<*> inside "parameters:parameters" do
|
||||
many "param" do
|
||||
notFollowedBy do
|
||||
consumeOrDie ")"
|
||||
|
||||
stubbed "parameters" paramDecl
|
||||
inside "parameter" paramDecl
|
||||
<*> inside "type:" type_
|
||||
<*> inside "body:" letExpr
|
||||
|
||||
recursive = do
|
||||
mr <- optional do
|
||||
inside "recursive" do
|
||||
token "recursie"
|
||||
token "recursive"
|
||||
|
||||
return $ maybe False (== "recursive") mr
|
||||
|
||||
@ -102,13 +106,291 @@ expr = stubbed "expr" do
|
||||
, big_map_expr
|
||||
, map_expr
|
||||
, map_remove
|
||||
-- , constant
|
||||
, indexing
|
||||
, constr_call
|
||||
, nat_literal
|
||||
, nullary_ctor
|
||||
, bytes_literal
|
||||
, case_expr
|
||||
, skip
|
||||
, case_action
|
||||
, clause_block
|
||||
, loop
|
||||
, seq_expr
|
||||
, lambda_expr
|
||||
, set_expr
|
||||
, map_patch
|
||||
, record_update
|
||||
, set_patch
|
||||
, set_remove
|
||||
]
|
||||
|
||||
set_remove :: Parser (Expr ASTInfo)
|
||||
set_remove = do
|
||||
subtree "set_remove" do
|
||||
ctor SetRemove
|
||||
<*> inside "key" expr
|
||||
<*> inside "container" do
|
||||
inside ":path" do
|
||||
qname <|> projection
|
||||
|
||||
set_patch = do
|
||||
subtree "set_patch" do
|
||||
ctor SetPatch
|
||||
<*> inside "container:path" (qname <|> projection)
|
||||
<*> many "key" do
|
||||
inside "key" expr
|
||||
|
||||
record_update = do
|
||||
subtree "update_record" do
|
||||
ctor RecordUpd
|
||||
<*> inside "record:path" do qname <|> projection
|
||||
<*> many "field" do
|
||||
inside "assignment" field_path_assignment
|
||||
|
||||
field_path_assignment = do
|
||||
subtree "field_path_assignment" do
|
||||
ctor FieldAssignment
|
||||
<*> inside "lhs:path" do qname <|> projection
|
||||
<*> inside "_rhs" expr
|
||||
|
||||
map_patch = do
|
||||
subtree "map_patch" do
|
||||
ctor MapPatch
|
||||
<*> inside "container:path" (qname <|> projection)
|
||||
<*> many "binding" do
|
||||
inside "binding" map_binding
|
||||
|
||||
set_expr :: Parser (Expr ASTInfo)
|
||||
set_expr = do
|
||||
subtree "set_expr" do
|
||||
ctor List <*> do
|
||||
many "list elem" do
|
||||
inside "element" expr
|
||||
|
||||
lambda_expr = do
|
||||
subtree "fun_expr" do
|
||||
ctor Lambda
|
||||
<*> inside "parameters:parameters" do
|
||||
many "param" do
|
||||
inside "parameter" paramDecl
|
||||
<*> inside "type" newtype_
|
||||
<*> inside "body" expr
|
||||
|
||||
seq_expr = do
|
||||
subtree "block" do
|
||||
dump
|
||||
ctor Seq <*> do
|
||||
many "statement" do
|
||||
inside "statement" do
|
||||
declaration <|> statement
|
||||
|
||||
loop = do
|
||||
subtree "loop" do
|
||||
for_loop <|> while_loop <|> for_container
|
||||
|
||||
for_container = do
|
||||
subtree "for_loop" do
|
||||
ctor ForBox
|
||||
<*> inside "key" name
|
||||
<*> optional do inside "value" name
|
||||
<*> inside "kind" anything
|
||||
<*> inside "collection" expr
|
||||
<*> inside "body" (expr <|> seq_expr)
|
||||
|
||||
while_loop = do
|
||||
subtree "while_loop" do
|
||||
ctor WhileLoop
|
||||
<*> inside "breaker" expr
|
||||
<*> inside "body" expr
|
||||
|
||||
for_loop = do
|
||||
subtree "for_loop" do
|
||||
ctor ForLoop
|
||||
<*> inside "name" name
|
||||
<*> inside "begin" expr
|
||||
<*> inside "end" expr
|
||||
<*> inside "body" expr
|
||||
|
||||
clause_block = do
|
||||
subtree "clause_block" do
|
||||
inside "block:block" do
|
||||
ctor Seq <*> many "statement" do
|
||||
inside "statement" (declaration <|> statement)
|
||||
<|> do
|
||||
subtree "clause_block" do
|
||||
ctor Seq <*> many "statement" do
|
||||
inside "statement" (declaration <|> statement)
|
||||
|
||||
skip :: Parser (Expr ASTInfo)
|
||||
skip = do
|
||||
ctor Skip <* token "skip"
|
||||
|
||||
case_action :: Parser (Expr ASTInfo)
|
||||
case_action = do
|
||||
subtree "case_instr" do
|
||||
dump
|
||||
ctor Case
|
||||
<*> inside "subject" expr
|
||||
<*> many "case" do
|
||||
inside "case" alt_action
|
||||
|
||||
alt_action :: Parser (Alt ASTInfo)
|
||||
alt_action = do
|
||||
subtree "case_clause_instr" do
|
||||
ctor Alt
|
||||
<*> inside "pattern" pattern
|
||||
<*> inside "body:if_clause" expr
|
||||
|
||||
case_expr :: Parser (Expr ASTInfo)
|
||||
case_expr = do
|
||||
subtree "case_expr" do
|
||||
ctor Case
|
||||
<*> inside "subject" expr
|
||||
<*> many "case" do
|
||||
inside "case" alt
|
||||
|
||||
alt :: Parser (Alt ASTInfo)
|
||||
alt = do
|
||||
subtree "case_clause_expr" do
|
||||
ctor Alt
|
||||
<*> inside "pattern" pattern
|
||||
<*> inside "body" expr
|
||||
|
||||
pattern :: Parser (Pattern ASTInfo)
|
||||
pattern = do
|
||||
subtree "pattern" $ do
|
||||
inside "the" core_pattern
|
||||
<|>
|
||||
do ctor IsCons
|
||||
<*> inside "head" core_pattern
|
||||
<*> inside "tail" pattern
|
||||
|
||||
core_pattern :: Parser (Pattern ASTInfo)
|
||||
core_pattern
|
||||
= -- int_pattern
|
||||
-- <|> nat_pattern
|
||||
-- <|> var_pattern
|
||||
-- <|> list_pattern
|
||||
-- <|> tuple_pattern
|
||||
-- <|>
|
||||
constr_pattern
|
||||
<|> string_pattern
|
||||
<|> int_pattern
|
||||
<|> nat_pattern
|
||||
<|> tuple_pattern
|
||||
<|> list_pattern
|
||||
<|> some_pattern
|
||||
<|> var_pattern
|
||||
|
||||
var_pattern :: Parser (Pattern ASTInfo)
|
||||
var_pattern =
|
||||
ctor IsVar <*> name
|
||||
|
||||
some_pattern :: Parser (Pattern ASTInfo)
|
||||
some_pattern = do
|
||||
subtree "Some_pattern" do
|
||||
ctor IsConstr
|
||||
<*> do inside "constr" do ctor Name <*> token "Some"
|
||||
<*> do Just <$> inside "arg" pattern
|
||||
|
||||
string_pattern :: Parser (Pattern ASTInfo)
|
||||
string_pattern =
|
||||
ctor IsConstant <*> do
|
||||
ctor String <*> token "String"
|
||||
|
||||
nat_pattern :: Parser (Pattern ASTInfo)
|
||||
nat_pattern =
|
||||
ctor IsConstant <*> do
|
||||
ctor Nat <*> token "Nat"
|
||||
|
||||
int_pattern :: Parser (Pattern ASTInfo)
|
||||
int_pattern =
|
||||
ctor IsConstant <*> do
|
||||
ctor Int <*> token "Int"
|
||||
|
||||
constr_pattern :: Parser (Pattern ASTInfo)
|
||||
constr_pattern =
|
||||
do
|
||||
subtree "user_constr_pattern" do
|
||||
ctor IsConstr
|
||||
<*> inside "constr:constr" capitalName
|
||||
<*> optional do
|
||||
inside "arguments" tuple_pattern
|
||||
<|>
|
||||
do
|
||||
ctor IsConstr
|
||||
<*> do ctor Name <*> do token "True" <|> token "False" <|> token "None" <|> token "Unit"
|
||||
<*> pure Nothing
|
||||
|
||||
tuple_pattern :: Parser (Pattern ASTInfo)
|
||||
tuple_pattern = do
|
||||
subtree "tuple_pattern" do
|
||||
ctor IsTuple <*> do
|
||||
many "element" do
|
||||
inside "element" pattern
|
||||
|
||||
list_pattern :: Parser (Pattern ASTInfo)
|
||||
list_pattern = do
|
||||
subtree "list_pattern" do
|
||||
ctor IsList <*> do
|
||||
many "element" do
|
||||
inside "element" pattern
|
||||
|
||||
nullary_ctor :: Parser (Expr ASTInfo)
|
||||
nullary_ctor = do
|
||||
ctor Ident <*> do
|
||||
ctor QualifiedName
|
||||
<*> do ctor Name <*> do
|
||||
true <|> false <|> none <|> unit
|
||||
<*> pure []
|
||||
where
|
||||
-- $.case_expr,
|
||||
-- $.cond_expr,
|
||||
-- $.disj_expr,
|
||||
-- $.fun_expr,
|
||||
true = token "True"
|
||||
false = token "False"
|
||||
none = token "None"
|
||||
unit = token "Unit"
|
||||
|
||||
nat_literal :: Parser (Expr ASTInfo)
|
||||
nat_literal = do
|
||||
ctor Constant <*> do
|
||||
ctor Nat <*> token "Nat"
|
||||
|
||||
bytes_literal :: Parser (Expr ASTInfo)
|
||||
bytes_literal = do
|
||||
ctor Constant <*> do
|
||||
ctor Bytes <*> token "Bytes"
|
||||
|
||||
constr_call :: Parser (Expr ASTInfo)
|
||||
constr_call = do
|
||||
some_call <|> user_constr_call
|
||||
where
|
||||
some_call = do
|
||||
subtree "Some_call" do
|
||||
ctor Apply
|
||||
<*> do ctor Ident <*> inside "constr" qname'
|
||||
<*> inside "arguments:arguments" do
|
||||
many "argument" do
|
||||
inside "argument" expr
|
||||
|
||||
user_constr_call = do
|
||||
subtree "constr_call" do
|
||||
ctor Apply
|
||||
<*> inside "constr:constr" do
|
||||
ctor Ident <*> do
|
||||
ctor QualifiedName
|
||||
<*> capitalName
|
||||
<*> pure []
|
||||
<*> inside "arguments:arguments" do
|
||||
many "argument" do
|
||||
inside "argument" expr
|
||||
|
||||
indexing :: Parser (Expr ASTInfo)
|
||||
indexing = do
|
||||
subtree "map_lookup" do
|
||||
ctor Indexing
|
||||
<*> inside "container:path" do
|
||||
qname <|> projection
|
||||
<*> inside "index" expr
|
||||
|
||||
map_remove :: Parser (Expr ASTInfo)
|
||||
map_remove = do
|
||||
@ -117,7 +399,7 @@ map_remove = do
|
||||
<*> inside "key" expr
|
||||
<*> inside "container" do
|
||||
inside ":path" do
|
||||
qname
|
||||
qname <|> projection
|
||||
|
||||
big_map_expr :: Parser (Expr ASTInfo)
|
||||
big_map_expr = do
|
||||
@ -148,7 +430,7 @@ moduleQualified = do
|
||||
ctor Ident <*> do
|
||||
ctor QualifiedName
|
||||
<*> inside "module" capitalName
|
||||
<*> do pure <$> do ctor At <*> inside "method" name
|
||||
<*> do pure <$> do ctor At <*> inside "method" do name <|> name'
|
||||
|
||||
tuple_expr :: Parser (Expr ASTInfo)
|
||||
tuple_expr = do
|
||||
@ -191,6 +473,12 @@ qname = do
|
||||
<*> name
|
||||
<*> pure []
|
||||
|
||||
qname' :: Parser (QualifiedName ASTInfo)
|
||||
qname' = do
|
||||
ctor QualifiedName
|
||||
<*> name'
|
||||
<*> pure []
|
||||
|
||||
assign :: Parser (Expr ASTInfo)
|
||||
assign = do
|
||||
subtree "assignment" do
|
||||
@ -230,17 +518,25 @@ if_expr = do
|
||||
<*> inside "selector" expr
|
||||
<*> inside "then:if_clause" expr
|
||||
<*> inside "else:if_clause" expr
|
||||
<|> do
|
||||
subtree "cond_expr" do
|
||||
ctor If
|
||||
<*> inside "selector" expr
|
||||
<*> inside "then" expr
|
||||
<*> inside "else" expr
|
||||
|
||||
method_call :: Parser (Expr ASTInfo)
|
||||
method_call = do
|
||||
subtree "projection_call" do
|
||||
ctor Apply
|
||||
<*> do ctor Ident <*> field "f" projection
|
||||
<*> inside "arguments" arguments
|
||||
ctor apply'
|
||||
<*> field "f" projection
|
||||
<*> optional do inside "arguments" arguments
|
||||
where
|
||||
apply' r f (Just xs) = Apply r (Ident r f) xs
|
||||
apply' r f _ = Ident r f
|
||||
|
||||
projection :: Parser (QualifiedName ASTInfo)
|
||||
projection = do
|
||||
gets pfGrove >>= traceShowM
|
||||
subtree "data_projection" do
|
||||
ctor QualifiedName
|
||||
<*> inside "struct" name
|
||||
@ -258,9 +554,12 @@ selection = do
|
||||
par_call :: Parser (Expr ASTInfo)
|
||||
par_call = do
|
||||
subtree "par_call" do
|
||||
ctor Apply
|
||||
ctor apply'
|
||||
<*> inside "f" expr
|
||||
<*> inside "arguments" arguments
|
||||
<*> optional do inside "arguments" arguments
|
||||
where
|
||||
apply' r f (Just xs) = Apply r f xs
|
||||
apply' _ f _ = f
|
||||
|
||||
int_literal :: Parser (Expr ASTInfo)
|
||||
int_literal = do
|
||||
@ -296,7 +595,7 @@ function_id = select
|
||||
subtree "module_field" do
|
||||
ctor QualifiedName
|
||||
<*> inside "module" capitalName
|
||||
<*> do pure <$> do ctor At <*> inside "method" name
|
||||
<*> do pure <$> do ctor At <*> inside "method" do name <|> name'
|
||||
]
|
||||
|
||||
opCall :: Parser (Expr ASTInfo)
|
||||
@ -331,8 +630,7 @@ statement = ctor Action <*> expr
|
||||
|
||||
paramDecl :: Parser (VarDecl ASTInfo)
|
||||
paramDecl = do
|
||||
info <- getRange
|
||||
inside "parameter:param_decl" do
|
||||
subtree "param_decl" do
|
||||
ctor Decl
|
||||
<*> do inside ":access" do
|
||||
select
|
||||
@ -345,9 +643,21 @@ paramDecl = do
|
||||
newtype_ = select
|
||||
[ record_type
|
||||
, type_
|
||||
-- , sum_type
|
||||
, sum_type
|
||||
]
|
||||
|
||||
sum_type = do
|
||||
subtree "sum_type" do
|
||||
ctor TSum <*> do
|
||||
many "variant" do
|
||||
inside "variant" variant
|
||||
|
||||
variant = do
|
||||
subtree "variant" do
|
||||
ctor Variant
|
||||
<*> inside "constructor:constr" capitalName
|
||||
<*> optional do inside "arguments" type_
|
||||
|
||||
record_type = do
|
||||
subtree "record_type" do
|
||||
ctor TRecord
|
||||
@ -359,7 +669,7 @@ field_decl = do
|
||||
subtree "field_decl" do
|
||||
ctor TField
|
||||
<*> inside "fieldName" name
|
||||
<*> inside "fieldType" type_
|
||||
<*> inside "fieldType" newtype_
|
||||
|
||||
type_ :: Parser (Type ASTInfo)
|
||||
type_ =
|
||||
@ -395,6 +705,8 @@ type_ =
|
||||
ctor TApply
|
||||
<*> inside "typeConstr" name'
|
||||
<*> do pure <$> inside "arguments" type_
|
||||
|
||||
, subtree "type_expr" newtype_
|
||||
]
|
||||
|
||||
name' :: Parser (Name ASTInfo)
|
||||
@ -417,12 +729,15 @@ typeTuple = do
|
||||
-- example = "../../../src/test/contracts/bad_timestamp.ligo"
|
||||
-- example = "../../../src/test/contracts/bad_type_operator.ligo"
|
||||
-- example = "../../../src/test/contracts/balance_constant.ligo"
|
||||
example = "../../../src/test/contracts/big_map.ligo"
|
||||
-- example = "../../../src/test/contracts/application.ligo"
|
||||
-- example = "../../../src/test/contracts/application.ligo"
|
||||
-- example = "../../../src/test/contracts/application.ligo"
|
||||
-- example = "../../../src/test/contracts/application.ligo"
|
||||
-- example = "../../../src/test/contracts/application.ligo"
|
||||
-- example = "../../../src/test/contracts/big_map.ligo"
|
||||
-- example = "../../../src/test/contracts/bitwise_arithmetic.ligo"
|
||||
-- example = "../../../src/test/contracts/blockless.ligo"
|
||||
-- example = "../../../src/test/contracts/boolean_operators.ligo"
|
||||
-- example = "../../../src/test/contracts/bytes_arithmetic.ligo"
|
||||
-- example = "../../../src/test/contracts/bytes_unpack.ligo"
|
||||
-- example = "../../../src/test/contracts/chain_id.ligo"
|
||||
-- example = "../../../src/test/contracts/coase.ligo"
|
||||
example = "../../../src/test/contracts/failwith.ligo"
|
||||
-- example = "../../../src/test/contracts/application.ligo"
|
||||
-- example = "../../../src/test/contracts/application.ligo"
|
||||
-- example = "../../../src/test/contracts/application.ligo"
|
||||
|
||||
@ -28,6 +28,7 @@ data Declaration info
|
||||
= ValueDecl info (Binding info)
|
||||
| TypeDecl info (Name info) (Type info)
|
||||
| Action info (Expr info)
|
||||
| Include info Text
|
||||
| WrongDecl Error
|
||||
deriving (Show) via PP (Declaration info)
|
||||
|
||||
@ -63,7 +64,7 @@ data Type info
|
||||
= TArrow info (Type info) (Type info)
|
||||
| TRecord info [TField info]
|
||||
| TVar info (Name info)
|
||||
| TSum info [(Name info, [Type info])]
|
||||
| TSum info [Variant info]
|
||||
| TProduct info [Type info]
|
||||
| TApply info (Name info) [Type info]
|
||||
| WrongType Error
|
||||
@ -71,6 +72,13 @@ data Type info
|
||||
|
||||
instance Stubbed (Type info) where stub = WrongType
|
||||
|
||||
data Variant info
|
||||
= Variant info (Name info) (Maybe (Type info))
|
||||
| WrongVariant Error
|
||||
deriving (Show) via PP (Variant info)
|
||||
|
||||
instance Stubbed (Variant info) where stub = WrongVariant
|
||||
|
||||
data TField info
|
||||
= TField info (Name info) (Type info)
|
||||
| WrongTField Error
|
||||
@ -89,6 +97,7 @@ data Expr info
|
||||
| If info (Expr info) (Expr info) (Expr info)
|
||||
| Assign info (LHS info) (Expr info)
|
||||
| List info [Expr info]
|
||||
| Set info [Expr info]
|
||||
| Tuple info [Expr info]
|
||||
| Annot info (Expr info) (Type info)
|
||||
| Attrs info [Text]
|
||||
@ -96,11 +105,29 @@ data Expr info
|
||||
| Map info [MapBinding info]
|
||||
| MapRemove info (Expr info) (QualifiedName info)
|
||||
| SetRemove info (Expr info) (QualifiedName info)
|
||||
| Indexing info (QualifiedName info) (Expr info)
|
||||
| Case info (Expr info) [Alt info]
|
||||
| Skip info
|
||||
| ForLoop info (Name info) (Expr info) (Expr info) (Expr info)
|
||||
| WhileLoop info (Expr info) (Expr info)
|
||||
| Seq info [Declaration info]
|
||||
| Lambda info [VarDecl info] (Type info) (Expr info)
|
||||
| ForBox info (Name info) (Maybe (Name info)) Text (Expr info) (Expr info)
|
||||
| MapPatch info (QualifiedName info) [MapBinding info]
|
||||
| SetPatch info (QualifiedName info) [Expr info]
|
||||
| RecordUpd info (QualifiedName info) [FieldAssignment info]
|
||||
| WrongExpr Error
|
||||
deriving (Show) via PP (Expr info)
|
||||
|
||||
instance Stubbed (Expr info) where stub = WrongExpr
|
||||
|
||||
data Alt info
|
||||
= Alt info (Pattern info) (Expr info)
|
||||
| WrongAlt Error
|
||||
deriving (Show) via PP (Alt info)
|
||||
|
||||
instance Stubbed (Alt info) where stub = WrongAlt
|
||||
|
||||
data LHS info
|
||||
= LHS info (QualifiedName info) (Maybe (Expr info))
|
||||
| WrongLHS Error
|
||||
@ -122,8 +149,16 @@ data Assignment info
|
||||
|
||||
instance Stubbed (Assignment info) where stub = WrongAssignment
|
||||
|
||||
data FieldAssignment info
|
||||
= FieldAssignment info (QualifiedName info) (Expr info)
|
||||
| WrongFieldAssignment Error
|
||||
deriving (Show) via PP (FieldAssignment info)
|
||||
|
||||
instance Stubbed (FieldAssignment info) where stub = WrongFieldAssignment
|
||||
|
||||
data Constant info
|
||||
= Int info Text
|
||||
| Nat info Text
|
||||
| String info Text
|
||||
| Float info Text
|
||||
| Bytes info Text
|
||||
@ -134,9 +169,13 @@ data Constant info
|
||||
instance Stubbed (Constant info) where stub = WrongConstant
|
||||
|
||||
data Pattern info
|
||||
= IsConstr info (Name info) [Pattern info]
|
||||
= IsConstr info (Name info) (Maybe (Pattern info))
|
||||
| IsConstant info (Constant info)
|
||||
| IsVar info (Name info)
|
||||
| IsCons info (Pattern info) (Pattern info)
|
||||
| IsWildcard info
|
||||
| IsList info [Pattern info]
|
||||
| IsTuple info [Pattern info]
|
||||
| WrongPattern Error
|
||||
deriving (Show) via PP (Pattern info)
|
||||
|
||||
@ -188,6 +227,7 @@ instance Pretty (Declaration i) where
|
||||
ValueDecl _ binding -> pp binding
|
||||
TypeDecl _ n ty -> hang ("type" <+> pp n <+> "=") 2 (pp ty)
|
||||
Action _ e -> pp e
|
||||
Include _ f -> "#include" <+> pp f
|
||||
WrongDecl err -> pp err
|
||||
|
||||
instance Pretty (Binding i) where
|
||||
@ -242,27 +282,32 @@ instance Pretty (Type i) where
|
||||
TArrow _ dom codom -> parens (pp dom <+> "->" <+> pp codom)
|
||||
TRecord _ fields -> "record [" <> (vcat $ map pp fields) <> "]"
|
||||
TVar _ name -> pp name
|
||||
TSum _ variants -> vcat $ map ppCtor variants
|
||||
TSum _ variants -> vcat $ map pp variants
|
||||
TProduct _ elements -> fsep $ punctuate " *" $ map pp elements
|
||||
TApply _ f xs -> pp f <> parens (fsep $ punctuate "," $ map pp xs)
|
||||
WrongType err -> pp err
|
||||
where
|
||||
ppField (name, ty) = pp name <> ": " <> pp ty <> ";"
|
||||
ppCtor (ctor, fields) =
|
||||
"|" <+> pp ctor <+> parens (fsep $ punctuate "," $ map pp fields)
|
||||
|
||||
instance Pretty (Variant i) where
|
||||
pp = \case
|
||||
Variant _ ctor (Just ty) -> hang ("|" <+> pp ctor <+> "of") 2 (pp ty)
|
||||
Variant _ ctor _ -> "|" <+> pp ctor
|
||||
WrongVariant err -> pp err
|
||||
|
||||
instance Pretty (Expr i) where
|
||||
pp = \case
|
||||
Let _ decls body -> "block {" $$ (nest 2 $ vcat $ punctuate "\n" $ map pp decls) $$ "}" $$ "with" $$ nest 2 (pp body)
|
||||
Apply _ f xs -> pp f <> tuple xs
|
||||
Apply _ f xs -> pp f <+> tuple xs
|
||||
Constant _ constant -> pp constant
|
||||
Ident _ qname -> pp qname
|
||||
BinOp _ l o r -> parens (pp l <+> pp o <+> pp r)
|
||||
UnOp _ o r -> parens (pp o <+> pp r)
|
||||
Record _ az -> "record [" <> (fsep $ punctuate ";" $ map pp az) <> "]"
|
||||
If _ b t e -> fsep ["if" <+> pp b, nest 2 $ "then" <+> pp t, nest 2 $ "else" <+> pp e]
|
||||
If _ b t e -> fsep ["if" <+> pp b, hang "then" 2 $ pp t, hang "else" 2 $ pp e]
|
||||
Assign _ l r -> hang (pp l <+> ":=") 2 (pp r)
|
||||
List _ l -> "[" <> fsep (punctuate ";" $ map pp l) <> "]"
|
||||
List _ l -> "list [" <> fsep (punctuate ";" $ map pp l) <> "]"
|
||||
Set _ l -> "set [" <> fsep (punctuate ";" $ map pp l) <> "]"
|
||||
Tuple _ l -> "(" <> fsep (punctuate "," $ map pp l) <> ")"
|
||||
Annot _ n t -> ("(" <> pp n) <+> ":" <+> (pp t <> ")")
|
||||
Attrs _ ts -> "attributes [" <> fsep (punctuate ";" $ map pp ts) <> "]"
|
||||
@ -270,8 +315,24 @@ instance Pretty (Expr i) where
|
||||
Map _ bs -> "map [" <> fsep (punctuate ";" $ map pp bs) <> "]"
|
||||
MapRemove _ k m -> hang ("remove" <+> pp k) 0 ("from" <+> "map" <+> pp m)
|
||||
SetRemove _ k s -> hang ("remove" <+> pp k) 0 ("from" <+> "set" <+> pp s)
|
||||
Indexing _ a i -> pp a <> brackets (pp i)
|
||||
Case _ s az -> hang ("case" <+> pp s <+> "of") 2 (vcat $ map pp az)
|
||||
Skip _ -> "skip"
|
||||
ForLoop _ i s f b -> hang ("for" <+> pp i <+> ":=" <+> pp s <+> "to" <+> pp f) 2 (pp b)
|
||||
ForBox _ k mv t c b -> hang ("for" <+> (pp k <> maybe empty ((" ->" <+>) . pp) mv) <+> "in" <+> pp t <+> pp c) 2 (pp b)
|
||||
WhileLoop _ f b -> hang ("while" <+> pp f) 2 (pp b)
|
||||
Seq _ es -> hang (hang "block {" 2 (vcat $ map pp es)) 0 "}"
|
||||
Lambda _ ps ty b -> parens (hang ("function" <+> ("(" <> fsep (punctuate "," $ map pp ps) <> ") :") <+> pp ty) 2 (pp b))
|
||||
MapPatch _ c bs -> hang (hang "patch" 2 (pp c)) 0 (hang ("with" <+> "map") 2 ("[" <> fsep (punctuate ";" $ map pp bs) <> "]"))
|
||||
SetPatch _ c bs -> hang (hang "patch" 2 (pp c)) 0 (hang ("with" <+> "set") 2 ("[" <> fsep (punctuate ";" $ map pp bs) <> "]"))
|
||||
RecordUpd _ r up -> hang (pp r) 2 (hang ("with" <+> "record") 2 ("[" <> fsep (punctuate ";" $ map pp up) <> "]"))
|
||||
WrongExpr err -> pp err
|
||||
|
||||
instance Pretty (Alt info) where
|
||||
pp = \case
|
||||
Alt _ p b -> hang ("|" <+> pp p <+> "->") 2 (pp b)
|
||||
WrongAlt err -> pp err
|
||||
|
||||
instance Pretty (MapBinding i) where
|
||||
pp = \case
|
||||
MapBinding _ k v -> hang (pp k <+> "->") 2 (pp v)
|
||||
@ -282,9 +343,15 @@ instance Pretty (Assignment i) where
|
||||
Assignment _ n e -> pp n <+> "=" <+> pp e
|
||||
WrongAssignment err -> pp err
|
||||
|
||||
instance Pretty (FieldAssignment i) where
|
||||
pp = \case
|
||||
FieldAssignment _ n e -> pp n <+> "=" <+> pp e
|
||||
WrongFieldAssignment err -> pp err
|
||||
|
||||
instance Pretty (Constant i) where
|
||||
pp = \case
|
||||
Int _ c -> pp c
|
||||
Nat _ c -> pp c
|
||||
String _ c -> pp c
|
||||
Float _ c -> pp c
|
||||
Bytes _ c -> pp c
|
||||
@ -298,9 +365,13 @@ instance Pretty (QualifiedName i) where
|
||||
|
||||
instance Pretty (Pattern info) where
|
||||
pp = \case
|
||||
IsConstr _ ctor args -> pp ctor <> tuple args
|
||||
IsConstr _ ctor arg -> pp ctor <> maybe empty pp arg
|
||||
IsConstant _ c -> pp c
|
||||
IsVar _ name -> pp name
|
||||
IsCons _ h t -> pp h <+> "#" <+> pp t
|
||||
IsWildcard _ -> "_"
|
||||
IsList _ l -> "[" <> fsep (punctuate ";" $ map pp l) <> "]"
|
||||
IsTuple _ t -> "(" <> fsep (punctuate "," $ map pp t) <> ")"
|
||||
WrongPattern err -> pp err
|
||||
|
||||
|
||||
|
||||
@ -30,7 +30,7 @@ data Error
|
||||
deriving stock (Show)
|
||||
|
||||
instance Pretty Error where
|
||||
pp (Expected msg found r) = "<<<" <> pp msg <> pp r <> ": " <> pp found <> ">>>"
|
||||
pp (Expected msg found r) = "░" <> pp msg <> pp r <> "▒" <> pp found <> "▓"
|
||||
|
||||
newtype Parser a = Parser
|
||||
{ unParser
|
||||
@ -318,3 +318,6 @@ data ASTInfo = ASTInfo
|
||||
|
||||
ctor :: (ASTInfo -> a) -> Parser a
|
||||
ctor = (<$> (ASTInfo <$> getRange <*> pure []))
|
||||
|
||||
dump :: Parser ()
|
||||
dump = gets pfGrove >>= traceShowM
|
||||
|
||||
Loading…
Reference in New Issue
Block a user