251 lines
9.3 KiB
Haskell
251 lines
9.3 KiB
Haskell
|
|
module AST.Camligo.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/address.mligo"
|
|
-- example = "../../../src/test/contracts/amount_lambda.mligo"
|
|
-- example = "../../../src/test/contracts/attributes.mligo"
|
|
-- example = "../../../src/test/contracts/assert.mligo"
|
|
-- example = "../../../src/test/contracts/amount.mligo"
|
|
-- example = "../../../src/test/contracts/arithmetic.mligo"
|
|
-- example = "../../../src/test/contracts/basic.mligo"
|
|
-- example = "../../../src/test/contracts/bytes_arithmetic.mligo"
|
|
-- example = "../../../src/test/contracts/bitwise_arithmetic.mligo"
|
|
-- example = "../../../src/test/contracts/big_map.mligo"
|
|
-- example = "../../../src/test/contracts/boolean_operators.mligo"
|
|
-- example = "../../../src/test/contracts/balance_constant.mligo"
|
|
-- example = "../../../src/test/contracts/closure.mligo"
|
|
-- example = "../../../src/test/contracts/counter.mligo"
|
|
-- example = "../../../src/test/contracts/condition.mligo"
|
|
-- example = "../../../src/test/contracts/crypto.mligo"
|
|
-- example = "../../../src/test/contracts/condition-annot.mligo"
|
|
-- example = "../../../src/test/contracts/curry.mligo"
|
|
-- example = "../../../src/test/contracts/condition-shadowing.mligo"
|
|
-- example = "../../../src/test/contracts/create_contract.mligo"
|
|
-- example = "../../../src/test/contracts/comparable.mligo"
|
|
-- example = "../../../src/test/contracts/check_signature.mligo"
|
|
-- example = "../../../src/test/contracts/double_michelson_or.mligo"
|
|
-- example = "../../../src/test/contracts/eq_bool.mligo"
|
|
-- example = "../../../src/test/contracts/empty_case.mligo"
|
|
-- example = "../../../src/test/contracts/fibo4.mligo"
|
|
-- example = "../../../src/test/contracts/fibo3.mligo"
|
|
-- example = "../../../src/test/contracts/fibo2.mligo"
|
|
-- example = "../../../src/test/contracts/fibo.mligo"
|
|
-- example = "../../../src/test/contracts/function-shared.mligo"
|
|
-- example = "../../../src/test/contracts/failwith.mligo"
|
|
-- example = "../../../src/test/contracts/guess_string.mligo"
|
|
-- example = "../../../src/test/contracts/high-order.mligo"
|
|
-- example = "../../../src/test/contracts/hashlock.mligo"
|
|
-- example = "../../../src/test/contracts/includer.mligo"
|
|
-- example = "../../../src/test/contracts/incr_decr.mligo"
|
|
-- example = "../../../src/test/contracts/issue-184-combs.mligo"
|
|
-- example = "../../../src/test/contracts/implicit.mligo"
|
|
-- example = "../../../src/test/contracts/included.mligo"
|
|
-- example = "../../../src/test/contracts/implicit_account.mligo"
|
|
-- example = "../../../src/test/contracts/interpret_test.mligo"
|
|
-- example = "../../../src/test/contracts/isnat.mligo"
|
|
-- example = "../../../src/test/contracts/id.mligo"
|
|
-- example = "../../../src/test/contracts/key_hash.mligo"
|
|
-- example = "../../../src/test/contracts/letin.mligo"
|
|
-- example = "../../../src/test/contracts/lambda.mligo"
|
|
-- example = "../../../src/test/contracts/let_multiple.mligo"
|
|
-- example = "../../../src/test/contracts/lambda2.mligo"
|
|
-- example = "../../../src/test/contracts/loop.mligo"
|
|
-- example = "../../../src/test/contracts/let_in_multi_bind.mligo"
|
|
example = "../../../src/test/contracts/list.mligo"
|
|
|
|
raw :: IO ()
|
|
raw = toParseTree (Path example)
|
|
>>= print . pp
|
|
|
|
raw' :: FilePath -> IO ()
|
|
raw' example = toParseTree (Path example)
|
|
>>= print . pp
|
|
|
|
sample :: IO ()
|
|
sample
|
|
= toParseTree (Path example)
|
|
>>= runParserM . recognise
|
|
>>= print . pp . fst
|
|
|
|
sample' :: FilePath -> IO ()
|
|
sample' example
|
|
= toParseTree (Path example)
|
|
>>= runParserM . recognise
|
|
>>= print . pp . fst
|
|
|
|
recognise :: RawTree -> ParserM (LIGO Info)
|
|
recognise = descent (\_ -> error . show . pp) $ map usingScope
|
|
[ -- Contract
|
|
Descent do
|
|
boilerplate $ \case
|
|
"contract" -> RawContract <$> fields "declaration"
|
|
_ -> fallthrough
|
|
|
|
, Descent do
|
|
boilerplate $ \case
|
|
"fun_decl" -> Function <$> flag "recursive" <*> field "name" <*> fields "arg" <*> fieldOpt "type" <*> field "body"
|
|
"let_decl" -> Const <$> field "name" <*> fieldOpt "type" <*> field "body"
|
|
"include" -> Include <$> field "filename"
|
|
"type_decl" -> TypeDecl <$> field "name" <*> field "type"
|
|
_ -> fallthrough
|
|
|
|
, Descent do
|
|
boilerplate $ \case
|
|
"let_expr1" -> Let <$> field "decl" <*> field "body"
|
|
_ -> fallthrough
|
|
|
|
-- -- Expr
|
|
, Descent do
|
|
boilerplate $ \case
|
|
"fun_app" -> Apply <$> field "f" <*> field "x"
|
|
"index_accessor" -> ListAccess <$> field "box" <*> fields "field"
|
|
"rec_expr" -> RecordUpd <$> field "subject" <*> fields "field"
|
|
"rec_literal" -> Record <$> fields "field"
|
|
"if_expr" -> If <$> field "condition" <*> field "then" <*> fieldOpt "else"
|
|
"match_expr" -> Case <$> field "subject" <*> fields "alt"
|
|
"lambda_expr" -> Lambda <$> fields "arg" <*> pure Nothing <*> field "body"
|
|
"list_expr" -> List <$> fields "item"
|
|
"tup_expr" -> Tuple <$> fields "x"
|
|
"paren_expr" -> Tuple <$> fields "expr"
|
|
"block_expr" -> Seq <$> fields "item"
|
|
"annot_expr" -> Annot <$> field "expr" <*> field "type"
|
|
"binary_op_app" -> BinOp <$> field "left" <*> field "op" <*> field "right"
|
|
"unary_op_app" -> UnOp <$> field "negate" <*> field "arg"
|
|
_ -> fallthrough
|
|
|
|
-- Pattern
|
|
, Descent do
|
|
boilerplate $ \case
|
|
"list_pattern" -> IsList <$> fields "item"
|
|
"list_con_pattern" -> IsCons <$> field "x" <*> field "xs"
|
|
"tup_pattern" -> IsTuple <$> fields "item"
|
|
"con_pattern" -> IsConstr <$> field "ctor" <*> fieldOpt "args"
|
|
"annot_pattern" -> IsAnnot <$> field "pat" <*> field "type"
|
|
"paren_pattern" -> IsTuple <$> fields "pat"
|
|
"_" -> pure IsWildcard
|
|
_ -> fallthrough
|
|
|
|
-- Alt
|
|
, Descent do
|
|
boilerplate $ \case
|
|
"matching" -> Alt <$> field "pattern" <*> field "body"
|
|
_ -> fallthrough
|
|
|
|
-- Record fields
|
|
, Descent do
|
|
boilerplate $ \case
|
|
"rec_assignment" -> FieldAssignment <$> field "field" <*> field "value"
|
|
_ -> fallthrough
|
|
|
|
, Descent do
|
|
boilerplate' $ \case
|
|
("+", _) -> return $ Op "+"
|
|
("-", _) -> return $ Op "-"
|
|
("mod", _) -> return $ Op "mod"
|
|
("/", _) -> return $ Op "/"
|
|
("*", _) -> return $ Op "*"
|
|
("^", _) -> return $ Op "^"
|
|
("::", _) -> return $ Op "::"
|
|
(">", _) -> return $ Op ">"
|
|
("<", _) -> return $ Op "<"
|
|
(">=", _) -> return $ Op ">="
|
|
("<=", _) -> return $ Op "<="
|
|
("=", _) -> return $ Op "=="
|
|
("!=", _) -> return $ Op "!="
|
|
("<>", _) -> return $ Op "!="
|
|
("||", _) -> return $ Op "||"
|
|
("&&", _) -> return $ Op "&&"
|
|
("negate", n) -> return $ Op n
|
|
_ -> 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
|
|
|
|
-- Name
|
|
, Descent do
|
|
boilerplate' $ \case
|
|
("Name", n) -> return $ Name n
|
|
_ -> fallthrough
|
|
|
|
-- FieldName
|
|
, Descent do
|
|
boilerplate' $ \case
|
|
("FieldName", n) -> return $ FieldName n
|
|
_ -> fallthrough
|
|
|
|
-- Type
|
|
, Descent do
|
|
boilerplate $ \case
|
|
"type_fun" -> TArrow <$> field "domain" <*> field "codomain"
|
|
"type_app" -> TApply <$> field "f" <*> fields "x"
|
|
"type_product" -> TProduct <$> fields "x"
|
|
"type_tuple" -> TTuple <$> fields "x"
|
|
"type_rec" -> TRecord <$> fields "field"
|
|
"type_sum" -> TSum <$> fields "variant"
|
|
_ -> fallthrough
|
|
|
|
-- Variant
|
|
, Descent do
|
|
boilerplate $ \case
|
|
"variant" -> Variant <$> field "constructor" <*> fieldOpt "type"
|
|
_ -> fallthrough
|
|
|
|
-- TField
|
|
, Descent do
|
|
boilerplate $ \case
|
|
"type_rec_field" -> TField <$> field "field" <*> field "type"
|
|
_ -> fallthrough
|
|
|
|
-- TypeName
|
|
, Descent do
|
|
boilerplate' $ \case
|
|
("type_con", name) -> return $ TypeName name
|
|
_ -> fallthrough
|
|
|
|
-- Ctor
|
|
, Descent do
|
|
boilerplate' $ \case
|
|
("Name_Capital", name) -> return $ Ctor name
|
|
("data_con", name) -> return $ Ctor name
|
|
("False", _) -> return $ Ctor "False"
|
|
("True", _) -> return $ Ctor "True"
|
|
("Unit", _) -> return $ Ctor "Unit"
|
|
_ -> fallthrough
|
|
|
|
-- Err
|
|
, Descent do
|
|
\(r :> _, ParseTree _ _ msg) -> do
|
|
withComments do
|
|
return (r :> N :> Nil, Err msg)
|
|
|
|
, Descent do
|
|
\case
|
|
(r :> _, ParseTree "ERROR" _ msg) -> do
|
|
return ([] :> r :> Y :> Nil, Err msg)
|
|
|
|
_ -> fallthrough
|
|
]
|
|
|