From 6ee5aff96203a39102176f7cf791d0040f8a365c Mon Sep 17 00:00:00 2001 From: Galfour Date: Thu, 23 May 2019 07:49:06 +0000 Subject: [PATCH] merge and fix --- src/ast_simplified/combinators.ml | 6 + src/parser/ligodity/AST.mli | 1 + src/parser/ligodity/Parser.mly | 4 +- src/parser/ligodity/Version.ml | 1 + src/simplify/ligodity.ml | 337 ++++-------------------------- 5 files changed, 56 insertions(+), 293 deletions(-) create mode 100644 src/parser/ligodity/Version.ml diff --git a/src/ast_simplified/combinators.ml b/src/ast_simplified/combinators.ml index a1f008735..7fd963b0f 100644 --- a/src/ast_simplified/combinators.ml +++ b/src/ast_simplified/combinators.ml @@ -69,6 +69,12 @@ let e_application a b = E_application (a , b) let e_binop name a b = E_constant (name , [a ; b]) +let make_option_typed e t_opt = + match t_opt with + | None -> e + | Some t -> e_annotation e t + + let ez_e_record lst = let aux prev (k, v) = SMap.add k v prev in let map = List.fold_left aux SMap.empty lst in diff --git a/src/parser/ligodity/AST.mli b/src/parser/ligodity/AST.mli index 95f5a18c0..7d09626bc 100644 --- a/src/parser/ligodity/AST.mli +++ b/src/parser/ligodity/AST.mli @@ -491,3 +491,4 @@ val unpar : expr -> expr (* TODO *) val print_projection : projection -> unit +val print_pattern : pattern -> unit diff --git a/src/parser/ligodity/Parser.mly b/src/parser/ligodity/Parser.mly index 0bf897599..471f0cd32 100644 --- a/src/parser/ligodity/Parser.mly +++ b/src/parser/ligodity/Parser.mly @@ -390,7 +390,7 @@ let_binding: ({variable=$1; lhs_type=$3; eq=$4; let_rhs}: let_binding), map } | irrefutable type_annotation? eq expr { - let variable, type_opt, map = split_pattern $1 in + let variable, _type_opt, map = split_pattern $1 in ({variable; lhs_type=$2; eq=$3; let_rhs=$4}: let_binding), map } (* TODO *) @@ -401,7 +401,7 @@ let_in_binding: {pattern = PVar $1; lhs_type=$3; eq=$4; let_rhs}: let_in_binding } | irrefutable type_annotation? eq expr { - let variable, type_opt, map = split_pattern $1 in + let variable, _type_opt, _map = split_pattern $1 in {pattern = PVar variable; lhs_type=$2; eq=$3; let_rhs=$4} : let_in_binding } diff --git a/src/parser/ligodity/Version.ml b/src/parser/ligodity/Version.ml new file mode 100644 index 000000000..d89964cb1 --- /dev/null +++ b/src/parser/ligodity/Version.ml @@ -0,0 +1 @@ +let version = "UNKNOWN" diff --git a/src/simplify/ligodity.ml b/src/simplify/ligodity.ml index b2e6d1fd5..c374f5c5a 100644 --- a/src/simplify/ligodity.ml +++ b/src/simplify/ligodity.ml @@ -85,12 +85,12 @@ and simpl_list_type_expression (lst:Raw.type_expr list) : type_expression result ok @@ T_tuple lst let rec simpl_expression : - ?te_annot:type_expression -> Raw.expr -> ae result = fun ?te_annot t -> - let return x = ok @@ make_e_a ?type_annotation:te_annot x in + ?te_annot:type_expression -> Raw.expr -> expr result = fun ?te_annot t -> + let return x = ok @@ make_option_typed x te_annot in let simpl_projection = fun (p:Raw.projection) -> let var = let name = p.struct_name.value in - make_e_a @@ E_variable name in + e_variable name in let path = p.field_path in let path' = let aux (s:Raw.selection) = @@ -116,7 +116,7 @@ let rec simpl_expression : let%bind rhs = simpl_expression ?te_annot:type_annotation let_rhs in let%bind body = simpl_expression body in match pattern with - Raw.PVar v -> return (mk_let_in v.value rhs body) + Raw.PVar v -> return (mk_let_in (v.value , None) rhs body) | _ -> let%bind case = simpl_cases [(pattern, body)] in return (E_matching (rhs, case)) ) @@ -151,7 +151,7 @@ let rec simpl_expression : (match List.assoc_opt f.value constants with | None -> let%bind arg = simpl_tuple_expression (nseq_to_list e2) in - return @@ E_application (make_e_a @@ E_variable f.value, arg) + return @@ E_application (e_variable f.value, arg) | Some arity -> let%bind _arity = trace (simple_error "wrong arity for constants") @@ @@ -227,8 +227,8 @@ let rec simpl_expression : return @@ E_matching (e, cases) | _ -> failwith "XXX" (* TODO *) -and simpl_logic_expression ?te_annot (t:Raw.logic_expr) : annotated_expression result = - let return x = ok @@ make_e_a ?type_annotation:te_annot x in +and simpl_logic_expression ?te_annot (t:Raw.logic_expr) : expr result = + let return x = ok @@ make_option_typed x te_annot in match t with | BoolExpr (False _) -> return @@ E_literal (Literal_bool false) @@ -253,8 +253,8 @@ and simpl_logic_expression ?te_annot (t:Raw.logic_expr) : annotated_expression r | CompExpr (Neq c) -> simpl_binop ?te_annot "NEQ" c.value -and simpl_list_expression ?te_annot (t:Raw.list_expr) : annotated_expression result = - let return x = ok @@ make_e_a ?type_annotation:te_annot x in +and simpl_list_expression ?te_annot (t:Raw.list_expr) : expression result = + let return x = ok @@ make_option_typed x te_annot in match t with | Cons c -> simpl_binop ?te_annot "CONS" c.value @@ -264,19 +264,19 @@ and simpl_list_expression ?te_annot (t:Raw.list_expr) : annotated_expression res pseq_to_list lst.value.elements in return @@ E_list lst' -and simpl_binop ?te_annot (name:string) (t:_ Raw.bin_op) : annotated_expression result = - let return x = ok @@ make_e_a ?type_annotation:te_annot x in +and simpl_binop ?te_annot (name:string) (t:_ Raw.bin_op) : expression result = + let return x = ok @@ make_option_typed x te_annot in let%bind a = simpl_expression t.arg1 in let%bind b = simpl_expression t.arg2 in return @@ E_constant (name, [a;b]) -and simpl_unop ?te_annot (name:string) (t:_ Raw.un_op) : annotated_expression result = - let return x = ok @@ make_e_a ?type_annotation:te_annot x in +and simpl_unop ?te_annot (name:string) (t:_ Raw.un_op) : expression result = + let return x = ok @@ make_option_typed x te_annot in let%bind a = simpl_expression t.arg in return @@ E_constant (name, [a]) -and simpl_tuple_expression ?te_annot (lst:Raw.expr list) : annotated_expression result = - let return x = ok @@ make_e_a ?type_annotation:te_annot x in +and simpl_tuple_expression ?te_annot (lst:Raw.expr list) : expression result = + let return x = ok @@ make_option_typed x te_annot in match lst with | [] -> return @@ E_literal Literal_unit | [hd] -> simpl_expression ?te_annot hd @@ -284,116 +284,6 @@ and simpl_tuple_expression ?te_annot (lst:Raw.expr list) : annotated_expression let%bind lst = bind_list @@ List.map simpl_expression lst in return @@ E_tuple lst -and simpl_local_declaration (t:Raw.local_decl) : (instruction * named_expression) result = - match t with - | LocalData d -> simpl_data_declaration d - | LocalLam l -> simpl_lambda_declaration l - -and simpl_lambda_declaration : Raw.lambda_decl -> (instruction * named_expression) result = - fun l -> - match l with - | FunDecl f -> - let%bind e = simpl_fun_declaration (f.value) in - ok (I_assignment e, e) - | ProcDecl _ -> simple_fail "no local procedure yet" - | EntryDecl _ -> simple_fail "no local entry-point yet" - -and simpl_data_declaration (t:Raw.data_decl) : (instruction * named_expression) result = - let return x = ok (I_assignment x, x) in - match t with - | LocalVar x -> - let x = x.value in - let name = x.name.value in - let%bind t = simpl_type_expression x.var_type in - let%bind annotated_expression = simpl_expression ~te_annot:t x.init in - return {name;annotated_expression} - | LocalConst x -> - let x = x.value in - let name = x.name.value in - let%bind t = simpl_type_expression x.const_type in - let%bind annotated_expression = simpl_expression ~te_annot:t x.init in - return {name;annotated_expression} - - -and simpl_param : Raw.param_decl -> named_type_expression result = fun t -> - match t with - | ParamConst c -> - let c = c.value in - let type_name = c.var.value in - let%bind type_expression = simpl_type_expression c.param_type in - ok { type_name ; type_expression } - | ParamVar v -> - let c = v.value in - let type_name = c.var.value in - let%bind type_expression = simpl_type_expression c.param_type in - ok { type_name ; type_expression } - -and simpl_fun_declaration : Raw.fun_decl -> named_expression result = fun x -> - let open! Raw in - let {name;param;ret_type;local_decls;block;return} : fun_decl = x in - (match npseq_to_list param.value.inside with - | [] -> simple_fail "function without parameters are not allowed" - | [a] -> ( - let%bind input = simpl_param a in - let name = name.value in - let binder = input.type_name in - let input_type = input.type_expression in - let%bind local_declarations = - let%bind tmp = bind_list - @@ List.map simpl_local_declaration local_decls in - ok (List.map fst tmp) in - let%bind instructions = bind_list - @@ 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 - let expression = E_lambda {binder ; input_type = Some input_type; - output_type = Some input_type; result ; body } in - let type_annotation = Some (T_function (input_type, output_type)) in - ok {name;annotated_expression = {expression;type_annotation}} - ) - | lst -> ( - let arguments_name = "arguments" in - let%bind params = bind_map_list simpl_param lst in - let input = - let aux = fun x -> x.type_expression in - let type_expression = T_tuple (List.map aux params) in - { type_name = arguments_name ; type_expression } in - let binder = input.type_name in - let input_type = input.type_expression in - let tpl_declarations = - let aux = fun i (x:named_type_expression) -> - let ass = I_assignment { - name = x.type_name ; - annotated_expression = { - expression = E_accessor ({ - expression = E_variable arguments_name ; - type_annotation = Some input.type_expression ; - } , [ Access_tuple i ] ) ; - type_annotation = Some (x.type_expression) ; - } - } in - ass - in - List.mapi aux params in - let%bind local_declarations = - let%bind typed = bind_map_list simpl_local_declaration local_decls in - ok (List.map fst typed) - in - let%bind output_type = simpl_type_expression ret_type in - let%bind instructions = bind_list - @@ List.map simpl_statement - @@ npseq_to_list block.value.statements in - - let body = tpl_declarations @ local_declarations @ instructions in - let%bind result = simpl_expression return in - let expression = E_lambda {binder ; input_type = Some input_type; - output_type = Some output_type; result ; body } in - let type_annotation = Some (T_function (input_type, output_type)) in - ok {name = name.value;annotated_expression = {expression;type_annotation}} - ) - ) and simpl_declaration : Raw.declaration -> declaration Location.wrap result = fun t -> let open! Raw in let loc : 'a . 'a Raw.reg -> _ -> _ = fun x v -> Location.wrap ~loc:(File x.region) v in @@ -401,22 +291,18 @@ and simpl_declaration : Raw.declaration -> declaration Location.wrap result = fu | TypeDecl x -> let {name;type_expr} : Raw.type_decl = x.value in let%bind type_expression = simpl_type_expression type_expr in - ok @@ loc x @@ Declaration_type {type_name=name.value;type_expression} + ok @@ loc x @@ Declaration_type (name.value , type_expression) | LetEntry _ -> simple_fail "no entry point yet" - | Let x -> + | Let x -> ( let _, binding = x.value in - let {pattern; lhs_type; let_rhs} = binding in + let {variable ; lhs_type ; let_rhs} = binding in let%bind type_annotation = bind_map_option (fun (_,type_expr) -> simpl_type_expression type_expr) lhs_type in let%bind rhs = simpl_expression ?te_annot:type_annotation let_rhs in - match pattern with - Raw.PVar v -> - let name = v.value in - let named_expr = {name; annotated_expression=rhs} - in return (Declaration_constant named_expr) - | _ -> let%bind case = simpl_cases [(pattern, rhs)] - in return (Declaration_constant (E_matching (rhs, case))) + let name = variable.value in + ok @@ loc x @@ (Declaration_constant (name , type_annotation , rhs)) + ) (* | ConstDecl x -> @@ -424,7 +310,7 @@ and simpl_declaration : Raw.declaration -> declaration Location.wrap result = fu let%bind expression = simpl_expression init in let%bind t = simpl_type_expression const_type in let type_annotation = Some t in - ok @@ Declaration_constant {name=name.value;annotated_expression={expression with type_annotation}} + ok @@ Declaration_constant {name=name.value;expression={expression with type_annotation}} in bind_map_location simpl_const_decl (Location.lift_region x) | LambdaDecl (FunDecl x) -> @@ -435,117 +321,6 @@ and simpl_declaration : Raw.declaration -> declaration Location.wrap result = fu | LambdaDecl (ProcDecl _) -> simple_fail "no proc declaration 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 : Raw.single_instr -> instruction result = fun t -> - match t with - | ProcCall _ -> simple_fail "no proc call" - | Fail e -> - let%bind expr = simpl_expression e.value.fail_expr in - ok @@ I_do (untyped_expression @@ E_failwith expr) - | Skip _ -> ok @@ I_skip - | Loop (While l) -> - let l = l.value in - let%bind cond = simpl_expression l.cond in - let%bind body = simpl_block l.block.value in - ok @@ I_loop (cond, body) - | Loop (For _) -> - simple_fail "no for yet" - | Cond c -> - let c = c.value in - let%bind expr = simpl_expression c.test in - let%bind match_true = match c.ifso with - | ClauseInstr i -> simpl_instruction_block i - | ClauseBlock b -> simpl_statements @@ fst b.value.inside in - let%bind match_false = match c.ifnot with - | ClauseInstr i -> simpl_instruction_block i - | ClauseBlock b -> simpl_statements @@ fst b.value.inside in - ok @@ I_matching (expr, (Match_bool {match_true; match_false})) - | Assign a -> ( - let a = a.value in - let%bind value_expr = match a.rhs with - | Expr e -> simpl_expression e - | NoneExpr _ -> simple_fail "no none assignments yet" - in - match a.lhs with - | Path path -> ( - let (name , path') = simpl_path path in - match List.rev_uncons_opt path' with - | None -> ( - ok @@ I_assignment {name ; annotated_expression = value_expr} - ) - | Some (hds , last) -> ( - match last with - | Access_record property -> ok @@ I_record_patch (name , hds , [(property , value_expr)]) - | Access_tuple index -> ok @@ I_tuple_patch (name , hds , [(index , value_expr)]) - | _ -> simple_fail "no map assignment in this weird case yet" - ) - ) - | MapPath v -> ( - let v' = v.value in - let%bind name = match v'.path with - | Name name -> ok name - | _ -> simple_fail "no complex map assignments yet" in - let%bind key_expr = simpl_expression v'.index.value.inside in - let old_expr = make_e_a @@ E_variable name.value in - let expr' = make_e_a @@ E_constant ("MAP_UPDATE", [key_expr ; value_expr ; old_expr]) in - ok @@ I_assignment {name = name.value ; annotated_expression = expr'} - ) - ) - | CaseInstr c -> - let c = c.value in - let%bind expr = simpl_expression c.expr in - let%bind cases = - let aux (x : Raw.instruction Raw.case_clause Raw.reg) = - let%bind i = simpl_instruction_block x.value.rhs 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 @@ I_matching (expr, m) - | RecordPatch r -> ( - let r = r.value in - let (name , access_path) = simpl_path r.path in - let%bind inj = bind_list - @@ List.map (fun (x:Raw.field_assign) -> let%bind e = simpl_expression x.field_expr in ok (x.field_name.value, e)) - @@ List.map (fun (x:_ Raw.reg) -> x.value) - @@ pseq_to_list r.record_inj.value.elements in - ok @@ I_record_patch (name, access_path, inj) - ) - | MapPatch _ -> simple_fail "no map patch yet" - | SetPatch _ -> simple_fail "no set patch yet" - | MapRemove r -> - let v = r.value in - let key = v.key in - let%bind map = match v.map with - | Name v -> ok v.value - | _ -> simple_fail "no complex map remove yet" in - let%bind key' = simpl_expression key in - let expr = E_constant ("MAP_REMOVE", [key' ; make_e_a (E_variable map)]) in - ok @@ I_assignment {name = map ; annotated_expression = make_e_a expr} - | SetRemove _ -> simple_fail "no set remove yet" - -and simpl_path : Raw.path -> string * Ast_simplified.access_path = fun p -> - match p with - | Raw.Name v -> (v.value , []) - | Raw.Path p -> ( - let p' = p.value in - let var = p'.struct_name.value in - let path = p'.field_path in - let path' = - let aux (s:Raw.selection) = - match s with - | FieldName property -> Access_record property.value - | Component index -> Access_tuple (Z.to_int (snd index.value)) - in - List.map aux @@ npseq_to_list path in - (var , path') - ) - and simpl_cases : type a . (Raw.pattern * a) list -> a matching result = fun t -> let open Raw in let get_var (t:Raw.pattern) = match t with @@ -559,8 +334,7 @@ and simpl_cases : type a . (Raw.pattern * a) list -> a matching result = fun t - fail error in let get_tuple (t:Raw.pattern) = match t with - | PCons v -> npseq_to_list v.value - | PTuple v -> npseq_to_list v.value.inside + | PTuple v -> npseq_to_list v.value | x -> [ x ] in let get_single (t:Raw.pattern) = @@ -570,9 +344,15 @@ and simpl_cases : type a . (Raw.pattern * a) list -> a matching result = fun t - Assert.assert_list_size t' 1 in ok (List.hd t') in let get_constr (t:Raw.pattern) = match t with - | PConstr v -> - let%bind var = get_single (snd v.value).value >>? get_var in - ok ((fst v.value).value , var) + | PConstr v -> ( + let (const , pat_opt) = v.value in + let%bind pat = + trace_option (simple_error "No constructor without variable yet") @@ + pat_opt in + let%bind single_pat = get_single pat in + let%bind var = get_var single_pat in + ok (const.value , var) + ) | _ -> simple_fail "not a constr" in let%bind patterns = @@ -586,26 +366,22 @@ and simpl_cases : type a . (Raw.pattern * a) list -> a matching result = fun t - match patterns with | [(PFalse _ , f) ; (PTrue _ , t)] | [(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 - let%bind v = match v.value.inside with - | PVar v -> ok v.value - | _ -> simple_fail "complex none patterns not supported yet" in - ok @@ Match_option {match_none = none ; match_some = (v, some) } - ) - | [(PCons c , cons) ; (PList (PNil _) , nil)] - | [(PList (PNil _) , nil) ; (PCons c, cons)] -> + | [(PList (PCons c) , cons) ; (PList (Sugar sugar_nil) , nil)] + | [(PList (Sugar sugar_nil) , nil) ; (PList (PCons c), cons)] -> ( + let%bind () = + trace_strong (simple_error "Only empty list patterns and cons are allowed yet") + @@ Assert.assert_list_empty + @@ pseq_to_list + @@ sugar_nil.value.elements in let%bind (a, b) = - match c.value with - | a, [(_, b)] -> - let%bind a = get_var a in - let%bind b = get_var b in - ok (a, b) - | _ -> simple_fail "complex list patterns not supported yet" + let (a , _ , b) = c.value in + let%bind a = get_var a in + let%bind b = get_var b in + ok (a, b) in ok @@ Match_list {match_cons = (a, b, cons) ; match_nil = nil} - | lst -> + ) + | lst -> ( trace (simple_error "weird patterns not supported yet") @@ let%bind constrs = let aux (x , y) = @@ -620,28 +396,7 @@ and simpl_cases : type a . (Raw.pattern * a) list -> a matching result = fun t - ok (x' , y) in bind_map_list aux lst in ok @@ Match_variant constrs - -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 : Raw.instruction -> instruction result = fun t -> - let main_error = - let title () = "simplifiying instruction" in - let content () = Format.asprintf "%a" PP_helpers.(printer Raw.print_instruction) t in - error title content in - trace main_error @@ - match t with - | Single s -> simpl_single_instruction s - | Block _ -> simple_fail "no block instruction yet" - -and simpl_statements : Raw.statements -> block result = fun ss -> - let lst = npseq_to_list ss in - bind_map_list simpl_statement lst - -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