a1a846b554
Problem: With generated ReasonLIGO grammar we need to develop its parser as well. With it we also need to restructure AST a bit and add expressions that are used for ReasonLIGO specifically. Solution: Add ReasonLIGO parser and some dummy examples of its usage, adapt AST to it, rename LIGO to AST.
274 lines
11 KiB
Haskell
274 lines
11 KiB
Haskell
-- | Parser for a PascaLigo contract.
|
|
module AST.Pascaligo.Parser where
|
|
|
|
import Data.Maybe (isJust)
|
|
|
|
import AST.Skeleton
|
|
|
|
import Duplo.Error
|
|
import Duplo.Tree
|
|
import Duplo.Pretty
|
|
|
|
import Product
|
|
import Parser
|
|
import ParseTree
|
|
|
|
-- import Debug.Trace
|
|
|
|
example :: FilePath
|
|
-- example = "../../../src/test/contracts/arithmetic.ligo"
|
|
-- example = "../../../src/test/contracts/address.ligo"
|
|
-- example = "../../../src/test/contracts/annotation.ligo"
|
|
-- example = "../../../src/test/contracts/amount.ligo"
|
|
-- example = "../../../src/test/contracts/attributes.ligo"
|
|
-- example = "../../../src/test/contracts/application.ligo"
|
|
-- example = "../../../src/test/contracts/assign.ligo"
|
|
-- example = "../../../src/test/contracts/big_map.ligo"
|
|
-- example = "../../../src/test/contracts/blockless.ligo"
|
|
-- example = "../../../src/test/contracts/bad_timestamp.ligo"
|
|
-- example = "../../../src/test/contracts/boolean_operators.ligo"
|
|
-- example = "../../../src/test/contracts/bitwise_arithmetic.ligo"
|
|
-- example = "../../../src/test/contracts/bad_type_operator.ligo"
|
|
-- example = "../../../src/test/contracts/blocks.ligo"
|
|
-- example = "../../../src/test/contracts/bytes_unpack.ligo"
|
|
-- example = "../../../src/test/contracts/balance_constant.ligo"
|
|
-- example = "../../../src/test/contracts/blockless.ligo"
|
|
-- example = "../../../src/test/contracts/bytes_arithmetic.ligo"
|
|
-- example = "../../../src/test/contracts/chain_id.ligo"
|
|
-- example = "../../../src/test/contracts/closure-3.ligo"
|
|
example = "../../../src/test/contracts/coase.ligo"
|
|
|
|
sample' :: FilePath -> IO (LIGO Info)
|
|
sample' f
|
|
= mkRawTreePascal (Path f)
|
|
>>= runParserM . recognise
|
|
>>= return . fst
|
|
|
|
source' :: FilePath -> IO ()
|
|
source' f
|
|
= mkRawTreePascal (Path f)
|
|
>>= print . pp
|
|
|
|
sample :: IO ()
|
|
sample
|
|
= mkRawTreePascal (Path example)
|
|
>>= runParserM . recognise
|
|
>>= print . pp . fst
|
|
|
|
source :: IO ()
|
|
source
|
|
= mkRawTreePascal (Path example)
|
|
>>= print . pp
|
|
|
|
recognise :: RawTree -> ParserM (LIGO Info)
|
|
recognise = descent (\_ -> error . show . pp) $ map usingScope
|
|
[ -- Contract
|
|
Descent do
|
|
boilerplate \case
|
|
"Start" -> RawContract <$> fields "declaration"
|
|
_ -> fallthrough
|
|
|
|
-- Expr
|
|
, Descent do
|
|
boilerplate \case
|
|
"let_expr" -> Let <$> field "locals" <*> field "body"
|
|
"fun_call" -> Apply <$> field "f" <*> field "arguments"
|
|
"par_call" -> Apply <$> field "f" <*> field "arguments"
|
|
"projection_call" -> Apply <$> field "f" <*> field "arguments"
|
|
"Some_call" -> Apply <$> field "constr" <*> field "arguments"
|
|
"constr_call" -> Apply <$> field "constr" <*> field "arguments"
|
|
"arguments" -> Tuple <$> fields "argument"
|
|
"unop" -> UnOp <$> field "negate" <*> field "arg"
|
|
"binop" -> BinOp <$> field "arg1" <*> field "op" <*> field "arg2"
|
|
"block" -> Seq <$> fields "statement"
|
|
"clause_block" -> Seq <$> fields "statement"
|
|
"list_expr" -> List <$> fields "element"
|
|
"annot_expr" -> Annot <$> field "subject" <*> field "type"
|
|
"conditional" -> If <$> field "selector" <*> field "then" <*> field "else"
|
|
"cond_expr" -> If <$> field "selector" <*> field "then" <*> field "else"
|
|
"assignment" -> Assign <$> field "LHS" <*> field "RHS"
|
|
"attr_decl" -> Attrs <$> fields "attribute"
|
|
"record_expr" -> Record <$> fields "assignment"
|
|
"big_map_injection" -> BigMap <$> fields "binding"
|
|
"map_remove" -> MapRemove <$> field "key" <*> field "container"
|
|
"tuple_expr" -> Tuple <$> fields "element"
|
|
"skip" -> return Skip
|
|
"case_expr" -> Case <$> field "subject" <*> fields "case"
|
|
"case_instr" -> Case <$> field "subject" <*> fields "case"
|
|
"fun_expr" -> Lambda <$> field "parameters" <*> fieldOpt "type" <*> field "body"
|
|
"for_cycle" -> ForLoop <$> field "name" <*> field "begin" <*> field "end" <*> fieldOpt "step" <*> field "body"
|
|
"for_box" -> ForBox <$> field "key" <*> fieldOpt "value" <*> field "kind" <*> field "collection" <*> field "body"
|
|
"while_loop" -> WhileLoop <$> field "breaker" <*> field "body"
|
|
"map_injection" -> Map <$> fields "binding"
|
|
"list_injection" -> List <$> fields "element"
|
|
"set_expr" -> Set <$> fields "element"
|
|
"map_patch" -> MapPatch <$> field "container" <*> fields "binding"
|
|
"set_patch" -> SetPatch <$> field "container" <*> fields "key"
|
|
"set_remove" -> SetRemove <$> field "key" <*> field "container"
|
|
"update_record" -> RecordUpd <$> field "record" <*> fields "assignment"
|
|
_ -> fallthrough
|
|
|
|
-- Pattern
|
|
, Descent do
|
|
boilerplate \case
|
|
"user_constr_pattern" -> IsConstr <$> field "constr" <*> fieldOpt "arguments"
|
|
"tuple_pattern" -> IsTuple <$> fields "element"
|
|
"nil" -> return $ IsList []
|
|
"list_pattern" -> IsList <$> fields "element"
|
|
"cons_pattern" -> IsCons <$> field "head" <*> field "tail"
|
|
_ -> fallthrough
|
|
|
|
-- Alt
|
|
, Descent do
|
|
boilerplate \case
|
|
"case_clause_expr" -> Alt <$> field "pattern" <*> field "body"
|
|
"case_clause_instr" -> Alt <$> field "pattern" <*> field "body"
|
|
_ -> fallthrough
|
|
|
|
-- FieldAssignment
|
|
, Descent do
|
|
boilerplate \case
|
|
"field_assignment" -> FieldAssignment <$> field "name" <*> field "_rhs"
|
|
"field_path_assignment" -> FieldAssignment <$> field "lhs" <*> field "_rhs"
|
|
_ -> fallthrough
|
|
|
|
-- MapBinding
|
|
, Descent do
|
|
boilerplate \case
|
|
"binding" -> MapBinding <$> field "key" <*> field "value"
|
|
_ -> fallthrough
|
|
|
|
, Descent do
|
|
boilerplate' \case
|
|
("negate", op) -> return $ Op op
|
|
("adder", op) -> return $ Op op
|
|
("multiplier", op) -> return $ Op op
|
|
("comparison", op) -> return $ Op op
|
|
("^", _) -> return $ Op "^"
|
|
("#", _) -> return $ Op "#"
|
|
_ -> fallthrough
|
|
|
|
, Descent do
|
|
boilerplate \case
|
|
"data_projection" -> QualifiedName <$> field "struct" <*> fields "index"
|
|
"map_lookup" -> QualifiedName <$> field "container" <*> fields "index"
|
|
"module_field" -> QualifiedName <$> field "module" <*> fields "method"
|
|
_ -> fallthrough
|
|
|
|
-- Literal
|
|
, Descent do
|
|
boilerplate' \case
|
|
("Int", i) -> return $ Int i
|
|
("Nat", i) -> return $ Nat i
|
|
("Bytes", i) -> return $ Bytes i
|
|
("String", i) -> return $ String i
|
|
("Tez", i) -> return $ Tez i
|
|
_ -> fallthrough
|
|
|
|
-- Declaration
|
|
, Descent do
|
|
boilerplate \case
|
|
"fun_decl" -> Function <$> (isJust <$> fieldOpt "recursive") <*> field "name" <*> field "parameters" <*> field "type" <*> field "body"
|
|
"const_decl" -> Const <$> field "name" <*> field "type" <*> field "value"
|
|
"var_decl" -> Var <$> field "name" <*> fieldOpt "type" <*> field "value"
|
|
"type_decl" -> TypeDecl <$> field "typeName" <*> field "typeValue"
|
|
"include" -> Include <$> field "filename"
|
|
_ -> fallthrough
|
|
|
|
-- Parameters
|
|
, Descent do
|
|
boilerplate \case
|
|
"parameters" -> Parameters <$> fields "parameter"
|
|
_ -> fallthrough
|
|
|
|
-- VarDecl
|
|
, Descent do
|
|
boilerplate \case
|
|
"param_decl" -> Decl <$> field "access" <*> field "name" <*> field "type"
|
|
_ -> fallthrough
|
|
|
|
-- Mutable
|
|
, Descent do
|
|
boilerplate \case
|
|
"const" -> return Immutable
|
|
"var" -> return Mutable
|
|
_ -> fallthrough
|
|
|
|
-- Name
|
|
, Descent do
|
|
boilerplate' \case
|
|
("Name", n) -> return $ Name n
|
|
("and", _) -> return $ Name "and"
|
|
("or", _) -> return $ Name "or"
|
|
_ -> fallthrough
|
|
|
|
-- Type
|
|
, Descent do
|
|
boilerplate \case
|
|
"fun_type" -> TArrow <$> field "domain" <*> field "codomain"
|
|
"cartesian" -> TProduct <$> fields "element"
|
|
"invokeBinary" -> TApply <$> field "typeConstr" <*> field "arguments"
|
|
"invokeUnary" -> TApply <$> field "typeConstr" <*> field "arguments"
|
|
"type_tuple" -> TTuple <$> fields "element"
|
|
"record_type" -> TRecord <$> fields "field"
|
|
"sum_type" -> TSum <$> fields "variant"
|
|
"michelsonTypeOr" -> TOr <$> field "left_type" <*> field "left_type_name" <*> field "right_type" <*> field "right_type_name"
|
|
"michelsonTypeAnd" -> TAnd <$> field "left_type" <*> field "left_type_name" <*> field "right_type" <*> field "right_type_name"
|
|
_ -> fallthrough
|
|
|
|
-- Variant
|
|
, Descent do
|
|
boilerplate \case
|
|
"variant" -> Variant <$> field "constructor" <*> fieldOpt "arguments"
|
|
_ -> fallthrough
|
|
|
|
-- TField
|
|
, Descent do
|
|
boilerplate \case
|
|
"field_decl" -> TField <$> field "fieldName" <*> field "fieldType"
|
|
_ -> fallthrough
|
|
|
|
-- TypeName
|
|
, Descent do
|
|
boilerplate' \case
|
|
("TypeName", name) -> return $ TypeName name
|
|
("list", _) -> return $ TypeName "list"
|
|
("big_map", _) -> return $ TypeName "big_map"
|
|
("map", _) -> return $ TypeName "map"
|
|
("set", _) -> return $ TypeName "set"
|
|
("option", _) -> return $ TypeName "option"
|
|
("contract", _) -> return $ TypeName "contract"
|
|
_ -> fallthrough
|
|
|
|
-- Ctor
|
|
, Descent do
|
|
boilerplate' \case
|
|
("Name_Capital", name) -> return $ Ctor name
|
|
("Some", _) -> return $ Ctor "Some"
|
|
("Some_pattern", _) -> return $ Ctor "Some"
|
|
("None", _) -> return $ Ctor "None"
|
|
("True", _) -> return $ Ctor "True"
|
|
("False", _) -> return $ Ctor "False"
|
|
("Unit", _) -> return $ Ctor "Unit"
|
|
("constr", n) -> return $ Ctor n
|
|
_ -> fallthrough
|
|
|
|
-- FieldName
|
|
, Descent do
|
|
boilerplate' \case
|
|
("FieldName", name) -> return $ FieldName name
|
|
_ -> fallthrough
|
|
|
|
-- Err
|
|
, Descent do
|
|
\(r :> _, ParseTree _ _ text') -> do
|
|
withComments do
|
|
return (r :> N :> Nil, Err text')
|
|
|
|
, Descent do
|
|
\case
|
|
(r :> _, ParseTree "ERROR" _ text') -> do
|
|
return ([] :> r :> Y :> Nil, Err text')
|
|
|
|
_ -> fallthrough
|
|
] |