balsoft/ligo
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

power merge

Browse Source
This commit is contained in:
Galfour 2019-03-28 14:43:49 +00:00
parent 3bc925cac3
commit e184903a4f
2 changed files with 66 additions and 40 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

103
src/ligo/ast_simplified.ml
View File

@ -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

3
src/ligo/ligo-parser/ligo_parser.ml Normal file
View File

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