power merge

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) ->
+    | EProj p' -> (
-        let record = p.value.record_name.value in
+        let p = p'.value in
-        let lst = List.map (fun (x:_ Raw.reg) -> x.value) @@ npseq_to_list p.value.field_path in
+        let var =
-        let aux prev cur =
+          let name = p.record_name.value in
-          ae @@ Accessor (prev, [Record_access cur])
+          ae @@ Variable name in
-        in
+        let path = p.field_path in
-        let init = ae @@ Variable record in
+        let path' =
-        ok @@ List.fold_left aux init lst
+          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
+                @@ List.map simpl_statement
-                @@ npseq_to_list block.value.instr in
+                @@ 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
+                @@ List.map simpl_statement
-                @@ npseq_to_list block.value.instr in
+                @@ 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_true = match c.ifso with
-        let%bind match_false = simpl_instruction_block c.ifnot in
+          | 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
+        let%bind cases =
-          @@ List.map (fun (x:Raw.case) -> let%bind i = simpl_instruction_block x.instr in ok (x.pattern, i))
+          let aux (x : Raw.case Raw.reg) =
-          @@ List.map (fun (x:_ Raw.reg) -> x.value)
+            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)]
+    | [(PCons c, cons) ; (PList (PNil _), nil)]
-    | [(PList n, nil) ; (PCons c, cons)] ->
+    | [(PList (PNil _), 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
         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 =
+  and simpl_statements : Raw.statements -> block result = fun ss ->
-    bind_list @@ List.map simpl_instruction (npseq_to_list t.instr)
+    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
 

src/ligo/ligo-parser/ligo_parser.ml

@@ -0,0 +1,3 @@
+module Parser = Parser
+module Lexer = Lexer.Make(LexToken)
+module AST = AST