From e184903a4f552f360a42011f96797d632b9dd79c Mon Sep 17 00:00:00 2001 From: Galfour Date: Thu, 28 Mar 2019 14:43:49 +0000 Subject: [PATCH] power merge --- src/ligo/ast_simplified.ml | 103 +++++++++++++++++----------- src/ligo/ligo-parser/ligo_parser.ml | 3 + 2 files changed, 66 insertions(+), 40 deletions(-) create mode 100644 src/ligo/ligo-parser/ligo_parser.ml diff --git a/src/ligo/ast_simplified.ml b/src/ligo/ast_simplified.ml index f75e39e38..3000cb1ff 100644 --- a/src/ligo/ast_simplified.ml +++ b/src/ligo/ast_simplified.ml @@ -349,7 +349,7 @@ module Simplify = struct let%bind lst = bind_list @@ List.map aux @@ List.map (fun (x:Raw.field_decl Raw.reg) -> (x.value.field_name.value, x.value.field_type)) - @@ npseq_to_list r.value.fields in + @@ npseq_to_list r.value.field_decls in let m = List.fold_left (fun m (x, y) -> SMap.add x y m) SMap.empty lst in ok @@ Type_record m | TSum s -> @@ -385,8 +385,9 @@ module Simplify = struct | EUnit _ -> ok @@ ae @@ Literal Unit | EBytes x -> ok @@ ae @@ Literal (Bytes (Bytes.of_string @@ fst x.value)) | ETuple tpl -> + let (Raw.TupleInj tpl') = tpl in simpl_list_expression - @@ npseq_to_list tpl.value.inside + @@ npseq_to_list tpl'.value.inside | ERecord (RecordInj r) -> let%bind fields = bind_list @@ List.map (fun ((k : _ Raw.reg), v) -> let%bind v = simpl_expression v in ok (k.value, v)) @@ -394,14 +395,21 @@ module Simplify = struct @@ npseq_to_list r.value.fields in let aux prev (k, v) = SMap.add k v prev in ok @@ ae @@ Record (List.fold_left aux SMap.empty fields) - | ERecord (RecordProj p) -> - let record = p.value.record_name.value in - let lst = List.map (fun (x:_ Raw.reg) -> x.value) @@ npseq_to_list p.value.field_path in - let aux prev cur = - ae @@ Accessor (prev, [Record_access cur]) - in - let init = ae @@ Variable record in - ok @@ List.fold_left aux init lst + | EProj p' -> ( + let p = p'.value in + let var = + let name = p.record_name.value in + ae @@ Variable name in + let path = p.field_path in + let path' = + let aux (s:Raw.selection) = + match s with + | FieldName property -> Record_access property.value + | Component index -> Tuple_access (Z.to_int (snd index.value)) + in + List.map aux @@ npseq_to_list path in + ok @@ ae @@ Accessor (var, path') + ) | EConstr (ConstrApp c) -> let (c, args) = c.value in let%bind arg = @@ -466,6 +474,11 @@ module Simplify = struct ok @@ ae @@ Tuple lst and simpl_local_declaration (t:Raw.local_decl) : (instruction * named_expression) result = + match t with + | LocalData d -> simpl_data_declaration d + | LocalLam _ -> simple_fail "no local lambdas yet" + + and simpl_data_declaration (t:Raw.data_decl) : (instruction * named_expression) result = let return x = ok (Assignment x, x) in match t with | LocalVar x -> @@ -482,9 +495,9 @@ module Simplify = struct let type_annotation = Some t in let%bind expression = simpl_expression x.init in return {name;annotated_expression={expression with type_annotation}} - | _ -> simple_fail "todo" - and simpl_param (t:Raw.param_decl) : named_type_expression result = + + and simpl_param : Raw.param_decl -> named_type_expression result = fun t -> match t with | ParamConst c -> let c = c.value in @@ -497,7 +510,7 @@ module Simplify = struct let%bind type_expression = simpl_type_expression c.param_type in ok { type_name ; type_expression } - and simpl_declaration (t:Raw.declaration) : declaration result = + and simpl_declaration : Raw.declaration -> declaration result = fun t -> let open! Raw in match t with | TypeDecl x -> @@ -524,8 +537,8 @@ module Simplify = struct @@ List.map simpl_local_declaration local_decls in ok (List.map fst tmp) in let%bind instructions = bind_list - @@ List.map simpl_instruction - @@ npseq_to_list block.value.instr in + @@ List.map simpl_statement + @@ npseq_to_list block.value.statements in let%bind result = simpl_expression return in let%bind output_type = simpl_type_expression ret_type in let body = local_declarations @ instructions in @@ -553,8 +566,8 @@ module Simplify = struct in let%bind output_type = simpl_type_expression ret_type in let%bind instructions = bind_list - @@ List.map simpl_instruction - @@ npseq_to_list block.value.instr in + @@ List.map simpl_statement + @@ npseq_to_list block.value.statements in let%bind (body, result) = let renamings = let aux ({type_name}:named_type_expression) : Rename.Value.renaming = @@ -582,8 +595,12 @@ module Simplify = struct | LambdaDecl (ProcDecl _) -> simple_fail "no proc declaration yet" | LambdaDecl (EntryDecl _)-> simple_fail "no entry point yet" + and simpl_statement : Raw.statement -> instruction result = fun s -> + match s with + | Instr i -> simpl_instruction i + | Data d -> let%bind (i, _) = simpl_data_declaration d in ok i - and simpl_single_instruction (t:Raw.single_instr) : instruction result = + and simpl_single_instruction : Raw.single_instr -> instruction result = fun t -> match t with | ProcCall _ -> simple_fail "no proc call" | Fail e -> @@ -600,8 +617,12 @@ module Simplify = struct | Cond c -> let c = c.value in let%bind expr = simpl_expression c.test in - let%bind match_true = simpl_instruction_block c.ifso in - let%bind match_false = simpl_instruction_block c.ifnot in + let%bind match_true = match c.ifso with + | ClauseInstr i -> let%bind i = simpl_instruction i in ok [i] + | ClauseBlock b -> simpl_statements @@ fst b.value.inside in + let%bind match_false = match c.ifnot with + | ClauseInstr i -> let%bind i = simpl_instruction i in ok [i] + | ClauseBlock b -> simpl_statements @@ fst b.value.inside in ok @@ Matching (expr, (Match_bool {match_true; match_false})) | Assign a -> let a = a.value in @@ -617,9 +638,12 @@ module Simplify = struct | Case c -> let c = c.value in let%bind expr = simpl_expression c.expr in - let%bind cases = bind_list - @@ List.map (fun (x:Raw.case) -> let%bind i = simpl_instruction_block x.instr in ok (x.pattern, i)) - @@ List.map (fun (x:_ Raw.reg) -> x.value) + let%bind cases = + let aux (x : Raw.case Raw.reg) = + let%bind i = simpl_instruction_block x.value.instr in + ok (x.value.pattern, i) in + bind_list + @@ List.map aux @@ npseq_to_list c.cases.value in let%bind m = simpl_cases cases in ok @@ Matching (expr, m) @@ -635,8 +659,11 @@ module Simplify = struct @@ npseq_to_list r.record_inj.value.fields in ok @@ Record_patch (record, [], inj) | MapPatch _ -> simple_fail "no map patch yet" + | SetPatch _ -> simple_fail "no set patch yet" + | MapRemove _ -> simple_fail "no map remove yet" + | SetRemove _ -> simple_fail "no set remove yet" - and simpl_cases (t:(Raw.pattern * block) list) : matching result = + and simpl_cases : (Raw.pattern * block) list -> matching result = fun t -> let open Raw in let get_var (t:Raw.pattern) = match t with | PVar v -> ok v.value @@ -644,7 +671,7 @@ module Simplify = struct in match t with | [(PFalse _, f) ; (PTrue _, t)] - | [(PTrue _, f) ; (PFalse _, t)] -> ok @@ Match_bool {match_true = t ; match_false = f} + | [(PTrue _, t) ; (PFalse _, f)] -> ok @@ Match_bool {match_true = t ; match_false = f} | [(PSome v, some) ; (PNone _, none)] | [(PNone _, none) ; (PSome v, some)] -> ( let (_, v) = v.value in @@ -653,16 +680,8 @@ module Simplify = struct | _ -> simple_fail "complex patterns not supported yet" in ok @@ Match_option {match_none = none ; match_some = (v, some) } ) - | [(PCons c, cons) ; (PList n, nil)] - | [(PList n, nil) ; (PCons c, cons)] -> - let%bind _ = match n with - | Sugar c -> ( - match pseq_to_list c.value.inside with - | [] -> ok () - | _ -> simple_fail "complex patterns not supported yet" - ) - | Raw _ -> simple_fail "complex patterns not supported yet" - in + | [(PCons c, cons) ; (PList (PNil _), nil)] + | [(PList (PNil _), nil) ; (PCons c, cons)] -> let%bind (a, b) = match c.value with | a, [(_, b)] -> @@ -674,20 +693,24 @@ module Simplify = struct ok @@ Match_list {match_cons = (a, b, cons) ; match_nil = nil} | _ -> simple_fail "complex patterns not supported yet" - and simpl_instruction_block (t:Raw.instruction) : block result = + and simpl_instruction_block : Raw.instruction -> block result = fun t -> match t with | Single s -> let%bind i = simpl_single_instruction s in ok [ i ] | Block b -> simpl_block b.value - and simpl_instruction (t:Raw.instruction) : instruction result = + and simpl_instruction : Raw.instruction -> instruction result = fun t -> match t with | Single s -> simpl_single_instruction s | Block _ -> simple_fail "no block instruction yet" - and simpl_block (t:Raw.block) : block result = - bind_list @@ List.map simpl_instruction (npseq_to_list t.instr) + and simpl_statements : Raw.statements -> block result = fun ss -> + let lst = npseq_to_list ss in + bind_map_list simpl_statement lst - let simpl_program (t:Raw.ast) : program result = + and simpl_block : Raw.block -> block result = fun t -> + simpl_statements t.statements + + let simpl_program : Raw.ast -> program result = fun t -> bind_list @@ List.map simpl_declaration @@ nseq_to_list t.decl end diff --git a/src/ligo/ligo-parser/ligo_parser.ml b/src/ligo/ligo-parser/ligo_parser.ml new file mode 100644 index 000000000..7fec46e33 --- /dev/null +++ b/src/ligo/ligo-parser/ligo_parser.ml @@ -0,0 +1,3 @@ +module Parser = Parser +module Lexer = Lexer.Make(LexToken) +module AST = AST