Type inference, Constraints, function, change idents to patterns

FSharpActivePatterns/bin/REPL.ml

@@ -5,16 +5,17 @@
 open FSharpActivePatterns.AstPrinter
 open FSharpActivePatterns.Parser
 open FSharpActivePatterns.Inferencer
+open FSharpActivePatterns.TypedTree
 open FSharpActivePatterns.TypesPp
+open FSharpActivePatterns.Ast
 open Stdlib
 
 type input =
   | Input of string
   | EOF
 
-type 'a run_result =
-  | Result of 'a
-  | Fail
+type run_result =
+  | Result of (construction, string) result
   | Empty
   | End
 
@@ -42,54 +43,88 @@ let input_upto_sep sep ic =
   fill_buffer buffer
 ;;
 
+let input_with_indents ic =
+  let take_line () = In_channel.input_line ic in
+  let rec fill_buffer b =
+    let start_pos = pos_in ic in
+    let line = take_line () in
+    match line with
+    | None -> Input (Buffer.contents b)
+    | Some line ->
+      let is_empty = String.length line = 0 in
+      let is_continue =
+        List.exists (fun pref -> String.starts_with ~prefix:pref line) [ " "; "\t"; "\n" ]
+        || is_empty
+        || String.starts_with ~prefix:"and" (String.trim line)
+      in
+      (match is_continue with
+       | true ->
+         Buffer.add_string b (line ^ "\n");
+         fill_buffer b
+       | false ->
+         seek_in ic start_pos;
+         Buffer.add_string b "\n";
+         Input (Buffer.contents b))
+  in
+  let buffer = Buffer.create 1024 in
+  let first_line = take_line () in
+  match first_line with
+  | None -> EOF
+  | Some first_line ->
+    Buffer.add_string buffer (first_line ^ "\n");
+    fill_buffer buffer
+;;
+
 let run_single ic =
-  match input_upto_sep ";;" ic with
+  let input =
+    match ic with
+    | None -> input_upto_sep ";;" stdin
+    | Some ic -> input_with_indents ic
+  in
+  match input with
   | EOF -> End
-  | Input input ->
-    let trimmed_input = String.trim input in
-    if trimmed_input = ""
-    then Empty
-    else (
-      match parse trimmed_input with
-      | Some ast -> Result ast
-      | None -> Fail)
+  | Input input -> if String.trim input = "" then Empty else Result (parse input)
 ;;
 
 let run_repl dump_parsetree input_file =
   let ic =
     match input_file with
-    | None -> stdin
-    | Some n -> open_in n
+    | None -> None
+    | Some n -> Some (open_in n)
   in
   let rec run_repl_helper run env state =
     let open Format in
     match run ic with
-    | Fail -> fprintf err_formatter "Error occured\n"
+    | Result (Error e) -> fprintf err_formatter "%s\n" e
     | Empty ->
       fprintf std_formatter "\n";
       print_flush ();
       run_repl_helper run env state
     | End -> ()
-    | Result ast ->
-      let result = infer ast env state in
-      (match result with
-       | new_state, Error err ->
-         fprintf err_formatter "Type checking failed: %a\n" pp_error err;
-         print_flush ();
-         run_repl_helper run env new_state
-       | new_state, Ok (env, types) ->
-         (match dump_parsetree with
-          | true -> print_construction std_formatter ast
-          | false ->
+    | Result (Ok ast) ->
+      (match dump_parsetree with
+       | true -> print_construction std_formatter ast
+       | false ->
+         let result = infer ast env state in
+         (match result with
+          | new_state, Error err ->
+            fprintf err_formatter "Type checking failed: %a\n" pp_error err;
+            print_flush ();
+            run_repl_helper run env new_state
+          | new_state, Ok (env, names_and_types) ->
             List.iter
-              (fun t ->
-                fprintf std_formatter "- : ";
-                pp_typ std_formatter t)
-              types;
-            print_flush ());
-         run_repl_helper run env new_state)
+              (fun (n, t) -> fprintf std_formatter "%s : %a" n pp_typ t)
+              names_and_types;
+            print_flush ();
+            run_repl_helper run env new_state))
+  in
+  let env =
+    TypeEnvironment.extend
+      TypeEnvironment.empty
+      "print_int"
+      (Scheme (VarSet.empty, Arrow (int_typ, unit_typ)))
   in
-  run_repl_helper run_single TypeEnvironment.empty 0
+  run_repl_helper run_single env 0
 ;;
 
 type opts =

FSharpActivePatterns/bin/dune

@@ -1,6 +1,6 @@
 (executable
  (public_name repl)
  (name REPL)
- (libraries FSharpActivePatterns stdlib)
+ (libraries FSharpActivePatterns stdlib str)
  (instrumentation
   (backend bisect_ppx)))

FSharpActivePatterns/bin/input.txt

@@ -1,4 +1,41 @@
-1 + ();;
-1 + "";;
-1 + true;;
-1 + 1;;
+let rec length xs =
+  match xs with
+  | [] -> 0
+  | h::tl -> 1 + length tl
+
+let length_tail =
+  let rec helper acc xs =
+  match xs with
+  | [] -> acc
+  | h::tl -> helper (acc + 1) tl
+  in
+  helper 0
+
+let rec map f xs =
+  match xs with
+  | [] -> []
+  | a::[] -> [f a]
+  | a::b::[] -> [f a; f b]
+  | a::b::c::[] -> [f a; f b; f c]
+  | a::b::c::d::tl -> f a :: f b :: f c :: f d :: map f tl
+
+let rec append xs ys = match xs with [] -> ys | x::xs -> x::(append xs ys)
+
+let concat =
+  let rec helper xs =
+    match xs with
+    | [] -> []
+    | h::tl -> append h (helper tl)
+  in helper
+
+let rec iter f xs = match xs with [] -> () | h::tl -> let () = f h in iter f tl
+
+let rec cartesian xs ys =
+  match xs with
+  | [] -> []
+  | h::tl -> append (map (fun a -> (h,a)) ys) (cartesian tl ys)
+
+let main =
+  let () = iter print_int [1;2;3] in
+  let () = print_int (length (cartesian [1;2] [1;2;3;4])) in
+  0

FSharpActivePatterns/lib/ast.ml

@@ -3,9 +3,9 @@
 (** SPDX-License-Identifier: LGPL-3.0-or-later *)
 
 open KeywordChecker
+open TypedTree
 
-type ident = Ident of string * string option (** identifier *)
-[@@deriving show { with_path = false }]
+type ident = Ident of string (** identifier *) [@@deriving show { with_path = false }]
 
 let gen_varname =
   let open QCheck.Gen in
@@ -26,8 +26,8 @@ let gen_varname =
   loop >>= fun name -> if is_keyword name then loop else return name
 ;;
 
-let gen_ident = QCheck.Gen.map (fun s -> Ident (s, None)) gen_varname
-let gen_ident_small_list = QCheck.Gen.(list_size (0 -- 3) gen_ident)
+let gen_ident = QCheck.Gen.map (fun s -> Ident s) gen_varname
+(* let gen_ident_small_list = QCheck.Gen.(list_size (0 -- 3) gen_ident) *)
 
 let gen_escape_sequence =
   let open QCheck.Gen in
@@ -98,15 +98,21 @@ type pattern =
   | PConst of literal (** | [4] -> *)
   | PVar of ident (** pattern identifier *)
   | POption of pattern option
-    (*| Variant of (ident list[@gen gen_ident_small_list]) (** | [Blue, Green, Yellow] -> *) *)
+  (*| Variant of (ident list[@gen gen_ident_small_list]) (** | [Blue, Green, Yellow] -> *) *)
+  | PConstraint of pattern * (typ[@gen gen_typ_sized (n / 4)])
 [@@deriving show { with_path = false }, qcheck]
 
+let gen_typed_pattern_sized n = QCheck.Gen.(pair (gen_pattern_sized n) (return None))
+
 type is_recursive =
   | Nonrec (** let factorial n = ... *)
   | Rec (** let rec factorial n = ... *)
 [@@deriving show { with_path = false }, qcheck]
 
-type expr =
+type case = (pattern[@gen gen_pattern_sized n]) * (expr[@gen gen_expr_sized n])
+[@@deriving show { with_path = false }, qcheck]
+
+and expr =
   | Const of literal (** [Int], [Bool], [String], [Unit], [Null] *)
   | Tuple of
       (expr[@gen gen_expr_sized (n / 4)])
@@ -129,29 +135,30 @@ type expr =
       * expr (** fun x y -> x + y *)
   | Apply of (expr[@gen gen_expr_sized (n / 4)]) * (expr[@gen gen_expr_sized (n / 4)])
   (** [sum 1 ] *)
+  | Function of
+      (case[@gen gen_case_sized (n / 4)])
+      * (case list[@gen QCheck.Gen.(list_size (0 -- 2) (gen_case_sized (n / 20)))])
+  (** [function | p1 -> e1 | p2 -> e2 | ... |]*)
   | Match of
       (expr[@gen gen_expr_sized (n / 4)])
-      * (pattern[@gen gen_pattern_sized (n / 4)])
-      * (expr[@gen gen_expr_sized (n / 4)])
-      * ((pattern * expr) list
-        [@gen
-          QCheck.Gen.(
-            list_size
-              (0 -- 2)
-              (pair (gen_pattern_sized (n / 20)) (gen_expr_sized (n / 20))))])
-  (** [match x with | x -> ... | y -> ...] *)
+      * (case[@gen gen_case_sized (n / 4)])
+      * (case list[@gen QCheck.Gen.(list_size (0 -- 2) (gen_case_sized (n / 20)))])
+  (** [match x with | p1 -> e1 | p2 -> e2 | ...] *)
   | LetIn of
       is_recursive
       * let_bind
       * (let_bind list
         [@gen QCheck.Gen.(list_size (0 -- 2) (gen_let_bind_sized (n / 20)))])
       * expr (** [let rec f x = if (x <= 0) then x else g x and g x = f (x-2) in f 3] *)
   | Option of expr option (** [int option] *)
+  | EConstraint of expr * (typ[@gen gen_typ_sized (n / 4)])
 [@@deriving show { with_path = false }, qcheck]
 
 and let_bind =
-  | Let_bind of ident * (ident list[@gen gen_ident_small_list]) * expr
-  (** [and sum n m = n+m] *)
+  | Let_bind of
+      (pattern[@gen gen_pattern_sized (n / 2)])
+      * (pattern list[@gen QCheck.Gen.(list_size (0 -- 3) (gen_pattern_sized (n / 4)))])
+      * expr (** [let sum n m = n + m] *)
 [@@deriving show { with_path = false }, qcheck]
 
 let gen_expr =

FSharpActivePatterns/lib/astPrinter.ml

@@ -49,34 +49,31 @@ let rec print_pattern indent fmt = function
     fprintf fmt "%s| PCons:\n" (String.make indent '-');
     print_pattern (indent + 2) fmt l;
     print_pattern (indent + 2) fmt r
-  | PVar (Ident (name, _)) -> fprintf fmt "%s| PVar(%s)\n" (String.make indent '-') name
+  | PVar (Ident name) -> fprintf fmt "%s| PVar(%s)\n" (String.make indent '-') name
   | POption p ->
     fprintf fmt "%s| POption: " (String.make indent '-');
     (match p with
      | None -> fprintf fmt "None\n"
      | Some p ->
        fprintf fmt "Some:\n";
        print_pattern (indent + 2) fmt p)
+  | PConstraint (p, _) -> print_pattern indent fmt p
 ;;
 
 let print_unary_op indent fmt = function
   | Unary_minus -> fprintf fmt "%s| Unary minus\n" (String.make indent '-')
   | Unary_not -> fprintf fmt "%s| Unary negative\n" (String.make indent '-')
 ;;
 
-let tag_of_ident = function
-  | Ident (s, _) -> s
-;;
-
 let rec print_let_bind indent fmt = function
   | Let_bind (name, args, body) ->
-    let name = tag_of_ident name in
-    let args = List.map tag_of_ident args in
     fprintf fmt "%s| Let_bind:\n" (String.make indent '-');
     fprintf fmt "%sNAME:\n" (String.make (indent + 4) ' ');
-    fprintf fmt "%s| %s\n" (String.make (indent + 4) '-') name;
+    fprintf fmt "%s| %a\n" (String.make (indent + 4) '-') pp_pattern name;
     fprintf fmt "%sARGS:\n" (String.make (indent + 4) ' ');
-    List.iter (fun arg -> fprintf fmt "%s| %s\n" (String.make (indent + 2) '-') arg) args;
+    List.iter
+      (fun arg -> fprintf fmt "%s| %a\n" (String.make (indent + 2) '-') pp_pattern arg)
+      args;
     fprintf fmt "%sBODY:\n" (String.make (indent + 4) ' ');
     print_expr (indent + 2) fmt body
 
@@ -93,18 +90,27 @@ and print_expr indent fmt expr =
   | Tuple (e1, e2, rest) ->
     fprintf fmt "%s| Tuple:\n" (String.make indent '-');
     List.iter (print_expr (indent + 2) fmt) (e1 :: e2 :: rest)
-  | Match (value, pat1, expr1, cases) ->
+  | Function ((pat1, expr1), cases) ->
+    fprintf fmt "%s| Function:\n" (String.make indent '-');
+    List.iter
+      (fun (pat, expr) ->
+        fprintf fmt "%s| Pattern:\n" (String.make (indent + 2) '-');
+        print_pattern (indent + 4) fmt pat;
+        fprintf fmt "%s| Case expr:\n" (String.make (indent + 2) '-');
+        print_expr (indent + 4) fmt expr)
+      ((pat1, expr1) :: cases)
+  | Match (value, (pat1, expr1), cases) ->
     fprintf fmt "%s| Match:\n" (String.make indent '-');
     fprintf fmt "%s| Value:\n" (String.make (indent + 2) '-');
     print_expr (indent + 4) fmt value;
     List.iter
       (fun (pat, expr) ->
         fprintf fmt "%s| Pattern:\n" (String.make (indent + 2) '-');
         print_pattern (indent + 4) fmt pat;
-        fprintf fmt "%s| Inner expr:\n" (String.make (indent + 2) '-');
+        fprintf fmt "%s| Case expr:\n" (String.make (indent + 2) '-');
         print_expr (indent + 4) fmt expr)
       ((pat1, expr1) :: cases)
-  | Variable (Ident (name, _)) ->
+  | Variable (Ident name) ->
     fprintf fmt "%s| Variable(%s)\n" (String.make indent '-') name
   | Unary_expr (op, expr) ->
     fprintf fmt "%s| Unary expr(\n" (String.make indent '-');
@@ -125,12 +131,11 @@ and print_expr indent fmt expr =
     (match else_body with
      | Some body -> print_expr (indent + 2) fmt body
      | None -> fprintf fmt "%s| No else body\n" (String.make (indent + 2) '-'))
-  | Lambda (pat1, pat_list, body) ->
-    (*let args = List.map tag_of_ident args in*)
+  | Lambda (arg1, args, body) ->
     fprintf fmt "%s| Lambda:\n" (String.make indent '-');
     fprintf fmt "%sARGS\n" (String.make (indent + 2) ' ');
-    print_pattern (indent + 4) fmt pat1;
-    List.iter (fun pat -> print_pattern (indent + 4) fmt pat) pat_list;
+    print_pattern (indent + 4) fmt arg1;
+    List.iter (fun pat -> print_pattern (indent + 4) fmt pat) (arg1 :: args);
     fprintf fmt "%sBODY\n" (String.make (indent + 2) ' ');
     print_expr (indent + 4) fmt body
   | Apply (func, arg) ->
@@ -157,6 +162,7 @@ and print_expr indent fmt expr =
      | Some e ->
        fprintf fmt "%s| Option: Some\n" (String.make indent '-');
        print_expr (indent + 2) fmt e)
+  | EConstraint (e, _) -> print_expr indent fmt e
 ;;
 
 let print_statement indent fmt = function
@@ -186,6 +192,6 @@ let print_construction fmt = function
 ;;
 
 let print_p_res fmt = function
-  | Some expr -> print_construction fmt expr
-  | None -> fprintf fmt "Error occured"
+  | Ok ast -> print_construction fmt ast
+  | Error e -> fprintf fmt "%s\n" e
 ;;

FSharpActivePatterns/lib/astPrinter.mli

@@ -6,4 +6,4 @@ open Ast
 open Format
 
 val print_construction : formatter -> construction -> unit
-val print_p_res : formatter -> construction option -> unit
+val print_p_res : formatter -> (construction, tag) result -> unit