From bc5082388506443ec6888b48ca3d7705934070f1 Mon Sep 17 00:00:00 2001
From: Emanon42 <EmanonTang@outlook.com>
Date: Wed, 27 May 2020 22:31:32 +0100
Subject: [PATCH 01/50] Using buffer in SQL query building

---
 core/query/sql.ml | 94 +++++++++++++++++++++++++----------------------
 1 file changed, 50 insertions(+), 44 deletions(-)

diff --git a/core/query/sql.ml b/core/query/sql.ml
index 59b5abb3f..5d2bcc275 100644
--- a/core/query/sql.ml
+++ b/core/query/sql.ml
@@ -69,6 +69,12 @@ let string_of_label label =
   else
     label
 
+(* concatenation implement with Buffer module*)
+let buffer_concat xs =
+  let buf = Buffer.create 0 in (* maybe a better heuristic init size? *)
+  List.iter (Buffer.add_string buf) xs;
+  Buffer.contents buf
+
 module Arithmetic :
 sig
   val is : string -> bool
@@ -137,10 +143,10 @@ let order_by_clause n =
    returned. This allows these operators to take lists that have any
    element type at all. *)
 
-let rec string_of_query quote ignore_fields q =
-  let sq = string_of_query quote ignore_fields in
-  let sb = string_of_base quote false in
-  let sbt = string_of_base quote true in
+let rec string_of_query buf quote ignore_fields q =
+  let sq = string_of_query buf quote ignore_fields in
+  let sb = string_of_base buf quote false in
+  let sbt = string_of_base buf quote true in
   let string_of_fields fields =
     if ignore_fields then
       "0 as \"@unit@\"" (* SQL doesn't support empty records! *)
@@ -150,7 +156,7 @@ let rec string_of_query quote ignore_fields q =
         | fields ->
           mapstrcat ","
             (fun (b, l) ->
-              "(" ^ sb b ^ ") as "^ quote l) (* string_of_label l) *)
+              buffer_concat ["("; sb b; ") as "; quote l]) (* string_of_label l) *)
             fields
   in
   let string_of_select fields tables condition os =
@@ -159,28 +165,28 @@ let rec string_of_query quote ignore_fields q =
     let orderby =
       match os with
         | [] -> ""
-        | _ -> " order by " ^ mapstrcat "," sb os in
+        | _ ->  buffer_concat [" order by "; mapstrcat "," sb os] in
     let where =
       match condition with
         | Constant (Constant.Bool true) -> ""
-        | _ ->  " where " ^ sb condition
+        | _ ->   buffer_concat [" where "; sb condition]
     in
-      "select " ^ fields ^ " from " ^ tables ^ where ^ orderby
+       buffer_concat ["select "; fields; " from "; tables; where; orderby]
   in
   let string_of_delete table where =
     let where =
       OptionUtils.opt_app
-        (fun x -> "where (" ^ sbt x ^ ")") "" where in
+        (fun x ->  buffer_concat ["where ("; sbt x; ")"]) "" where in
     Printf.sprintf "delete from %s %s" table where
   in
   let string_of_update table fields where =
     let fields =
-      List.map (fun (k, v) -> quote k ^ " = " ^ sbt v) fields
+      List.map (fun (k, v) -> buffer_concat [quote k; " = "; sbt v]) fields
       |> String.concat ", " in
 
     let where =
       OptionUtils.opt_app
-        (fun x -> "where (" ^ sbt x ^ ")") "" where in
+        (fun x -> buffer_concat ["where ("; sbt x; ")"]) "" where in
     Printf.sprintf "update %s set %s %s" table fields where
   in
   let string_of_insert table fields values =
@@ -196,18 +202,18 @@ let rec string_of_query quote ignore_fields q =
   in
     match q with
       | UnionAll ([], _) -> "select 42 as \"@unit@\" where false"
-      | UnionAll ([q], n) -> sq q ^ order_by_clause n
+      | UnionAll ([q], n) -> buffer_concat [sq q; order_by_clause n]
       | UnionAll (qs, n) ->
-        mapstrcat " union all " (fun q -> "(" ^ sq q ^ ")") qs ^ order_by_clause n
+        mapstrcat " union all " (fun q -> buffer_concat ["("; sq q; ")"]) qs ^ order_by_clause n
       | Select (fields, [], Constant (Constant.Bool true), _os) ->
           let fields = string_of_fields fields in
-            "select " ^ fields
+            buffer_concat ["select "; fields]
       | Select (fields, [], condition, _os) ->
           let fields = string_of_fields fields in
-            "select * from (select " ^ fields ^ ") as " ^ fresh_dummy_var () ^ " where " ^ sb condition
+            buffer_concat ["select * from (select "; fields; ") as "; fresh_dummy_var (); " where "; sb condition]
       | Select (fields, tables, condition, os) ->
           (* using quote_field assumes tables contains table names (not nested queries) *)
-          let tables = List.map (fun (t, x) -> quote t ^ " as " ^ (string_of_table_var x)) tables
+          let tables = List.map (fun (t, x) -> buffer_concat [quote t; " as "; (string_of_table_var x)]) tables
           in string_of_select fields tables condition os
       | Delete { del_table; del_where } ->
           string_of_delete del_table del_where
@@ -219,56 +225,56 @@ let rec string_of_query quote ignore_fields q =
           match q' with
           | Select (fields, tables, condition, os) ->
               (* Inline the query *)
-              let tables = List.map (fun (t, x) -> quote t ^ " as " ^ (string_of_table_var x)) tables in
-              let q = "(" ^ sq q ^ ") as " ^ string_of_table_var z in
+              let tables = List.map (fun (t, x) -> buffer_concat [quote t; " as "; (string_of_table_var x)]) tables in
+              let q = buffer_concat ["("; sq q; ") as "; string_of_table_var z] in
               string_of_select fields (q::tables) condition os
           | _ -> assert false
 
-and string_of_base quote one_table b =
-  let sb = string_of_base quote one_table in
+and string_of_base buf quote one_table b =
+  let sb = string_of_base buf quote one_table in
     match b with
       | Case (c, t, e) ->
-          "case when " ^ sb c ^ " then " ^sb t ^ " else "^ sb e ^ " end"
+          buffer_concat ["case when "; sb c; " then "; sb t; " else "; sb e; " end"]
       | Constant c -> Constant.to_string c
       | Project (var, label) -> string_of_projection quote one_table (var, label)
       | Apply (op, [l; r]) when Arithmetic.is op
           -> Arithmetic.gen (sb l, op, sb r)
       | Apply (("intToString" | "stringToInt" | "intToFloat" | "floatToString"
                 | "stringToFloat"), [v]) -> sb v
-      | Apply ("floatToInt", [v]) -> "floor("^sb v^")"
+      | Apply ("floatToInt", [v]) -> buffer_concat ["floor("; sb v; ")"]
 
       (* optimisation *)
-      | Apply ("not", [Empty q]) -> "exists (" ^ string_of_query quote true q ^ ")"
-
-      | Apply ("not", [v]) -> "not (" ^ sb v ^ ")"
-      | Apply (("negate" | "negatef"), [v]) -> "-(" ^ sb v ^ ")"
-      | Apply ("&&", [v; w]) -> "(" ^ sb v ^ ")" ^ " and " ^ "(" ^ sb w ^ ")"
-      | Apply ("||", [v; w]) -> "(" ^ sb v ^ ")" ^ " or " ^ "(" ^ sb w ^ ")"
-      | Apply ("==", [v; w]) -> "(" ^ sb v ^ ")" ^ " = " ^ "(" ^ sb w ^ ")"
-      | Apply ("<>", [v; w]) -> "(" ^ sb v ^ ")" ^ " <> " ^ "(" ^ sb w ^ ")"
-      | Apply ("<", [v; w]) -> "(" ^ sb v ^ ")" ^ " < " ^ "(" ^ sb w ^ ")"
-      | Apply (">", [v; w]) -> "(" ^ sb v ^ ")" ^ " > " ^ "(" ^ sb w ^ ")"
-      | Apply ("<=", [v; w]) -> "(" ^ sb v ^ ")" ^ " <= " ^ "(" ^ sb w ^ ")"
-      | Apply (">=", [v; w]) -> "(" ^ sb v ^ ")" ^ " >= " ^ "(" ^ sb w ^ ")"
-      | Apply ("RLIKE", [v; w]) -> "(" ^ sb v ^ ")" ^ " RLIKE " ^ "(" ^ sb w ^ ")"
-      | Apply ("LIKE", [v; w]) -> "(" ^ sb v ^ ")" ^ " LIKE " ^ "(" ^ sb w ^ ")"
-      | Apply (f, args) when SqlFuns.is f -> SqlFuns.name f ^ "(" ^ String.concat "," (List.map sb args) ^ ")"
-      | Apply (f, args) -> f ^ "(" ^ String.concat "," (List.map sb args) ^ ")"
-      | Empty q -> "not exists (" ^ string_of_query quote true q ^ ")"
-      | Length q -> "select count(*) from (" ^ string_of_query quote true q ^ ") as " ^ fresh_dummy_var ()
+      | Apply ("not", [Empty q]) -> buffer_concat ["exists ("; string_of_query buf quote true q; ")"]
+      | Apply ("not", [v]) -> buffer_concat ["not ("; sb v; ")"]
+      | Apply (("negate" | "negatef"), [v]) -> buffer_concat ["-("; sb v; ")"]
+      | Apply ("&&", [v; w]) -> buffer_concat ["("; sb v; ")"; " and "; "("; sb w; ")"]
+      | Apply ("||", [v; w]) -> buffer_concat ["("; sb v; ")"; " or "; "("; sb w; ")"]
+      | Apply ("==", [v; w]) -> buffer_concat ["("; sb v; ")"; " = "; "("; sb w; ")"]
+      | Apply ("<>", [v; w]) -> buffer_concat ["("; sb v; ")"; " <> "; "("; sb w; ")"]
+      | Apply ("<", [v; w]) -> buffer_concat ["("; sb v; ")"; " < "; "("; sb w; ")"]
+      | Apply (">", [v; w]) -> buffer_concat ["("; sb v; ")"; " > "; "("; sb w; ")"]
+      | Apply ("<=", [v; w]) -> buffer_concat ["("; sb v; ")"; " <= "; "("; sb w; ")"]
+      | Apply (">=", [v; w]) -> buffer_concat ["("; sb v; ")"; " >= "; "("; sb w; ")"]
+      | Apply ("RLIKE", [v; w]) -> buffer_concat ["("; sb v; ")"; " RLIKE "; "("; sb w; ")"]
+      | Apply ("LIKE", [v; w]) -> buffer_concat ["("; sb v; ")"; " LIKE "; "("; sb w; ")"]
+      | Apply (f, args) when SqlFuns.is f -> buffer_concat [SqlFuns.name f; "("; String.concat "," (List.map sb args); ")"]
+      | Apply (f, args) -> buffer_concat [f; "("; String.concat "," (List.map sb args); ")"]
+      | Empty q -> buffer_concat ["not exists ("; string_of_query buf quote true q; ")"]
+      | Length q -> buffer_concat ["select count(*) from ("; string_of_query buf quote true q; ") as "; fresh_dummy_var ()]
       | RowNumber [] -> "1"
       | RowNumber ps ->
-        "row_number() over (order by " ^ String.concat "," (List.map (string_of_projection quote one_table) ps) ^ ")"
+        buffer_concat ["row_number() over (order by "; String.concat "," (List.map (string_of_projection quote one_table) ps); ")"]
 and string_of_projection quote one_table (var, label) =
   if one_table then
     quote label
   else
-    string_of_table_var var ^ "." ^ (quote label)
+    buffer_concat [string_of_table_var var; "."; (quote label)]
 
 let string_of_query ?(range=None) quote q =
+  let buf = Buffer.create 0 in
   let range =
     match range with
       | None -> ""
-      | Some (limit, offset) -> " limit " ^string_of_int limit^" offset "^string_of_int offset
+      | Some (limit, offset) -> buffer_concat [" limit "; string_of_int limit; " offset "; string_of_int offset]
   in
-    string_of_query quote false q ^ range
+    buffer_concat [string_of_query buf quote false q; range]

From 93f50ed82f7e23ba83082d54c1ae51d127c27b8c Mon Sep 17 00:00:00 2001
From: Emanon42 <EmanonTang@outlook.com>
Date: Wed, 3 Jun 2020 05:25:50 +0100
Subject: [PATCH 02/50] unique bufferize query building

---
 core/query/sql.ml | 229 ++++++++++++++++++++++++++++++++++------------
 1 file changed, 169 insertions(+), 60 deletions(-)

diff --git a/core/query/sql.ml b/core/query/sql.ml
index 5d2bcc275..6c10ecde7 100644
--- a/core/query/sql.ml
+++ b/core/query/sql.ml
@@ -144,73 +144,167 @@ let order_by_clause n =
    element type at all. *)
 
 let rec string_of_query buf quote ignore_fields q =
+  let buf_add = Buffer.add_string buf in
   let sq = string_of_query buf quote ignore_fields in
   let sb = string_of_base buf quote false in
   let sbt = string_of_base buf quote true in
+  let buf_mapstrcat buf list = 
+    let load b l = buf_add "("; sb b; buf_add ") as "; buf_add (quote l) in (* string_of_label l) *)
+    match list with
+      | [] -> ()
+      | [(b, l)] -> load b l
+      | (b, l) :: xs -> 
+        load b l; 
+        List.iter(function
+            | (b, l) -> buf_add ","; load b l) 
+          xs
+  in
   let string_of_fields fields =
     if ignore_fields then
-      "0 as \"@unit@\"" (* SQL doesn't support empty records! *)
+      buf_add "0 as \"@unit@\"" (* SQL doesn't support empty records! *)
     else
       match fields with
-        | [] -> "0 as \"@unit@\"" (* SQL doesn't support empty records! *)
-        | fields ->
-          mapstrcat ","
-            (fun (b, l) ->
-              buffer_concat ["("; sb b; ") as "; quote l]) (* string_of_label l) *)
-            fields
+        | [] -> buf_add "0 as \"@unit@\"" (* SQL doesn't support empty records! *)
+        | fields -> buf_mapstrcat buf fields (* string_of_label l) *)
   in
   let string_of_select fields tables condition os =
     let tables = String.concat "," tables in
     let fields = string_of_fields fields in
+    let buf_mapstrcat2 buf list = 
+      let load os = sb os in (* string_of_label l) *)
+      match list with
+        | [] -> ()
+        | [x] -> load x
+        | x :: xs -> 
+          load x; 
+          List.iter(function
+              | x -> buf_add ","; load x) 
+            xs
+    in
     let orderby =
       match os with
-        | [] -> ""
-        | _ ->  buffer_concat [" order by "; mapstrcat "," sb os] in
+        | [] -> ()
+        | _ ->  buf_add " order by "; buf_mapstrcat2 buf os in
     let where =
       match condition with
-        | Constant (Constant.Bool true) -> ""
-        | _ ->   buffer_concat [" where "; sb condition]
+        | Constant (Constant.Bool true) -> ()
+        | _ ->  buf_add " where ";(* sb condition*)
     in
-       buffer_concat ["select "; fields; " from "; tables; where; orderby]
+       buf_add "select "; fields; buf_add " from "; buf_add tables; where; orderby
   in
   let string_of_delete table where =
-    let where =
+    (* let where = *)
+      buf_add "delete from";
+      buf_add table;
       OptionUtils.opt_app
-        (fun x ->  buffer_concat ["where ("; sbt x; ")"]) "" where in
-    Printf.sprintf "delete from %s %s" table where
+        (fun x ->  buf_add "where ("; sbt x; buf_add ")") () where 
+        (* in
+    Printf.sprintf "delete from %s %s" table where *)
   in
   let string_of_update table fields where =
-    let fields =
-      List.map (fun (k, v) -> buffer_concat [quote k; " = "; sbt v]) fields
-      |> String.concat ", " in
-
-    let where =
+    let buf_mapstrcat3 buf list = 
+      let load k v = buf_add (quote k); buf_add " = "; sbt v in (* string_of_label l) *)
+      match list with
+        | [] -> ()
+        | [(k, v)] -> load k v
+        | (k, v) :: xs -> 
+          load k v; 
+          List.iter(function
+              | (k, v) -> buf_add ","; load k v) 
+            xs
+    in
+    (* let fields =
+      List.map (fun (k, v) -> buf_add (quote k); buf_add " = "; sbt v) fields
+      |> String.concat ", " in *)
+    buf_mapstrcat3 buf fields;
+    (* let where = *)
       OptionUtils.opt_app
-        (fun x -> buffer_concat ["where ("; sbt x; ")"]) "" where in
-    Printf.sprintf "update %s set %s %s" table fields where
+        (fun x -> buf_add "where ("; sbt x; buf_add ")") () where 
+        (* in
+    Printf.sprintf "update %s set %s %s" table fields where *)
   in
   let string_of_insert table fields values =
-    let fields = String.concat ", " fields in
+    let buf_mapstrcat4 buf list = 
+        let load x = buf_add x in
+        match list with
+          | [] -> ()
+          | [x] -> load x
+          | x :: xs -> 
+            load x; 
+            List.iter(function
+                | x -> buf_add ","; load x) 
+              xs
+    in
+    let buf_mapstrcat5 buf list = 
+        let load x = buf_add "("; sbt x; buf_add ")" in
+        match list with
+          | [] -> ()
+          | [x] -> load x
+          | x :: xs -> 
+            load x; 
+            List.iter(function
+                | x -> buf_add ","; load x) 
+              xs
+    in
+    let buf_mapstrcat6 buf list = 
+        let load x = buf_add x in
+        match list with
+          | [] -> ()
+          | [x] ->  buf_mapstrcat5 buf x
+          | x :: xs -> 
+            buf_mapstrcat5 buf x; 
+            List.iter(function
+                | x -> buf_add ","; buf_mapstrcat5 buf x) 
+              xs
+    in
+    buf_add "insert into ";
+    buf_add table;
+    buf_add " (";
+    buf_mapstrcat4 buf fields;
+    buf_add ") values ";
+    buf_mapstrcat6 buf values;
+    (* let fields = String.concat ", " fields in
     let values =
       values
       (* Concatenate and bracket the values in each row *)
       |> List.map ((List.map sbt) ->- String.concat ", " ->- Printf.sprintf "(%s)")
+      (* String.concat ", " (sprintf "(%s)" (String.concat ", " （List.map sbt))) values *)
       (* Join all rows *)
       |> String.concat ", " in
     Printf.sprintf "insert into %s (%s) values %s"
-      table fields values
+      table fields values *)
   in
     match q with
-      | UnionAll ([], _) -> "select 42 as \"@unit@\" where false"
-      | UnionAll ([q], n) -> buffer_concat [sq q; order_by_clause n]
+      | UnionAll ([], _) -> buf_add "select 42 as \"@unit@\" where false"
+      | UnionAll ([q], n) -> sq q; buf_add (order_by_clause n)
       | UnionAll (qs, n) ->
-        mapstrcat " union all " (fun q -> buffer_concat ["("; sq q; ")"]) qs ^ order_by_clause n
+        let buf_mapstrcat6 buf list = 
+            let load x = buf_add "("; sq x; buf_add ")" in
+            match list with
+              | [] -> ()
+              | [x] -> load x
+              | x :: xs -> 
+                load x; 
+                List.iter(function
+                    | x -> buf_add " union all "; load x) 
+                  xs
+        in
+        buf_mapstrcat6 buf qs;
+        buf_add (order_by_clause n)
+        (* mapstrcat " union all " (fun q -> buffer_concat ["("; sq q; ")"]) qs ^ order_by_clause n *)
       | Select (fields, [], Constant (Constant.Bool true), _os) ->
-          let fields = string_of_fields fields in
-            buffer_concat ["select "; fields]
+          buf_add "select "; string_of_fields fields
+          (* let fields = string_of_fields fields in
+            buffer_concat ["select "; fields] *)
       | Select (fields, [], condition, _os) ->
-          let fields = string_of_fields fields in
-            buffer_concat ["select * from (select "; fields; ") as "; fresh_dummy_var (); " where "; sb condition]
+          buf_add "select * from (select ";
+          string_of_fields fields;
+          buf_add ") as ";
+          buf_add (fresh_dummy_var ());
+          buf_add " where ";
+          sb condition;
+          (* let fields = string_of_fields fields in
+            buffer_concat ["select * from (select "; fields; ") as "; fresh_dummy_var (); " where "; sb condition] *)
       | Select (fields, tables, condition, os) ->
           (* using quote_field assumes tables contains table names (not nested queries) *)
           let tables = List.map (fun (t, x) -> buffer_concat [quote t; " as "; (string_of_table_var x)]) tables
@@ -231,50 +325,65 @@ let rec string_of_query buf quote ignore_fields q =
           | _ -> assert false
 
 and string_of_base buf quote one_table b =
+  let string_of_projection quote one_table (var, label) =
+  if one_table then
+    quote label
+  else
+    buffer_concat [string_of_table_var var; "."; (quote label)]
+  in
+  let buf_add = Buffer.add_string buf in
   let sb = string_of_base buf quote one_table in
+  let buf_mapstrcat7 buf list = 
+    let load x = sb x in
+    match list with
+      | [] -> ()
+      | [x] -> load x
+      | x :: xs -> 
+        load x; 
+        List.iter(function
+            | x -> buf_add ","; load x) 
+          xs
+  in
     match b with
       | Case (c, t, e) ->
-          buffer_concat ["case when "; sb c; " then "; sb t; " else "; sb e; " end"]
-      | Constant c -> Constant.to_string c
-      | Project (var, label) -> string_of_projection quote one_table (var, label)
+          buf_add "case when "; sb c; buf_add " then "; sb t; buf_add " else "; sb e; buf_add " end"
+      | Constant c -> buf_add (Constant.to_string c)
+      | Project (var, label) -> buf_add (string_of_projection quote one_table (var, label))
       | Apply (op, [l; r]) when Arithmetic.is op
           -> Arithmetic.gen (sb l, op, sb r)
       | Apply (("intToString" | "stringToInt" | "intToFloat" | "floatToString"
                 | "stringToFloat"), [v]) -> sb v
-      | Apply ("floatToInt", [v]) -> buffer_concat ["floor("; sb v; ")"]
+      | Apply ("floatToInt", [v]) -> buf_add "floor("; sb v; buf_add ")"
 
       (* optimisation *)
-      | Apply ("not", [Empty q]) -> buffer_concat ["exists ("; string_of_query buf quote true q; ")"]
-      | Apply ("not", [v]) -> buffer_concat ["not ("; sb v; ")"]
-      | Apply (("negate" | "negatef"), [v]) -> buffer_concat ["-("; sb v; ")"]
-      | Apply ("&&", [v; w]) -> buffer_concat ["("; sb v; ")"; " and "; "("; sb w; ")"]
-      | Apply ("||", [v; w]) -> buffer_concat ["("; sb v; ")"; " or "; "("; sb w; ")"]
-      | Apply ("==", [v; w]) -> buffer_concat ["("; sb v; ")"; " = "; "("; sb w; ")"]
-      | Apply ("<>", [v; w]) -> buffer_concat ["("; sb v; ")"; " <> "; "("; sb w; ")"]
-      | Apply ("<", [v; w]) -> buffer_concat ["("; sb v; ")"; " < "; "("; sb w; ")"]
-      | Apply (">", [v; w]) -> buffer_concat ["("; sb v; ")"; " > "; "("; sb w; ")"]
-      | Apply ("<=", [v; w]) -> buffer_concat ["("; sb v; ")"; " <= "; "("; sb w; ")"]
-      | Apply (">=", [v; w]) -> buffer_concat ["("; sb v; ")"; " >= "; "("; sb w; ")"]
-      | Apply ("RLIKE", [v; w]) -> buffer_concat ["("; sb v; ")"; " RLIKE "; "("; sb w; ")"]
-      | Apply ("LIKE", [v; w]) -> buffer_concat ["("; sb v; ")"; " LIKE "; "("; sb w; ")"]
-      | Apply (f, args) when SqlFuns.is f -> buffer_concat [SqlFuns.name f; "("; String.concat "," (List.map sb args); ")"]
-      | Apply (f, args) -> buffer_concat [f; "("; String.concat "," (List.map sb args); ")"]
-      | Empty q -> buffer_concat ["not exists ("; string_of_query buf quote true q; ")"]
-      | Length q -> buffer_concat ["select count(*) from ("; string_of_query buf quote true q; ") as "; fresh_dummy_var ()]
-      | RowNumber [] -> "1"
+      | Apply ("not", [Empty q]) -> buf_add "exists ("; string_of_query buf quote true q; buf_add ")"
+      | Apply ("not", [v]) -> buf_add "not ("; sb v; buf_add ")"
+      | Apply (("negate" | "negatef"), [v]) -> buf_add "-("; sb v; buf_add ")"
+      | Apply ("&&", [v; w]) -> buf_add "("; sb v; buf_add ")"; buf_add " and "; buf_add "("; sb w; buf_add ")"
+      | Apply ("||", [v; w]) -> buf_add "("; sb v; buf_add ")"; buf_add " or "; buf_add "("; sb w; buf_add ")"
+      | Apply ("==", [v; w]) -> buf_add "("; sb v; buf_add ")"; buf_add " = "; buf_add "("; sb w; buf_add ")"
+      | Apply ("<>", [v; w]) -> buf_add "("; sb v; buf_add ")"; buf_add " <> "; buf_add "("; sb w; buf_add ")"
+      | Apply ("<", [v; w]) -> buf_add "("; sb v; buf_add ")"; buf_add " < "; buf_add "("; sb w; buf_add ")"
+      | Apply (">", [v; w]) -> buf_add "("; sb v; buf_add ")"; buf_add " > "; buf_add "("; sb w; buf_add ")"
+      | Apply ("<=", [v; w]) -> buf_add "("; sb v; buf_add ")"; buf_add " <= "; buf_add "("; sb w; buf_add ")"
+      | Apply (">=", [v; w]) -> buf_add "("; sb v; buf_add ")"; buf_add " >= "; buf_add "("; sb w; buf_add ")"
+      | Apply ("RLIKE", [v; w]) -> buf_add "("; sb v; buf_add ")"; buf_add " RLIKE "; buf_add "("; sb w; buf_add ")"
+      | Apply ("LIKE", [v; w]) -> buf_add "("; sb v; buf_add ")"; buf_add " LIKE "; buf_add "("; sb w; buf_add ")"
+      | Apply (f, args) when SqlFuns.is f -> buf_add (SqlFuns.name f); buf_add "("; buf_mapstrcat7 buf args; buf_add ")"
+      | Apply (f, args) -> buf_add f; buf_add "("; buf_mapstrcat7 buf args; buf_add ")"
+      | Empty q -> buf_add "not exists ("; string_of_query buf quote true q; buf_add ")"
+      | Length q -> buf_add "select count(*) from ("; string_of_query buf quote true q; buf_add ") as "; buf_add (fresh_dummy_var ())
+      | RowNumber [] -> buf_add "1"
       | RowNumber ps ->
-        buffer_concat ["row_number() over (order by "; String.concat "," (List.map (string_of_projection quote one_table) ps); ")"]
-and string_of_projection quote one_table (var, label) =
-  if one_table then
-    quote label
-  else
-    buffer_concat [string_of_table_var var; "."; (quote label)]
+        buf_add "row_number() over (order by "; buf_add (String.concat "," (List.map (string_of_projection quote one_table) ps)); buf_add ")"
+
 
 let string_of_query ?(range=None) quote q =
   let buf = Buffer.create 0 in
+  let buf_add = Buffer.add_string buf in
   let range =
     match range with
       | None -> ""
       | Some (limit, offset) -> buffer_concat [" limit "; string_of_int limit; " offset "; string_of_int offset]
   in
-    buffer_concat [string_of_query buf quote false q; range]
+    string_of_query buf quote false q; buf_add range

From ebd092a0e3ef739eed7b9b3df48f79b82c24869b Mon Sep 17 00:00:00 2001
From: Emanon42 <EmanonTang@outlook.com>
Date: Wed, 3 Jun 2020 05:42:39 +0100
Subject: [PATCH 03/50] fix sprintf and intermediate string building

---
 core/query/sql.ml | 57 +++++++++++++++++++++++++++--------------------
 1 file changed, 33 insertions(+), 24 deletions(-)

diff --git a/core/query/sql.ml b/core/query/sql.ml
index 6c10ecde7..dccbf5164 100644
--- a/core/query/sql.ml
+++ b/core/query/sql.ml
@@ -148,7 +148,7 @@ let rec string_of_query buf quote ignore_fields q =
   let sq = string_of_query buf quote ignore_fields in
   let sb = string_of_base buf quote false in
   let sbt = string_of_base buf quote true in
-  let buf_mapstrcat buf list = 
+  let buf_mapstrcat list = 
     let load b l = buf_add "("; sb b; buf_add ") as "; buf_add (quote l) in (* string_of_label l) *)
     match list with
       | [] -> ()
@@ -165,12 +165,12 @@ let rec string_of_query buf quote ignore_fields q =
     else
       match fields with
         | [] -> buf_add "0 as \"@unit@\"" (* SQL doesn't support empty records! *)
-        | fields -> buf_mapstrcat buf fields (* string_of_label l) *)
+        | fields -> buf_mapstrcat fields (* string_of_label l) *)
   in
   let string_of_select fields tables condition os =
     let tables = String.concat "," tables in
     let fields = string_of_fields fields in
-    let buf_mapstrcat2 buf list = 
+    let buf_mapstrcat2 list = 
       let load os = sb os in (* string_of_label l) *)
       match list with
         | [] -> ()
@@ -184,7 +184,7 @@ let rec string_of_query buf quote ignore_fields q =
     let orderby =
       match os with
         | [] -> ()
-        | _ ->  buf_add " order by "; buf_mapstrcat2 buf os in
+        | _ ->  buf_add " order by "; buf_mapstrcat2 os in
     let where =
       match condition with
         | Constant (Constant.Bool true) -> ()
@@ -202,7 +202,7 @@ let rec string_of_query buf quote ignore_fields q =
     Printf.sprintf "delete from %s %s" table where *)
   in
   let string_of_update table fields where =
-    let buf_mapstrcat3 buf list = 
+    let buf_mapstrcat3 list = 
       let load k v = buf_add (quote k); buf_add " = "; sbt v in (* string_of_label l) *)
       match list with
         | [] -> ()
@@ -216,7 +216,11 @@ let rec string_of_query buf quote ignore_fields q =
     (* let fields =
       List.map (fun (k, v) -> buf_add (quote k); buf_add " = "; sbt v) fields
       |> String.concat ", " in *)
-    buf_mapstrcat3 buf fields;
+    buf_add "update ";
+    buf_add table;
+    buf_add " set ";
+    buf_mapstrcat3 fields;
+    buf_add " ";
     (* let where = *)
       OptionUtils.opt_app
         (fun x -> buf_add "where ("; sbt x; buf_add ")") () where 
@@ -224,7 +228,7 @@ let rec string_of_query buf quote ignore_fields q =
     Printf.sprintf "update %s set %s %s" table fields where *)
   in
   let string_of_insert table fields values =
-    let buf_mapstrcat4 buf list = 
+    let buf_mapstrcat4 list = 
         let load x = buf_add x in
         match list with
           | [] -> ()
@@ -235,7 +239,7 @@ let rec string_of_query buf quote ignore_fields q =
                 | x -> buf_add ","; load x) 
               xs
     in
-    let buf_mapstrcat5 buf list = 
+    let buf_mapstrcat5 list = 
         let load x = buf_add "("; sbt x; buf_add ")" in
         match list with
           | [] -> ()
@@ -246,23 +250,22 @@ let rec string_of_query buf quote ignore_fields q =
                 | x -> buf_add ","; load x) 
               xs
     in
-    let buf_mapstrcat6 buf list = 
-        let load x = buf_add x in
+    let buf_mapstrcat6 list =
         match list with
           | [] -> ()
-          | [x] ->  buf_mapstrcat5 buf x
+          | [x] ->  buf_mapstrcat5 x
           | x :: xs -> 
-            buf_mapstrcat5 buf x; 
+            buf_mapstrcat5 x; 
             List.iter(function
-                | x -> buf_add ","; buf_mapstrcat5 buf x) 
+                | x -> buf_add ","; buf_mapstrcat5 x) 
               xs
     in
     buf_add "insert into ";
     buf_add table;
     buf_add " (";
-    buf_mapstrcat4 buf fields;
+    buf_mapstrcat4 fields;
     buf_add ") values ";
-    buf_mapstrcat6 buf values;
+    buf_mapstrcat6 values;
     (* let fields = String.concat ", " fields in
     let values =
       values
@@ -278,7 +281,7 @@ let rec string_of_query buf quote ignore_fields q =
       | UnionAll ([], _) -> buf_add "select 42 as \"@unit@\" where false"
       | UnionAll ([q], n) -> sq q; buf_add (order_by_clause n)
       | UnionAll (qs, n) ->
-        let buf_mapstrcat6 buf list = 
+        let buf_mapstrcat7 list = 
             let load x = buf_add "("; sq x; buf_add ")" in
             match list with
               | [] -> ()
@@ -289,7 +292,7 @@ let rec string_of_query buf quote ignore_fields q =
                     | x -> buf_add " union all "; load x) 
                   xs
         in
-        buf_mapstrcat6 buf qs;
+        buf_mapstrcat7 qs;
         buf_add (order_by_clause n)
         (* mapstrcat " union all " (fun q -> buffer_concat ["("; sq q; ")"]) qs ^ order_by_clause n *)
       | Select (fields, [], Constant (Constant.Bool true), _os) ->
@@ -320,7 +323,9 @@ let rec string_of_query buf quote ignore_fields q =
           | Select (fields, tables, condition, os) ->
               (* Inline the query *)
               let tables = List.map (fun (t, x) -> buffer_concat [quote t; " as "; (string_of_table_var x)]) tables in
-              let q = buffer_concat ["("; sq q; ") as "; string_of_table_var z] in
+              let buf2 = Buffer.create 0 in
+              let q2 = string_of_query buf2 quote ignore_fields q; Buffer.contents buf2 in 
+              let q = buffer_concat ["("; q2; ") as "; string_of_table_var z] in
               string_of_select fields (q::tables) condition os
           | _ -> assert false
 
@@ -333,7 +338,7 @@ and string_of_base buf quote one_table b =
   in
   let buf_add = Buffer.add_string buf in
   let sb = string_of_base buf quote one_table in
-  let buf_mapstrcat7 buf list = 
+  let buf_mapstrcat8 list = 
     let load x = sb x in
     match list with
       | [] -> ()
@@ -349,8 +354,12 @@ and string_of_base buf quote one_table b =
           buf_add "case when "; sb c; buf_add " then "; sb t; buf_add " else "; sb e; buf_add " end"
       | Constant c -> buf_add (Constant.to_string c)
       | Project (var, label) -> buf_add (string_of_projection quote one_table (var, label))
-      | Apply (op, [l; r]) when Arithmetic.is op
-          -> Arithmetic.gen (sb l, op, sb r)
+      | Apply (op, [l; r]) when Arithmetic.is op -> 
+        let buf2 = Buffer.create 0 in
+        let buf3 = Buffer.create 0 in
+        let l2 = string_of_base buf2 quote one_table l; Buffer.contents buf2 in
+        let r2 = string_of_base buf3 quote one_table r; Buffer.contents buf3 in
+        buf_add (Arithmetic.gen (l2, op, r2))
       | Apply (("intToString" | "stringToInt" | "intToFloat" | "floatToString"
                 | "stringToFloat"), [v]) -> sb v
       | Apply ("floatToInt", [v]) -> buf_add "floor("; sb v; buf_add ")"
@@ -369,8 +378,8 @@ and string_of_base buf quote one_table b =
       | Apply (">=", [v; w]) -> buf_add "("; sb v; buf_add ")"; buf_add " >= "; buf_add "("; sb w; buf_add ")"
       | Apply ("RLIKE", [v; w]) -> buf_add "("; sb v; buf_add ")"; buf_add " RLIKE "; buf_add "("; sb w; buf_add ")"
       | Apply ("LIKE", [v; w]) -> buf_add "("; sb v; buf_add ")"; buf_add " LIKE "; buf_add "("; sb w; buf_add ")"
-      | Apply (f, args) when SqlFuns.is f -> buf_add (SqlFuns.name f); buf_add "("; buf_mapstrcat7 buf args; buf_add ")"
-      | Apply (f, args) -> buf_add f; buf_add "("; buf_mapstrcat7 buf args; buf_add ")"
+      | Apply (f, args) when SqlFuns.is f -> buf_add (SqlFuns.name f); buf_add "("; buf_mapstrcat8 args; buf_add ")"
+      | Apply (f, args) -> buf_add f; buf_add "("; buf_mapstrcat8 args; buf_add ")"
       | Empty q -> buf_add "not exists ("; string_of_query buf quote true q; buf_add ")"
       | Length q -> buf_add "select count(*) from ("; string_of_query buf quote true q; buf_add ") as "; buf_add (fresh_dummy_var ())
       | RowNumber [] -> buf_add "1"
@@ -386,4 +395,4 @@ let string_of_query ?(range=None) quote q =
       | None -> ""
       | Some (limit, offset) -> buffer_concat [" limit "; string_of_int limit; " offset "; string_of_int offset]
   in
-    string_of_query buf quote false q; buf_add range
+    string_of_query buf quote false q; buf_add range; Buffer.contents buf

From a7adb2caf2e4e9eb5fdbea6a8526bdeb0a94ad81 Mon Sep 17 00:00:00 2001
From: Emanon42 <EmanonTang@outlook.com>
Date: Fri, 5 Jun 2020 22:38:45 +0100
Subject: [PATCH 04/50] better higher-order buf_mapstrcat

---
 core/query/sql.ml | 152 +++++++++-------------------------------------
 1 file changed, 29 insertions(+), 123 deletions(-)

diff --git a/core/query/sql.ml b/core/query/sql.ml
index dccbf5164..219772486 100644
--- a/core/query/sql.ml
+++ b/core/query/sql.ml
@@ -75,6 +75,13 @@ let buffer_concat xs =
   List.iter (Buffer.add_string buf) xs;
   Buffer.contents buf
 
+let rec buf_mapstrcat buf list f sep = 
+  match list with
+    | [] -> ()
+    | [x] -> f x
+    | x :: xs -> 
+      f x; Buffer.add_string buf sep; buf_mapstrcat buf xs f sep
+
 module Arithmetic :
 sig
   val is : string -> bool
@@ -148,157 +155,69 @@ let rec string_of_query buf quote ignore_fields q =
   let sq = string_of_query buf quote ignore_fields in
   let sb = string_of_base buf quote false in
   let sbt = string_of_base buf quote true in
-  let buf_mapstrcat list = 
-    let load b l = buf_add "("; sb b; buf_add ") as "; buf_add (quote l) in (* string_of_label l) *)
-    match list with
-      | [] -> ()
-      | [(b, l)] -> load b l
-      | (b, l) :: xs -> 
-        load b l; 
-        List.iter(function
-            | (b, l) -> buf_add ","; load b l) 
-          xs
-  in
   let string_of_fields fields =
     if ignore_fields then
       buf_add "0 as \"@unit@\"" (* SQL doesn't support empty records! *)
     else
       match fields with
         | [] -> buf_add "0 as \"@unit@\"" (* SQL doesn't support empty records! *)
-        | fields -> buf_mapstrcat fields (* string_of_label l) *)
+        | fields -> buf_mapstrcat buf fields 
+                      (fun (b, l) -> 
+                        buf_add "("; sb b; buf_add ") as "; buf_add (quote l)) (* string_of_label l) *)
+                      "," 
   in
   let string_of_select fields tables condition os =
     let tables = String.concat "," tables in
     let fields = string_of_fields fields in
-    let buf_mapstrcat2 list = 
-      let load os = sb os in (* string_of_label l) *)
-      match list with
-        | [] -> ()
-        | [x] -> load x
-        | x :: xs -> 
-          load x; 
-          List.iter(function
-              | x -> buf_add ","; load x) 
-            xs
-    in
     let orderby =
       match os with
         | [] -> ()
-        | _ ->  buf_add " order by "; buf_mapstrcat2 os in
+        | _ ->  buf_add " order by "; buf_mapstrcat buf os (fun os -> sb os) "," in
     let where =
       match condition with
         | Constant (Constant.Bool true) -> ()
-        | _ ->  buf_add " where ";(* sb condition*)
+        | _ ->  buf_add " where "; (* sb condition*)
     in
        buf_add "select "; fields; buf_add " from "; buf_add tables; where; orderby
   in
   let string_of_delete table where =
-    (* let where = *)
       buf_add "delete from";
       buf_add table;
       OptionUtils.opt_app
-        (fun x ->  buf_add "where ("; sbt x; buf_add ")") () where 
-        (* in
-    Printf.sprintf "delete from %s %s" table where *)
+        (fun x ->  buf_add "where ("; sbt x; buf_add ")") 
+        () 
+        where 
   in
   let string_of_update table fields where =
-    let buf_mapstrcat3 list = 
-      let load k v = buf_add (quote k); buf_add " = "; sbt v in (* string_of_label l) *)
-      match list with
-        | [] -> ()
-        | [(k, v)] -> load k v
-        | (k, v) :: xs -> 
-          load k v; 
-          List.iter(function
-              | (k, v) -> buf_add ","; load k v) 
-            xs
-    in
-    (* let fields =
-      List.map (fun (k, v) -> buf_add (quote k); buf_add " = "; sbt v) fields
-      |> String.concat ", " in *)
     buf_add "update ";
     buf_add table;
     buf_add " set ";
-    buf_mapstrcat3 fields;
+    buf_mapstrcat buf fields (fun (k, v) -> buf_add (quote k); buf_add " = "; sbt v) ",";
     buf_add " ";
-    (* let where = *)
-      OptionUtils.opt_app
-        (fun x -> buf_add "where ("; sbt x; buf_add ")") () where 
-        (* in
-    Printf.sprintf "update %s set %s %s" table fields where *)
+    OptionUtils.opt_app
+      (fun x -> buf_add "where ("; sbt x; buf_add ")") 
+      () 
+      where 
   in
   let string_of_insert table fields values =
-    let buf_mapstrcat4 list = 
-        let load x = buf_add x in
-        match list with
-          | [] -> ()
-          | [x] -> load x
-          | x :: xs -> 
-            load x; 
-            List.iter(function
-                | x -> buf_add ","; load x) 
-              xs
-    in
-    let buf_mapstrcat5 list = 
-        let load x = buf_add "("; sbt x; buf_add ")" in
-        match list with
-          | [] -> ()
-          | [x] -> load x
-          | x :: xs -> 
-            load x; 
-            List.iter(function
-                | x -> buf_add ","; load x) 
-              xs
-    in
-    let buf_mapstrcat6 list =
-        match list with
-          | [] -> ()
-          | [x] ->  buf_mapstrcat5 x
-          | x :: xs -> 
-            buf_mapstrcat5 x; 
-            List.iter(function
-                | x -> buf_add ","; buf_mapstrcat5 x) 
-              xs
-    in
     buf_add "insert into ";
     buf_add table;
     buf_add " (";
-    buf_mapstrcat4 fields;
+    buf_mapstrcat buf fields (fun x -> buf_add x) ",";
     buf_add ") values ";
-    buf_mapstrcat6 values;
-    (* let fields = String.concat ", " fields in
-    let values =
-      values
-      (* Concatenate and bracket the values in each row *)
-      |> List.map ((List.map sbt) ->- String.concat ", " ->- Printf.sprintf "(%s)")
-      (* String.concat ", " (sprintf "(%s)" (String.concat ", " （List.map sbt))) values *)
-      (* Join all rows *)
-      |> String.concat ", " in
-    Printf.sprintf "insert into %s (%s) values %s"
-      table fields values *)
+    buf_mapstrcat buf values 
+      (fun list -> 
+        buf_mapstrcat buf list (fun x -> buf_add "("; sbt x; buf_add ")") ",") 
+      ",";
   in
     match q with
       | UnionAll ([], _) -> buf_add "select 42 as \"@unit@\" where false"
       | UnionAll ([q], n) -> sq q; buf_add (order_by_clause n)
       | UnionAll (qs, n) ->
-        let buf_mapstrcat7 list = 
-            let load x = buf_add "("; sq x; buf_add ")" in
-            match list with
-              | [] -> ()
-              | [x] -> load x
-              | x :: xs -> 
-                load x; 
-                List.iter(function
-                    | x -> buf_add " union all "; load x) 
-                  xs
-        in
-        buf_mapstrcat7 qs;
+        buf_mapstrcat buf qs (fun x -> buf_add "("; sq x; buf_add ")") " union all ";
         buf_add (order_by_clause n)
-        (* mapstrcat " union all " (fun q -> buffer_concat ["("; sq q; ")"]) qs ^ order_by_clause n *)
       | Select (fields, [], Constant (Constant.Bool true), _os) ->
           buf_add "select "; string_of_fields fields
-          (* let fields = string_of_fields fields in
-            buffer_concat ["select "; fields] *)
       | Select (fields, [], condition, _os) ->
           buf_add "select * from (select ";
           string_of_fields fields;
@@ -306,8 +225,6 @@ let rec string_of_query buf quote ignore_fields q =
           buf_add (fresh_dummy_var ());
           buf_add " where ";
           sb condition;
-          (* let fields = string_of_fields fields in
-            buffer_concat ["select * from (select "; fields; ") as "; fresh_dummy_var (); " where "; sb condition] *)
       | Select (fields, tables, condition, os) ->
           (* using quote_field assumes tables contains table names (not nested queries) *)
           let tables = List.map (fun (t, x) -> buffer_concat [quote t; " as "; (string_of_table_var x)]) tables
@@ -338,17 +255,6 @@ and string_of_base buf quote one_table b =
   in
   let buf_add = Buffer.add_string buf in
   let sb = string_of_base buf quote one_table in
-  let buf_mapstrcat8 list = 
-    let load x = sb x in
-    match list with
-      | [] -> ()
-      | [x] -> load x
-      | x :: xs -> 
-        load x; 
-        List.iter(function
-            | x -> buf_add ","; load x) 
-          xs
-  in
     match b with
       | Case (c, t, e) ->
           buf_add "case when "; sb c; buf_add " then "; sb t; buf_add " else "; sb e; buf_add " end"
@@ -378,8 +284,8 @@ and string_of_base buf quote one_table b =
       | Apply (">=", [v; w]) -> buf_add "("; sb v; buf_add ")"; buf_add " >= "; buf_add "("; sb w; buf_add ")"
       | Apply ("RLIKE", [v; w]) -> buf_add "("; sb v; buf_add ")"; buf_add " RLIKE "; buf_add "("; sb w; buf_add ")"
       | Apply ("LIKE", [v; w]) -> buf_add "("; sb v; buf_add ")"; buf_add " LIKE "; buf_add "("; sb w; buf_add ")"
-      | Apply (f, args) when SqlFuns.is f -> buf_add (SqlFuns.name f); buf_add "("; buf_mapstrcat8 args; buf_add ")"
-      | Apply (f, args) -> buf_add f; buf_add "("; buf_mapstrcat8 args; buf_add ")"
+      | Apply (f, args) when SqlFuns.is f -> buf_add (SqlFuns.name f); buf_add "("; buf_mapstrcat buf args (fun x -> sb x) ","; buf_add ")"
+      | Apply (f, args) -> buf_add f; buf_add "("; buf_mapstrcat buf args (fun x -> sb x) ","; buf_add ")"
       | Empty q -> buf_add "not exists ("; string_of_query buf quote true q; buf_add ")"
       | Length q -> buf_add "select count(*) from ("; string_of_query buf quote true q; buf_add ") as "; buf_add (fresh_dummy_var ())
       | RowNumber [] -> buf_add "1"

From c5e90d2d57b5958dd069c8db59233da2013870ca Mon Sep 17 00:00:00 2001
From: Emanon42 <EmanonTang@outlook.com>
Date: Mon, 8 Jun 2020 11:48:00 +0100
Subject: [PATCH 05/50] add wrappers

---
 core/query/sql.ml | 12 +++++++++++-
 1 file changed, 11 insertions(+), 1 deletion(-)

diff --git a/core/query/sql.ml b/core/query/sql.ml
index 219772486..e7e881a2f 100644
--- a/core/query/sql.ml
+++ b/core/query/sql.ml
@@ -199,7 +199,7 @@ let rec string_of_query buf quote ignore_fields q =
       () 
       where 
   in
-  let string_of_insert table fields values =
+  let string_of_insert table fields values = 
     buf_add "insert into ";
     buf_add table;
     buf_add " (";
@@ -292,6 +292,16 @@ and string_of_base buf quote one_table b =
       | RowNumber ps ->
         buf_add "row_number() over (order by "; buf_add (String.concat "," (List.map (string_of_projection quote one_table) ps)); buf_add ")"
 
+(* let string_of_insert table fields values =
+  let buf = Buffer.create 0 in
+  let buf_add = Buffer.add_string buf in
+  string_of_insert buf table fields values;
+  Buffer.contents buf *)
+
+let string_of_base quote one_table b = 
+  let buf = Buffer.create 0 in
+  string_of_base buf quote one_table b; Buffer.contents buf
+
 
 let string_of_query ?(range=None) quote q =
   let buf = Buffer.create 0 in

From 665b9ee7c26cd68bef876625a0302d06a54d2b42 Mon Sep 17 00:00:00 2001
From: Emanon42 <EmanonTang@outlook.com>
Date: Mon, 8 Jun 2020 13:14:50 +0100
Subject: [PATCH 06/50] fix wrong side-effect execute order

---
 core/query/sql.ml | 11 +++++------
 1 file changed, 5 insertions(+), 6 deletions(-)

diff --git a/core/query/sql.ml b/core/query/sql.ml
index e7e881a2f..8c04b383f 100644
--- a/core/query/sql.ml
+++ b/core/query/sql.ml
@@ -168,20 +168,19 @@ let rec string_of_query buf quote ignore_fields q =
   in
   let string_of_select fields tables condition os =
     let tables = String.concat "," tables in
-    let fields = string_of_fields fields in
-    let orderby =
+    let orderby = fun () ->
       match os with
         | [] -> ()
         | _ ->  buf_add " order by "; buf_mapstrcat buf os (fun os -> sb os) "," in
-    let where =
+    let where = fun () ->
       match condition with
         | Constant (Constant.Bool true) -> ()
-        | _ ->  buf_add " where "; (* sb condition*)
+        | _ ->  buf_add " where "; sb condition
     in
-       buf_add "select "; fields; buf_add " from "; buf_add tables; where; orderby
+       buf_add "select "; string_of_fields fields; buf_add " from "; buf_add tables; where (); orderby ()
   in
   let string_of_delete table where =
-      buf_add "delete from";
+      buf_add "delete from ";
       buf_add table;
       OptionUtils.opt_app
         (fun x ->  buf_add "where ("; sbt x; buf_add ")") 

From 3e6a25f9921b4c42c6eb13e2629814137f705d61 Mon Sep 17 00:00:00 2001
From: Emanon42 <EmanonTang@outlook.com>
Date: Mon, 8 Jun 2020 13:21:42 +0100
Subject: [PATCH 07/50] sweep the code

---
 core/query/sql.ml | 13 +++----------
 1 file changed, 3 insertions(+), 10 deletions(-)

diff --git a/core/query/sql.ml b/core/query/sql.ml
index 8c04b383f..44e9280c0 100644
--- a/core/query/sql.ml
+++ b/core/query/sql.ml
@@ -163,16 +163,16 @@ let rec string_of_query buf quote ignore_fields q =
         | [] -> buf_add "0 as \"@unit@\"" (* SQL doesn't support empty records! *)
         | fields -> buf_mapstrcat buf fields 
                       (fun (b, l) -> 
-                        buf_add "("; sb b; buf_add ") as "; buf_add (quote l)) (* string_of_label l) *)
+                        buf_add "("; sb b; buf_add ") as "; buf_add (quote l))
                       "," 
   in
   let string_of_select fields tables condition os =
     let tables = String.concat "," tables in
-    let orderby = fun () ->
+    let orderby = fun () -> (* thunking:  delay the side effect*)
       match os with
         | [] -> ()
         | _ ->  buf_add " order by "; buf_mapstrcat buf os (fun os -> sb os) "," in
-    let where = fun () ->
+    let where = fun () -> (* thunking:  delay the side effect*)
       match condition with
         | Constant (Constant.Bool true) -> ()
         | _ ->  buf_add " where "; sb condition
@@ -291,17 +291,10 @@ and string_of_base buf quote one_table b =
       | RowNumber ps ->
         buf_add "row_number() over (order by "; buf_add (String.concat "," (List.map (string_of_projection quote one_table) ps)); buf_add ")"
 
-(* let string_of_insert table fields values =
-  let buf = Buffer.create 0 in
-  let buf_add = Buffer.add_string buf in
-  string_of_insert buf table fields values;
-  Buffer.contents buf *)
-
 let string_of_base quote one_table b = 
   let buf = Buffer.create 0 in
   string_of_base buf quote one_table b; Buffer.contents buf
 
-
 let string_of_query ?(range=None) quote q =
   let buf = Buffer.create 0 in
   let buf_add = Buffer.add_string buf in

From 89bcdae79d2d83b90eb3724911e1d6996b86fc4e Mon Sep 17 00:00:00 2001
From: Emanon42 <EmanonTang@outlook.com>
Date: Mon, 8 Jun 2020 14:00:08 +0100
Subject: [PATCH 08/50] trim the trailing whitespace

---
 core/query/sql.ml | 36 ++++++++++++++++++------------------
 1 file changed, 18 insertions(+), 18 deletions(-)

diff --git a/core/query/sql.ml b/core/query/sql.ml
index 44e9280c0..77beeb842 100644
--- a/core/query/sql.ml
+++ b/core/query/sql.ml
@@ -75,11 +75,11 @@ let buffer_concat xs =
   List.iter (Buffer.add_string buf) xs;
   Buffer.contents buf
 
-let rec buf_mapstrcat buf list f sep = 
+let rec buf_mapstrcat buf list f sep =
   match list with
     | [] -> ()
     | [x] -> f x
-    | x :: xs -> 
+    | x :: xs ->
       f x; Buffer.add_string buf sep; buf_mapstrcat buf xs f sep
 
 module Arithmetic :
@@ -161,10 +161,10 @@ let rec string_of_query buf quote ignore_fields q =
     else
       match fields with
         | [] -> buf_add "0 as \"@unit@\"" (* SQL doesn't support empty records! *)
-        | fields -> buf_mapstrcat buf fields 
-                      (fun (b, l) -> 
+        | fields -> buf_mapstrcat buf fields
+                      (fun (b, l) ->
                         buf_add "("; sb b; buf_add ") as "; buf_add (quote l))
-                      "," 
+                      ","
   in
   let string_of_select fields tables condition os =
     let tables = String.concat "," tables in
@@ -183,9 +183,9 @@ let rec string_of_query buf quote ignore_fields q =
       buf_add "delete from ";
       buf_add table;
       OptionUtils.opt_app
-        (fun x ->  buf_add "where ("; sbt x; buf_add ")") 
-        () 
-        where 
+        (fun x ->  buf_add "where ("; sbt x; buf_add ")")
+        ()
+        where
   in
   let string_of_update table fields where =
     buf_add "update ";
@@ -194,19 +194,19 @@ let rec string_of_query buf quote ignore_fields q =
     buf_mapstrcat buf fields (fun (k, v) -> buf_add (quote k); buf_add " = "; sbt v) ",";
     buf_add " ";
     OptionUtils.opt_app
-      (fun x -> buf_add "where ("; sbt x; buf_add ")") 
-      () 
-      where 
+      (fun x -> buf_add "where ("; sbt x; buf_add ")")
+      ()
+      where
   in
-  let string_of_insert table fields values = 
+  let string_of_insert table fields values =
     buf_add "insert into ";
     buf_add table;
     buf_add " (";
     buf_mapstrcat buf fields (fun x -> buf_add x) ",";
     buf_add ") values ";
-    buf_mapstrcat buf values 
-      (fun list -> 
-        buf_mapstrcat buf list (fun x -> buf_add "("; sbt x; buf_add ")") ",") 
+    buf_mapstrcat buf values
+      (fun list ->
+        buf_mapstrcat buf list (fun x -> buf_add "("; sbt x; buf_add ")") ",")
       ",";
   in
     match q with
@@ -240,7 +240,7 @@ let rec string_of_query buf quote ignore_fields q =
               (* Inline the query *)
               let tables = List.map (fun (t, x) -> buffer_concat [quote t; " as "; (string_of_table_var x)]) tables in
               let buf2 = Buffer.create 0 in
-              let q2 = string_of_query buf2 quote ignore_fields q; Buffer.contents buf2 in 
+              let q2 = string_of_query buf2 quote ignore_fields q; Buffer.contents buf2 in
               let q = buffer_concat ["("; q2; ") as "; string_of_table_var z] in
               string_of_select fields (q::tables) condition os
           | _ -> assert false
@@ -259,7 +259,7 @@ and string_of_base buf quote one_table b =
           buf_add "case when "; sb c; buf_add " then "; sb t; buf_add " else "; sb e; buf_add " end"
       | Constant c -> buf_add (Constant.to_string c)
       | Project (var, label) -> buf_add (string_of_projection quote one_table (var, label))
-      | Apply (op, [l; r]) when Arithmetic.is op -> 
+      | Apply (op, [l; r]) when Arithmetic.is op ->
         let buf2 = Buffer.create 0 in
         let buf3 = Buffer.create 0 in
         let l2 = string_of_base buf2 quote one_table l; Buffer.contents buf2 in
@@ -291,7 +291,7 @@ and string_of_base buf quote one_table b =
       | RowNumber ps ->
         buf_add "row_number() over (order by "; buf_add (String.concat "," (List.map (string_of_projection quote one_table) ps)); buf_add ")"
 
-let string_of_base quote one_table b = 
+let string_of_base quote one_table b =
   let buf = Buffer.create 0 in
   string_of_base buf quote one_table b; Buffer.contents buf
 

From 6a6aa27e997e82ce4387618b482af6aeac84ca80 Mon Sep 17 00:00:00 2001
From: Emanon42 <EmanonTang@outlook.com>
Date: Fri, 19 Jun 2020 16:27:01 +0100
Subject: [PATCH 09/50] Fix #154 by raising runtime error

---
 core/evalir.ml    |  3 ++-
 core/utility.ml   | 10 ++++++++++
 core/webif.ml     | 17 +++--------------
 core/webif.mli    |  1 -
 core/webserver.ml |  2 +-
 5 files changed, 16 insertions(+), 17 deletions(-)

diff --git a/core/evalir.ml b/core/evalir.ml
index 96bf87dda..50ff2eca6 100644
--- a/core/evalir.ml
+++ b/core/evalir.ml
@@ -126,8 +126,9 @@ struct
      Value.continuation ->
      Value.t list ->
      result =
-
        fun req_data name cont args ->
+         if not(Utility.is_ajax_call(RequestData.get_cgi_parameters req_data)) then
+           raise (Errors.RuntimeError "Tried to make a client call on the server.");
          if not(Settings.get Basicsettings.web_mode) then
            raise (Errors.client_call_outside_webmode name);
          (*if not(Proc.singlethreaded()) then
diff --git a/core/utility.ml b/core/utility.ml
index 0b86855fe..a032a1bf3 100644
--- a/core/utility.ml
+++ b/core/utility.ml
@@ -1459,4 +1459,14 @@ struct
         Lwt.return (x :: xs)
 end
 
+(** remote client->server call *)
+let is_remote_call params =
+  List.mem_assoc "__name" params && List.mem_assoc "__args" params
+
+(** return __result from server->client call with server continuation __continuation *)
+let is_client_return params =
+  List.mem_assoc "__continuation" params && List.mem_assoc "__result" params
+
+let is_ajax_call cgi_args =
+  (is_remote_call cgi_args) || (is_client_return cgi_args)
 
diff --git a/core/webif.ml b/core/webif.ml
index b5ed59da2..f3c8de7fd 100644
--- a/core/webif.ml
+++ b/core/webif.ml
@@ -44,14 +44,6 @@ struct
 
   (** Boolean tests for cgi parameters *)
 
-  (** remote client->server call *)
-  let is_remote_call params =
-    mem_assoc "__name" params && mem_assoc "__args" params
-
-  (** return __result from server->client call with server continuation __continuation *)
-  let is_client_return params =
-    mem_assoc "__continuation" params && mem_assoc "__result" params
-
   (** invoke server continuation _k
       (e.g. from a hypertext link or a formlet post)
    *)
@@ -88,14 +80,11 @@ struct
       body ^
       "\n  </body></html>\n"
 
-  let is_ajax_call cgi_args =
-    (is_remote_call cgi_args) || (is_client_return cgi_args)
-
   (* jcheney: lifted from serve_request, to de-clutter *)
   let parse_request env cgi_args  =
-    if      (is_remote_call cgi_args)
+    if      (Utility.is_remote_call cgi_args)
     then parse_remote_call env cgi_args
-    else if (is_client_return cgi_args)
+    else if (Utility.is_client_return cgi_args)
     then parse_client_return env cgi_args
     else if (is_server_cont cgi_args)
     then parse_server_cont env cgi_args
@@ -188,7 +177,7 @@ struct
            Lwt.return (mime_type, error_page (Errors.format_exception_html exc)) in
 
     let handle_error e =
-      if (is_ajax_call cgi_args) then
+      if (Utility.is_ajax_call cgi_args) then
         handle_ajax_error e
       else
         handle_html_error e in
diff --git a/core/webif.mli b/core/webif.mli
index 41c53757c..c95b2ed06 100644
--- a/core/webif.mli
+++ b/core/webif.mli
@@ -5,7 +5,6 @@ open Webserver_types
 module WebIf : functor (Webs : WEBSERVER) ->
 sig
 
-  val is_ajax_call : (string * string) list -> bool
 
   val do_request :
     (Value.env * Ir.var Env.String.t * Types.typing_environment) ->
diff --git a/core/webserver.ml b/core/webserver.ml
index 570362509..9105e854f 100644
--- a/core/webserver.ml
+++ b/core/webserver.ml
@@ -162,7 +162,7 @@ struct
 
 
   let get_or_make_client_id cgi_args =
-    if (Webif.is_ajax_call cgi_args) then
+    if (Utility.is_ajax_call cgi_args) then
       get_client_id_or_die cgi_args
     else
       ClientID.create ()

From 01a3b4f0d50710bc2ad0b76d83c66f1c165c9e60 Mon Sep 17 00:00:00 2001
From: Emanon42 <EmanonTang@outlook.com>
Date: Thu, 2 Jul 2020 03:37:49 +0100
Subject: [PATCH 10/50] move to Format module

---
 core/query/sql.ml | 265 ++++++++++++++++++++++++++--------------------
 1 file changed, 152 insertions(+), 113 deletions(-)

diff --git a/core/query/sql.ml b/core/query/sql.ml
index 77beeb842..4041a768f 100644
--- a/core/query/sql.ml
+++ b/core/query/sql.ml
@@ -150,102 +150,123 @@ let order_by_clause n =
    returned. This allows these operators to take lists that have any
    element type at all. *)
 
-let rec string_of_query buf quote ignore_fields q =
+let rec pr_query ppf buf quote ignore_fields q =
   let buf_add = Buffer.add_string buf in
-  let sq = string_of_query buf quote ignore_fields in
-  let sb = string_of_base buf quote false in
-  let sbt = string_of_base buf quote true in
-  let string_of_fields fields =
+  let pp_constant ppf s = Format.fprintf ppf "%s" s in
+  let pp_comma ppf () = Format.fprintf ppf "," in
+  let pp_quote ppf q = Format.fprintf ppf "%s" (quote q) in
+
+  let pr_q ppf q = pr_query ppf buf quote ignore_fields q in
+  let pr_b ppf q = pr_base ppf buf quote false q in
+  let pr_b_ignore_fields ppf q = pr_base ppf buf quote true q in
+
+  (*TODO: maybe add a template pair/option/list printer func? *)
+  (*TODO: or single term with/without bracket template printer func *)
+  let pr_fields ppf fields =
+    let pp_field ppf (b, l) = Format.fprintf ppf "(%a) as %a" pr_b b pp_quote l in (*MARK: can be template-pair *)
     if ignore_fields then
-      buf_add "0 as \"@unit@\"" (* SQL doesn't support empty records! *)
+      Format.fprintf ppf "%a" pp_constant "0 as \"@unit@\"" (* SQL doesn't support empty records! *)
     else
       match fields with
-        | [] -> buf_add "0 as \"@unit@\"" (* SQL doesn't support empty records! *)
-        | fields -> buf_mapstrcat buf fields
-                      (fun (b, l) ->
-                        buf_add "("; sb b; buf_add ") as "; buf_add (quote l))
-                      ","
+        | [] -> Format.fprintf ppf "%a" pp_constant "0 as \"@unit@\"" (* SQL doesn't support empty records! *)
+        | fields -> Format.fprintf ppf "%a" (Format.pp_print_list ~pp_sep:pp_comma pp_field) fields
   in
-  let string_of_select fields tables condition os =
-    let tables = String.concat "," tables in
-    let orderby = fun () -> (* thunking:  delay the side effect*)
+
+  let pr_select ppf fields tables condition os =
+    let pp_tables ppf tables = Format.fprintf ppf "%a" (Format.pp_print_list ~pp_sep:pp_comma Format.pp_print_string) tables in (*MARK: can be template-list *)
+    let pp_os_condition ppf a = Format.fprintf ppf "%a" pr_b a in
+    let pp_orderby ppf os = 
       match os with
         | [] -> ()
-        | _ ->  buf_add " order by "; buf_mapstrcat buf os (fun os -> sb os) "," in
-    let where = fun () -> (* thunking:  delay the side effect*)
+        | _ -> Format.fprintf ppf " order by %a" (Format.pp_print_list ~pp_sep:pp_comma pp_os_condition) os in
+    let pp_where ppf condition = 
       match condition with
         | Constant (Constant.Bool true) -> ()
-        | _ ->  buf_add " where "; sb condition
-    in
-       buf_add "select "; string_of_fields fields; buf_add " from "; buf_add tables; where (); orderby ()
+        | _ -> Format.fprintf ppf " where %a" pp_os_condition condition in
+
+    Format.fprintf ppf "select %a from %a%a%a" 
+      pr_fields fields
+      pp_tables tables
+      pp_where condition
+      pp_orderby os
   in
-  let string_of_delete table where =
-      buf_add "delete from ";
-      buf_add table;
-      OptionUtils.opt_app
-        (fun x ->  buf_add "where ("; sbt x; buf_add ")")
-        ()
-        where
+
+  let pr_delete ppf table where =
+    let pp_where ppf where = 
+      match where with
+        | None -> ()
+        | Some x -> Format.fprintf ppf "where (%a)" pr_b_ignore_fields x in (*MARK: can be template-option *)
+
+    Format.fprintf ppf "delete from %a%a"
+      pp_constant table
+      pp_where where
   in
-  let string_of_update table fields where =
-    buf_add "update ";
-    buf_add table;
-    buf_add " set ";
-    buf_mapstrcat buf fields (fun (k, v) -> buf_add (quote k); buf_add " = "; sbt v) ",";
-    buf_add " ";
-    OptionUtils.opt_app
-      (fun x -> buf_add "where ("; sbt x; buf_add ")")
-      ()
-      where
+  let pr_update ppf table fields where =
+    let pp_field ppf (k, v) = Format.fprintf ppf "%a = %a" pp_quote k pr_b_ignore_fields v in (*MARK: can be template-pair *)
+    let pp_fields ppf fields = Format.fprintf ppf "%a" (Format.pp_print_list ~pp_sep:pp_comma pp_field) fields in (*MARK: can be template-list *)
+    let pp_where ppf where = 
+      match where with
+        | None -> ()
+        | Some x -> Format.fprintf ppf "where (%a)" pr_b_ignore_fields x in (*MARK: can be template-option *)
+    
+    Format.fprintf ppf "update %a set %a %a"
+      pp_constant table
+      pp_fields fields
+      pp_where where
   in
-  let string_of_insert table fields values =
-    buf_add "insert into ";
-    buf_add table;
-    buf_add " (";
-    buf_mapstrcat buf fields (fun x -> buf_add x) ",";
-    buf_add ") values ";
-    buf_mapstrcat buf values
-      (fun list ->
-        buf_mapstrcat buf list (fun x -> buf_add "("; sbt x; buf_add ")") ",")
-      ",";
+  let pr_insert ppf table fields values =
+    let pp_fields ppf fields = Format.fprintf ppf "%a" (Format.pp_print_list ~pp_sep:pp_comma Format.pp_print_string) fields in (*MARK: can be template-list *)
+    let pp_value ppf x = Format.fprintf ppf "(%a)" (Format.pp_print_list ~pp_sep:pp_comma pr_b_ignore_fields) x in
+    let pp_values ppf values = Format.fprintf ppf "%a" (Format.pp_print_list ~pp_sep:pp_comma pp_value) values in (*MARK: can be template-list *)
+    
+    Format.fprintf ppf "insert into %a (%a) values %a"
+      pp_constant table
+      pp_fields fields
+      pp_values values
   in
-    match q with
-      | UnionAll ([], _) -> buf_add "select 42 as \"@unit@\" where false"
-      | UnionAll ([q], n) -> sq q; buf_add (order_by_clause n)
-      | UnionAll (qs, n) ->
-        buf_mapstrcat buf qs (fun x -> buf_add "("; sq x; buf_add ")") " union all ";
-        buf_add (order_by_clause n)
-      | Select (fields, [], Constant (Constant.Bool true), _os) ->
-          buf_add "select "; string_of_fields fields
-      | Select (fields, [], condition, _os) ->
-          buf_add "select * from (select ";
-          string_of_fields fields;
-          buf_add ") as ";
-          buf_add (fresh_dummy_var ());
-          buf_add " where ";
-          sb condition;
-      | Select (fields, tables, condition, os) ->
-          (* using quote_field assumes tables contains table names (not nested queries) *)
-          let tables = List.map (fun (t, x) -> buffer_concat [quote t; " as "; (string_of_table_var x)]) tables
-          in string_of_select fields tables condition os
-      | Delete { del_table; del_where } ->
-          string_of_delete del_table del_where
-      | Update { upd_table; upd_fields; upd_where } ->
-          string_of_update upd_table upd_fields upd_where
-      | Insert { ins_table; ins_fields; ins_records } ->
-          string_of_insert ins_table ins_fields ins_records
-      | With (_, q, z, q') ->
-          match q' with
-          | Select (fields, tables, condition, os) ->
-              (* Inline the query *)
-              let tables = List.map (fun (t, x) -> buffer_concat [quote t; " as "; (string_of_table_var x)]) tables in
-              let buf2 = Buffer.create 0 in
-              let q2 = string_of_query buf2 quote ignore_fields q; Buffer.contents buf2 in
-              let q = buffer_concat ["("; q2; ") as "; string_of_table_var z] in
-              string_of_select fields (q::tables) condition os
-          | _ -> assert false
+  match q with
+    | UnionAll ([], _) -> Format.fprintf ppf "%a" pp_constant "select 42 as \"@unit@\" where false"
+    | UnionAll ([q], n) -> Format.fprintf ppf "%a%a" pr_q q pp_constant (order_by_clause n)
+    | UnionAll (qs, n) ->
+      let pp_sep_union ppf () = Format.fprintf ppf " union all " in
+      let pp_value ppf x = Format.fprintf ppf "(%a)" pr_q x in
+      let pp_values ppf values = Format.fprintf ppf "%a" (Format.pp_print_list ~pp_sep:pp_sep_union pp_value) values in (*MARK: can be template-list *)
+      Format.fprintf ppf "%a%a" 
+        pp_values qs 
+        pp_constant (order_by_clause n)
+    | Select (fields, [], Constant (Constant.Bool true), _os) ->
+      Format.fprintf ppf "select %a" pr_fields fields
+    | Select (fields, [], condition, _os) ->
+      Format.fprintf ppf "select * from (select %a) as %a where %a"
+        pr_fields fields
+        pp_constant (fresh_dummy_var ())
+        pr_b condition
+    | Select (fields, tables, condition, os) ->
+        (* using quote_field assumes tables contains table names (not nested queries) *)
+        let tables = List.map (fun (t, x) -> buffer_concat [quote t; " as "; (string_of_table_var x)]) tables in 
+        pr_select ppf fields tables condition os
+    | Delete { del_table; del_where } ->
+        pr_delete ppf del_table del_where
+    | Update { upd_table; upd_fields; upd_where } ->
+        pr_update ppf upd_table upd_fields upd_where
+    | Insert { ins_table; ins_fields; ins_records } ->
+        pr_insert ppf ins_table ins_fields ins_records
+    | With (_, q, z, q') ->
+        match q' with
+        | Select (fields, tables, condition, os) ->
+            (* Inline the query *)
+            let tables = List.map (fun (t, x) -> buffer_concat [quote t; " as "; (string_of_table_var x)]) tables in
+            let buf2 = Buffer.create 0 in
+            let ppf2 = Format.formatter_of_buffer buf2 in
+            let q2 = pr_query ppf2 buf2 quote ignore_fields q; Format.pp_print_flush ppf2 (); Buffer.contents buf2 in
+            let q = buffer_concat ["("; q2; ") as "; string_of_table_var z] in
+            pr_select ppf fields (q::tables) condition os
+        | _ -> assert false
 
-and string_of_base buf quote one_table b =
+and pr_base ppf buf quote one_table b =
+  let pp_constant ppf s = Format.fprintf ppf "%s" s in
+  let pp_comma ppf () = Format.fprintf ppf "," in
+  let pp_quote ppf q = Format.fprintf ppf "%s" (quote q) in
   let string_of_projection quote one_table (var, label) =
   if one_table then
     quote label
@@ -253,54 +274,72 @@ and string_of_base buf quote one_table b =
     buffer_concat [string_of_table_var var; "."; (quote label)]
   in
   let buf_add = Buffer.add_string buf in
-  let sb = string_of_base buf quote one_table in
+  let pr_b ppf b = pr_base ppf buf quote one_table b in
+  let pr_q ppf q = pr_query ppf buf quote true q in
     match b with
       | Case (c, t, e) ->
-          buf_add "case when "; sb c; buf_add " then "; sb t; buf_add " else "; sb e; buf_add " end"
-      | Constant c -> buf_add (Constant.to_string c)
-      | Project (var, label) -> buf_add (string_of_projection quote one_table (var, label))
+        Format.fprintf ppf "case when %a then %a else %a end"
+          pr_b c
+          pr_b t
+          pr_b e
+      | Constant c -> Format.fprintf ppf "%a" pp_constant (Constant.to_string c)
+      | Project (var, label) -> Format.fprintf ppf "%a" pp_constant (string_of_projection quote one_table (var, label))
       | Apply (op, [l; r]) when Arithmetic.is op ->
         let buf2 = Buffer.create 0 in
+        let ppf2 = Format.formatter_of_buffer buf2 in
         let buf3 = Buffer.create 0 in
-        let l2 = string_of_base buf2 quote one_table l; Buffer.contents buf2 in
-        let r2 = string_of_base buf3 quote one_table r; Buffer.contents buf3 in
-        buf_add (Arithmetic.gen (l2, op, r2))
+        let ppf3 = Format.formatter_of_buffer buf3 in
+        let l2 = pr_base ppf2 buf2 quote one_table l; Format.pp_print_flush ppf2 (); Buffer.contents buf2 in
+        let r2 = pr_base ppf3 buf3 quote one_table r; Format.pp_print_flush ppf3 (); Buffer.contents buf3 in
+        Format.fprintf ppf "%a" pp_constant (Arithmetic.gen (l2, op, r2))
       | Apply (("intToString" | "stringToInt" | "intToFloat" | "floatToString"
-                | "stringToFloat"), [v]) -> sb v
-      | Apply ("floatToInt", [v]) -> buf_add "floor("; sb v; buf_add ")"
+                | "stringToFloat"), [v]) -> Format.fprintf ppf "%a" pr_b v
+      | Apply ("floatToInt", [v]) -> Format.fprintf ppf "floor(%a)" pr_b v
 
       (* optimisation *)
-      | Apply ("not", [Empty q]) -> buf_add "exists ("; string_of_query buf quote true q; buf_add ")"
-      | Apply ("not", [v]) -> buf_add "not ("; sb v; buf_add ")"
-      | Apply (("negate" | "negatef"), [v]) -> buf_add "-("; sb v; buf_add ")"
-      | Apply ("&&", [v; w]) -> buf_add "("; sb v; buf_add ")"; buf_add " and "; buf_add "("; sb w; buf_add ")"
-      | Apply ("||", [v; w]) -> buf_add "("; sb v; buf_add ")"; buf_add " or "; buf_add "("; sb w; buf_add ")"
-      | Apply ("==", [v; w]) -> buf_add "("; sb v; buf_add ")"; buf_add " = "; buf_add "("; sb w; buf_add ")"
-      | Apply ("<>", [v; w]) -> buf_add "("; sb v; buf_add ")"; buf_add " <> "; buf_add "("; sb w; buf_add ")"
-      | Apply ("<", [v; w]) -> buf_add "("; sb v; buf_add ")"; buf_add " < "; buf_add "("; sb w; buf_add ")"
-      | Apply (">", [v; w]) -> buf_add "("; sb v; buf_add ")"; buf_add " > "; buf_add "("; sb w; buf_add ")"
-      | Apply ("<=", [v; w]) -> buf_add "("; sb v; buf_add ")"; buf_add " <= "; buf_add "("; sb w; buf_add ")"
-      | Apply (">=", [v; w]) -> buf_add "("; sb v; buf_add ")"; buf_add " >= "; buf_add "("; sb w; buf_add ")"
-      | Apply ("RLIKE", [v; w]) -> buf_add "("; sb v; buf_add ")"; buf_add " RLIKE "; buf_add "("; sb w; buf_add ")"
-      | Apply ("LIKE", [v; w]) -> buf_add "("; sb v; buf_add ")"; buf_add " LIKE "; buf_add "("; sb w; buf_add ")"
-      | Apply (f, args) when SqlFuns.is f -> buf_add (SqlFuns.name f); buf_add "("; buf_mapstrcat buf args (fun x -> sb x) ","; buf_add ")"
-      | Apply (f, args) -> buf_add f; buf_add "("; buf_mapstrcat buf args (fun x -> sb x) ","; buf_add ")"
-      | Empty q -> buf_add "not exists ("; string_of_query buf quote true q; buf_add ")"
-      | Length q -> buf_add "select count(*) from ("; string_of_query buf quote true q; buf_add ") as "; buf_add (fresh_dummy_var ())
-      | RowNumber [] -> buf_add "1"
-      | RowNumber ps ->
-        buf_add "row_number() over (order by "; buf_add (String.concat "," (List.map (string_of_projection quote one_table) ps)); buf_add ")"
+      | Apply ("not", [Empty q]) -> Format.fprintf ppf "exists (%a)" pr_q q
+      | Apply ("not", [v]) -> Format.fprintf ppf "not (%a)" pr_b v
+      | Apply (("negate" | "negatef"), [v]) -> Format.fprintf ppf "-(%a)" pr_b v
+      | Apply ("&&", [v; w]) -> Format.fprintf ppf "(%a) and (%a)" pr_b v pr_b w
+      | Apply ("||", [v; w]) -> Format.fprintf ppf "(%a) or (%a)" pr_b v pr_b w
+      | Apply ("==", [v; w]) -> Format.fprintf ppf "(%a) = (%a)" pr_b v pr_b w
+      | Apply ("<>", [v; w]) -> Format.fprintf ppf "(%a) <> (%a)" pr_b v pr_b w
+      | Apply ("<", [v; w]) -> Format.fprintf ppf "(%a) < (%a)" pr_b v pr_b w
+      | Apply (">", [v; w]) -> Format.fprintf ppf "(%a) > (%a)" pr_b v pr_b w
+      | Apply ("<=", [v; w]) -> Format.fprintf ppf "(%a) <= (%a)" pr_b v pr_b w
+      | Apply (">=", [v; w]) -> Format.fprintf ppf "(%a) >= (%a)" pr_b v pr_b w
+      | Apply ("RLIKE", [v; w]) -> Format.fprintf ppf "(%a) RLIKE (%a)" pr_b v pr_b w
+      | Apply ("LIKE", [v; w]) -> Format.fprintf ppf "(%a) LIKE (%a)" pr_b v pr_b w
+      | Apply (f, args) when SqlFuns.is f -> 
+        let pp_value ppf x = Format.fprintf ppf "%a" pr_b x in
+        let pp_values ppf values = Format.fprintf ppf "%a" (Format.pp_print_list ~pp_sep:pp_comma pp_value) values in
+        Format.fprintf ppf "%a(%a)" pp_constant (SqlFuns.name f) pp_values args
+      | Apply (f, args) -> 
+        let pp_value ppf x = Format.fprintf ppf "%a" pr_b x in
+        let pp_values ppf values = Format.fprintf ppf "%a" (Format.pp_print_list ~pp_sep:pp_comma pp_value) values in
+        Format.fprintf ppf "%a(%a)" pp_constant f pp_values args
+      | Empty q -> Format.fprintf ppf "not exists (%a)" pr_q q
+      | Length q -> Format.fprintf ppf "select count(*) from (%a) as %a" pr_q q pp_constant (fresh_dummy_var ())
+      | RowNumber [] -> Format.fprintf ppf "%a" pp_constant "1"
+      | RowNumber ps -> Format.fprintf ppf "row_number() over (order by %a)" pp_constant (String.concat "," (List.map (string_of_projection quote one_table) ps))
 
 let string_of_base quote one_table b =
   let buf = Buffer.create 0 in
-  string_of_base buf quote one_table b; Buffer.contents buf
+  let ppf = Format.formatter_of_buffer buf in
+  pr_base ppf buf quote one_table b; Format.pp_print_flush ppf (); Buffer.contents buf
 
 let string_of_query ?(range=None) quote q =
+  let pp_constant ppf s = Format.fprintf ppf "%s" s in
   let buf = Buffer.create 0 in
+  let ppf = Format.formatter_of_buffer buf in
   let buf_add = Buffer.add_string buf in
   let range =
     match range with
       | None -> ""
       | Some (limit, offset) -> buffer_concat [" limit "; string_of_int limit; " offset "; string_of_int offset]
   in
-    string_of_query buf quote false q; buf_add range; Buffer.contents buf
+  let print_query ppf q = pr_query ppf buf quote false q in
+    Format.fprintf ppf "%a%a" print_query q pp_constant range;
+    Format.pp_print_flush ppf ();
+    Buffer.contents buf
+    (* pr_query buf quote false q; buf_add range; Buffer.contents buf *)

From 709d7a6ea12daa24cd7ab950b2ea8866a3e47cc1 Mon Sep 17 00:00:00 2001
From: Emanon42 <EmanonTang@outlook.com>
Date: Fri, 3 Jul 2020 16:35:49 +0100
Subject: [PATCH 11/50] improve fprintf structure

---
 core/query/sql.ml | 173 +++++++++++++++++++---------------------------
 1 file changed, 71 insertions(+), 102 deletions(-)

diff --git a/core/query/sql.ml b/core/query/sql.ml
index 4041a768f..757947356 100644
--- a/core/query/sql.ml
+++ b/core/query/sql.ml
@@ -30,6 +30,8 @@ and base =
   | RowNumber of (Var.var * string) list
     [@@deriving show]
 
+type 'a fmt_fn = Format.formatter -> 'a -> unit
+
 (* optimizing smart constructor for && *)
 let smart_and c c' =
   let open Constant in
@@ -150,20 +152,25 @@ let order_by_clause n =
    returned. This allows these operators to take lists that have any
    element type at all. *)
 
-let rec pr_query ppf buf quote ignore_fields q =
-  let buf_add = Buffer.add_string buf in
-  let pp_constant ppf s = Format.fprintf ppf "%s" s in
-  let pp_comma ppf () = Format.fprintf ppf "," in
+let pp_constant ppf s = Format.fprintf ppf "%s" s
+let pp_comma ppf () = Format.fprintf ppf ","
+
+let rec pr_query ppf quote ignore_fields q =
   let pp_quote ppf q = Format.fprintf ppf "%s" (quote q) in
 
-  let pr_q ppf q = pr_query ppf buf quote ignore_fields q in
-  let pr_b ppf q = pr_base ppf buf quote false q in
-  let pr_b_ignore_fields ppf q = pr_base ppf buf quote true q in
+  let pr_q ppf q = pr_query ppf quote ignore_fields q in
+  let pr_b ppf q = pr_base ppf quote false q in
+  let pr_b_ignore_fields ppf q = pr_base ppf quote true q in
+
+  let gen_pp_pair ppf fmt_str fl fr (l, r) = Format.fprintf ppf fmt_str fl l fr r in
+  let gen_pp_option ppf fmt_str f option =
+    match option with
+      | None -> ()
+      | Some x -> Format.fprintf ppf fmt_str f x
+  in
 
-  (*TODO: maybe add a template pair/option/list printer func? *)
-  (*TODO: or single term with/without bracket template printer func *)
   let pr_fields ppf fields =
-    let pp_field ppf (b, l) = Format.fprintf ppf "(%a) as %a" pr_b b pp_quote l in (*MARK: can be template-pair *)
+    let pp_field ppf (b, l) = gen_pp_pair ppf "(%a) as %a" pr_b pp_constant (b, l) in
     if ignore_fields then
       Format.fprintf ppf "%a" pp_constant "0 as \"@unit@\"" (* SQL doesn't support empty records! *)
     else
@@ -173,56 +180,38 @@ let rec pr_query ppf buf quote ignore_fields q =
   in
 
   let pr_select ppf fields tables condition os =
-    let pp_tables ppf tables = Format.fprintf ppf "%a" (Format.pp_print_list ~pp_sep:pp_comma Format.pp_print_string) tables in (*MARK: can be template-list *)
     let pp_os_condition ppf a = Format.fprintf ppf "%a" pr_b a in
-    let pp_orderby ppf os = 
+    let pp_orderby ppf os =
       match os with
         | [] -> ()
         | _ -> Format.fprintf ppf " order by %a" (Format.pp_print_list ~pp_sep:pp_comma pp_os_condition) os in
-    let pp_where ppf condition = 
+    let pp_where ppf condition =
       match condition with
         | Constant (Constant.Bool true) -> ()
         | _ -> Format.fprintf ppf " where %a" pp_os_condition condition in
 
-    Format.fprintf ppf "select %a from %a%a%a" 
+    Format.fprintf ppf "select %a from %a%a%a"
       pr_fields fields
-      pp_tables tables
+      (Format.pp_print_list ~pp_sep:pp_comma Format.pp_print_string) tables
       pp_where condition
       pp_orderby os
   in
 
   let pr_delete ppf table where =
-    let pp_where ppf where = 
-      match where with
-        | None -> ()
-        | Some x -> Format.fprintf ppf "where (%a)" pr_b_ignore_fields x in (*MARK: can be template-option *)
-
-    Format.fprintf ppf "delete from %a%a"
-      pp_constant table
-      pp_where where
+    let pp_where ppf where = gen_pp_option ppf "where (%a)" pr_b_ignore_fields where in
+    Format.fprintf ppf "delete from %a%a" pp_constant table pp_where where
   in
   let pr_update ppf table fields where =
-    let pp_field ppf (k, v) = Format.fprintf ppf "%a = %a" pp_quote k pr_b_ignore_fields v in (*MARK: can be template-pair *)
-    let pp_fields ppf fields = Format.fprintf ppf "%a" (Format.pp_print_list ~pp_sep:pp_comma pp_field) fields in (*MARK: can be template-list *)
-    let pp_where ppf where = 
-      match where with
-        | None -> ()
-        | Some x -> Format.fprintf ppf "where (%a)" pr_b_ignore_fields x in (*MARK: can be template-option *)
-    
-    Format.fprintf ppf "update %a set %a %a"
-      pp_constant table
-      pp_fields fields
-      pp_where where
+    let pp_field ppf (k, v) = gen_pp_pair ppf "%a = %a" pp_quote pr_b_ignore_fields (k, v) in
+    let pp_where ppf where = gen_pp_option ppf "where (%a)" pr_b_ignore_fields where in
+    Format.fprintf ppf "update %a set %a %a" pp_constant table (Format.pp_print_list ~pp_sep:pp_comma pp_field) fields pp_where where
   in
   let pr_insert ppf table fields values =
-    let pp_fields ppf fields = Format.fprintf ppf "%a" (Format.pp_print_list ~pp_sep:pp_comma Format.pp_print_string) fields in (*MARK: can be template-list *)
     let pp_value ppf x = Format.fprintf ppf "(%a)" (Format.pp_print_list ~pp_sep:pp_comma pr_b_ignore_fields) x in
-    let pp_values ppf values = Format.fprintf ppf "%a" (Format.pp_print_list ~pp_sep:pp_comma pp_value) values in (*MARK: can be template-list *)
-    
     Format.fprintf ppf "insert into %a (%a) values %a"
       pp_constant table
-      pp_fields fields
-      pp_values values
+      (Format.pp_print_list ~pp_sep:pp_comma Format.pp_print_string) fields
+      (Format.pp_print_list ~pp_sep:pp_comma pp_value) values
   in
   match q with
     | UnionAll ([], _) -> Format.fprintf ppf "%a" pp_constant "select 42 as \"@unit@\" where false"
@@ -230,9 +219,8 @@ let rec pr_query ppf buf quote ignore_fields q =
     | UnionAll (qs, n) ->
       let pp_sep_union ppf () = Format.fprintf ppf " union all " in
       let pp_value ppf x = Format.fprintf ppf "(%a)" pr_q x in
-      let pp_values ppf values = Format.fprintf ppf "%a" (Format.pp_print_list ~pp_sep:pp_sep_union pp_value) values in (*MARK: can be template-list *)
-      Format.fprintf ppf "%a%a" 
-        pp_values qs 
+      Format.fprintf ppf "%a%a"
+        (Format.pp_print_list ~pp_sep:pp_sep_union pp_value) qs
         pp_constant (order_by_clause n)
     | Select (fields, [], Constant (Constant.Bool true), _os) ->
       Format.fprintf ppf "select %a" pr_fields fields
@@ -243,7 +231,7 @@ let rec pr_query ppf buf quote ignore_fields q =
         pr_b condition
     | Select (fields, tables, condition, os) ->
         (* using quote_field assumes tables contains table names (not nested queries) *)
-        let tables = List.map (fun (t, x) -> buffer_concat [quote t; " as "; (string_of_table_var x)]) tables in 
+        let tables = List.map (fun (t, x) -> buffer_concat [quote t; " as "; (string_of_table_var x)]) tables in
         pr_select ppf fields tables condition os
     | Delete { del_table; del_where } ->
         pr_delete ppf del_table del_where
@@ -256,90 +244,71 @@ let rec pr_query ppf buf quote ignore_fields q =
         | Select (fields, tables, condition, os) ->
             (* Inline the query *)
             let tables = List.map (fun (t, x) -> buffer_concat [quote t; " as "; (string_of_table_var x)]) tables in
-            let buf2 = Buffer.create 0 in
-            let ppf2 = Format.formatter_of_buffer buf2 in
-            let q2 = pr_query ppf2 buf2 quote ignore_fields q; Format.pp_print_flush ppf2 (); Buffer.contents buf2 in
+            let pr_q ppf q = pr_query ppf quote ignore_fields q in
+            let q2 = Format.asprintf "%a" pr_q q in
             let q = buffer_concat ["("; q2; ") as "; string_of_table_var z] in
             pr_select ppf fields (q::tables) condition os
         | _ -> assert false
 
-and pr_base ppf buf quote one_table b =
-  let pp_constant ppf s = Format.fprintf ppf "%s" s in
-  let pp_comma ppf () = Format.fprintf ppf "," in
-  let pp_quote ppf q = Format.fprintf ppf "%s" (quote q) in
+and pr_base ppf quote one_table b =
   let string_of_projection quote one_table (var, label) =
   if one_table then
     quote label
   else
     buffer_concat [string_of_table_var var; "."; (quote label)]
   in
-  let buf_add = Buffer.add_string buf in
-  let pr_b ppf b = pr_base ppf buf quote one_table b in
-  let pr_q ppf q = pr_query ppf buf quote true q in
+  let pr_b ppf b = pr_base ppf quote one_table b in
+  let pr_q ppf q = pr_query ppf quote true q in
+  let unary_ops = StringSet.of_list ["intToString"; "stringToInt"; "intToFloat"; "floatToString"; "stringToFloat"; "floatToInt"; "not"; "negate"; "negatef"] in
+  let binary_ops = StringSet.of_list ["&&"; "||"; "=="; "<>"; "<"; ">"; "<="; ">="; "RLIKE"; "LIKE"] in
+  let binary_map op =
+    match op with
+      | "&&" -> "and"
+      | "||" -> "or"
+      | "==" -> "="
+      | _ -> op
+  in
+  let unary_map op =
+    match op with
+      | "floatToInt" -> "floor"
+      | "not" -> "not "
+      | "negate" | "negatef" -> "-"
+      | _ -> ""
+  in
     match b with
-      | Case (c, t, e) ->
-        Format.fprintf ppf "case when %a then %a else %a end"
-          pr_b c
-          pr_b t
-          pr_b e
+      | Case (c, t, e) -> Format.fprintf ppf "case when %a then %a else %a end" pr_b c pr_b t pr_b e
       | Constant c -> Format.fprintf ppf "%a" pp_constant (Constant.to_string c)
       | Project (var, label) -> Format.fprintf ppf "%a" pp_constant (string_of_projection quote one_table (var, label))
       | Apply (op, [l; r]) when Arithmetic.is op ->
-        let buf2 = Buffer.create 0 in
-        let ppf2 = Format.formatter_of_buffer buf2 in
-        let buf3 = Buffer.create 0 in
-        let ppf3 = Format.formatter_of_buffer buf3 in
-        let l2 = pr_base ppf2 buf2 quote one_table l; Format.pp_print_flush ppf2 (); Buffer.contents buf2 in
-        let r2 = pr_base ppf3 buf3 quote one_table r; Format.pp_print_flush ppf3 (); Buffer.contents buf3 in
-        Format.fprintf ppf "%a" pp_constant (Arithmetic.gen (l2, op, r2))
-      | Apply (("intToString" | "stringToInt" | "intToFloat" | "floatToString"
-                | "stringToFloat"), [v]) -> Format.fprintf ppf "%a" pr_b v
-      | Apply ("floatToInt", [v]) -> Format.fprintf ppf "floor(%a)" pr_b v
+        let pr_b ppf b = pr_base ppf quote one_table b in
+        let l = Format.asprintf "%a" pr_b l in
+        let r = Format.asprintf "%a" pr_b r in
+        Format.fprintf ppf "%a" pp_constant (Arithmetic.gen (l, op, r))
+      | Apply ("not", [Empty q]) -> Format.fprintf ppf "exists (%a)" pr_q q
+      | Apply (uop, [v]) when StringSet.mem uop unary_ops -> Format.fprintf ppf "%s(%a)" (unary_map uop) pr_b v
 
       (* optimisation *)
-      | Apply ("not", [Empty q]) -> Format.fprintf ppf "exists (%a)" pr_q q
-      | Apply ("not", [v]) -> Format.fprintf ppf "not (%a)" pr_b v
-      | Apply (("negate" | "negatef"), [v]) -> Format.fprintf ppf "-(%a)" pr_b v
-      | Apply ("&&", [v; w]) -> Format.fprintf ppf "(%a) and (%a)" pr_b v pr_b w
-      | Apply ("||", [v; w]) -> Format.fprintf ppf "(%a) or (%a)" pr_b v pr_b w
-      | Apply ("==", [v; w]) -> Format.fprintf ppf "(%a) = (%a)" pr_b v pr_b w
-      | Apply ("<>", [v; w]) -> Format.fprintf ppf "(%a) <> (%a)" pr_b v pr_b w
-      | Apply ("<", [v; w]) -> Format.fprintf ppf "(%a) < (%a)" pr_b v pr_b w
-      | Apply (">", [v; w]) -> Format.fprintf ppf "(%a) > (%a)" pr_b v pr_b w
-      | Apply ("<=", [v; w]) -> Format.fprintf ppf "(%a) <= (%a)" pr_b v pr_b w
-      | Apply (">=", [v; w]) -> Format.fprintf ppf "(%a) >= (%a)" pr_b v pr_b w
-      | Apply ("RLIKE", [v; w]) -> Format.fprintf ppf "(%a) RLIKE (%a)" pr_b v pr_b w
-      | Apply ("LIKE", [v; w]) -> Format.fprintf ppf "(%a) LIKE (%a)" pr_b v pr_b w
-      | Apply (f, args) when SqlFuns.is f -> 
+      | Apply (op, [v; w]) when StringSet.mem op binary_ops -> Format.fprintf ppf "(%a) %s (%a)" pr_b v (binary_map op) pr_b w
+      | Apply (f, args) when SqlFuns.is f ->
         let pp_value ppf x = Format.fprintf ppf "%a" pr_b x in
-        let pp_values ppf values = Format.fprintf ppf "%a" (Format.pp_print_list ~pp_sep:pp_comma pp_value) values in
-        Format.fprintf ppf "%a(%a)" pp_constant (SqlFuns.name f) pp_values args
-      | Apply (f, args) -> 
+        Format.fprintf ppf "%a(%a)" pp_constant (SqlFuns.name f) (Format.pp_print_list ~pp_sep:pp_comma pp_value) args
+      | Apply (f, args) ->
         let pp_value ppf x = Format.fprintf ppf "%a" pr_b x in
-        let pp_values ppf values = Format.fprintf ppf "%a" (Format.pp_print_list ~pp_sep:pp_comma pp_value) values in
-        Format.fprintf ppf "%a(%a)" pp_constant f pp_values args
+        Format.fprintf ppf "%a(%a)" pp_constant f (Format.pp_print_list ~pp_sep:pp_comma pp_value) args
       | Empty q -> Format.fprintf ppf "not exists (%a)" pr_q q
       | Length q -> Format.fprintf ppf "select count(*) from (%a) as %a" pr_q q pp_constant (fresh_dummy_var ())
       | RowNumber [] -> Format.fprintf ppf "%a" pp_constant "1"
       | RowNumber ps -> Format.fprintf ppf "row_number() over (order by %a)" pp_constant (String.concat "," (List.map (string_of_projection quote one_table) ps))
 
 let string_of_base quote one_table b =
-  let buf = Buffer.create 0 in
-  let ppf = Format.formatter_of_buffer buf in
-  pr_base ppf buf quote one_table b; Format.pp_print_flush ppf (); Buffer.contents buf
+  let pr_b ppf b = pr_base ppf quote one_table b in
+  Format.asprintf "%a" pr_b b
 
 let string_of_query ?(range=None) quote q =
-  let pp_constant ppf s = Format.fprintf ppf "%s" s in
-  let buf = Buffer.create 0 in
-  let ppf = Format.formatter_of_buffer buf in
-  let buf_add = Buffer.add_string buf in
-  let range =
+  let pr_q ppf q = pr_query ppf quote false q in
+  let pr_range ppf range =
     match range with
-      | None -> ""
-      | Some (limit, offset) -> buffer_concat [" limit "; string_of_int limit; " offset "; string_of_int offset]
+      | None -> ()
+      | Some (limit, offset) -> Format.fprintf ppf " limit %i offset %i" limit offset
   in
-  let print_query ppf q = pr_query ppf buf quote false q in
-    Format.fprintf ppf "%a%a" print_query q pp_constant range;
-    Format.pp_print_flush ppf ();
-    Buffer.contents buf
-    (* pr_query buf quote false q; buf_add range; Buffer.contents buf *)
+  Format.asprintf "%a%a" pr_q q pr_range range

From 9fcaf344857cff755ea551c7dc24283c113442a5 Mon Sep 17 00:00:00 2001
From: Emanon42 <EmanonTang@outlook.com>
Date: Fri, 3 Jul 2020 16:43:13 +0100
Subject: [PATCH 12/50] use asprintf in tables

---
 core/query/sql.ml | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/core/query/sql.ml b/core/query/sql.ml
index 757947356..57eb8f5dc 100644
--- a/core/query/sql.ml
+++ b/core/query/sql.ml
@@ -243,7 +243,7 @@ let rec pr_query ppf quote ignore_fields q =
         match q' with
         | Select (fields, tables, condition, os) ->
             (* Inline the query *)
-            let tables = List.map (fun (t, x) -> buffer_concat [quote t; " as "; (string_of_table_var x)]) tables in
+            let tables = List.map (fun (t, x) -> Format.asprintf "%a as %s" pp_quote t (string_of_table_var x)) tables in
             let pr_q ppf q = pr_query ppf quote ignore_fields q in
             let q2 = Format.asprintf "%a" pr_q q in
             let q = buffer_concat ["("; q2; ") as "; string_of_table_var z] in

From 6ddfbe8774923f8b8a8764ae3bcf0de64f1c7d52 Mon Sep 17 00:00:00 2001
From: Emanon42 <EmanonTang@outlook.com>
Date: Fri, 3 Jul 2020 17:08:16 +0100
Subject: [PATCH 13/50] fix quote

---
 core/query/sql.ml | 7 +++----
 1 file changed, 3 insertions(+), 4 deletions(-)

diff --git a/core/query/sql.ml b/core/query/sql.ml
index 57eb8f5dc..5c60e98c5 100644
--- a/core/query/sql.ml
+++ b/core/query/sql.ml
@@ -170,7 +170,7 @@ let rec pr_query ppf quote ignore_fields q =
   in
 
   let pr_fields ppf fields =
-    let pp_field ppf (b, l) = gen_pp_pair ppf "(%a) as %a" pr_b pp_constant (b, l) in
+    let pp_field ppf (b, l) = gen_pp_pair ppf "(%a) as %a" pr_b pp_quote (b, l) in
     if ignore_fields then
       Format.fprintf ppf "%a" pp_constant "0 as \"@unit@\"" (* SQL doesn't support empty records! *)
     else
@@ -231,7 +231,7 @@ let rec pr_query ppf quote ignore_fields q =
         pr_b condition
     | Select (fields, tables, condition, os) ->
         (* using quote_field assumes tables contains table names (not nested queries) *)
-        let tables = List.map (fun (t, x) -> buffer_concat [quote t; " as "; (string_of_table_var x)]) tables in
+        let tables = List.map (fun (t, x) -> Format.asprintf "%a as %s" pp_quote t (string_of_table_var x)) tables in
         pr_select ppf fields tables condition os
     | Delete { del_table; del_where } ->
         pr_delete ppf del_table del_where
@@ -245,8 +245,7 @@ let rec pr_query ppf quote ignore_fields q =
             (* Inline the query *)
             let tables = List.map (fun (t, x) -> Format.asprintf "%a as %s" pp_quote t (string_of_table_var x)) tables in
             let pr_q ppf q = pr_query ppf quote ignore_fields q in
-            let q2 = Format.asprintf "%a" pr_q q in
-            let q = buffer_concat ["("; q2; ") as "; string_of_table_var z] in
+            let q = Format.asprintf "(%s) as %s" (Format.asprintf "%a" pr_q q) (string_of_table_var z) in
             pr_select ppf fields (q::tables) condition os
         | _ -> assert false
 

From c5619c4c18fd83d4259672e2620cb44f5d440358 Mon Sep 17 00:00:00 2001
From: Emanon42 <EmanonTang@outlook.com>
Date: Fri, 3 Jul 2020 17:16:51 +0100
Subject: [PATCH 14/50] resolve conflict in webif

---
 core/webif.ml | 8 --------
 1 file changed, 8 deletions(-)

diff --git a/core/webif.ml b/core/webif.ml
index 3f705d345..5305381bf 100644
--- a/core/webif.ml
+++ b/core/webif.ml
@@ -80,18 +80,10 @@ struct
       body ^
       "\n  </body></html>\n"
 
-<<<<<<< HEAD
-  (* jcheney: lifted from serve_request, to de-clutter *)
-  let parse_request env cgi_args  =
-    if      (Utility.is_remote_call cgi_args)
-    then parse_remote_call env cgi_args
-    else if (Utility.is_client_return cgi_args)
-=======
   let parse_request env cgi_args  =
     if      (RequestData.is_remote_call cgi_args)
     then parse_remote_call env cgi_args
     else if (RequestData.is_client_return cgi_args)
->>>>>>> upstream/master
     then parse_client_return env cgi_args
     else if (is_server_cont cgi_args)
     then parse_server_cont env cgi_args

From 80fc6b1c1563f9c575757ee639db9ec3b71eaf72 Mon Sep 17 00:00:00 2001
From: Emanon42 <EmanonTang@outlook.com>
Date: Fri, 3 Jul 2020 17:42:52 +0100
Subject: [PATCH 15/50] remove old bufconcat

---
 core/evalir.ml    |  1 +
 core/query/sql.ml | 21 ++-------------------
 core/utility.ml   | 10 ----------
 3 files changed, 3 insertions(+), 29 deletions(-)

diff --git a/core/evalir.ml b/core/evalir.ml
index f4d9e7bb4..e470adfe9 100644
--- a/core/evalir.ml
+++ b/core/evalir.ml
@@ -126,6 +126,7 @@ struct
      Value.continuation ->
      Value.t list ->
      result =
+     
        fun req_data name cont args ->
          if not(Settings.get webs_running) then
            raise (Errors.forbidden_client_call name "outside of web mode");
diff --git a/core/query/sql.ml b/core/query/sql.ml
index 5c60e98c5..269ac7797 100644
--- a/core/query/sql.ml
+++ b/core/query/sql.ml
@@ -71,19 +71,6 @@ let string_of_label label =
   else
     label
 
-(* concatenation implement with Buffer module*)
-let buffer_concat xs =
-  let buf = Buffer.create 0 in (* maybe a better heuristic init size? *)
-  List.iter (Buffer.add_string buf) xs;
-  Buffer.contents buf
-
-let rec buf_mapstrcat buf list f sep =
-  match list with
-    | [] -> ()
-    | [x] -> f x
-    | x :: xs ->
-      f x; Buffer.add_string buf sep; buf_mapstrcat buf xs f sep
-
 module Arithmetic :
 sig
   val is : string -> bool
@@ -163,11 +150,7 @@ let rec pr_query ppf quote ignore_fields q =
   let pr_b_ignore_fields ppf q = pr_base ppf quote true q in
 
   let gen_pp_pair ppf fmt_str fl fr (l, r) = Format.fprintf ppf fmt_str fl l fr r in
-  let gen_pp_option ppf fmt_str f option =
-    match option with
-      | None -> ()
-      | Some x -> Format.fprintf ppf fmt_str f x
-  in
+  let gen_pp_option ppf fmt_str f option = OptionUtils.opt_iter (Format.fprintf ppf fmt_str f) option in
 
   let pr_fields ppf fields =
     let pp_field ppf (b, l) = gen_pp_pair ppf "(%a) as %a" pr_b pp_quote (b, l) in
@@ -254,7 +237,7 @@ and pr_base ppf quote one_table b =
   if one_table then
     quote label
   else
-    buffer_concat [string_of_table_var var; "."; (quote label)]
+    Format.asprintf "%s.%s" (string_of_table_var var) (quote label)
   in
   let pr_b ppf b = pr_base ppf quote one_table b in
   let pr_q ppf q = pr_query ppf quote true q in
diff --git a/core/utility.ml b/core/utility.ml
index 03d016db6..4c225eba2 100644
--- a/core/utility.ml
+++ b/core/utility.ml
@@ -1459,16 +1459,6 @@ struct
         Lwt.return (x :: xs)
 end
 
-(** remote client->server call *)
-let is_remote_call params =
-  List.mem_assoc "__name" params && List.mem_assoc "__args" params
-
-(** return __result from server->client call with server continuation __continuation *)
-let is_client_return params =
-  List.mem_assoc "__continuation" params && List.mem_assoc "__result" params
-
-let is_ajax_call cgi_args =
-  (is_remote_call cgi_args) || (is_client_return cgi_args)
 
 (* efficient polymorphic buffers *)
 (* builds an array of n pages of size m, with some initial dummy value *)

From e86649e54672c36d6089623103503a2889ec9be5 Mon Sep 17 00:00:00 2001
From: Emanon42 <EmanonTang@outlook.com>
Date: Fri, 3 Jul 2020 17:43:55 +0100
Subject: [PATCH 16/50] trim space

---
 core/evalir.ml | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/core/evalir.ml b/core/evalir.ml
index e470adfe9..c68b69632 100644
--- a/core/evalir.ml
+++ b/core/evalir.ml
@@ -126,7 +126,7 @@ struct
      Value.continuation ->
      Value.t list ->
      result =
-     
+
        fun req_data name cont args ->
          if not(Settings.get webs_running) then
            raise (Errors.forbidden_client_call name "outside of web mode");

From f4e101928113727884e22180b760c1477d48081b Mon Sep 17 00:00:00 2001
From: Emanon42 <EmanonTang@outlook.com>
Date: Sun, 5 Jul 2020 17:00:14 +0100
Subject: [PATCH 17/50] many fine-grained fix

---
 core/query/sql.ml | 99 +++++++++++++++++++++++------------------------
 1 file changed, 48 insertions(+), 51 deletions(-)

diff --git a/core/query/sql.ml b/core/query/sql.ml
index 269ac7797..0402e24b4 100644
--- a/core/query/sql.ml
+++ b/core/query/sql.ml
@@ -139,15 +139,15 @@ let order_by_clause n =
    returned. This allows these operators to take lists that have any
    element type at all. *)
 
-let pp_constant ppf s = Format.fprintf ppf "%s" s
-let pp_comma ppf () = Format.fprintf ppf ","
+let pp_comma ppf () = Format.pp_print_string ppf ","
+let pp_comma_separated pp_item = Format.pp_print_list ~pp_sep:pp_comma pp_item
 
-let rec pr_query ppf quote ignore_fields q =
-  let pp_quote ppf q = Format.fprintf ppf "%s" (quote q) in
+let rec pr_query quote ignore_fields ppf q =
+  let pp_quote ppf q = Format.pp_print_string ppf (quote q) in
 
-  let pr_q ppf q = pr_query ppf quote ignore_fields q in
-  let pr_b ppf q = pr_base ppf quote false q in
-  let pr_b_ignore_fields ppf q = pr_base ppf quote true q in
+  let pr_q = pr_query quote ignore_fields in
+  let pr_b = pr_base quote false in
+  let pr_b_ignore_fields = pr_base quote true in
 
   let gen_pp_pair ppf fmt_str fl fr (l, r) = Format.fprintf ppf fmt_str fl l fr r in
   let gen_pp_option ppf fmt_str f option = OptionUtils.opt_iter (Format.fprintf ppf fmt_str f) option in
@@ -155,11 +155,11 @@ let rec pr_query ppf quote ignore_fields q =
   let pr_fields ppf fields =
     let pp_field ppf (b, l) = gen_pp_pair ppf "(%a) as %a" pr_b pp_quote (b, l) in
     if ignore_fields then
-      Format.fprintf ppf "%a" pp_constant "0 as \"@unit@\"" (* SQL doesn't support empty records! *)
+      Format.pp_print_string ppf "0 as \"@unit@\"" (* SQL doesn't support empty records! *)
     else
       match fields with
-        | [] -> Format.fprintf ppf "%a" pp_constant "0 as \"@unit@\"" (* SQL doesn't support empty records! *)
-        | fields -> Format.fprintf ppf "%a" (Format.pp_print_list ~pp_sep:pp_comma pp_field) fields
+        | [] -> Format.pp_print_string ppf "0 as \"@unit@\"" (* SQL doesn't support empty records! *)
+        | fields -> (pp_comma_separated pp_field) ppf fields
   in
 
   let pr_select ppf fields tables condition os =
@@ -167,7 +167,7 @@ let rec pr_query ppf quote ignore_fields q =
     let pp_orderby ppf os =
       match os with
         | [] -> ()
-        | _ -> Format.fprintf ppf " order by %a" (Format.pp_print_list ~pp_sep:pp_comma pp_os_condition) os in
+        | _ -> Format.fprintf ppf " order by %a" (pp_comma_separated pp_os_condition) os in
     let pp_where ppf condition =
       match condition with
         | Constant (Constant.Bool true) -> ()
@@ -175,45 +175,45 @@ let rec pr_query ppf quote ignore_fields q =
 
     Format.fprintf ppf "select %a from %a%a%a"
       pr_fields fields
-      (Format.pp_print_list ~pp_sep:pp_comma Format.pp_print_string) tables
+      (pp_comma_separated Format.pp_print_string) tables
       pp_where condition
       pp_orderby os
   in
 
+  let pp_where_d_u ppf where = gen_pp_option ppf "where (%a)" pr_b_ignore_fields where in
   let pr_delete ppf table where =
-    let pp_where ppf where = gen_pp_option ppf "where (%a)" pr_b_ignore_fields where in
-    Format.fprintf ppf "delete from %a%a" pp_constant table pp_where where
+    Format.fprintf ppf "delete from %a %a" Format.pp_print_string table pp_where_d_u where
   in
   let pr_update ppf table fields where =
     let pp_field ppf (k, v) = gen_pp_pair ppf "%a = %a" pp_quote pr_b_ignore_fields (k, v) in
-    let pp_where ppf where = gen_pp_option ppf "where (%a)" pr_b_ignore_fields where in
-    Format.fprintf ppf "update %a set %a %a" pp_constant table (Format.pp_print_list ~pp_sep:pp_comma pp_field) fields pp_where where
+    Format.fprintf ppf "update %a set %a %a" Format.pp_print_string table (pp_comma_separated pp_field) fields pp_where_d_u where
   in
   let pr_insert ppf table fields values =
-    let pp_value ppf x = Format.fprintf ppf "(%a)" (Format.pp_print_list ~pp_sep:pp_comma pr_b_ignore_fields) x in
+    let pp_value ppf x = Format.fprintf ppf "(%a)" (pp_comma_separated pr_b_ignore_fields) x in
     Format.fprintf ppf "insert into %a (%a) values %a"
-      pp_constant table
-      (Format.pp_print_list ~pp_sep:pp_comma Format.pp_print_string) fields
-      (Format.pp_print_list ~pp_sep:pp_comma pp_value) values
+      Format.pp_print_string table
+      (pp_comma_separated Format.pp_print_string) fields
+      (pp_comma_separated pp_value) values
   in
   match q with
-    | UnionAll ([], _) -> Format.fprintf ppf "%a" pp_constant "select 42 as \"@unit@\" where false"
-    | UnionAll ([q], n) -> Format.fprintf ppf "%a%a" pr_q q pp_constant (order_by_clause n)
+    | UnionAll ([], _) -> Format.fprintf ppf "%a" Format.pp_print_string "select 42 as \"@unit@\" where false"
+    | UnionAll ([q], n) -> Format.fprintf ppf "%a%a" pr_q q Format.pp_print_string (order_by_clause n)
     | UnionAll (qs, n) ->
       let pp_sep_union ppf () = Format.fprintf ppf " union all " in
       let pp_value ppf x = Format.fprintf ppf "(%a)" pr_q x in
       Format.fprintf ppf "%a%a"
         (Format.pp_print_list ~pp_sep:pp_sep_union pp_value) qs
-        pp_constant (order_by_clause n)
+        Format.pp_print_string (order_by_clause n)
     | Select (fields, [], Constant (Constant.Bool true), _os) ->
       Format.fprintf ppf "select %a" pr_fields fields
     | Select (fields, [], condition, _os) ->
       Format.fprintf ppf "select * from (select %a) as %a where %a"
         pr_fields fields
-        pp_constant (fresh_dummy_var ())
+        Format.pp_print_string (fresh_dummy_var ())
         pr_b condition
     | Select (fields, tables, condition, os) ->
         (* using quote_field assumes tables contains table names (not nested queries) *)
+        (* FIXME: type Select forces tables to be list((table name, var)), but it can have subqueries instead of plain table names in general cases *)
         let tables = List.map (fun (t, x) -> Format.asprintf "%a as %s" pp_quote t (string_of_table_var x)) tables in
         pr_select ppf fields tables condition os
     | Delete { del_table; del_where } ->
@@ -226,21 +226,22 @@ let rec pr_query ppf quote ignore_fields q =
         match q' with
         | Select (fields, tables, condition, os) ->
             (* Inline the query *)
+            (* FIXME: should emitting standard SQL WITH expressions here, move inline to a separate preprocessing step *)
             let tables = List.map (fun (t, x) -> Format.asprintf "%a as %s" pp_quote t (string_of_table_var x)) tables in
-            let pr_q ppf q = pr_query ppf quote ignore_fields q in
+            let pr_q = pr_query quote ignore_fields in
             let q = Format.asprintf "(%s) as %s" (Format.asprintf "%a" pr_q q) (string_of_table_var z) in
             pr_select ppf fields (q::tables) condition os
         | _ -> assert false
 
-and pr_base ppf quote one_table b =
+and pr_base quote one_table ppf b =
   let string_of_projection quote one_table (var, label) =
   if one_table then
     quote label
   else
     Format.asprintf "%s.%s" (string_of_table_var var) (quote label)
   in
-  let pr_b ppf b = pr_base ppf quote one_table b in
-  let pr_q ppf q = pr_query ppf quote true q in
+  let pr_b_one_table = pr_base quote one_table in
+  let pr_q_true = pr_query quote true in
   let unary_ops = StringSet.of_list ["intToString"; "stringToInt"; "intToFloat"; "floatToString"; "stringToFloat"; "floatToInt"; "not"; "negate"; "negatef"] in
   let binary_ops = StringSet.of_list ["&&"; "||"; "=="; "<>"; "<"; ">"; "<="; ">="; "RLIKE"; "LIKE"] in
   let binary_map op =
@@ -255,42 +256,38 @@ and pr_base ppf quote one_table b =
       | "floatToInt" -> "floor"
       | "not" -> "not "
       | "negate" | "negatef" -> "-"
-      | _ -> ""
+      | "intToString" | "stringToInt" | "intToFloat" | "floatToString" | "stringToFloat" -> ""
+      | _ -> assert false
   in
     match b with
-      | Case (c, t, e) -> Format.fprintf ppf "case when %a then %a else %a end" pr_b c pr_b t pr_b e
-      | Constant c -> Format.fprintf ppf "%a" pp_constant (Constant.to_string c)
-      | Project (var, label) -> Format.fprintf ppf "%a" pp_constant (string_of_projection quote one_table (var, label))
+      | Case (c, t, e) -> Format.fprintf ppf "case when %a then %a else %a end" pr_b_one_table c pr_b_one_table t pr_b_one_table e
+      | Constant c -> Format.pp_print_string ppf (Constant.to_string c)
+      | Project (var, label) -> Format.pp_print_string ppf (string_of_projection quote one_table (var, label))
       | Apply (op, [l; r]) when Arithmetic.is op ->
-        let pr_b ppf b = pr_base ppf quote one_table b in
-        let l = Format.asprintf "%a" pr_b l in
-        let r = Format.asprintf "%a" pr_b r in
-        Format.fprintf ppf "%a" pp_constant (Arithmetic.gen (l, op, r))
-      | Apply ("not", [Empty q]) -> Format.fprintf ppf "exists (%a)" pr_q q
-      | Apply (uop, [v]) when StringSet.mem uop unary_ops -> Format.fprintf ppf "%s(%a)" (unary_map uop) pr_b v
+        let l = Format.asprintf "%a" pr_b_one_table l in
+        let r = Format.asprintf "%a" pr_b_one_table r in
+        Format.fprintf ppf "%a" Format.pp_print_string (Arithmetic.gen (l, op, r))
+      | Apply ("not", [Empty q]) -> Format.fprintf ppf "exists (%a)" pr_q_true q
+      | Apply (uop, [v]) when StringSet.mem uop unary_ops -> Format.fprintf ppf "%s(%a)" (unary_map uop) pr_b_one_table v
 
       (* optimisation *)
-      | Apply (op, [v; w]) when StringSet.mem op binary_ops -> Format.fprintf ppf "(%a) %s (%a)" pr_b v (binary_map op) pr_b w
+      | Apply (op, [v; w]) when StringSet.mem op binary_ops -> Format.fprintf ppf "(%a) %s (%a)" pr_b_one_table v (binary_map op) pr_b_one_table w
       | Apply (f, args) when SqlFuns.is f ->
-        let pp_value ppf x = Format.fprintf ppf "%a" pr_b x in
-        Format.fprintf ppf "%a(%a)" pp_constant (SqlFuns.name f) (Format.pp_print_list ~pp_sep:pp_comma pp_value) args
+        Format.fprintf ppf "%a(%a)" Format.pp_print_string (SqlFuns.name f) (pp_comma_separated pr_b_one_table) args
       | Apply (f, args) ->
-        let pp_value ppf x = Format.fprintf ppf "%a" pr_b x in
-        Format.fprintf ppf "%a(%a)" pp_constant f (Format.pp_print_list ~pp_sep:pp_comma pp_value) args
-      | Empty q -> Format.fprintf ppf "not exists (%a)" pr_q q
-      | Length q -> Format.fprintf ppf "select count(*) from (%a) as %a" pr_q q pp_constant (fresh_dummy_var ())
-      | RowNumber [] -> Format.fprintf ppf "%a" pp_constant "1"
-      | RowNumber ps -> Format.fprintf ppf "row_number() over (order by %a)" pp_constant (String.concat "," (List.map (string_of_projection quote one_table) ps))
+        Format.fprintf ppf "%a(%a)" Format.pp_print_string f (pp_comma_separated pr_b_one_table) args
+      | Empty q -> Format.fprintf ppf "not exists (%a)" pr_q_true q
+      | Length q -> Format.fprintf ppf "select count(*) from (%a) as %a" pr_q_true q Format.pp_print_string (fresh_dummy_var ())
+      | RowNumber [] -> Format.fprintf ppf "%a" Format.pp_print_string "1"
+      | RowNumber ps -> Format.fprintf ppf "row_number() over (order by %a)" Format.pp_print_string (String.concat "," (List.map (string_of_projection quote one_table) ps))
 
 let string_of_base quote one_table b =
-  let pr_b ppf b = pr_base ppf quote one_table b in
-  Format.asprintf "%a" pr_b b
+  Format.asprintf "%a" (pr_base quote one_table) b
 
 let string_of_query ?(range=None) quote q =
-  let pr_q ppf q = pr_query ppf quote false q in
   let pr_range ppf range =
     match range with
       | None -> ()
       | Some (limit, offset) -> Format.fprintf ppf " limit %i offset %i" limit offset
   in
-  Format.asprintf "%a%a" pr_q q pr_range range
+  Format.asprintf "%a%a" (pr_query quote false) q pr_range range

From 3594cd11e00cf39acd41e4cd3de852b9f94bbf26 Mon Sep 17 00:00:00 2001
From: Emanon42 <EmanonTang@outlook.com>
Date: Sun, 5 Jul 2020 17:05:26 +0100
Subject: [PATCH 18/50] many fine-grained fix

---
 core/query/sql.ml | 8 +++-----
 1 file changed, 3 insertions(+), 5 deletions(-)

diff --git a/core/query/sql.ml b/core/query/sql.ml
index 0402e24b4..ab49c3a09 100644
--- a/core/query/sql.ml
+++ b/core/query/sql.ml
@@ -144,6 +144,7 @@ let pp_comma_separated pp_item = Format.pp_print_list ~pp_sep:pp_comma pp_item
 
 let rec pr_query quote ignore_fields ppf q =
   let pp_quote ppf q = Format.pp_print_string ppf (quote q) in
+  let tables_to_string = List.map (fun (t, x) -> Format.asprintf "%a as %s" pp_quote t (string_of_table_var x)) in
 
   let pr_q = pr_query quote ignore_fields in
   let pr_b = pr_base quote false in
@@ -214,8 +215,7 @@ let rec pr_query quote ignore_fields ppf q =
     | Select (fields, tables, condition, os) ->
         (* using quote_field assumes tables contains table names (not nested queries) *)
         (* FIXME: type Select forces tables to be list((table name, var)), but it can have subqueries instead of plain table names in general cases *)
-        let tables = List.map (fun (t, x) -> Format.asprintf "%a as %s" pp_quote t (string_of_table_var x)) tables in
-        pr_select ppf fields tables condition os
+        pr_select ppf fields (tables_to_string tables) condition os
     | Delete { del_table; del_where } ->
         pr_delete ppf del_table del_where
     | Update { upd_table; upd_fields; upd_where } ->
@@ -227,10 +227,8 @@ let rec pr_query quote ignore_fields ppf q =
         | Select (fields, tables, condition, os) ->
             (* Inline the query *)
             (* FIXME: should emitting standard SQL WITH expressions here, move inline to a separate preprocessing step *)
-            let tables = List.map (fun (t, x) -> Format.asprintf "%a as %s" pp_quote t (string_of_table_var x)) tables in
-            let pr_q = pr_query quote ignore_fields in
             let q = Format.asprintf "(%s) as %s" (Format.asprintf "%a" pr_q q) (string_of_table_var z) in
-            pr_select ppf fields (q::tables) condition os
+            pr_select ppf fields (q::(tables_to_string tables)) condition os
         | _ -> assert false
 
 and pr_base quote one_table ppf b =

From 5eb6b12fbed8458a6b908cd8bf39b69e3ac56a8e Mon Sep 17 00:00:00 2001
From: Emanon42 <EmanonTang@outlook.com>
Date: Tue, 7 Jul 2020 18:34:28 +0100
Subject: [PATCH 19/50] improve by james advice

---
 core/query/sql.ml | 26 ++++++++++++++++----------
 1 file changed, 16 insertions(+), 10 deletions(-)

diff --git a/core/query/sql.ml b/core/query/sql.ml
index ab49c3a09..f5ee5d744 100644
--- a/core/query/sql.ml
+++ b/core/query/sql.ml
@@ -75,6 +75,7 @@ module Arithmetic :
 sig
   val is : string -> bool
   val gen : (string * string * string) -> string
+  val sql_name : string -> string
 end =
 struct
   let builtin_ops =
@@ -197,7 +198,7 @@ let rec pr_query quote ignore_fields ppf q =
       (pp_comma_separated pp_value) values
   in
   match q with
-    | UnionAll ([], _) -> Format.fprintf ppf "%a" Format.pp_print_string "select 42 as \"@unit@\" where false"
+    | UnionAll ([], _) -> Format.pp_print_string ppf "select 42 as \"@unit@\" where false"
     | UnionAll ([q], n) -> Format.fprintf ppf "%a%a" pr_q q Format.pp_print_string (order_by_clause n)
     | UnionAll (qs, n) ->
       let pp_sep_union ppf () = Format.fprintf ppf " union all " in
@@ -232,11 +233,11 @@ let rec pr_query quote ignore_fields ppf q =
         | _ -> assert false
 
 and pr_base quote one_table ppf b =
-  let string_of_projection quote one_table (var, label) =
+  let pp_projection quote one_table ppf (var, label) =
   if one_table then
-    quote label
+    Format.pp_print_string ppf (quote label)
   else
-    Format.asprintf "%s.%s" (string_of_table_var var) (quote label)
+    Format.fprintf ppf "%s.%s" (string_of_table_var var) (quote label)
   in
   let pr_b_one_table = pr_base quote one_table in
   let pr_q_true = pr_query quote true in
@@ -256,15 +257,20 @@ and pr_base quote one_table ppf b =
       | "negate" | "negatef" -> "-"
       | "intToString" | "stringToInt" | "intToFloat" | "floatToString" | "stringToFloat" -> ""
       | _ -> assert false
+  in
+  let pp_sql_arithmetic ppf (l, op, r) =
+    match op with
+      | "/" -> Format.fprintf ppf "floor(%a/%a)" pr_b_one_table l pr_b_one_table r
+      | "^" -> Format.fprintf ppf "floor(pow(%a,%a))" pr_b_one_table l pr_b_one_table r
+      | "^." -> Format.fprintf ppf "pow(%a,%a)" pr_b_one_table l pr_b_one_table r
+      | _ -> Format.fprintf ppf "(%a%s%a)" pr_b_one_table l (Arithmetic.sql_name op) pr_b_one_table r
   in
     match b with
       | Case (c, t, e) -> Format.fprintf ppf "case when %a then %a else %a end" pr_b_one_table c pr_b_one_table t pr_b_one_table e
       | Constant c -> Format.pp_print_string ppf (Constant.to_string c)
-      | Project (var, label) -> Format.pp_print_string ppf (string_of_projection quote one_table (var, label))
-      | Apply (op, [l; r]) when Arithmetic.is op ->
-        let l = Format.asprintf "%a" pr_b_one_table l in
-        let r = Format.asprintf "%a" pr_b_one_table r in
-        Format.fprintf ppf "%a" Format.pp_print_string (Arithmetic.gen (l, op, r))
+      | Project (var, label) -> pp_projection quote one_table ppf (var, label)
+      | Apply (op, [l; r]) when Arithmetic.is op -> pp_sql_arithmetic ppf (l, op, r)
+      (* special case: not empty is translated to exists *)
       | Apply ("not", [Empty q]) -> Format.fprintf ppf "exists (%a)" pr_q_true q
       | Apply (uop, [v]) when StringSet.mem uop unary_ops -> Format.fprintf ppf "%s(%a)" (unary_map uop) pr_b_one_table v
 
@@ -277,7 +283,7 @@ and pr_base quote one_table ppf b =
       | Empty q -> Format.fprintf ppf "not exists (%a)" pr_q_true q
       | Length q -> Format.fprintf ppf "select count(*) from (%a) as %a" pr_q_true q Format.pp_print_string (fresh_dummy_var ())
       | RowNumber [] -> Format.fprintf ppf "%a" Format.pp_print_string "1"
-      | RowNumber ps -> Format.fprintf ppf "row_number() over (order by %a)" Format.pp_print_string (String.concat "," (List.map (string_of_projection quote one_table) ps))
+      | RowNumber ps -> Format.fprintf ppf "row_number() over (order by %a)" (pp_comma_separated (pp_projection quote one_table)) ps
 
 let string_of_base quote one_table b =
   Format.asprintf "%a" (pr_base quote one_table) b

From f9780db0d5c86a3049d4a788160390d68707cea0 Mon Sep 17 00:00:00 2001
From: Emanon42 <EmanonTang@outlook.com>
Date: Tue, 7 Jul 2020 18:35:37 +0100
Subject: [PATCH 20/50] sweep the code

---
 core/query/sql.ml | 2 --
 1 file changed, 2 deletions(-)

diff --git a/core/query/sql.ml b/core/query/sql.ml
index f5ee5d744..77011ab96 100644
--- a/core/query/sql.ml
+++ b/core/query/sql.ml
@@ -30,8 +30,6 @@ and base =
   | RowNumber of (Var.var * string) list
     [@@deriving show]
 
-type 'a fmt_fn = Format.formatter -> 'a -> unit
-
 (* optimizing smart constructor for && *)
 let smart_and c c' =
   let open Constant in

From 4e7881e6712525ef96ebacdf4ab9eaf056ba327a Mon Sep 17 00:00:00 2001
From: Emanon42 <EmanonTang@outlook.com>
Date: Tue, 7 Jul 2020 18:40:07 +0100
Subject: [PATCH 21/50] add delete where unit test

---
 tests/database/factorials.links | 6 ++++++
 1 file changed, 6 insertions(+)

diff --git a/tests/database/factorials.links b/tests/database/factorials.links
index 2264d237c..448d41458 100644
--- a/tests/database/factorials.links
+++ b/tests/database/factorials.links
@@ -5,6 +5,11 @@ fun deleteAll() {
   delete (x <-- factorials);
 }
 
+fun deleteWhere() {
+  delete (x <-- factorials)
+  where (x.i == 2);
+}
+
 fun insertNone() {
   insert factorials
   values (i, f)
@@ -65,6 +70,7 @@ fun trivialNested2() server {
 
 fun test() {
   deleteAll();
+  deleteWhere();
   assertEq(lookupFactorials(10), []);
   assertEq(insertReturningOne(), 1);
   assertEq(lookupFactorials(10), [(f=1,i=1)]);

From 719ac5f6a52d36749aeb7fc492b8994a3ea863a2 Mon Sep 17 00:00:00 2001
From: Emanon42 <EmanonTang@outlook.com>
Date: Tue, 14 Jul 2020 18:06:56 +0100
Subject: [PATCH 22/50] add pattern matching sugared node

---
 core/desugarFuns.ml       | 26 ++++++++++++--------------
 core/desugarInners.ml     |  3 ++-
 core/desugarModules.ml    | 24 ++++++++++++++----------
 core/lens_sugar_conv.ml   |  4 ++--
 core/renamer.ml           | 28 ++++++++++++++++------------
 core/sugarConstructors.ml |  6 +++---
 core/sugarTraversals.ml   | 28 +++++++++++++++++++---------
 core/sugartoir.ml         |  5 +++--
 core/sugartypes.ml        | 17 +++++++++++++++--
 core/transformSugar.ml    | 23 ++++++++++++++---------
 10 files changed, 100 insertions(+), 64 deletions(-)

diff --git a/core/desugarFuns.ml b/core/desugarFuns.ml
index fe8b7abba..ee0442035 100644
--- a/core/desugarFuns.ml
+++ b/core/desugarFuns.ml
@@ -59,17 +59,15 @@ let unwrap_def (bndr, linearity, (tyvars, lam), location) =
   let ft = Binder.to_type bndr in
   let rt = TypeUtils.return_type ft in
   let lam =
-    let rec make_lam t : funlit -> funlit =
-      function
-        | ([_ps], _body) as lam -> lam
-        | (ps::pss, body) ->
-            let g = gensym ~prefix:"_fun_" () in
-            let rt = TypeUtils.return_type t in
-              ([ps], block
-                  ([fun_binding' ~linearity ~location (binder ~ty:t g)
-                                 (make_lam rt (pss, body))],
-                   freeze_var g))
-        | _, _ -> assert false
+    let rec make_lam t funlit =
+      match funlit with
+        | NormalFunlit ([_ps], _body) -> NormalFunlit ([_ps], _body)
+        | NormalFunlit (ps::pss, body) -> 
+          let g = gensym ~prefix:"_fun_" () in
+          let rt = TypeUtils.return_type t in
+            NormalFunlit ([ps], block ([fun_binding' ~linearity ~location (binder ~ty:t g) (make_lam rt (NormalFunlit (pss, body)))], freeze_var g))
+        | NormalFunlit (_,_) -> assert false (*TODO: matchfunlit *)
+        | MatchFunlit (_, _) -> assert false (*TODO: matchfunlit *)
     in make_lam rt lam
   in (binder ~ty:ft f, linearity, (tyvars, lam), location)
 
@@ -141,7 +139,7 @@ object (o : 'self_type)
         let tyvars = List.map SugarQuantifier.mk_resolved [ab; rhob; effb] in
         let e : phrasenode =
           block_node
-            ([fun_binding' ~tyvars:tyvars (binder ~ty:ft f) (pss, body)],
+            ([fun_binding' ~tyvars:tyvars (binder ~ty:ft f) (NormalFunlit (pss, body))],
              freeze_var f)
         in (o, e, ft)
     | e -> super#phrasenode e
@@ -186,13 +184,13 @@ object
     | e -> super#phrasenode e
 
   method! bindingnode = function
-    | Fun { fun_definition = (_, ([_], _)); _ } as b -> super#bindingnode b
+    | Fun { fun_definition = (_, (NormalFunlit ([_], _))); _ } as b -> super#bindingnode b
     | Fun _ -> {< has_no_funs = false >}
     | Funs defs as b ->
         if
           List.exists
             (function
-               | {WithPos.node={ rec_definition = (_, ([_], _)); _ }; _ } -> false
+               | {WithPos.node={ rec_definition = (_, (NormalFunlit ([_], _))); _ }; _ } -> false
                | _ -> true) defs
         then
           {< has_no_funs = false >}
diff --git a/core/desugarInners.ml b/core/desugarInners.ml
index 0181f8f9c..ff24a6322 100644
--- a/core/desugarInners.ml
+++ b/core/desugarInners.ml
@@ -172,7 +172,8 @@ object (o : 'self_type)
                let o = o#with_visiting (StringSet.add (Binder.to_name rec_binder) visiting_funs) in
                let (o, tyvars) = o#quantifiers tyvars in
                let (o, inner) = o#datatype inner in
-               let inner_effects = TransformSugar.fun_effects inner (fst lam) in
+               let lam_in = match lam with | NormalFunlit x -> x | MatchFunlit _ -> assert false in (*TODO: matchfunlit *)
+               let inner_effects = TransformSugar.fun_effects inner (fst lam_in) in
                let (o, lam, _) = o#funlit inner_effects lam in
                let o = o#restore_quantifiers outer_tyvars in
                let o = o#with_visiting visiting_funs in
diff --git a/core/desugarModules.ml b/core/desugarModules.ml
index 1ebb44797..6d46d4251 100644
--- a/core/desugarModules.ml
+++ b/core/desugarModules.ml
@@ -307,16 +307,20 @@ and desugar ?(toplevel=false) (renamer' : Epithet.t) (scope' : Scope.t) =
         raise (Errors.module_error ~pos (Printf.sprintf "Unbound module %s" (Scope.Resolve.best_guess path)))
 
     method! funlit : funlit -> funlit
-      = fun (paramss, body) ->
-      let visitor = self#clone in
-      let paramss' =
-        List.map
-          (fun params ->
-            List.map (fun param -> visitor#pattern param) params)
-          paramss
-      in
-      let body' = visitor#phrase body in
-      (paramss', body')
+      = fun f ->
+      match f with
+        | NormalFunlit (paramss, body) -> 
+          let visitor = self#clone in
+          let paramss' =
+            List.map
+              (fun params ->
+                List.map (fun param -> visitor#pattern param) params)
+              paramss
+          in
+          let body' = visitor#phrase body in
+          NormalFunlit (paramss', body')
+        | MatchFunlit (_,_) -> assert false (*TODO: matchfunlit *)
+
 
     method cases : (Pattern.with_pos * phrase) list -> (Pattern.with_pos * phrase) list
       = fun cases ->
diff --git a/core/lens_sugar_conv.ml b/core/lens_sugar_conv.ml
index 78e160d5d..48acfc192 100644
--- a/core/lens_sugar_conv.ml
+++ b/core/lens_sugar_conv.ml
@@ -61,7 +61,7 @@ let is_static _typ p =
        if body contains any external references. If it does, then it is dynamic,
        otherwise it is static. *)
   match WithPos.node p with
-  | S.FunLit (_, _, ([ [ var ] ], body), _) -> (
+  | S.FunLit (_, _, Sugartypes.NormalFunlit ([ [ var ] ], body), _) -> (
       let var = WithPos.node var in
       match var with
       | S.Pattern.Variable x -> no_ext_deps x body
@@ -105,7 +105,7 @@ let rec lens_sugar_phrase_of_body v p =
 
 let lens_sugar_phrase_of_sugar p =
   ( match WithPos.node p with
-  | S.FunLit (_, _, ([ [ var ] ], body), _) -> (
+  | S.FunLit (_, _, Sugartypes.NormalFunlit ([ [ var ] ], body), _) -> (
       let var = WithPos.node var in
       match var with
       | S.Pattern.Variable x ->
diff --git a/core/renamer.ml b/core/renamer.ml
index dcbac4fb2..eda404e11 100644
--- a/core/renamer.ml
+++ b/core/renamer.ml
@@ -135,18 +135,19 @@ let renamer qs_from qs_to =
            function_definition -> 'self * function_definition
      = fun { fun_binder
            ; fun_linearity
-           ; fun_definition = (tyvars, (pats, body))
+           ; fun_definition = (tyvars, f)
            ; fun_location
            ; fun_signature
            ; fun_frozen
            ; fun_unsafe_signature } ->
      let o, (pats', tyvars', typ', _, signature', body') =
-       o#handle_function pats tyvars (Binder.to_type fun_binder) None
-                         fun_signature body in
+       match f with 
+        | NormalFunlit (pats, body) -> o#handle_function pats tyvars (Binder.to_type fun_binder) None fun_signature body 
+        | MatchFunlit (_,_) -> assert false in (*TODO: matchfunlit *)
      let function_definition' =
        { fun_binder = Binder.set_type fun_binder typ'
        ; fun_linearity
-       ; fun_definition = (tyvars', (pats', body'))
+       ; fun_definition = (tyvars', NormalFunlit (pats', body')) (*TODO: matchfunlit *)
        ; fun_location
        ; fun_signature = signature'
        ; fun_frozen
@@ -158,18 +159,19 @@ let renamer qs_from qs_to =
              recursive_functionnode -> 'self * recursive_functionnode
        = fun { rec_binder
              ; rec_linearity
-             ; rec_definition = ((tyvars, ty), (pats, body))
+             ; rec_definition = ((tyvars, ty), f)
              ; rec_location
              ; rec_signature
              ; rec_unsafe_signature
              ; rec_frozen } ->
        let o, (pats', tyvars', typ', ty', signature', body') =
-         o#handle_function pats tyvars (Binder.to_type rec_binder) ty
-                           rec_signature body in
+         match f with
+          | NormalFunlit (pats, body) -> o#handle_function pats tyvars (Binder.to_type rec_binder) ty rec_signature body 
+          | MatchFunlit (_,_) -> assert false in (*TODO: matchfunlit *)
        let recursive_definition' =
          { rec_binder = Binder.set_type rec_binder typ'
          ; rec_linearity
-         ; rec_definition = ((tyvars', ty'), (pats', body'))
+         ; rec_definition = ((tyvars', ty'), NormalFunlit (pats', body')) (*TODO: matchfunlit *)
          ; rec_location
          ; rec_signature = signature'
          ; rec_unsafe_signature
@@ -213,11 +215,12 @@ let renamer qs_from qs_to =
 let rename_function_definition : function_definition -> function_definition =
   fun { fun_binder
       ; fun_linearity
-      ; fun_definition = (tyvars_from, (pats, body))
+      ; fun_definition = (tyvars_from, f)
       ; fun_location
       ; fun_signature
       ; fun_frozen
       ; fun_unsafe_signature } ->
+  let (pats, body) = match f with | NormalFunlit (ps, bd) -> (ps, bd) | MatchFunlit (_,_) -> assert false in (*TODO: matchfunlit *)
   let qs_from = List.map SugarQuantifier.get_resolved_exn tyvars_from in
   let qs_to, _      = Instantiate.build_fresh_quantifiers qs_from in
   let tyvars_to     = List.map SugarQuantifier.mk_resolved qs_to in
@@ -228,7 +231,7 @@ let rename_function_definition : function_definition -> function_definition =
   let _, signature' = o#option (fun o -> o#datatype') fun_signature in
   { fun_binder =  Binder.set_type fun_binder typ'
   ; fun_linearity
-  ; fun_definition = (tyvars_to, (pats', body'))
+  ; fun_definition = (tyvars_to, NormalFunlit (pats', body')) (*TODO: matchfunlit *)
   ; fun_location
   ; fun_signature = signature'
   ; fun_frozen
@@ -239,11 +242,12 @@ let rename_recursive_functionnode :
       recursive_functionnode -> recursive_functionnode =
   fun { rec_binder
       ; rec_linearity
-      ; rec_definition = ((tyvars_from, ty), (pats, body))
+      ; rec_definition = ((tyvars_from, ty), f)
       ; rec_location
       ; rec_signature
       ; rec_frozen
       ; rec_unsafe_signature } ->
+  let (pats, body) = match f with | NormalFunlit (ps, bd) -> (ps, bd) | MatchFunlit (_,_) -> assert false in (*TODO: matchfunlit *)
   let qs_from = List.map SugarQuantifier.get_resolved_exn tyvars_from in
   let qs_to, _      = Instantiate.build_fresh_quantifiers qs_from in
   let tyvars_to     = List.map SugarQuantifier.mk_resolved qs_to in
@@ -255,7 +259,7 @@ let rename_recursive_functionnode :
   let _, signature' = o#option (fun o -> o#datatype') rec_signature in
   { rec_binder =  Binder.set_type rec_binder typ'
   ; rec_linearity
-  ; rec_definition = ((tyvars_to, ty'), (pats', body'))
+  ; rec_definition = ((tyvars_to, ty'), NormalFunlit (pats', body')) (*TODO: matchfunlit *)
   ; rec_location
   ; rec_signature = signature'
   ; rec_frozen
diff --git a/core/sugarConstructors.ml b/core/sugarConstructors.ml
index 964e6b676..c0a32952c 100644
--- a/core/sugarConstructors.ml
+++ b/core/sugarConstructors.ml
@@ -132,9 +132,9 @@ module SugarConstructors (Position : Pos)
 
   (** Various phrases *)
 
-  (* Create a FunLit. *)
+  (* Create a Normal FunLit. *)
   let fun_lit ?(ppos=dp) ?args ?(location=loc_unknown) linearity pats blk =
-    with_pos ppos (FunLit (args, linearity, (pats, blk), location))
+    with_pos ppos (FunLit (args, linearity, NormalFunlit (pats, blk), location))
 
   (* Create a Spawn. *)
   let spawn ?(ppos=dp) ?row spawn_kind location blk =
@@ -156,7 +156,7 @@ module SugarConstructors (Position : Pos)
     let fun_signature = datatype_opt_of_sig_opt sig_opt bndr in
     with_pos ppos (Fun { fun_binder = binder bndr;
                          fun_linearity = linearity;
-                         fun_definition = ([], (args, blk));
+                         fun_definition = ([], NormalFunlit (args, blk));
                          fun_location = location;
                          fun_signature;
                          fun_frozen = frozen;
diff --git a/core/sugarTraversals.ml b/core/sugarTraversals.ml
index f2368808c..01c24ffa3 100644
--- a/core/sugarTraversals.ml
+++ b/core/sugarTraversals.ml
@@ -559,9 +559,12 @@ class map =
           let _x_i1 = o#phrase _x_i1 in Table ((_x, _x_i1))
 
     method funlit : funlit -> funlit =
-      fun (_x, _x_i1) ->
-        let _x = o#list (fun o -> o#list (fun o -> o#pattern)) _x in
-        let _x_i1 = o#phrase _x_i1 in (_x, _x_i1)
+      fun f ->
+        match f with 
+          | NormalFunlit (_x, _x_i1) -> 
+            let _x = o#list (fun o -> o#list (fun o -> o#pattern)) _x in
+            let _x_i1 = o#phrase _x_i1 in NormalFunlit (_x, _x_i1) (*TODO: matchfunlit *)
+          | MatchFunlit (_,_) -> assert false
 
     method handle_params : handler_parameterisation -> handler_parameterisation =
       fun { shp_bindings; shp_types }->
@@ -1287,9 +1290,13 @@ class fold =
           let o = o#pattern _x in let o = o#phrase _x_i1 in o
 
     method funlit : funlit -> 'self_type =
-      fun (_x, _x_i1) ->
-        let o = o#list (fun o -> o#list (fun o -> o#pattern)) _x in
-        let o = o#phrase _x_i1 in o
+      fun f ->
+        match f with 
+          | NormalFunlit (_x, _x_i1) -> 
+            let o = o#list (fun o -> o#list (fun o -> o#pattern)) _x in
+            let o = o#phrase _x_i1 in o
+          | MatchFunlit (_,_) -> assert false (*TODO: matchfunlit *)
+
 
     method handle_params : handler_parameterisation -> 'self_type =
       fun params ->
@@ -2115,9 +2122,12 @@ class fold_map =
           let (o, _x_i1) = o#phrase _x_i1 in (o, (Table ((_x, _x_i1))))
 
     method funlit : funlit -> ('self_type * funlit) =
-      fun (_x, _x_i1) ->
-        let (o, _x) = o#list (fun o -> o#list (fun o -> o#pattern)) _x in
-        let (o, _x_i1) = o#phrase _x_i1 in (o, (_x, _x_i1))
+      fun f ->
+        match f with 
+          | NormalFunlit (_x, _x_i1) -> 
+            let (o, _x) = o#list (fun o -> o#list (fun o -> o#pattern)) _x in
+            let (o, _x_i1) = o#phrase _x_i1 in (o, NormalFunlit (_x, _x_i1))
+          | MatchFunlit (_,_) -> assert false (*TODO: matchfunlit *)
 
     method handle_params : handler_parameterisation -> ('self_type * handler_parameterisation) =
       fun { shp_bindings; shp_types } ->
diff --git a/core/sugartoir.ml b/core/sugartoir.ml
index e6794c411..176e8610d 100644
--- a/core/sugartoir.ml
+++ b/core/sugartoir.ml
@@ -1140,7 +1140,7 @@ struct
                     let ss = eval_bindings scope env' bs e in
                       I.comp env (p, s, ss)
                 | Fun { fun_binder           = bndr;
-                        fun_definition       = (tyvars, ([ps], body));
+                        fun_definition       = (tyvars, NormalFunlit ([ps], body)); (*TODO: matchfunlit *)
                         fun_location         = location;
                         fun_unsafe_signature = unsafe; _ }
                      when Binder.has_type bndr ->
@@ -1177,9 +1177,10 @@ struct
                     let defs =
                       List.map
                         (fun { rec_binder           = bndr;
-                               rec_definition       = ((tyvars, _), (pss, body));
+                               rec_definition       = ((tyvars, _), fnlit); 
                                rec_location         = location;
                                rec_unsafe_signature = unsafe; _ } ->
+                          let (pss, body) = match fnlit with | NormalFunlit (pss, body) -> (pss, body) | MatchFunlit (_,_) -> assert false in (*TODO: matchfunlit *)
                           assert (List.length pss = 1);
                           let f  = Binder.to_name bndr in
                           let ft = Binder.to_type bndr in
diff --git a/core/sugartypes.ml b/core/sugartypes.ml
index 0758a4970..dc24d60e1 100644
--- a/core/sugartypes.ml
+++ b/core/sugartypes.ml
@@ -369,7 +369,10 @@ and regex =
   | Splice    of phrase
   | Replace   of regex * replace_rhs
 and clause = Pattern.with_pos * phrase
-and funlit = Pattern.with_pos list list * phrase
+and funlit = NormalFunlit of normal_funlit | MatchFunlit of match_funlit
+and match_funlit = Pattern.with_pos list list * match_body
+and match_body = (Pattern.with_pos * phrase) list
+and normal_funlit = Pattern.with_pos list list * phrase
 and handler =
   { sh_expr         : phrase
   ; sh_effect_cases : clause list
@@ -766,8 +769,18 @@ struct
            let fvs'' = diff fvs' bnd in
            union bnd bnd', union fvs fvs'')
          (empty, empty) members
-  and funlit (args, body : funlit) : StringSet.t =
+  and funlit (fn : funlit) : StringSet.t =
+    match fn with
+    | NormalFunlit n_fn -> normal_funlit n_fn
+    | MatchFunlit m_fn -> match_funlit m_fn
+  and normal_funlit (args, body : normal_funlit) : StringSet.t = 
     diff (phrase body) (union_map (union_map pattern) args)
+  and match_funlit (args, body : match_funlit) : StringSet.t = 
+    diff (match_body body) (union_map (union_map pattern) args)
+  and match_body (body : (Pattern.with_pos * phrase) list) : StringSet.t = 
+    union_map (fun (pat, phr) -> union (pattern pat) (phrase phr)) body
+  (* and funlit (args, body : funlit) : StringSet.t =
+    diff (phrase body) (union_map (union_map pattern) args) *)
   and block (binds, expr : binding list * phrase) : StringSet.t =
     ListLabels.fold_right binds ~init:(phrase expr)
       ~f:(fun bind bodyfree ->
diff --git a/core/transformSugar.ml b/core/transformSugar.ml
index a1565eb27..fdf2bbbf0 100644
--- a/core/transformSugar.ml
+++ b/core/transformSugar.ml
@@ -724,13 +724,16 @@ class transform (env : Types.typing_environment) =
           (o, Sugartypes.Table (p, e))
 
     method funlit : Types.row -> funlit -> ('self_type * funlit * Types.datatype) =
-      fun inner_eff (pss, e) ->
-        let envs = o#backup_envs in
-        let (o, pss) = listu o (fun o -> listu o (fun o -> o#pattern)) pss in
-        let o = o#with_effects inner_eff in
-        let (o, e, t) = o#phrase e in
-        let o = o#restore_envs envs in
-        (o, (pss, e), t)
+      fun inner_eff f ->
+        match f with 
+          | NormalFunlit (pss, e) ->
+            let envs = o#backup_envs in
+            let (o, pss) = listu o (fun o -> listu o (fun o -> o#pattern)) pss in
+            let o = o#with_effects inner_eff in
+            let (o, e, t) = o#phrase e in
+            let o = o#restore_envs envs in
+            (o, NormalFunlit (pss, e), t)
+          | MatchFunlit (_,_) -> assert false (*TODO: matchfunlit *)
 
     method constant : Constant.t -> ('self_type * Constant.t * Types.datatype) =
       function
@@ -753,7 +756,8 @@ class transform (env : Types.typing_environment) =
           | {node={ rec_definition = ((tyvars, Some (inner, extras)), lam); _ } as fn; pos} :: defs ->
               let (o, tyvars) = o#quantifiers tyvars in
               let (o, inner) = o#datatype inner in
-              let inner_effects = fun_effects inner (fst lam) in
+              let lam_in = match lam with | NormalFunlit x -> x | MatchFunlit _ -> assert false in (*TODO: matchfunlit *)
+              let inner_effects = fun_effects inner (fst lam_in) in
               let (o, lam, _) = o#funlit inner_effects lam in
               let o = o#restore_quantifiers outer_tyvars in
               let (o, defs) = list o defs in
@@ -800,7 +804,8 @@ class transform (env : Types.typing_environment) =
            when Binder.has_type fun_binder ->
          let outer_tyvars = o#backup_quantifiers in
          let (o, tyvars) = o#quantifiers tyvars in
-         let inner_effects = fun_effects (Binder.to_type fun_binder) (fst lam) in
+         let lam_in = match lam with | NormalFunlit x -> x | MatchFunlit _ -> assert false in (*TODO: matchfunlit *)
+         let inner_effects = fun_effects (Binder.to_type fun_binder) (fst lam_in) in
          let (o, lam, _) = o#funlit inner_effects lam in
          let o = o#restore_quantifiers outer_tyvars in
          let (o, fun_binder) = o#binder fun_binder in

From 47cdf678f966987aa59cdbf9134afa0cdb7aeafd Mon Sep 17 00:00:00 2001
From: Emanon42 <EmanonTang@outlook.com>
Date: Mon, 20 Jul 2020 19:18:24 +0100
Subject: [PATCH 23/50] add some traversal

---
 core/desugarFuns.ml       |  2 +-
 core/desugarModules.ml    | 12 ++++++++++--
 core/lens_sugar_conv.ml   |  1 +
 core/sugarConstructors.ml | 19 +++++++++++--------
 core/sugartypes.ml        |  2 +-
 5 files changed, 24 insertions(+), 12 deletions(-)

diff --git a/core/desugarFuns.ml b/core/desugarFuns.ml
index ee0442035..6f594aca7 100644
--- a/core/desugarFuns.ml
+++ b/core/desugarFuns.ml
@@ -66,7 +66,7 @@ let unwrap_def (bndr, linearity, (tyvars, lam), location) =
           let g = gensym ~prefix:"_fun_" () in
           let rt = TypeUtils.return_type t in
             NormalFunlit ([ps], block ([fun_binding' ~linearity ~location (binder ~ty:t g) (make_lam rt (NormalFunlit (pss, body)))], freeze_var g))
-        | NormalFunlit (_,_) -> assert false (*TODO: matchfunlit *)
+        | NormalFunlit (_,_) -> assert false
         | MatchFunlit (_, _) -> assert false (*TODO: matchfunlit *)
     in make_lam rt lam
   in (binder ~ty:ft f, linearity, (tyvars, lam), location)
diff --git a/core/desugarModules.ml b/core/desugarModules.ml
index 6d46d4251..51a46cc64 100644
--- a/core/desugarModules.ml
+++ b/core/desugarModules.ml
@@ -319,8 +319,16 @@ and desugar ?(toplevel=false) (renamer' : Epithet.t) (scope' : Scope.t) =
           in
           let body' = visitor#phrase body in
           NormalFunlit (paramss', body')
-        | MatchFunlit (_,_) -> assert false (*TODO: matchfunlit *)
-
+        | MatchFunlit (paramss, body) -> 
+          let visitor = self#clone in
+          let paramss' =
+            List.map
+              (fun params ->
+                List.map (fun param -> visitor#pattern param) params)
+              paramss
+          in
+          let body' = list.map (fun (pat, blk) -> visitor#pattern pat; visitor#phrase blk) body in
+          MatchFunlit (paramss', body')
 
     method cases : (Pattern.with_pos * phrase) list -> (Pattern.with_pos * phrase) list
       = fun cases ->
diff --git a/core/lens_sugar_conv.ml b/core/lens_sugar_conv.ml
index 48acfc192..a544cf81c 100644
--- a/core/lens_sugar_conv.ml
+++ b/core/lens_sugar_conv.ml
@@ -113,5 +113,6 @@ let lens_sugar_phrase_of_sugar p =
       | _ ->
           Format.asprintf "Unsupported binder: %a" S.pp_phrase p
           |> Error.internal_error_res )
+  | S.FunLit (_, _, Sugartypes.MatchFunlit ([ [ var ] ], body), _) -> assert False 
   | _ -> lens_sugar_phrase_of_body "" p )
   |> Result.ok_exn
diff --git a/core/sugarConstructors.ml b/core/sugarConstructors.ml
index c0a32952c..14f9cc5ed 100644
--- a/core/sugarConstructors.ml
+++ b/core/sugarConstructors.ml
@@ -134,7 +134,9 @@ module SugarConstructors (Position : Pos)
 
   (* Create a Normal FunLit. *)
   let fun_lit ?(ppos=dp) ?args ?(location=loc_unknown) linearity pats blk =
-    with_pos ppos (FunLit (args, linearity, NormalFunlit (pats, blk), location))
+    match blk with 
+      | MatchBody mb -> with_pos ppos (FunLit (args, linearity, MatchFunlit (pats, mb), location))
+      | _ -> with_pos ppos (FunLit (args, linearity, NormalFunlit (pats, blk), location))
 
   (* Create a Spawn. *)
   let spawn ?(ppos=dp) ?row spawn_kind location blk =
@@ -154,13 +156,14 @@ module SugarConstructors (Position : Pos)
   (* Create a function binding. *)
   let fun_binding ?(ppos=dp) sig_opt ?(unsafe_sig=false) ((linearity, frozen), bndr, args, location, blk) =
     let fun_signature = datatype_opt_of_sig_opt sig_opt bndr in
-    with_pos ppos (Fun { fun_binder = binder bndr;
-                         fun_linearity = linearity;
-                         fun_definition = ([], NormalFunlit (args, blk));
-                         fun_location = location;
-                         fun_signature;
-                         fun_frozen = frozen;
-                         fun_unsafe_signature = unsafe_sig })
+    let fun_def = match blk with | MatchBody mb -> ([], MatchFunlit (args, mb)) | _ -> ([], NormalFunlit (args, blk)) in
+      with_pos ppos (Fun { fun_binder = binder bndr;
+                           fun_linearity = linearity;
+                           fun_definition = fun_def;
+                           fun_location = location;
+                           fun_signature;
+                           fun_frozen = frozen;
+                           fun_unsafe_signature = unsafe_sig })
 
   let fun_binding' ?(ppos=dp) ?(linearity=dl_unl) ?(tyvars=[])
         ?(location=loc_unknown) ?annotation bndr fnlit =
diff --git a/core/sugartypes.ml b/core/sugartypes.ml
index dc24d60e1..072c6e29a 100644
--- a/core/sugartypes.ml
+++ b/core/sugartypes.ml
@@ -371,7 +371,7 @@ and regex =
 and clause = Pattern.with_pos * phrase
 and funlit = NormalFunlit of normal_funlit | MatchFunlit of match_funlit
 and match_funlit = Pattern.with_pos list list * match_body
-and match_body = (Pattern.with_pos * phrase) list
+and match_body = MatchBody of (Pattern.with_pos * phrase) list
 and normal_funlit = Pattern.with_pos list list * phrase
 and handler =
   { sh_expr         : phrase

From cca27e864ff785db50bcb00feb69a15aa8d47d5b Mon Sep 17 00:00:00 2001
From: Emanon42 <EmanonTang@outlook.com>
Date: Fri, 24 Jul 2020 13:49:04 +0100
Subject: [PATCH 24/50] fix type

---
 core/desugarModules.ml    | 2 +-
 core/lens_sugar_conv.ml   | 2 +-
 core/sugarConstructors.ml | 4 ++--
 core/sugartypes.ml        | 2 +-
 4 files changed, 5 insertions(+), 5 deletions(-)

diff --git a/core/desugarModules.ml b/core/desugarModules.ml
index 51a46cc64..bd55c2f2b 100644
--- a/core/desugarModules.ml
+++ b/core/desugarModules.ml
@@ -327,7 +327,7 @@ and desugar ?(toplevel=false) (renamer' : Epithet.t) (scope' : Scope.t) =
                 List.map (fun param -> visitor#pattern param) params)
               paramss
           in
-          let body' = list.map (fun (pat, blk) -> visitor#pattern pat; visitor#phrase blk) body in
+          let body' = visitor#cases body in
           MatchFunlit (paramss', body')
 
     method cases : (Pattern.with_pos * phrase) list -> (Pattern.with_pos * phrase) list
diff --git a/core/lens_sugar_conv.ml b/core/lens_sugar_conv.ml
index a544cf81c..b30417bd8 100644
--- a/core/lens_sugar_conv.ml
+++ b/core/lens_sugar_conv.ml
@@ -113,6 +113,6 @@ let lens_sugar_phrase_of_sugar p =
       | _ ->
           Format.asprintf "Unsupported binder: %a" S.pp_phrase p
           |> Error.internal_error_res )
-  | S.FunLit (_, _, Sugartypes.MatchFunlit ([ [ var ] ], body), _) -> assert False 
+  | S.FunLit (_, _, Sugartypes.MatchFunlit (_, _), _) -> assert false 
   | _ -> lens_sugar_phrase_of_body "" p )
   |> Result.ok_exn
diff --git a/core/sugarConstructors.ml b/core/sugarConstructors.ml
index 14f9cc5ed..51c5868c7 100644
--- a/core/sugarConstructors.ml
+++ b/core/sugarConstructors.ml
@@ -135,8 +135,8 @@ module SugarConstructors (Position : Pos)
   (* Create a Normal FunLit. *)
   let fun_lit ?(ppos=dp) ?args ?(location=loc_unknown) linearity pats blk =
     match blk with 
-      | MatchBody mb -> with_pos ppos (FunLit (args, linearity, MatchFunlit (pats, mb), location))
-      | _ -> with_pos ppos (FunLit (args, linearity, NormalFunlit (pats, blk), location))
+      | branch::branches as mb -> with_pos ppos (FunLit (args, linearity, MatchFunlit (pats, mb), location))
+      | blk -> with_pos ppos (FunLit (args, linearity, NormalFunlit (pats, blk), location)) (* blk can be either phrase or match_body *)
 
   (* Create a Spawn. *)
   let spawn ?(ppos=dp) ?row spawn_kind location blk =
diff --git a/core/sugartypes.ml b/core/sugartypes.ml
index 072c6e29a..dc24d60e1 100644
--- a/core/sugartypes.ml
+++ b/core/sugartypes.ml
@@ -371,7 +371,7 @@ and regex =
 and clause = Pattern.with_pos * phrase
 and funlit = NormalFunlit of normal_funlit | MatchFunlit of match_funlit
 and match_funlit = Pattern.with_pos list list * match_body
-and match_body = MatchBody of (Pattern.with_pos * phrase) list
+and match_body = (Pattern.with_pos * phrase) list
 and normal_funlit = Pattern.with_pos list list * phrase
 and handler =
   { sh_expr         : phrase

From 90fd8f5e728d0d842cd6bc272925dfa4177e870c Mon Sep 17 00:00:00 2001
From: Emanon42 <EmanonTang@outlook.com>
Date: Sat, 25 Jul 2020 16:10:40 +0100
Subject: [PATCH 25/50] add sugar to parser

---
 core/lexer.mll                |  2 ++
 core/parser.mly               | 13 +++++++++++++
 core/sugarConstructors.ml     | 19 ++++++++++++++-----
 core/sugarConstructorsIntf.ml |  9 +++++++++
 core/typeSugar.ml             | 19 +++++++++++--------
 5 files changed, 49 insertions(+), 13 deletions(-)

diff --git a/core/lexer.mll b/core/lexer.mll
index 5d9d0356d..c5d1d3209 100644
--- a/core/lexer.mll
+++ b/core/lexer.mll
@@ -225,6 +225,7 @@ rule lex ctxt nl = parse
   | '@'                                 { AT }
   | "%" def_id as var                   { PERCENTVAR var }
   | '%'                                 { PERCENT }
+  | '|'                                 { PIPE }
   | initopchar opchar * as op           { OPERATOR op }
   | '`' (def_id as var) '`'             { if List.mem_assoc var keywords || Char.isUpper var.[0] then
                                               raise (LexicalError (lexeme lexbuf, lexeme_end_p lexbuf))
@@ -242,6 +243,7 @@ rule lex ctxt nl = parse
   | "postfix"                           { FIXITY Associativity.Left }
   | "~fun"                              { FROZEN_FUN }
   | "~linfun"                           { FROZEN_LINFUN }
+  | "match"                             { MATCH }
   | def_id as var                       { try List.assoc var keywords
                                           with Not_found | NotFound _ ->
                                             if Char.isUpper var.[0] then CONSTRUCTOR var
diff --git a/core/parser.mly b/core/parser.mly
index b5661e30b..86b60c06d 100644
--- a/core/parser.mly
+++ b/core/parser.mly
@@ -286,6 +286,8 @@ let parse_foreign_language pos lang =
 %token LENS LENSDROP LENSSELECT LENSJOIN DETERMINED BY ON DELETE_LEFT
 %token LENSPUT LENSGET LENSCHECK LENSSERIAL
 %token READONLY DEFAULT
+%token MATCH
+%token PIPE
 %token ESCAPE
 %token CLIENT SERVER
 %token SEMICOLON
@@ -426,6 +428,8 @@ fun_declarations:
 fun_declaration:
 | tlfunbinding                                                 { fun_binding ~ppos:$loc($1) None $1 }
 | signatures tlfunbinding                                      { fun_binding ~ppos:$loc($2) (fst $1) ~unsafe_sig:(snd $1) $2 }
+| match_tlfunbinding                                           { match_fun_binding ~ppos:$loc($1) None $1 }
+| signatures match_tlfunbinding                                { match_fun_binding ~ppos:$loc($2) (fst $1) ~unsafe_sig:(snd $1) $2 }
 
 linearity:
 | FUN                                                          { dl_unl }
@@ -443,6 +447,15 @@ tlfunbinding:
 | OP OPERATOR pattern perhaps_location block                   { ((dl_unl, false), $2, [[$3]], $4, $5)          }
 | OP pattern OPERATOR perhaps_location block                   { ((dl_unl, false), $3, [[$2]], $4, $5)          }
 
+match_tlfunbinding:
+| fun_kind VARIABLE arg_lists perhaps_location match_body      { ($1, $2, $3, $4, $5)                }
+
+match_body:
+| MATCH LPAREN PIPE separated_list(PIPE, match_cases) RPAREN   { $4 }
+
+match_cases:
+| pattern RARROW block_contents                                { ($1, block ~ppos:$loc $3) }
+
 tlvarbinding:
 | VAR VARIABLE perhaps_location EQ exp                         { (PatName $2, $5, $3) }
 
diff --git a/core/sugarConstructors.ml b/core/sugarConstructors.ml
index 51c5868c7..27f0d223c 100644
--- a/core/sugarConstructors.ml
+++ b/core/sugarConstructors.ml
@@ -134,9 +134,10 @@ module SugarConstructors (Position : Pos)
 
   (* Create a Normal FunLit. *)
   let fun_lit ?(ppos=dp) ?args ?(location=loc_unknown) linearity pats blk =
-    match blk with 
-      | branch::branches as mb -> with_pos ppos (FunLit (args, linearity, MatchFunlit (pats, mb), location))
-      | blk -> with_pos ppos (FunLit (args, linearity, NormalFunlit (pats, blk), location)) (* blk can be either phrase or match_body *)
+    with_pos ppos (FunLit (args, linearity, NormalFunlit (pats, blk), location))
+
+  let match_fun_lit ?(ppos=dp) ?args ?(location=loc_unknown) linearity pats match_body =
+    with_pos ppos (FunLit (args, linearity, MatchFunlit (pats, match_body), location))
 
   (* Create a Spawn. *)
   let spawn ?(ppos=dp) ?row spawn_kind location blk =
@@ -156,10 +157,9 @@ module SugarConstructors (Position : Pos)
   (* Create a function binding. *)
   let fun_binding ?(ppos=dp) sig_opt ?(unsafe_sig=false) ((linearity, frozen), bndr, args, location, blk) =
     let fun_signature = datatype_opt_of_sig_opt sig_opt bndr in
-    let fun_def = match blk with | MatchBody mb -> ([], MatchFunlit (args, mb)) | _ -> ([], NormalFunlit (args, blk)) in
       with_pos ppos (Fun { fun_binder = binder bndr;
                            fun_linearity = linearity;
-                           fun_definition = fun_def;
+                           fun_definition = ([], NormalFunlit (args, blk));
                            fun_location = location;
                            fun_signature;
                            fun_frozen = frozen;
@@ -175,6 +175,15 @@ module SugarConstructors (Position : Pos)
                          fun_frozen = false;
                          fun_unsafe_signature = false })
 
+  let match_fun_binding ?(ppos=dp) sig_opt ?(unsafe_sig=false) ((linearity, frozen), bndr, args, location, blk) =
+    let fun_signature = datatype_opt_of_sig_opt sig_opt bndr in
+      with_pos ppos (Fun { fun_binder = binder bndr;
+                           fun_linearity = linearity;
+                           fun_definition = ([], MatchFunlit (args, blk));
+                           fun_location = location;
+                           fun_signature;
+                           fun_frozen = frozen;
+                           fun_unsafe_signature = unsafe_sig })
 
   (* Create a Val binding.  This function takes either a name for a variable
      pattern or an already constructed pattern.  In the latter case no signature
diff --git a/core/sugarConstructorsIntf.ml b/core/sugarConstructorsIntf.ml
index 2540e953a..0e3937c16 100644
--- a/core/sugarConstructorsIntf.ml
+++ b/core/sugarConstructorsIntf.ml
@@ -93,6 +93,11 @@ module type SugarConstructorsSig = sig
      -> ?location:Location.t -> DeclaredLinearity.t
      -> Pattern.with_pos list list -> phrase
      -> phrase
+  val match_fun_lit
+      : ?ppos:t -> ?args:((Types.datatype * Types.row) list)
+     -> ?location:Location.t -> DeclaredLinearity.t
+     -> Pattern.with_pos list list -> match_body
+     -> phrase
   val spawn
       : ?ppos:t
      -> ?row:Types.row -> spawn_kind -> given_spawn_location -> phrase
@@ -114,6 +119,10 @@ module type SugarConstructorsSig = sig
      -> ?location:Location.t -> ?annotation:datatype'
      -> Binder.with_pos -> funlit
      -> binding
+  val match_fun_binding
+      : ?ppos:t -> signature -> ?unsafe_sig:bool
+     -> ((DeclaredLinearity.t * bool) * Name.t * Pattern.with_pos list list * Location.t * match_body)
+     -> binding
   val val_binding'
       : ?ppos:t -> signature -> (name_or_pat * phrase * Location.t)
      -> binding
diff --git a/core/typeSugar.ml b/core/typeSugar.ml
index 8f5ee6450..3291c2fa6 100644
--- a/core/typeSugar.ml
+++ b/core/typeSugar.ml
@@ -2667,7 +2667,8 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * Usage.t =
                   List.iter (fun e' -> unify ~handle:Gripers.list_lit (pos_and_typ e, pos_and_typ e')) es;
                   ListLit (List.map erase (e::es), Some (typ e)), T.Application (Types.list, [PrimaryKind.Type, typ e]), Usage.combine_many (List.map usages (e::es))
             end
-        | FunLit (argss_prev, lin, (pats, body), location) ->
+        | FunLit (argss_prev, lin, fnlit, location) ->
+            let (pats, body) = match fnlit with | NormalFunlit (pat, body) -> (pat, body) | MatchFunlit (_,_) -> assert false in
             let vs = check_for_duplicate_names pos (List.flatten pats) in
             let (pats_init, pats_tail) = from_option ([], []) (unsnoc_opt pats) in
             let tpc' = if DeclaredLinearity.is_linear lin then tpc else tpcu in
@@ -2740,7 +2741,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * Usage.t =
               in
                 arg_types (ftype, curried_argument_count) in
 
-            let e = FunLit (Some argss, lin, (List.map (List.map erase_pat) pats, erase body), location) in
+            let e = FunLit (Some argss, lin, NormalFunlit (List.map (List.map erase_pat) pats, erase body), location) in
             let vs' = List.fold_right Ident.Set.add vs Ident.Set.empty in
             e, ftype, Usage.restrict (usages body) vs'
 
@@ -4193,13 +4194,13 @@ and type_binding : context -> binding -> binding * context * Usage.t =
       | Fun def ->
          let { fun_binder = bndr;
                fun_linearity = lin;
-               fun_definition = (_, (pats, body));
+               fun_definition = (_, fnlit);
                fun_location;
                fun_signature = t_ann';
                fun_frozen;
                fun_unsafe_signature = unsafe } =
            Renamer.rename_function_definition def in
-
+          let (pats, body) = match fnlit with | NormalFunlit (pats, body) -> (pats, body) | MatchFunlit (_,_) -> assert false in
           let name = Binder.to_name bndr in
           let vs = name :: check_for_duplicate_names pos (List.flatten pats) in
           let (pats_init, pats_tail) = from_option ([], []) (unsnoc_opt pats) in
@@ -4328,7 +4329,7 @@ and type_binding : context -> binding -> binding * context * Usage.t =
           let sugar_tyvars = List.map SugarQuantifier.mk_resolved tyvars in
           (Fun { fun_binder = Binder.set_type bndr ft;
                  fun_linearity = lin;
-                 fun_definition = (sugar_tyvars, (List.map (List.map erase_pat) pats, erase body));
+                 fun_definition = (sugar_tyvars, NormalFunlit (List.map (List.map erase_pat) pats, erase body));
                  fun_frozen = true;
                  fun_location; fun_signature = t_ann'; fun_unsafe_signature = unsafe },
              {empty_context with
@@ -4362,12 +4363,13 @@ and type_binding : context -> binding -> binding * context * Usage.t =
             List.fold_left
               (fun (inner_rec_vars, inner_env, patss)
                    {node= { rec_binder = bndr; rec_linearity = lin;
-                            rec_definition = ((_, def), (pats, _));
+                            rec_definition = ((_, def), fnlit);
                             rec_signature = t_ann';
                             rec_unsafe_signature = unsafe;
                             rec_frozen = frozen;
                             _ }; _ } ->
                  let name = Binder.to_name bndr in
+                 let pats = match fnlit with NormalFunlit (pats, _) -> pats | MatchFunlit (_,_) -> assert false in
                  (* recursive functions can't be linear! *)
                  if DeclaredLinearity.is_linear lin then
                    Gripers.linear_recursive_function pos name;
@@ -4434,8 +4436,9 @@ and type_binding : context -> binding -> binding * context * Usage.t =
                 (List.fold_left2
                    (fun defs_and_uses
                         {node={ rec_binder = bndr; rec_linearity = lin;
-                                rec_definition = (_, (_, body)); _ } as fn; pos }
+                                rec_definition = (_, fnlit); _ } as fn; pos }
                         pats ->
+                      let body = match fnlit with NormalFunlit (_, body) -> body | MatchFunlit (_,_) -> assert false in
                       let name = Binder.to_name bndr in
                       let pat_env = List.fold_left (fun env pat -> Env.extend env (pattern_env pat)) Env.empty (List.flatten pats) in
                       let self_env =
@@ -4566,7 +4569,7 @@ and type_binding : context -> binding -> binding * context * Usage.t =
                    let sugar_tyvars = List.map SugarQuantifier.mk_resolved tyvars in
                    (make ~pos { fn with
                       rec_binder = Binder.set_type bndr outer;
-                      rec_definition = ((sugar_tyvars, Some inner), (pats, body)) }::defs,
+                      rec_definition = ((sugar_tyvars, Some inner), NormalFunlit (pats, body)) }::defs,
                       Env.bind name outer outer_env))
                 ([], Env.empty) defs patss
             in

From be36d66646b955fba2c0e7a2c2a93b269c774810 Mon Sep 17 00:00:00 2001
From: Emanon42 <EmanonTang@outlook.com>
Date: Sat, 25 Jul 2020 16:16:55 +0100
Subject: [PATCH 26/50] fix BRACE

---
 core/parser.mly | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/core/parser.mly b/core/parser.mly
index 86b60c06d..bf23a0bd1 100644
--- a/core/parser.mly
+++ b/core/parser.mly
@@ -451,7 +451,7 @@ match_tlfunbinding:
 | fun_kind VARIABLE arg_lists perhaps_location match_body      { ($1, $2, $3, $4, $5)                }
 
 match_body:
-| MATCH LPAREN PIPE separated_list(PIPE, match_cases) RPAREN   { $4 }
+| MATCH LBRACE PIPE separated_list(PIPE, match_cases) RBRACE   { $4 }
 
 match_cases:
 | pattern RARROW block_contents                                { ($1, block ~ppos:$loc $3) }

From 65839f7f150a34e0a0205ecdc51a426ab6fab997 Mon Sep 17 00:00:00 2001
From: Emanon42 <EmanonTang@outlook.com>
Date: Sat, 25 Jul 2020 16:42:23 +0100
Subject: [PATCH 27/50] fix pattern

---
 core/parser.mly | 5 +++--
 1 file changed, 3 insertions(+), 2 deletions(-)

diff --git a/core/parser.mly b/core/parser.mly
index bf23a0bd1..93aef244b 100644
--- a/core/parser.mly
+++ b/core/parser.mly
@@ -451,10 +451,10 @@ match_tlfunbinding:
 | fun_kind VARIABLE arg_lists perhaps_location match_body      { ($1, $2, $3, $4, $5)                }
 
 match_body:
-| MATCH LBRACE PIPE separated_list(PIPE, match_cases) RBRACE   { $4 }
+| MATCH LBRACE match_cases* RBRACE                             { $3 }
 
 match_cases:
-| pattern RARROW block_contents                                { ($1, block ~ppos:$loc $3) }
+| PIPE pattern RARROW block_contents                           { ($2, block ~ppos:$loc $4) }
 
 tlvarbinding:
 | VAR VARIABLE perhaps_location EQ exp                         { (PatName $2, $5, $3) }
@@ -560,6 +560,7 @@ primary_expression:
 | LBRACKET exp DOTDOT exp RBRACKET                             { with_pos $loc (RangeLit($2, $4))   }
 | xml                                                          { $1 }
 | linearity arg_lists block                                    { fun_lit ~ppos:$loc $1 $2 $3 }
+| linearity arg_lists match_body                               { match_fun_lit ~ppos:$loc $1 $2 $3 }
 | LEFTTRIANGLE cp_expression RIGHTTRIANGLE                     { with_pos $loc (CP $2) }
 | DOLLAR primary_expression                                    { with_pos $loc (Generalise $2) }
 

From 7318fae0966942820449f7f5b003d40c54e3de2f Mon Sep 17 00:00:00 2001
From: Emanon42 <EmanonTang@outlook.com>
Date: Mon, 3 Aug 2020 02:00:04 +0100
Subject: [PATCH 28/50] add transformation to normalfunlit

---
 core/desugarMatching.ml  | 39 +++++++++++++++++++++++++++++++++++++++
 core/desugarMatching.mli |  3 +++
 core/frontend.ml         |  3 ++-
 core/lexer.mll           |  3 +--
 core/parser.mly          |  3 +--
 5 files changed, 46 insertions(+), 5 deletions(-)
 create mode 100644 core/desugarMatching.ml
 create mode 100644 core/desugarMatching.mli

diff --git a/core/desugarMatching.ml b/core/desugarMatching.ml
new file mode 100644
index 000000000..42d7a4435
--- /dev/null
+++ b/core/desugarMatching.ml
@@ -0,0 +1,39 @@
+open Sugartypes
+open Utility
+open SourceCode
+
+let with_pos = SourceCode.WithPos.make
+
+let desugar_matching =
+object ((self : 'self_type))
+    inherit SugarTraversals.map as super
+    method! binding = fun b ->
+      let pos = WithPos.pos b in
+      match WithPos.node b with
+      |  Fun ({ fun_definition = (tvs, MatchFunlit (patterns, cases)); _ } as fn) ->
+          let nameList = List.map (fun pats -> List.map (fun pat -> (pat, Utility.gensym())) pats) patterns in
+          let switchTuple = List.map (fun (_,name) -> with_pos (Var name)) (List.flatten nameList) in
+          let normalArgs = 
+            List.map (fun pats -> List.map (fun (pat, name) -> 
+                                              with_pos (Pattern.As (with_pos (Binder.make ~name ()), pat))) 
+                                            pats) nameList in
+          let switchBody = Switch (with_pos (TupleLit switchTuple), cases, None) in
+          let normalFnlit = NormalFunlit (normalArgs, with_pos switchBody) in
+          let normalFnlit = self#funlit normalFnlit in
+          let node = Fun { fun_binder = fn.fun_binder;
+                           fun_linearity = fn.fun_linearity;
+                           fun_definition = (tvs, normalFnlit);
+                           fun_location = fn.fun_location;
+                           fun_signature = fn.fun_signature;
+                           fun_unsafe_signature = fn.fun_unsafe_signature;
+                           fun_frozen = fn.fun_frozen;
+                           } in
+          WithPos.make ~pos node
+      | _ -> super#binding b
+end
+
+module Untyped
+  = Transform.Untyped.Make.Transformer(struct
+        let name = "desugar_pattern_matching"
+        let obj = desugar_matching
+      end)
diff --git a/core/desugarMatching.mli b/core/desugarMatching.mli
new file mode 100644
index 000000000..955749d33
--- /dev/null
+++ b/core/desugarMatching.mli
@@ -0,0 +1,3 @@
+val desugar_matching : SugarTraversals.map
+
+include Transform.Untyped.S
diff --git a/core/frontend.ml b/core/frontend.ml
index 294af13fb..f13c4281a 100644
--- a/core/frontend.ml
+++ b/core/frontend.ml
@@ -123,7 +123,8 @@ module Untyped = struct
 
   (* Collection of transformers. *)
   let transformers : transformer array
-    = [| (module ResolvePositions)
+    = [| (module DesugarMatching)
+       ; (module ResolvePositions)
        ; (module CheckXmlQuasiquotes)
        ; (module DesugarModules)
        ; (module Shunting)
diff --git a/core/lexer.mll b/core/lexer.mll
index c5d1d3209..5974abf90 100644
--- a/core/lexer.mll
+++ b/core/lexer.mll
@@ -134,6 +134,7 @@ let keywords = [
  "var"      , VAR;
  "where"    , WHERE;
  "with"     , WITH;
+ "match"    , MATCH;
 (* SAND *)
  "tablekeys"     , TABLEKEYS;
 ]
@@ -225,7 +226,6 @@ rule lex ctxt nl = parse
   | '@'                                 { AT }
   | "%" def_id as var                   { PERCENTVAR var }
   | '%'                                 { PERCENT }
-  | '|'                                 { PIPE }
   | initopchar opchar * as op           { OPERATOR op }
   | '`' (def_id as var) '`'             { if List.mem_assoc var keywords || Char.isUpper var.[0] then
                                               raise (LexicalError (lexeme lexbuf, lexeme_end_p lexbuf))
@@ -243,7 +243,6 @@ rule lex ctxt nl = parse
   | "postfix"                           { FIXITY Associativity.Left }
   | "~fun"                              { FROZEN_FUN }
   | "~linfun"                           { FROZEN_LINFUN }
-  | "match"                             { MATCH }
   | def_id as var                       { try List.assoc var keywords
                                           with Not_found | NotFound _ ->
                                             if Char.isUpper var.[0] then CONSTRUCTOR var
diff --git a/core/parser.mly b/core/parser.mly
index 93aef244b..6ac72b086 100644
--- a/core/parser.mly
+++ b/core/parser.mly
@@ -287,7 +287,6 @@ let parse_foreign_language pos lang =
 %token LENSPUT LENSGET LENSCHECK LENSSERIAL
 %token READONLY DEFAULT
 %token MATCH
-%token PIPE
 %token ESCAPE
 %token CLIENT SERVER
 %token SEMICOLON
@@ -454,7 +453,7 @@ match_body:
 | MATCH LBRACE match_cases* RBRACE                             { $3 }
 
 match_cases:
-| PIPE pattern RARROW block_contents                           { ($2, block ~ppos:$loc $4) }
+| VBAR pattern RARROW block_contents                           { ($2, block ~ppos:$loc $4) }
 
 tlvarbinding:
 | VAR VARIABLE perhaps_location EQ exp                         { (PatName $2, $5, $3) }

From 388fdf1e1632ff825b4a41d7cc8661b576ac76d8 Mon Sep 17 00:00:00 2001
From: Emanon42 <EmanonTang@outlook.com>
Date: Tue, 4 Aug 2020 04:03:19 +0100
Subject: [PATCH 29/50] add non-exhaustive case and test

---
 core/desugarMatching.ml | 25 +++++++++++++++++--------
 tests/functions.tests   | 16 ++++++++++++++++
 2 files changed, 33 insertions(+), 8 deletions(-)

diff --git a/core/desugarMatching.ml b/core/desugarMatching.ml
index 42d7a4435..a74c0dae2 100644
--- a/core/desugarMatching.ml
+++ b/core/desugarMatching.ml
@@ -11,18 +11,27 @@ object ((self : 'self_type))
       let pos = WithPos.pos b in
       match WithPos.node b with
       |  Fun ({ fun_definition = (tvs, MatchFunlit (patterns, cases)); _ } as fn) ->
-          let nameList = List.map (fun pats -> List.map (fun pat -> (pat, Utility.gensym())) pats) patterns in
-          let switchTuple = List.map (fun (_,name) -> with_pos (Var name)) (List.flatten nameList) in
-          let normalArgs = 
+          let name_list = List.map (fun pats -> List.map (fun pat -> (pat, Utility.gensym())) pats) patterns in
+          let switch_tuple = List.map (fun (_, name) -> with_pos (Var name)) (List.flatten name_list) in
+          let exhaustive_patterns = List.map (fun _ -> with_pos (Pattern.Any)) switch_tuple in
+          let exhaustive_patterns = 
+            match exhaustive_patterns with 
+              | [] -> with_pos (Pattern.Any)
+              | [single] -> single 
+              | _ -> with_pos (Pattern.Tuple exhaustive_patterns) in
+          let exhaustive_position = Format.sprintf "non-exhaustive pattern matching at %s" (SourceCode.Position.show pos) in
+          let exhaustive_case = FnAppl (with_pos (Var "error"), [with_pos (Constant (CommonTypes.Constant.String exhaustive_position))]) in
+          let normal_args = 
             List.map (fun pats -> List.map (fun (pat, name) -> 
                                               with_pos (Pattern.As (with_pos (Binder.make ~name ()), pat))) 
-                                            pats) nameList in
-          let switchBody = Switch (with_pos (TupleLit switchTuple), cases, None) in
-          let normalFnlit = NormalFunlit (normalArgs, with_pos switchBody) in
-          let normalFnlit = self#funlit normalFnlit in
+                                            pats) name_list in
+          let cases = cases@[(exhaustive_patterns, with_pos exhaustive_case)] in
+          let switch_body = Switch (with_pos (TupleLit switch_tuple), cases, None) in
+          let normal_fnlit = NormalFunlit (normal_args, with_pos switch_body) in
+          let normal_fnlit = self#funlit normal_fnlit in
           let node = Fun { fun_binder = fn.fun_binder;
                            fun_linearity = fn.fun_linearity;
-                           fun_definition = (tvs, normalFnlit);
+                           fun_definition = (tvs, normal_fnlit);
                            fun_location = fn.fun_location;
                            fun_signature = fn.fun_signature;
                            fun_unsafe_signature = fn.fun_unsafe_signature;
diff --git a/tests/functions.tests b/tests/functions.tests
index 9a673d652..0a6c5c27f 100644
--- a/tests/functions.tests
+++ b/tests/functions.tests
@@ -146,3 +146,19 @@ Linearity (9) - linear recursive functions should be disallowed
 linfun f(x) {f(x)} f
 stderr : @.*cannot be linear.*
 exit : 1
+
+Pattern Matching (1):
+fun foo(_) match {| x -> x} foo
+stdout : fun : (Int) ~> Int
+
+Pattern Matching (2):
+fun ack(_,_) match {| (0, n) -> n + 1 | (m, 0) -> ack(m - 1, 1) | (m, n) -> ack(m - 1, ack(m, n - 1))} ack
+stdout : fun : (Int, Int) ~> Int
+
+Pattern Matching (3):
+fun foo(_)(_) match {| (x, y) -> x + y} foo
+stdout : fun : (Int) -> (Int) ~> Int
+
+Pattern Matching (4) - runtime non-exhaustive error:
+fun foo(_) match {| 1 -> 1} foo(0)
+stdout : ***: Runtime error: non-exhaustive pattern matching at File pm.links, line 1, column 3, to line 0, column 31
\ No newline at end of file

From ff47876b2342f24af2e1da62f0337ba0b87ec322 Mon Sep 17 00:00:00 2001
From: Emanon42 <EmanonTang@outlook.com>
Date: Tue, 4 Aug 2020 04:38:47 +0100
Subject: [PATCH 30/50] trim space

---
 core/sugartypes.ml | 6 +++---
 1 file changed, 3 insertions(+), 3 deletions(-)

diff --git a/core/sugartypes.ml b/core/sugartypes.ml
index dc24d60e1..6f6af3fc5 100644
--- a/core/sugartypes.ml
+++ b/core/sugartypes.ml
@@ -773,11 +773,11 @@ struct
     match fn with
     | NormalFunlit n_fn -> normal_funlit n_fn
     | MatchFunlit m_fn -> match_funlit m_fn
-  and normal_funlit (args, body : normal_funlit) : StringSet.t = 
+  and normal_funlit (args, body : normal_funlit) : StringSet.t =
     diff (phrase body) (union_map (union_map pattern) args)
-  and match_funlit (args, body : match_funlit) : StringSet.t = 
+  and match_funlit (args, body : match_funlit) : StringSet.t =
     diff (match_body body) (union_map (union_map pattern) args)
-  and match_body (body : (Pattern.with_pos * phrase) list) : StringSet.t = 
+  and match_body (body : (Pattern.with_pos * phrase) list) : StringSet.t =
     union_map (fun (pat, phr) -> union (pattern pat) (phrase phr)) body
   (* and funlit (args, body : funlit) : StringSet.t =
     diff (phrase body) (union_map (union_map pattern) args) *)

From 3043dd118c139e1aa46da266e346f02fcfbba355 Mon Sep 17 00:00:00 2001
From: Emanon42 <EmanonTang@outlook.com>
Date: Tue, 4 Aug 2020 14:56:01 +0100
Subject: [PATCH 31/50] trim space

---
 core/desugarMatching.ml | 12 ++++++------
 1 file changed, 6 insertions(+), 6 deletions(-)

diff --git a/core/desugarMatching.ml b/core/desugarMatching.ml
index a74c0dae2..7142c6ca8 100644
--- a/core/desugarMatching.ml
+++ b/core/desugarMatching.ml
@@ -14,16 +14,16 @@ object ((self : 'self_type))
           let name_list = List.map (fun pats -> List.map (fun pat -> (pat, Utility.gensym())) pats) patterns in
           let switch_tuple = List.map (fun (_, name) -> with_pos (Var name)) (List.flatten name_list) in
           let exhaustive_patterns = List.map (fun _ -> with_pos (Pattern.Any)) switch_tuple in
-          let exhaustive_patterns = 
-            match exhaustive_patterns with 
+          let exhaustive_patterns =
+            match exhaustive_patterns with
               | [] -> with_pos (Pattern.Any)
-              | [single] -> single 
+              | [single] -> single
               | _ -> with_pos (Pattern.Tuple exhaustive_patterns) in
           let exhaustive_position = Format.sprintf "non-exhaustive pattern matching at %s" (SourceCode.Position.show pos) in
           let exhaustive_case = FnAppl (with_pos (Var "error"), [with_pos (Constant (CommonTypes.Constant.String exhaustive_position))]) in
-          let normal_args = 
-            List.map (fun pats -> List.map (fun (pat, name) -> 
-                                              with_pos (Pattern.As (with_pos (Binder.make ~name ()), pat))) 
+          let normal_args =
+            List.map (fun pats -> List.map (fun (pat, name) ->
+                                              with_pos (Pattern.As (with_pos (Binder.make ~name ()), pat)))
                                             pats) name_list in
           let cases = cases@[(exhaustive_patterns, with_pos exhaustive_case)] in
           let switch_body = Switch (with_pos (TupleLit switch_tuple), cases, None) in

From d1fe1ba526453de4bfa41b9b26a928146f199dd3 Mon Sep 17 00:00:00 2001
From: Emanon42 <EmanonTang@outlook.com>
Date: Tue, 4 Aug 2020 20:15:26 +0100
Subject: [PATCH 32/50] resolve Simon's review

---
 core/desugarFuns.ml     |  7 +++----
 core/desugarInners.ml   |  2 +-
 core/desugarMatching.ml | 35 ++++++++++++++++++++++++++++-------
 core/desugarModules.ml  | 13 ++-----------
 core/frontend.ml        |  4 ++--
 core/lens_sugar_conv.ml |  2 +-
 core/parser.mly         |  4 ++--
 core/renamer.ml         | 22 +++++++++++-----------
 core/sugarTraversals.ml | 26 ++++++++++++++++----------
 core/sugartoir.ml       |  6 +++---
 core/sugartypes.ml      |  2 --
 core/transformSugar.ml  | 17 +++++++++++++----
 tests/functions.tests   |  9 +++++++--
 13 files changed, 89 insertions(+), 60 deletions(-)

diff --git a/core/desugarFuns.ml b/core/desugarFuns.ml
index 6f594aca7..6fe229ef0 100644
--- a/core/desugarFuns.ml
+++ b/core/desugarFuns.ml
@@ -61,13 +61,12 @@ let unwrap_def (bndr, linearity, (tyvars, lam), location) =
   let lam =
     let rec make_lam t funlit =
       match funlit with
-        | NormalFunlit ([_ps], _body) -> NormalFunlit ([_ps], _body)
-        | NormalFunlit (ps::pss, body) -> 
+        | NormalFunlit ([ps], body) -> NormalFunlit ([ps], body)
+        | NormalFunlit (ps::pss, body) ->
           let g = gensym ~prefix:"_fun_" () in
           let rt = TypeUtils.return_type t in
             NormalFunlit ([ps], block ([fun_binding' ~linearity ~location (binder ~ty:t g) (make_lam rt (NormalFunlit (pss, body)))], freeze_var g))
-        | NormalFunlit (_,_) -> assert false
-        | MatchFunlit (_, _) -> assert false (*TODO: matchfunlit *)
+        | _ -> assert false
     in make_lam rt lam
   in (binder ~ty:ft f, linearity, (tyvars, lam), location)
 
diff --git a/core/desugarInners.ml b/core/desugarInners.ml
index ff24a6322..46cdda070 100644
--- a/core/desugarInners.ml
+++ b/core/desugarInners.ml
@@ -172,7 +172,7 @@ object (o : 'self_type)
                let o = o#with_visiting (StringSet.add (Binder.to_name rec_binder) visiting_funs) in
                let (o, tyvars) = o#quantifiers tyvars in
                let (o, inner) = o#datatype inner in
-               let lam_in = match lam with | NormalFunlit x -> x | MatchFunlit _ -> assert false in (*TODO: matchfunlit *)
+               let lam_in = match lam with | NormalFunlit x -> x | MatchFunlit _ -> assert false in
                let inner_effects = TransformSugar.fun_effects inner (fst lam_in) in
                let (o, lam, _) = o#funlit inner_effects lam in
                let o = o#restore_quantifiers outer_tyvars in
diff --git a/core/desugarMatching.ml b/core/desugarMatching.ml
index 7142c6ca8..06fd9fd5e 100644
--- a/core/desugarMatching.ml
+++ b/core/desugarMatching.ml
@@ -2,6 +2,30 @@ open Sugartypes
 open Utility
 open SourceCode
 
+(* This module desugars pattern-matching functions
+
+  This transformation convert function like that:
+
+  fun foo(a1, ..., an) match { 
+    | case (p1_1, ..., p1_n) -> b_1
+    | ...
+    | case (pm_1, pm_n) -> b_m
+  }
+
+  to function with switch body like that:
+
+  fun foo(a1 as x1, ..., an as xn) {
+    switch ((x1, ..., xn)) {
+      case (p1_1, ..., p1_n) -> b_1
+      ...
+      case (pm_1, ..., pm_n) -> b_m
+      case (_, ..., _) -> error("non-exhaustive")
+  }
+
+  The last non-exhaustive case with wild card pattern is always attached to the end of switch body.
+
+*)
+
 let with_pos = SourceCode.WithPos.make
 
 let desugar_matching =
@@ -11,14 +35,11 @@ object ((self : 'self_type))
       let pos = WithPos.pos b in
       match WithPos.node b with
       |  Fun ({ fun_definition = (tvs, MatchFunlit (patterns, cases)); _ } as fn) ->
+          (* bind the arguments with unique var name *)
           let name_list = List.map (fun pats -> List.map (fun pat -> (pat, Utility.gensym())) pats) patterns in
           let switch_tuple = List.map (fun (_, name) -> with_pos (Var name)) (List.flatten name_list) in
-          let exhaustive_patterns = List.map (fun _ -> with_pos (Pattern.Any)) switch_tuple in
-          let exhaustive_patterns =
-            match exhaustive_patterns with
-              | [] -> with_pos (Pattern.Any)
-              | [single] -> single
-              | _ -> with_pos (Pattern.Tuple exhaustive_patterns) in
+          (* assemble exhaustive handler *)
+          let exhaustive_patterns = with_pos (Pattern.Any) in
           let exhaustive_position = Format.sprintf "non-exhaustive pattern matching at %s" (SourceCode.Position.show pos) in
           let exhaustive_case = FnAppl (with_pos (Var "error"), [with_pos (Constant (CommonTypes.Constant.String exhaustive_position))]) in
           let normal_args =
@@ -43,6 +64,6 @@ end
 
 module Untyped
   = Transform.Untyped.Make.Transformer(struct
-        let name = "desugar_pattern_matching"
+        let name = "desugar_match_functions"
         let obj = desugar_matching
       end)
diff --git a/core/desugarModules.ml b/core/desugarModules.ml
index bd55c2f2b..ba2512896 100644
--- a/core/desugarModules.ml
+++ b/core/desugarModules.ml
@@ -309,7 +309,7 @@ and desugar ?(toplevel=false) (renamer' : Epithet.t) (scope' : Scope.t) =
     method! funlit : funlit -> funlit
       = fun f ->
       match f with
-        | NormalFunlit (paramss, body) -> 
+        | NormalFunlit (paramss, body) ->
           let visitor = self#clone in
           let paramss' =
             List.map
@@ -319,16 +319,7 @@ and desugar ?(toplevel=false) (renamer' : Epithet.t) (scope' : Scope.t) =
           in
           let body' = visitor#phrase body in
           NormalFunlit (paramss', body')
-        | MatchFunlit (paramss, body) -> 
-          let visitor = self#clone in
-          let paramss' =
-            List.map
-              (fun params ->
-                List.map (fun param -> visitor#pattern param) params)
-              paramss
-          in
-          let body' = visitor#cases body in
-          MatchFunlit (paramss', body')
+        | MatchFunlit (_, _) -> assert false
 
     method cases : (Pattern.with_pos * phrase) list -> (Pattern.with_pos * phrase) list
       = fun cases ->
diff --git a/core/frontend.ml b/core/frontend.ml
index f13c4281a..0c61cf376 100644
--- a/core/frontend.ml
+++ b/core/frontend.ml
@@ -123,9 +123,9 @@ module Untyped = struct
 
   (* Collection of transformers. *)
   let transformers : transformer array
-    = [| (module DesugarMatching)
-       ; (module ResolvePositions)
+    = [| (module ResolvePositions)
        ; (module CheckXmlQuasiquotes)
+       ; (module DesugarMatching)
        ; (module DesugarModules)
        ; (module Shunting)
        ; (module Collect_FFI_Files)
diff --git a/core/lens_sugar_conv.ml b/core/lens_sugar_conv.ml
index b30417bd8..ac3096333 100644
--- a/core/lens_sugar_conv.ml
+++ b/core/lens_sugar_conv.ml
@@ -113,6 +113,6 @@ let lens_sugar_phrase_of_sugar p =
       | _ ->
           Format.asprintf "Unsupported binder: %a" S.pp_phrase p
           |> Error.internal_error_res )
-  | S.FunLit (_, _, Sugartypes.MatchFunlit (_, _), _) -> assert false 
+  | S.FunLit (_, _, Sugartypes.MatchFunlit (_, _), _) -> assert false
   | _ -> lens_sugar_phrase_of_body "" p )
   |> Result.ok_exn
diff --git a/core/parser.mly b/core/parser.mly
index ca40f4da8..2fb8e4a89 100644
--- a/core/parser.mly
+++ b/core/parser.mly
@@ -450,9 +450,9 @@ match_tlfunbinding:
 | fun_kind VARIABLE arg_lists perhaps_location match_body      { ($1, $2, $3, $4, $5)                }
 
 match_body:
-| MATCH LBRACE match_cases* RBRACE                             { $3 }
+| MATCH LBRACE match_case* RBRACE                             { $3 }
 
-match_cases:
+match_case:
 | VBAR pattern RARROW block_contents                           { ($2, block ~ppos:$loc $4) }
 
 tlvarbinding:
diff --git a/core/renamer.ml b/core/renamer.ml
index eda404e11..23af7ef81 100644
--- a/core/renamer.ml
+++ b/core/renamer.ml
@@ -141,13 +141,13 @@ let renamer qs_from qs_to =
            ; fun_frozen
            ; fun_unsafe_signature } ->
      let o, (pats', tyvars', typ', _, signature', body') =
-       match f with 
-        | NormalFunlit (pats, body) -> o#handle_function pats tyvars (Binder.to_type fun_binder) None fun_signature body 
-        | MatchFunlit (_,_) -> assert false in (*TODO: matchfunlit *)
+       match f with
+        | NormalFunlit (pats, body) -> o#handle_function pats tyvars (Binder.to_type fun_binder) None fun_signature body
+        | MatchFunlit (_,_) -> assert false in
      let function_definition' =
        { fun_binder = Binder.set_type fun_binder typ'
        ; fun_linearity
-       ; fun_definition = (tyvars', NormalFunlit (pats', body')) (*TODO: matchfunlit *)
+       ; fun_definition = (tyvars', NormalFunlit (pats', body'))
        ; fun_location
        ; fun_signature = signature'
        ; fun_frozen
@@ -166,12 +166,12 @@ let renamer qs_from qs_to =
              ; rec_frozen } ->
        let o, (pats', tyvars', typ', ty', signature', body') =
          match f with
-          | NormalFunlit (pats, body) -> o#handle_function pats tyvars (Binder.to_type rec_binder) ty rec_signature body 
-          | MatchFunlit (_,_) -> assert false in (*TODO: matchfunlit *)
+          | NormalFunlit (pats, body) -> o#handle_function pats tyvars (Binder.to_type rec_binder) ty rec_signature body
+          | MatchFunlit (_,_) -> assert false in
        let recursive_definition' =
          { rec_binder = Binder.set_type rec_binder typ'
          ; rec_linearity
-         ; rec_definition = ((tyvars', ty'), NormalFunlit (pats', body')) (*TODO: matchfunlit *)
+         ; rec_definition = ((tyvars', ty'), NormalFunlit (pats', body'))
          ; rec_location
          ; rec_signature = signature'
          ; rec_unsafe_signature
@@ -220,7 +220,7 @@ let rename_function_definition : function_definition -> function_definition =
       ; fun_signature
       ; fun_frozen
       ; fun_unsafe_signature } ->
-  let (pats, body) = match f with | NormalFunlit (ps, bd) -> (ps, bd) | MatchFunlit (_,_) -> assert false in (*TODO: matchfunlit *)
+  let (pats, body) = match f with | NormalFunlit (ps, bd) -> (ps, bd) | MatchFunlit (_,_) -> assert false in
   let qs_from = List.map SugarQuantifier.get_resolved_exn tyvars_from in
   let qs_to, _      = Instantiate.build_fresh_quantifiers qs_from in
   let tyvars_to     = List.map SugarQuantifier.mk_resolved qs_to in
@@ -231,7 +231,7 @@ let rename_function_definition : function_definition -> function_definition =
   let _, signature' = o#option (fun o -> o#datatype') fun_signature in
   { fun_binder =  Binder.set_type fun_binder typ'
   ; fun_linearity
-  ; fun_definition = (tyvars_to, NormalFunlit (pats', body')) (*TODO: matchfunlit *)
+  ; fun_definition = (tyvars_to, NormalFunlit (pats', body'))
   ; fun_location
   ; fun_signature = signature'
   ; fun_frozen
@@ -247,7 +247,7 @@ let rename_recursive_functionnode :
       ; rec_signature
       ; rec_frozen
       ; rec_unsafe_signature } ->
-  let (pats, body) = match f with | NormalFunlit (ps, bd) -> (ps, bd) | MatchFunlit (_,_) -> assert false in (*TODO: matchfunlit *)
+  let (pats, body) = match f with | NormalFunlit (ps, bd) -> (ps, bd) | MatchFunlit (_,_) -> assert false in
   let qs_from = List.map SugarQuantifier.get_resolved_exn tyvars_from in
   let qs_to, _      = Instantiate.build_fresh_quantifiers qs_from in
   let tyvars_to     = List.map SugarQuantifier.mk_resolved qs_to in
@@ -259,7 +259,7 @@ let rename_recursive_functionnode :
   let _, signature' = o#option (fun o -> o#datatype') rec_signature in
   { rec_binder =  Binder.set_type rec_binder typ'
   ; rec_linearity
-  ; rec_definition = ((tyvars_to, ty'), NormalFunlit (pats', body')) (*TODO: matchfunlit *)
+  ; rec_definition = ((tyvars_to, ty'), NormalFunlit (pats', body'))
   ; rec_location
   ; rec_signature = signature'
   ; rec_frozen
diff --git a/core/sugarTraversals.ml b/core/sugarTraversals.ml
index 01c24ffa3..1400b92b7 100644
--- a/core/sugarTraversals.ml
+++ b/core/sugarTraversals.ml
@@ -560,11 +560,13 @@ class map =
 
     method funlit : funlit -> funlit =
       fun f ->
-        match f with 
-          | NormalFunlit (_x, _x_i1) -> 
+        match f with
+          | NormalFunlit (_x, _x_i1) ->
             let _x = o#list (fun o -> o#list (fun o -> o#pattern)) _x in
-            let _x_i1 = o#phrase _x_i1 in NormalFunlit (_x, _x_i1) (*TODO: matchfunlit *)
-          | MatchFunlit (_,_) -> assert false
+            let _x_i1 = o#phrase _x_i1 in NormalFunlit (_x, _x_i1)
+          | MatchFunlit (pat, body) ->
+            let pat = o#list (fun o -> o#list (fun o -> o#pattern)) pat in
+            let body = o#list (fun (p, c) -> o#pattern p; o#phrase c) body in MatchFunlit (pat, body)
 
     method handle_params : handler_parameterisation -> handler_parameterisation =
       fun { shp_bindings; shp_types }->
@@ -1291,11 +1293,13 @@ class fold =
 
     method funlit : funlit -> 'self_type =
       fun f ->
-        match f with 
-          | NormalFunlit (_x, _x_i1) -> 
+        match f with
+          | NormalFunlit (_x, _x_i1) ->
             let o = o#list (fun o -> o#list (fun o -> o#pattern)) _x in
             let o = o#phrase _x_i1 in o
-          | MatchFunlit (_,_) -> assert false (*TODO: matchfunlit *)
+          | MatchFunlit (pat, body) ->
+            let o = o#list (fun o -> o#list (fun o -> o#pattern)) pat in
+            let o = o#list (fun (p, c) -> o#pattern p; o#phrase c) body in o
 
 
     method handle_params : handler_parameterisation -> 'self_type =
@@ -2123,11 +2127,13 @@ class fold_map =
 
     method funlit : funlit -> ('self_type * funlit) =
       fun f ->
-        match f with 
-          | NormalFunlit (_x, _x_i1) -> 
+        match f with
+          | NormalFunlit (_x, _x_i1) ->
             let (o, _x) = o#list (fun o -> o#list (fun o -> o#pattern)) _x in
             let (o, _x_i1) = o#phrase _x_i1 in (o, NormalFunlit (_x, _x_i1))
-          | MatchFunlit (_,_) -> assert false (*TODO: matchfunlit *)
+          | MatchFunlit (pat, body) ->
+            let (o, pat) = o#list (fun o -> o#list (fun o -> o#pattern)) pat in
+            let (o, body) = o#list (fun (p, c) -> o#pattern p; o#phrase c) body in (o, MatchFunlit (pat, body))
 
     method handle_params : handler_parameterisation -> ('self_type * handler_parameterisation) =
       fun { shp_bindings; shp_types } ->
diff --git a/core/sugartoir.ml b/core/sugartoir.ml
index cf44b9b0e..892ecb557 100644
--- a/core/sugartoir.ml
+++ b/core/sugartoir.ml
@@ -1143,7 +1143,7 @@ struct
                     let ss = eval_bindings scope env' bs e in
                       I.comp env (p, s, ss)
                 | Fun { fun_binder           = bndr;
-                        fun_definition       = (tyvars, NormalFunlit ([ps], body)); (*TODO: matchfunlit *)
+                        fun_definition       = (tyvars, NormalFunlit ([ps], body));
                         fun_location         = location;
                         fun_unsafe_signature = unsafe; _ }
                      when Binder.has_type bndr ->
@@ -1180,10 +1180,10 @@ struct
                     let defs =
                       List.map
                         (fun { rec_binder           = bndr;
-                               rec_definition       = ((tyvars, _), fnlit); 
+                               rec_definition       = ((tyvars, _), fnlit);
                                rec_location         = location;
                                rec_unsafe_signature = unsafe; _ } ->
-                          let (pss, body) = match fnlit with | NormalFunlit (pss, body) -> (pss, body) | MatchFunlit (_,_) -> assert false in (*TODO: matchfunlit *)
+                          let (pss, body) = match fnlit with | NormalFunlit (pss, body) -> (pss, body) | MatchFunlit (_,_) -> assert false in
                           assert (List.length pss = 1);
                           let f  = Binder.to_name bndr in
                           let ft = Binder.to_type bndr in
diff --git a/core/sugartypes.ml b/core/sugartypes.ml
index 6f6af3fc5..0811cd255 100644
--- a/core/sugartypes.ml
+++ b/core/sugartypes.ml
@@ -779,8 +779,6 @@ struct
     diff (match_body body) (union_map (union_map pattern) args)
   and match_body (body : (Pattern.with_pos * phrase) list) : StringSet.t =
     union_map (fun (pat, phr) -> union (pattern pat) (phrase phr)) body
-  (* and funlit (args, body : funlit) : StringSet.t =
-    diff (phrase body) (union_map (union_map pattern) args) *)
   and block (binds, expr : binding list * phrase) : StringSet.t =
     ListLabels.fold_right binds ~init:(phrase expr)
       ~f:(fun bind bodyfree ->
diff --git a/core/transformSugar.ml b/core/transformSugar.ml
index fdf2bbbf0..a178ffdf4 100644
--- a/core/transformSugar.ml
+++ b/core/transformSugar.ml
@@ -130,6 +130,9 @@ let on_effects o (eff : Types.row) fn x =
   let (o, x, y) = fn o x in
   (o#with_effects effect_row, x, y)
 
+let get_normal_funlit fnlit =
+  match fnlit with | NormalFunlit x -> x | MatchFunlit _ -> assert false
+
 let check_type_application (e, t) k =
   begin
     try
@@ -725,7 +728,7 @@ class transform (env : Types.typing_environment) =
 
     method funlit : Types.row -> funlit -> ('self_type * funlit * Types.datatype) =
       fun inner_eff f ->
-        match f with 
+        match f with
           | NormalFunlit (pss, e) ->
             let envs = o#backup_envs in
             let (o, pss) = listu o (fun o -> listu o (fun o -> o#pattern)) pss in
@@ -733,7 +736,13 @@ class transform (env : Types.typing_environment) =
             let (o, e, t) = o#phrase e in
             let o = o#restore_envs envs in
             (o, NormalFunlit (pss, e), t)
-          | MatchFunlit (_,_) -> assert false (*TODO: matchfunlit *)
+          | MatchFunlit (pss, body) ->
+            let envs = o#backup_envs in
+            let (o, pss) = listu o (fun o -> listu o (fun o -> o#pattern)) pss in
+            let o = o#with_effects inner_eff in
+            let (o, body, t) = o#list (fun (p, c) -> o#pattern p; o#phrase c) body in
+            let o = o#restore_envs envs in
+            (o, MatchFunlit (pss, body), t)
 
     method constant : Constant.t -> ('self_type * Constant.t * Types.datatype) =
       function
@@ -756,7 +765,7 @@ class transform (env : Types.typing_environment) =
           | {node={ rec_definition = ((tyvars, Some (inner, extras)), lam); _ } as fn; pos} :: defs ->
               let (o, tyvars) = o#quantifiers tyvars in
               let (o, inner) = o#datatype inner in
-              let lam_in = match lam with | NormalFunlit x -> x | MatchFunlit _ -> assert false in (*TODO: matchfunlit *)
+              let lam_in = get_normal_funlit lam in
               let inner_effects = fun_effects inner (fst lam_in) in
               let (o, lam, _) = o#funlit inner_effects lam in
               let o = o#restore_quantifiers outer_tyvars in
@@ -804,7 +813,7 @@ class transform (env : Types.typing_environment) =
            when Binder.has_type fun_binder ->
          let outer_tyvars = o#backup_quantifiers in
          let (o, tyvars) = o#quantifiers tyvars in
-         let lam_in = match lam with | NormalFunlit x -> x | MatchFunlit _ -> assert false in (*TODO: matchfunlit *)
+         let lam_in = get_normal_funlit lam in
          let inner_effects = fun_effects (Binder.to_type fun_binder) (fst lam_in) in
          let (o, lam, _) = o#funlit inner_effects lam in
          let o = o#restore_quantifiers outer_tyvars in
diff --git a/tests/functions.tests b/tests/functions.tests
index 0a6c5c27f..820eac371 100644
--- a/tests/functions.tests
+++ b/tests/functions.tests
@@ -156,9 +156,14 @@ fun ack(_,_) match {| (0, n) -> n + 1 | (m, 0) -> ack(m - 1, 1) | (m, n) -> ack(
 stdout : fun : (Int, Int) ~> Int
 
 Pattern Matching (3):
+fun ack(_,_) match {| (0, n) -> n + 1 | (m, 0) -> ack(m - 1, 1) | (m, n) -> ack(m - 1, ack(m, n - 1))} fun test() { println(intToString(ack(0,1))); println(intToString(ack(1,0))); println(intToString(ack(1,1))); } test()
+stdout : 2\n2\n3\n() : ()
+
+Pattern Matching (4):
 fun foo(_)(_) match {| (x, y) -> x + y} foo
 stdout : fun : (Int) -> (Int) ~> Int
 
-Pattern Matching (4) - runtime non-exhaustive error:
+Pattern Matching (5) - runtime non-exhaustive error:
 fun foo(_) match {| 1 -> 1} foo(0)
-stdout : ***: Runtime error: non-exhaustive pattern matching at File pm.links, line 1, column 3, to line 0, column 31
\ No newline at end of file
+stderr : @.*Runtime error: non-exhaustive pattern matching.*
+exit : 1
\ No newline at end of file

From 6703c891a50e6964b2fc316ba5141f1e27334c1c Mon Sep 17 00:00:00 2001
From: Emanon42 <EmanonTang@outlook.com>
Date: Tue, 4 Aug 2020 20:35:09 +0100
Subject: [PATCH 33/50] trim space

---
 core/desugarMatching.ml | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/core/desugarMatching.ml b/core/desugarMatching.ml
index 06fd9fd5e..8e2780c76 100644
--- a/core/desugarMatching.ml
+++ b/core/desugarMatching.ml
@@ -6,7 +6,7 @@ open SourceCode
 
   This transformation convert function like that:
 
-  fun foo(a1, ..., an) match { 
+  fun foo(a1, ..., an) match {
     | case (p1_1, ..., p1_n) -> b_1
     | ...
     | case (pm_1, pm_n) -> b_m

From e802471823ba6acbf4bca5c44755da2dc24f97fc Mon Sep 17 00:00:00 2001
From: Emanon42 <EmanonTang@outlook.com>
Date: Tue, 4 Aug 2020 22:33:56 +0100
Subject: [PATCH 34/50] fix transformsugar

---
 core/sugarTraversals.ml | 6 +++---
 core/transformSugar.ml  | 4 ++--
 2 files changed, 5 insertions(+), 5 deletions(-)

diff --git a/core/sugarTraversals.ml b/core/sugarTraversals.ml
index 1400b92b7..d2d78f378 100644
--- a/core/sugarTraversals.ml
+++ b/core/sugarTraversals.ml
@@ -566,7 +566,7 @@ class map =
             let _x_i1 = o#phrase _x_i1 in NormalFunlit (_x, _x_i1)
           | MatchFunlit (pat, body) ->
             let pat = o#list (fun o -> o#list (fun o -> o#pattern)) pat in
-            let body = o#list (fun (p, c) -> o#pattern p; o#phrase c) body in MatchFunlit (pat, body)
+            let body = o#list (fun o (p, c) -> let p = o#pattern p in let c = o#phrase c in (p, c)) body in MatchFunlit (pat, body)
 
     method handle_params : handler_parameterisation -> handler_parameterisation =
       fun { shp_bindings; shp_types }->
@@ -1299,7 +1299,7 @@ class fold =
             let o = o#phrase _x_i1 in o
           | MatchFunlit (pat, body) ->
             let o = o#list (fun o -> o#list (fun o -> o#pattern)) pat in
-            let o = o#list (fun (p, c) -> o#pattern p; o#phrase c) body in o
+            let o = o#list (fun o (p, c) -> let o = o#pattern p in let o = o#phrase c in o) body in o
 
 
     method handle_params : handler_parameterisation -> 'self_type =
@@ -2133,7 +2133,7 @@ class fold_map =
             let (o, _x_i1) = o#phrase _x_i1 in (o, NormalFunlit (_x, _x_i1))
           | MatchFunlit (pat, body) ->
             let (o, pat) = o#list (fun o -> o#list (fun o -> o#pattern)) pat in
-            let (o, body) = o#list (fun (p, c) -> o#pattern p; o#phrase c) body in (o, MatchFunlit (pat, body))
+            let (o, body) = o#list (fun o (p, c) -> let (o, p) = o#pattern p in let (o, c) = o#phrase c in (o, (p, c))) body in (o, MatchFunlit (pat, body))
 
     method handle_params : handler_parameterisation -> ('self_type * handler_parameterisation) =
       fun { shp_bindings; shp_types } ->
diff --git a/core/transformSugar.ml b/core/transformSugar.ml
index a178ffdf4..5990e7497 100644
--- a/core/transformSugar.ml
+++ b/core/transformSugar.ml
@@ -740,9 +740,9 @@ class transform (env : Types.typing_environment) =
             let envs = o#backup_envs in
             let (o, pss) = listu o (fun o -> listu o (fun o -> o#pattern)) pss in
             let o = o#with_effects inner_eff in
-            let (o, body, t) = o#list (fun (p, c) -> o#pattern p; o#phrase c) body in
+            let (o, body) = listu o (fun o (p, c) -> let (o, p) = o#pattern p in let (o, c, _) = o#phrase c in (o, (p, c))) body in
             let o = o#restore_envs envs in
-            (o, MatchFunlit (pss, body), t)
+            (o, MatchFunlit (pss, body), Types.unit_type)
 
     method constant : Constant.t -> ('self_type * Constant.t * Types.datatype) =
       function

From 49f01221bc6cfe43d7291ca7ecbf9899fb1e34a6 Mon Sep 17 00:00:00 2001
From: Emanon42 <EmanonTang@outlook.com>
Date: Tue, 4 Aug 2020 23:15:05 +0100
Subject: [PATCH 35/50] fix test cases

---
 tests/functions.tests | 24 ++++++++++++------------
 1 file changed, 12 insertions(+), 12 deletions(-)

diff --git a/tests/functions.tests b/tests/functions.tests
index 820eac371..bc5365003 100644
--- a/tests/functions.tests
+++ b/tests/functions.tests
@@ -147,23 +147,23 @@ linfun f(x) {f(x)} f
 stderr : @.*cannot be linear.*
 exit : 1
 
-Pattern Matching (1):
-fun foo(_) match {| x -> x} foo
-stdout : fun : (Int) ~> Int
+Pattern Matching (1)
+fun foo(_) match { | x -> x } foo
+stdout : fun : (a) ~> a
 
-Pattern Matching (2):
-fun ack(_,_) match {| (0, n) -> n + 1 | (m, 0) -> ack(m - 1, 1) | (m, n) -> ack(m - 1, ack(m, n - 1))} ack
+Pattern Matching (2)
+fun ack(_,_) match { | (0, n) -> n + 1 | (m, 0) -> ack(m - 1, 1) | (m, n) -> ack(m - 1, ack(m, n - 1)) } ack
 stdout : fun : (Int, Int) ~> Int
 
-Pattern Matching (3):
-fun ack(_,_) match {| (0, n) -> n + 1 | (m, 0) -> ack(m - 1, 1) | (m, n) -> ack(m - 1, ack(m, n - 1))} fun test() { println(intToString(ack(0,1))); println(intToString(ack(1,0))); println(intToString(ack(1,1))); } test()
-stdout : 2\n2\n3\n() : ()
+Pattern Matching (3)
+fun ack(_,_) match { | (0, n) -> n + 1 | (m, 0) -> ack(m - 1, 1) | (m, n) -> ack(m - 1, ack(m, n - 1)) } fun test() { print(intToString(ack(0,1))); print(intToString(ack(1,0))); print(intToString(ack(1,1))); } test()
+stdout : 223() : ()
 
-Pattern Matching (4):
-fun foo(_)(_) match {| (x, y) -> x + y} foo
+Pattern Matching (4)
+fun foo(_)(_) match { | (x, y) -> x + y } foo
 stdout : fun : (Int) -> (Int) ~> Int
 
-Pattern Matching (5) - runtime non-exhaustive error:
-fun foo(_) match {| 1 -> 1} foo(0)
+Pattern Matching (5) - runtime non-exhaustive error
+fun foo(_) match { | 1 -> 1 } foo(0)
 stderr : @.*Runtime error: non-exhaustive pattern matching.*
 exit : 1
\ No newline at end of file

From e866a9ff1ba1297683f6384925c152e7dc86ac84 Mon Sep 17 00:00:00 2001
From: Emanon42 <EmanonTang@outlook.com>
Date: Thu, 13 Aug 2020 18:22:59 +0100
Subject: [PATCH 36/50] change keyword to switch and remove redundant
 productions

---
 core/lexer.mll  |  1 -
 core/parser.mly | 13 +++++--------
 2 files changed, 5 insertions(+), 9 deletions(-)

diff --git a/core/lexer.mll b/core/lexer.mll
index 5974abf90..5d9d0356d 100644
--- a/core/lexer.mll
+++ b/core/lexer.mll
@@ -134,7 +134,6 @@ let keywords = [
  "var"      , VAR;
  "where"    , WHERE;
  "with"     , WITH;
- "match"    , MATCH;
 (* SAND *)
  "tablekeys"     , TABLEKEYS;
 ]
diff --git a/core/parser.mly b/core/parser.mly
index 2fb8e4a89..2030d60bf 100644
--- a/core/parser.mly
+++ b/core/parser.mly
@@ -286,7 +286,6 @@ let parse_foreign_language pos lang =
 %token LENS LENSDROP LENSSELECT LENSJOIN DETERMINED BY ON DELETE_LEFT
 %token LENSPUT LENSGET LENSCHECK LENSSERIAL
 %token READONLY DEFAULT
-%token MATCH
 %token ESCAPE
 %token CLIENT SERVER
 %token SEMICOLON
@@ -427,8 +426,6 @@ fun_declarations:
 fun_declaration:
 | tlfunbinding                                                 { fun_binding ~ppos:$loc($1) None $1 }
 | signatures tlfunbinding                                      { fun_binding ~ppos:$loc($2) (fst $1) ~unsafe_sig:(snd $1) $2 }
-| match_tlfunbinding                                           { match_fun_binding ~ppos:$loc($1) None $1 }
-| signatures match_tlfunbinding                                { match_fun_binding ~ppos:$loc($2) (fst $1) ~unsafe_sig:(snd $1) $2 }
 
 linearity:
 | FUN                                                          { dl_unl }
@@ -442,18 +439,16 @@ fun_kind:
 
 tlfunbinding:
 | fun_kind VARIABLE arg_lists perhaps_location block           { ($1, $2, $3, $4, $5)                }
+| fun_kind VARIABLE arg_lists perhaps_location match_body      { ($1, $2, $3, $4, $5)                }
 | OP pattern sigop pattern perhaps_location block              { ((dl_unl, false), WithPos.node $3, [[$2; $4]], $5, $6) }
 | OP OPERATOR pattern perhaps_location block                   { ((dl_unl, false), $2, [[$3]], $4, $5)          }
 | OP pattern OPERATOR perhaps_location block                   { ((dl_unl, false), $3, [[$2]], $4, $5)          }
 
-match_tlfunbinding:
-| fun_kind VARIABLE arg_lists perhaps_location match_body      { ($1, $2, $3, $4, $5)                }
-
 match_body:
-| MATCH LBRACE match_case* RBRACE                             { $3 }
+| SWITCH LBRACE match_case* RBRACE                             { $3 }
 
 match_case:
-| VBAR pattern RARROW block_contents                           { ($2, block ~ppos:$loc $4) }
+| CASE pattern RARROW block_contents                           { ($2, block ~ppos:$loc $4) }
 
 tlvarbinding:
 | VAR VARIABLE perhaps_location EQ exp                         { (PatName $2, $5, $3) }
@@ -842,6 +837,8 @@ binding:
 | exp SEMICOLON                                                { with_pos $loc (Exp $1) }
 | signatures fun_kind VARIABLE arg_lists block                 { fun_binding ~ppos:$loc (fst $1) ~unsafe_sig:(snd $1) ($2, $3, $4, loc_unknown, $5) }
 | fun_kind VARIABLE arg_lists block                            { fun_binding ~ppos:$loc None ($1, $2, $3, loc_unknown, $4) }
+| signatures fun_kind VARIABLE arg_lists match_body            { fun_binding ~ppos:$loc (fst $1) ~unsafe_sig:(snd $1) ($2, $3, $4, loc_unknown, $5) }
+| fun_kind VARIABLE arg_lists match_body                       { fun_binding ~ppos:$loc None ($1, $2, $3, loc_unknown, $4) }
 | typedecl SEMICOLON | links_module
 | links_open SEMICOLON                                         { $1 }
 

From 7e1231928269056b6a022dc2bd9828ed75ab5b5c Mon Sep 17 00:00:00 2001
From: Emanon42 <EmanonTang@outlook.com>
Date: Thu, 13 Aug 2020 22:46:53 +0100
Subject: [PATCH 37/50] fix parser

---
 core/parser.mly | 10 +++++++---
 1 file changed, 7 insertions(+), 3 deletions(-)

diff --git a/core/parser.mly b/core/parser.mly
index 2030d60bf..7849bfecb 100644
--- a/core/parser.mly
+++ b/core/parser.mly
@@ -426,6 +426,8 @@ fun_declarations:
 fun_declaration:
 | tlfunbinding                                                 { fun_binding ~ppos:$loc($1) None $1 }
 | signatures tlfunbinding                                      { fun_binding ~ppos:$loc($2) (fst $1) ~unsafe_sig:(snd $1) $2 }
+| match_tlfunbinding                                           { match_fun_binding ~ppos:$loc($1) None $1 }
+| signatures match_tlfunbinding                                { match_fun_binding ~ppos:$loc($2) (fst $1) ~unsafe_sig:(snd $1) $2 }
 
 linearity:
 | FUN                                                          { dl_unl }
@@ -439,11 +441,13 @@ fun_kind:
 
 tlfunbinding:
 | fun_kind VARIABLE arg_lists perhaps_location block           { ($1, $2, $3, $4, $5)                }
-| fun_kind VARIABLE arg_lists perhaps_location match_body      { ($1, $2, $3, $4, $5)                }
 | OP pattern sigop pattern perhaps_location block              { ((dl_unl, false), WithPos.node $3, [[$2; $4]], $5, $6) }
 | OP OPERATOR pattern perhaps_location block                   { ((dl_unl, false), $2, [[$3]], $4, $5)          }
 | OP pattern OPERATOR perhaps_location block                   { ((dl_unl, false), $3, [[$2]], $4, $5)          }
 
+match_tlfunbinding:
+| fun_kind VARIABLE arg_lists perhaps_location match_body      { ($1, $2, $3, $4, $5)   }
+
 match_body:
 | SWITCH LBRACE match_case* RBRACE                             { $3 }
 
@@ -837,8 +841,8 @@ binding:
 | exp SEMICOLON                                                { with_pos $loc (Exp $1) }
 | signatures fun_kind VARIABLE arg_lists block                 { fun_binding ~ppos:$loc (fst $1) ~unsafe_sig:(snd $1) ($2, $3, $4, loc_unknown, $5) }
 | fun_kind VARIABLE arg_lists block                            { fun_binding ~ppos:$loc None ($1, $2, $3, loc_unknown, $4) }
-| signatures fun_kind VARIABLE arg_lists match_body            { fun_binding ~ppos:$loc (fst $1) ~unsafe_sig:(snd $1) ($2, $3, $4, loc_unknown, $5) }
-| fun_kind VARIABLE arg_lists match_body                       { fun_binding ~ppos:$loc None ($1, $2, $3, loc_unknown, $4) }
+| signatures fun_kind VARIABLE arg_lists match_body            { match_fun_binding ~ppos:$loc (fst $1) ~unsafe_sig:(snd $1) ($2, $3, $4, loc_unknown, $5) }
+| fun_kind VARIABLE arg_lists match_body                       { match_fun_binding ~ppos:$loc None ($1, $2, $3, loc_unknown, $4) }
 | typedecl SEMICOLON | links_module
 | links_open SEMICOLON                                         { $1 }
 

From b9ba88dd33e8b865223daceb3eb2b2d6d28b484e Mon Sep 17 00:00:00 2001
From: Emanon42 <EmanonTang@outlook.com>
Date: Mon, 24 Aug 2020 22:12:55 +0100
Subject: [PATCH 38/50] add flag and fix tests

---
 core/desugarMatching.ml | 16 ++++++++++++++++
 tests/functions.config  |  1 +
 tests/functions.tests   | 14 +++++++++-----
 3 files changed, 26 insertions(+), 5 deletions(-)
 create mode 100644 tests/functions.config

diff --git a/core/desugarMatching.ml b/core/desugarMatching.ml
index 8e2780c76..fd3f57d47 100644
--- a/core/desugarMatching.ml
+++ b/core/desugarMatching.ml
@@ -28,6 +28,21 @@ open SourceCode
 
 let with_pos = SourceCode.WithPos.make
 
+let pattern_matching_sugar =
+  Settings.(
+    flag "pattern_matching_sugar"
+    |> synopsis
+         "Toggles whether to enable the switch pattern matching syntax sugar"
+    |> convert parse_bool
+    |> sync)
+
+let pattern_matching_sugar_guard pos =
+  let pattern_matching_sugar_disabled pos =
+    Errors.disabled_extension ~pos ~setting:("pattern_matching_sugar", true) "Pattern Matching Sugar"
+  in
+  if not (Settings.get pattern_matching_sugar)
+  then raise (pattern_matching_sugar_disabled pos)
+
 let desugar_matching =
 object ((self : 'self_type))
     inherit SugarTraversals.map as super
@@ -35,6 +50,7 @@ object ((self : 'self_type))
       let pos = WithPos.pos b in
       match WithPos.node b with
       |  Fun ({ fun_definition = (tvs, MatchFunlit (patterns, cases)); _ } as fn) ->
+          pattern_matching_sugar_guard pos;
           (* bind the arguments with unique var name *)
           let name_list = List.map (fun pats -> List.map (fun pat -> (pat, Utility.gensym())) pats) patterns in
           let switch_tuple = List.map (fun (_, name) -> with_pos (Var name)) (List.flatten name_list) in
diff --git a/tests/functions.config b/tests/functions.config
new file mode 100644
index 000000000..7d378aced
--- /dev/null
+++ b/tests/functions.config
@@ -0,0 +1 @@
+pattern_matching_sugar=true
\ No newline at end of file
diff --git a/tests/functions.tests b/tests/functions.tests
index bc5365003..cf7a9c917 100644
--- a/tests/functions.tests
+++ b/tests/functions.tests
@@ -1,3 +1,7 @@
+---
+config: tests/functions.config
+---
+
 Function typing bug (see jdy's blog, 2005-10-24)
 (fun (x,y) { [x] ++ [y] }) ([1],"a")
 stderr : @..*
@@ -148,22 +152,22 @@ stderr : @.*cannot be linear.*
 exit : 1
 
 Pattern Matching (1)
-fun foo(_) match { | x -> x } foo
+fun foo(_) switch { case x -> x } foo
 stdout : fun : (a) ~> a
 
 Pattern Matching (2)
-fun ack(_,_) match { | (0, n) -> n + 1 | (m, 0) -> ack(m - 1, 1) | (m, n) -> ack(m - 1, ack(m, n - 1)) } ack
+fun ack(_,_) switch { case (0, n) -> n + 1 case (m, 0) -> ack(m - 1, 1) case (m, n) -> ack(m - 1, ack(m, n - 1)) } ack
 stdout : fun : (Int, Int) ~> Int
 
 Pattern Matching (3)
-fun ack(_,_) match { | (0, n) -> n + 1 | (m, 0) -> ack(m - 1, 1) | (m, n) -> ack(m - 1, ack(m, n - 1)) } fun test() { print(intToString(ack(0,1))); print(intToString(ack(1,0))); print(intToString(ack(1,1))); } test()
+fun ack(_,_) switch { case (0, n) -> n + 1 case (m, 0) -> ack(m - 1, 1) case (m, n) -> ack(m - 1, ack(m, n - 1)) } fun test() { print(intToString(ack(0,1))); print(intToString(ack(1,0))); print(intToString(ack(1,1))); } test()
 stdout : 223() : ()
 
 Pattern Matching (4)
-fun foo(_)(_) match { | (x, y) -> x + y } foo
+fun foo(_)(_) switch { case (x, y) -> x + y } foo
 stdout : fun : (Int) -> (Int) ~> Int
 
 Pattern Matching (5) - runtime non-exhaustive error
-fun foo(_) match { | 1 -> 1 } foo(0)
+fun foo(_) switch { case 1 -> 1 } foo(0)
 stderr : @.*Runtime error: non-exhaustive pattern matching.*
 exit : 1
\ No newline at end of file

From a2dbf5b9cb485efb000520c3f5552ffb0c94f124 Mon Sep 17 00:00:00 2001
From: Emanon42 <EmanonTang@outlook.com>
Date: Mon, 24 Aug 2020 22:53:55 +0100
Subject: [PATCH 39/50] fix test

---
 tests/functions.tests | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/tests/functions.tests b/tests/functions.tests
index cf7a9c917..fcbe181ea 100644
--- a/tests/functions.tests
+++ b/tests/functions.tests
@@ -160,7 +160,7 @@ fun ack(_,_) switch { case (0, n) -> n + 1 case (m, 0) -> ack(m - 1, 1) case (m,
 stdout : fun : (Int, Int) ~> Int
 
 Pattern Matching (3)
-fun ack(_,_) switch { case (0, n) -> n + 1 case (m, 0) -> ack(m - 1, 1) case (m, n) -> ack(m - 1, ack(m, n - 1)) } fun test() { print(intToString(ack(0,1))); print(intToString(ack(1,0))); print(intToString(ack(1,1))); } test()
+fun ack(_,_) switch { case (0, n) -> n + 1 case (m, 0) -> ack(m - 1, 1) case (m, n) -> ack(m - 1, ack(m, n - 1)) } fun test() { print(intToString(ack(0,1))); print(intToString(ack(1,0))); print(intToString(ack(1,1))) } test()
 stdout : 223() : ()
 
 Pattern Matching (4)

From 6b678ea432859025168013e805de17d5d83530b2 Mon Sep 17 00:00:00 2001
From: Emanon42 <EmanonTang@outlook.com>
Date: Tue, 25 Aug 2020 23:33:24 +0100
Subject: [PATCH 40/50] resolve daniel's review

---
 core/desugarInners.ml   |  6 +++++-
 core/desugarMatching.ml |  9 +++++++++
 core/desugarModules.ml  |  2 +-
 core/errors.ml          |  2 ++
 core/errors.mli         |  1 +
 core/parser.mly         |  5 +----
 core/renamer.ml         | 16 ++++++++++++----
 core/sugartoir.ml       |  6 +++++-
 core/transformSugar.ml  |  4 +++-
 core/typeSugar.ml       | 24 ++++++++++++++++++++----
 tests/functions.tests   |  5 +++++
 11 files changed, 64 insertions(+), 16 deletions(-)

diff --git a/core/desugarInners.ml b/core/desugarInners.ml
index 46cdda070..2a5ec9ff5 100644
--- a/core/desugarInners.ml
+++ b/core/desugarInners.ml
@@ -172,7 +172,11 @@ object (o : 'self_type)
                let o = o#with_visiting (StringSet.add (Binder.to_name rec_binder) visiting_funs) in
                let (o, tyvars) = o#quantifiers tyvars in
                let (o, inner) = o#datatype inner in
-               let lam_in = match lam with | NormalFunlit x -> x | MatchFunlit _ -> assert false in
+               let lam_in =
+                match lam with
+                | NormalFunlit x -> x
+                | _ -> assert false
+               in
                let inner_effects = TransformSugar.fun_effects inner (fst lam_in) in
                let (o, lam, _) = o#funlit inner_effects lam in
                let o = o#restore_quantifiers outer_tyvars in
diff --git a/core/desugarMatching.ml b/core/desugarMatching.ml
index fd3f57d47..cd114b6ce 100644
--- a/core/desugarMatching.ml
+++ b/core/desugarMatching.ml
@@ -43,6 +43,14 @@ let pattern_matching_sugar_guard pos =
   if not (Settings.get pattern_matching_sugar)
   then raise (pattern_matching_sugar_disabled pos)
 
+let nullary_guard tuple pos =
+  let nullary_error pos =
+    Errors.desugaring_error ~pos:pos ~stage:Errors.DesugarMatching ~message:"Can't match over nullary function"
+  in
+  match tuple with
+    | [] -> raise (nullary_error pos)
+    | _ -> ()
+
 let desugar_matching =
 object ((self : 'self_type))
     inherit SugarTraversals.map as super
@@ -54,6 +62,7 @@ object ((self : 'self_type))
           (* bind the arguments with unique var name *)
           let name_list = List.map (fun pats -> List.map (fun pat -> (pat, Utility.gensym())) pats) patterns in
           let switch_tuple = List.map (fun (_, name) -> with_pos (Var name)) (List.flatten name_list) in
+          nullary_guard switch_tuple pos;
           (* assemble exhaustive handler *)
           let exhaustive_patterns = with_pos (Pattern.Any) in
           let exhaustive_position = Format.sprintf "non-exhaustive pattern matching at %s" (SourceCode.Position.show pos) in
diff --git a/core/desugarModules.ml b/core/desugarModules.ml
index ba2512896..af57740f7 100644
--- a/core/desugarModules.ml
+++ b/core/desugarModules.ml
@@ -319,7 +319,7 @@ and desugar ?(toplevel=false) (renamer' : Epithet.t) (scope' : Scope.t) =
           in
           let body' = visitor#phrase body in
           NormalFunlit (paramss', body')
-        | MatchFunlit (_, _) -> assert false
+        | _ -> assert false
 
     method cases : (Pattern.with_pos * phrase) list -> (Pattern.with_pos * phrase) list
       = fun cases ->
diff --git a/core/errors.ml b/core/errors.ml
index b35ad187a..089b4b703 100644
--- a/core/errors.ml
+++ b/core/errors.ml
@@ -16,6 +16,7 @@ type sugar_error_stage =
   | CheckXML
   | DesugarInners
   | DesugarModules
+  | DesugarMatching
 
 let string_of_stage = function
   | DesugarFormlets    -> "compiling formlets"
@@ -26,6 +27,7 @@ let string_of_stage = function
   | CheckXML           -> "checking XML"
   | DesugarInners      -> "desugaring inner types"
   | DesugarModules     -> "desugaring modules"
+  | DesugarMatching    -> "desugaring matching"
 
 exception RuntimeError of string
 exception UndefinedVariable of string
diff --git a/core/errors.mli b/core/errors.mli
index a75b23590..e16f47cfc 100644
--- a/core/errors.mli
+++ b/core/errors.mli
@@ -14,6 +14,7 @@ type sugar_error_stage =
   | CheckXML
   | DesugarInners
   | DesugarModules
+  | DesugarMatching
 
 
 exception RuntimeError of string
diff --git a/core/parser.mly b/core/parser.mly
index 2ce4fae1e..daad6c0e3 100644
--- a/core/parser.mly
+++ b/core/parser.mly
@@ -449,10 +449,7 @@ match_tlfunbinding:
 | fun_kind VARIABLE arg_lists perhaps_location match_body      { ($1, $2, $3, $4, $5)   }
 
 match_body:
-| SWITCH LBRACE match_case* RBRACE                             { $3 }
-
-match_case:
-| CASE pattern RARROW block_contents                           { ($2, block ~ppos:$loc $4) }
+| SWITCH LBRACE case+ RBRACE                                   { $3 }
 
 tlvarbinding:
 | VAR VARIABLE perhaps_location EQ exp                         { (PatName $2, $5, $3) }
diff --git a/core/renamer.ml b/core/renamer.ml
index 3bf27a099..df88e3375 100644
--- a/core/renamer.ml
+++ b/core/renamer.ml
@@ -143,7 +143,7 @@ let renamer qs_from qs_to =
      let o, (pats', tyvars', typ', _, signature', body') =
        match f with
         | NormalFunlit (pats, body) -> o#handle_function pats tyvars (Binder.to_type fun_binder) None fun_signature body
-        | MatchFunlit (_,_) -> assert false in
+        | _ -> assert false in
      let function_definition' =
        { fun_binder = Binder.set_type fun_binder typ'
        ; fun_linearity
@@ -167,7 +167,7 @@ let renamer qs_from qs_to =
        let o, (pats', tyvars', typ', ty', signature', body') =
          match f with
           | NormalFunlit (pats, body) -> o#handle_function pats tyvars (Binder.to_type rec_binder) ty rec_signature body
-          | MatchFunlit (_,_) -> assert false in
+          | _ -> assert false in
        let recursive_definition' =
          { rec_binder = Binder.set_type rec_binder typ'
          ; rec_linearity
@@ -220,7 +220,11 @@ let rename_function_definition : function_definition -> function_definition =
       ; fun_signature
       ; fun_frozen
       ; fun_unsafe_signature } ->
-  let (pats, body) = match f with | NormalFunlit (ps, bd) -> (ps, bd) | MatchFunlit (_,_) -> assert false in
+  let (pats, body) =
+    match f with
+    | NormalFunlit (ps, bd) -> (ps, bd)
+    | _ -> assert false
+  in
   let qs_from = List.map SugarQuantifier.get_resolved_exn tyvars_from in
   let qs_to, _      = Instantiate.build_fresh_quantifiers qs_from in
   let tyvars_to     = List.map SugarQuantifier.mk_resolved qs_to in
@@ -247,7 +251,11 @@ let rename_recursive_functionnode :
       ; rec_signature
       ; rec_frozen
       ; rec_unsafe_signature } ->
-  let (pats, body) = match f with | NormalFunlit (ps, bd) -> (ps, bd) | MatchFunlit (_,_) -> assert false in
+  let (pats, body) =
+    match f with
+    | NormalFunlit (ps, bd) -> (ps, bd)
+    | _ -> assert false
+  in
   let qs_from = List.map SugarQuantifier.get_resolved_exn tyvars_from in
   let qs_to, _      = Instantiate.build_fresh_quantifiers qs_from in
   let tyvars_to     = List.map SugarQuantifier.mk_resolved qs_to in
diff --git a/core/sugartoir.ml b/core/sugartoir.ml
index 892ecb557..953d30d8c 100644
--- a/core/sugartoir.ml
+++ b/core/sugartoir.ml
@@ -1183,7 +1183,11 @@ struct
                                rec_definition       = ((tyvars, _), fnlit);
                                rec_location         = location;
                                rec_unsafe_signature = unsafe; _ } ->
-                          let (pss, body) = match fnlit with | NormalFunlit (pss, body) -> (pss, body) | MatchFunlit (_,_) -> assert false in
+                          let (pss, body) =
+                            match fnlit with
+                            | NormalFunlit (pss, body) -> (pss, body)
+                            | _ -> assert false
+                          in
                           assert (List.length pss = 1);
                           let f  = Binder.to_name bndr in
                           let ft = Binder.to_type bndr in
diff --git a/core/transformSugar.ml b/core/transformSugar.ml
index 5990e7497..c9827d5e4 100644
--- a/core/transformSugar.ml
+++ b/core/transformSugar.ml
@@ -131,7 +131,9 @@ let on_effects o (eff : Types.row) fn x =
   (o#with_effects effect_row, x, y)
 
 let get_normal_funlit fnlit =
-  match fnlit with | NormalFunlit x -> x | MatchFunlit _ -> assert false
+  match fnlit with
+  | NormalFunlit x -> x
+  | _-> assert false
 
 let check_type_application (e, t) k =
   begin
diff --git a/core/typeSugar.ml b/core/typeSugar.ml
index 9ec622e82..75afb40c6 100644
--- a/core/typeSugar.ml
+++ b/core/typeSugar.ml
@@ -2668,7 +2668,11 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * Usage.t =
                   ListLit (List.map erase (e::es), Some (typ e)), T.Application (Types.list, [PrimaryKind.Type, typ e]), Usage.combine_many (List.map usages (e::es))
             end
         | FunLit (argss_prev, lin, fnlit, location) ->
-            let (pats, body) = match fnlit with | NormalFunlit (pat, body) -> (pat, body) | MatchFunlit (_,_) -> assert false in
+            let (pats, body) =
+              match fnlit with
+              | NormalFunlit (pat, body) -> (pat, body)
+              | _ -> assert false
+            in
             let vs = check_for_duplicate_names pos (List.flatten pats) in
             let (pats_init, pats_tail) = from_option ([], []) (unsnoc_opt pats) in
             let tpc' = if DeclaredLinearity.is_linear lin then tpc else tpcu in
@@ -4194,7 +4198,11 @@ and type_binding : context -> binding -> binding * context * Usage.t =
                fun_frozen;
                fun_unsafe_signature = unsafe } =
            Renamer.rename_function_definition def in
-          let (pats, body) = match fnlit with | NormalFunlit (pats, body) -> (pats, body) | MatchFunlit (_,_) -> assert false in
+          let (pats, body) =
+            match fnlit with
+            | NormalFunlit (pats, body) -> (pats, body)
+            | _ -> assert false
+          in
           let name = Binder.to_name bndr in
           let vs = name :: check_for_duplicate_names pos (List.flatten pats) in
           let (pats_init, pats_tail) = from_option ([], []) (unsnoc_opt pats) in
@@ -4363,7 +4371,11 @@ and type_binding : context -> binding -> binding * context * Usage.t =
                             rec_frozen = frozen;
                             _ }; _ } ->
                  let name = Binder.to_name bndr in
-                 let pats = match fnlit with NormalFunlit (pats, _) -> pats | MatchFunlit (_,_) -> assert false in
+                 let pats =
+                  match fnlit with
+                  | NormalFunlit (pats, _) -> pats
+                  | _ -> assert false
+                 in
                  (* recursive functions can't be linear! *)
                  if DeclaredLinearity.is_linear lin then
                    Gripers.linear_recursive_function pos name;
@@ -4432,7 +4444,11 @@ and type_binding : context -> binding -> binding * context * Usage.t =
                         {node={ rec_binder = bndr; rec_linearity = lin;
                                 rec_definition = (_, fnlit); _ } as fn; pos }
                         pats ->
-                      let body = match fnlit with NormalFunlit (_, body) -> body | MatchFunlit (_,_) -> assert false in
+                      let body =
+                        match fnlit with
+                        | NormalFunlit (_, body) -> body
+                        | _ -> assert false
+                      in
                       let name = Binder.to_name bndr in
                       let pat_env = List.fold_left (fun env pat -> Env.extend env (pattern_env pat)) Env.empty (List.flatten pats) in
                       let self_env =
diff --git a/tests/functions.tests b/tests/functions.tests
index fcbe181ea..3844219d1 100644
--- a/tests/functions.tests
+++ b/tests/functions.tests
@@ -170,4 +170,9 @@ stdout : fun : (Int) -> (Int) ~> Int
 Pattern Matching (5) - runtime non-exhaustive error
 fun foo(_) switch { case 1 -> 1 } foo(0)
 stderr : @.*Runtime error: non-exhaustive pattern matching.*
+exit : 1
+
+Pattern Matching (6) - matching over nullary function
+fun f() switch { case n -> 1 }
+stderr : @.*Error desugaring matching: Can't match over nullary function.*
 exit : 1
\ No newline at end of file

From f56256c45b808dd9106b8e6a92dd5955b9e70ef3 Mon Sep 17 00:00:00 2001
From: Emanon42 <EmanonTang@outlook.com>
Date: Wed, 26 Aug 2020 13:40:02 +0100
Subject: [PATCH 41/50] rename and fix nullary guard

---
 core/desugarMatching.ml       | 18 +++++++++---------
 core/lens_sugar_conv.ml       |  2 +-
 core/parser.mly               | 16 ++++++++--------
 core/sugarConstructors.ml     |  8 ++++----
 core/sugarConstructorsIntf.ml |  8 ++++----
 core/sugarTraversals.ml       | 10 +++++-----
 core/sugartypes.ml            | 14 +++++++-------
 core/transformSugar.ml        |  4 ++--
 8 files changed, 40 insertions(+), 40 deletions(-)

diff --git a/core/desugarMatching.ml b/core/desugarMatching.ml
index cd114b6ce..44b1b6844 100644
--- a/core/desugarMatching.ml
+++ b/core/desugarMatching.ml
@@ -6,10 +6,10 @@ open SourceCode
 
   This transformation convert function like that:
 
-  fun foo(a1, ..., an) match {
-    | case (p1_1, ..., p1_n) -> b_1
-    | ...
-    | case (pm_1, pm_n) -> b_m
+  fun foo(a1, ..., an) switch {
+    case (p1_1, ..., p1_n) -> b_1
+    ...
+    case (pm_1, pm_n) -> b_m
   }
 
   to function with switch body like that:
@@ -43,12 +43,12 @@ let pattern_matching_sugar_guard pos =
   if not (Settings.get pattern_matching_sugar)
   then raise (pattern_matching_sugar_disabled pos)
 
-let nullary_guard tuple pos =
+let nullary_guard pss pos =
   let nullary_error pos =
     Errors.desugaring_error ~pos:pos ~stage:Errors.DesugarMatching ~message:"Can't match over nullary function"
   in
-  match tuple with
-    | [] -> raise (nullary_error pos)
+  match pss with
+    | [[]] -> raise (nullary_error pos)
     | _ -> ()
 
 let desugar_matching =
@@ -57,12 +57,12 @@ object ((self : 'self_type))
     method! binding = fun b ->
       let pos = WithPos.pos b in
       match WithPos.node b with
-      |  Fun ({ fun_definition = (tvs, MatchFunlit (patterns, cases)); _ } as fn) ->
+      |  Fun ({ fun_definition = (tvs, SwitchFunlit (patterns, cases)); _ } as fn) ->
           pattern_matching_sugar_guard pos;
+          nullary_guard patterns pos;
           (* bind the arguments with unique var name *)
           let name_list = List.map (fun pats -> List.map (fun pat -> (pat, Utility.gensym())) pats) patterns in
           let switch_tuple = List.map (fun (_, name) -> with_pos (Var name)) (List.flatten name_list) in
-          nullary_guard switch_tuple pos;
           (* assemble exhaustive handler *)
           let exhaustive_patterns = with_pos (Pattern.Any) in
           let exhaustive_position = Format.sprintf "non-exhaustive pattern matching at %s" (SourceCode.Position.show pos) in
diff --git a/core/lens_sugar_conv.ml b/core/lens_sugar_conv.ml
index ac3096333..dbae047af 100644
--- a/core/lens_sugar_conv.ml
+++ b/core/lens_sugar_conv.ml
@@ -113,6 +113,6 @@ let lens_sugar_phrase_of_sugar p =
       | _ ->
           Format.asprintf "Unsupported binder: %a" S.pp_phrase p
           |> Error.internal_error_res )
-  | S.FunLit (_, _, Sugartypes.MatchFunlit (_, _), _) -> assert false
+  | S.FunLit (_, _, Sugartypes.SwitchFunlit (_, _), _) -> assert false
   | _ -> lens_sugar_phrase_of_body "" p )
   |> Result.ok_exn
diff --git a/core/parser.mly b/core/parser.mly
index daad6c0e3..1067098f0 100644
--- a/core/parser.mly
+++ b/core/parser.mly
@@ -426,8 +426,8 @@ fun_declarations:
 fun_declaration:
 | tlfunbinding                                                 { fun_binding ~ppos:$loc($1) None $1 }
 | signatures tlfunbinding                                      { fun_binding ~ppos:$loc($2) (fst $1) ~unsafe_sig:(snd $1) $2 }
-| match_tlfunbinding                                           { match_fun_binding ~ppos:$loc($1) None $1 }
-| signatures match_tlfunbinding                                { match_fun_binding ~ppos:$loc($2) (fst $1) ~unsafe_sig:(snd $1) $2 }
+| switch_tlfunbinding                                          { switch_fun_binding ~ppos:$loc($1) None $1 }
+| signatures switch_tlfunbinding                               { switch_fun_binding ~ppos:$loc($2) (fst $1) ~unsafe_sig:(snd $1) $2 }
 
 linearity:
 | FUN                                                          { dl_unl }
@@ -445,10 +445,10 @@ tlfunbinding:
 | OP OPERATOR pattern perhaps_location block                   { ((dl_unl, false), $2, [[$3]], $4, $5)          }
 | OP pattern OPERATOR perhaps_location block                   { ((dl_unl, false), $3, [[$2]], $4, $5)          }
 
-match_tlfunbinding:
-| fun_kind VARIABLE arg_lists perhaps_location match_body      { ($1, $2, $3, $4, $5)   }
+switch_tlfunbinding:
+| fun_kind VARIABLE arg_lists perhaps_location switch_body     { ($1, $2, $3, $4, $5)   }
 
-match_body:
+switch_body:
 | SWITCH LBRACE case+ RBRACE                                   { $3 }
 
 tlvarbinding:
@@ -555,7 +555,7 @@ primary_expression:
 | LBRACKET exp DOTDOT exp RBRACKET                             { with_pos $loc (RangeLit($2, $4))   }
 | xml                                                          { $1 }
 | linearity arg_lists block                                    { fun_lit ~ppos:$loc $1 $2 $3 }
-| linearity arg_lists match_body                               { match_fun_lit ~ppos:$loc $1 $2 $3 }
+| linearity arg_lists switch_body                              { switch_fun_lit ~ppos:$loc $1 $2 $3 }
 | LEFTTRIANGLE cp_expression RIGHTTRIANGLE                     { with_pos $loc (CP $2) }
 | DOLLAR primary_expression                                    { with_pos $loc (Generalise $2) }
 
@@ -838,8 +838,8 @@ binding:
 | exp SEMICOLON                                                { with_pos $loc (Exp $1) }
 | signatures fun_kind VARIABLE arg_lists block                 { fun_binding ~ppos:$loc (fst $1) ~unsafe_sig:(snd $1) ($2, $3, $4, loc_unknown, $5) }
 | fun_kind VARIABLE arg_lists block                            { fun_binding ~ppos:$loc None ($1, $2, $3, loc_unknown, $4) }
-| signatures fun_kind VARIABLE arg_lists match_body            { match_fun_binding ~ppos:$loc (fst $1) ~unsafe_sig:(snd $1) ($2, $3, $4, loc_unknown, $5) }
-| fun_kind VARIABLE arg_lists match_body                       { match_fun_binding ~ppos:$loc None ($1, $2, $3, loc_unknown, $4) }
+| signatures fun_kind VARIABLE arg_lists switch_body           { switch_fun_binding ~ppos:$loc (fst $1) ~unsafe_sig:(snd $1) ($2, $3, $4, loc_unknown, $5) }
+| fun_kind VARIABLE arg_lists switch_body                      { switch_fun_binding ~ppos:$loc None ($1, $2, $3, loc_unknown, $4) }
 | typedecl SEMICOLON | links_module
 | links_open SEMICOLON                                         { $1 }
 
diff --git a/core/sugarConstructors.ml b/core/sugarConstructors.ml
index 27f0d223c..947f2210a 100644
--- a/core/sugarConstructors.ml
+++ b/core/sugarConstructors.ml
@@ -136,8 +136,8 @@ module SugarConstructors (Position : Pos)
   let fun_lit ?(ppos=dp) ?args ?(location=loc_unknown) linearity pats blk =
     with_pos ppos (FunLit (args, linearity, NormalFunlit (pats, blk), location))
 
-  let match_fun_lit ?(ppos=dp) ?args ?(location=loc_unknown) linearity pats match_body =
-    with_pos ppos (FunLit (args, linearity, MatchFunlit (pats, match_body), location))
+  let switch_fun_lit ?(ppos=dp) ?args ?(location=loc_unknown) linearity pats switch_funlit_body =
+    with_pos ppos (FunLit (args, linearity, SwitchFunlit (pats, switch_funlit_body), location))
 
   (* Create a Spawn. *)
   let spawn ?(ppos=dp) ?row spawn_kind location blk =
@@ -175,11 +175,11 @@ module SugarConstructors (Position : Pos)
                          fun_frozen = false;
                          fun_unsafe_signature = false })
 
-  let match_fun_binding ?(ppos=dp) sig_opt ?(unsafe_sig=false) ((linearity, frozen), bndr, args, location, blk) =
+  let switch_fun_binding ?(ppos=dp) sig_opt ?(unsafe_sig=false) ((linearity, frozen), bndr, args, location, blk) =
     let fun_signature = datatype_opt_of_sig_opt sig_opt bndr in
       with_pos ppos (Fun { fun_binder = binder bndr;
                            fun_linearity = linearity;
-                           fun_definition = ([], MatchFunlit (args, blk));
+                           fun_definition = ([], SwitchFunlit (args, blk));
                            fun_location = location;
                            fun_signature;
                            fun_frozen = frozen;
diff --git a/core/sugarConstructorsIntf.ml b/core/sugarConstructorsIntf.ml
index 0e3937c16..ad0869e89 100644
--- a/core/sugarConstructorsIntf.ml
+++ b/core/sugarConstructorsIntf.ml
@@ -93,10 +93,10 @@ module type SugarConstructorsSig = sig
      -> ?location:Location.t -> DeclaredLinearity.t
      -> Pattern.with_pos list list -> phrase
      -> phrase
-  val match_fun_lit
+  val switch_fun_lit
       : ?ppos:t -> ?args:((Types.datatype * Types.row) list)
      -> ?location:Location.t -> DeclaredLinearity.t
-     -> Pattern.with_pos list list -> match_body
+     -> Pattern.with_pos list list -> switch_funlit_body
      -> phrase
   val spawn
       : ?ppos:t
@@ -119,9 +119,9 @@ module type SugarConstructorsSig = sig
      -> ?location:Location.t -> ?annotation:datatype'
      -> Binder.with_pos -> funlit
      -> binding
-  val match_fun_binding
+  val switch_fun_binding
       : ?ppos:t -> signature -> ?unsafe_sig:bool
-     -> ((DeclaredLinearity.t * bool) * Name.t * Pattern.with_pos list list * Location.t * match_body)
+     -> ((DeclaredLinearity.t * bool) * Name.t * Pattern.with_pos list list * Location.t * switch_funlit_body)
      -> binding
   val val_binding'
       : ?ppos:t -> signature -> (name_or_pat * phrase * Location.t)
diff --git a/core/sugarTraversals.ml b/core/sugarTraversals.ml
index d2d78f378..7061704bb 100644
--- a/core/sugarTraversals.ml
+++ b/core/sugarTraversals.ml
@@ -564,9 +564,9 @@ class map =
           | NormalFunlit (_x, _x_i1) ->
             let _x = o#list (fun o -> o#list (fun o -> o#pattern)) _x in
             let _x_i1 = o#phrase _x_i1 in NormalFunlit (_x, _x_i1)
-          | MatchFunlit (pat, body) ->
+          | SwitchFunlit (pat, body) ->
             let pat = o#list (fun o -> o#list (fun o -> o#pattern)) pat in
-            let body = o#list (fun o (p, c) -> let p = o#pattern p in let c = o#phrase c in (p, c)) body in MatchFunlit (pat, body)
+            let body = o#list (fun o (p, c) -> let p = o#pattern p in let c = o#phrase c in (p, c)) body in SwitchFunlit (pat, body)
 
     method handle_params : handler_parameterisation -> handler_parameterisation =
       fun { shp_bindings; shp_types }->
@@ -1297,7 +1297,7 @@ class fold =
           | NormalFunlit (_x, _x_i1) ->
             let o = o#list (fun o -> o#list (fun o -> o#pattern)) _x in
             let o = o#phrase _x_i1 in o
-          | MatchFunlit (pat, body) ->
+          | SwitchFunlit (pat, body) ->
             let o = o#list (fun o -> o#list (fun o -> o#pattern)) pat in
             let o = o#list (fun o (p, c) -> let o = o#pattern p in let o = o#phrase c in o) body in o
 
@@ -2131,9 +2131,9 @@ class fold_map =
           | NormalFunlit (_x, _x_i1) ->
             let (o, _x) = o#list (fun o -> o#list (fun o -> o#pattern)) _x in
             let (o, _x_i1) = o#phrase _x_i1 in (o, NormalFunlit (_x, _x_i1))
-          | MatchFunlit (pat, body) ->
+          | SwitchFunlit (pat, body) ->
             let (o, pat) = o#list (fun o -> o#list (fun o -> o#pattern)) pat in
-            let (o, body) = o#list (fun o (p, c) -> let (o, p) = o#pattern p in let (o, c) = o#phrase c in (o, (p, c))) body in (o, MatchFunlit (pat, body))
+            let (o, body) = o#list (fun o (p, c) -> let (o, p) = o#pattern p in let (o, c) = o#phrase c in (o, (p, c))) body in (o, SwitchFunlit (pat, body))
 
     method handle_params : handler_parameterisation -> ('self_type * handler_parameterisation) =
       fun { shp_bindings; shp_types } ->
diff --git a/core/sugartypes.ml b/core/sugartypes.ml
index 0811cd255..bc6ad88de 100644
--- a/core/sugartypes.ml
+++ b/core/sugartypes.ml
@@ -369,9 +369,9 @@ and regex =
   | Splice    of phrase
   | Replace   of regex * replace_rhs
 and clause = Pattern.with_pos * phrase
-and funlit = NormalFunlit of normal_funlit | MatchFunlit of match_funlit
-and match_funlit = Pattern.with_pos list list * match_body
-and match_body = (Pattern.with_pos * phrase) list
+and funlit = NormalFunlit of normal_funlit | SwitchFunlit of switch_funlit
+and switch_funlit = Pattern.with_pos list list * switch_funlit_body
+and switch_funlit_body = (Pattern.with_pos * phrase) list
 and normal_funlit = Pattern.with_pos list list * phrase
 and handler =
   { sh_expr         : phrase
@@ -772,12 +772,12 @@ struct
   and funlit (fn : funlit) : StringSet.t =
     match fn with
     | NormalFunlit n_fn -> normal_funlit n_fn
-    | MatchFunlit m_fn -> match_funlit m_fn
+    | SwitchFunlit m_fn -> switch_funlit m_fn
   and normal_funlit (args, body : normal_funlit) : StringSet.t =
     diff (phrase body) (union_map (union_map pattern) args)
-  and match_funlit (args, body : match_funlit) : StringSet.t =
-    diff (match_body body) (union_map (union_map pattern) args)
-  and match_body (body : (Pattern.with_pos * phrase) list) : StringSet.t =
+  and switch_funlit (args, body : switch_funlit) : StringSet.t =
+    diff (switch_funlit_body body) (union_map (union_map pattern) args)
+  and switch_funlit_body (body : (Pattern.with_pos * phrase) list) : StringSet.t =
     union_map (fun (pat, phr) -> union (pattern pat) (phrase phr)) body
   and block (binds, expr : binding list * phrase) : StringSet.t =
     ListLabels.fold_right binds ~init:(phrase expr)
diff --git a/core/transformSugar.ml b/core/transformSugar.ml
index c9827d5e4..b9a16ef92 100644
--- a/core/transformSugar.ml
+++ b/core/transformSugar.ml
@@ -738,13 +738,13 @@ class transform (env : Types.typing_environment) =
             let (o, e, t) = o#phrase e in
             let o = o#restore_envs envs in
             (o, NormalFunlit (pss, e), t)
-          | MatchFunlit (pss, body) ->
+          | SwitchFunlit (pss, body) ->
             let envs = o#backup_envs in
             let (o, pss) = listu o (fun o -> listu o (fun o -> o#pattern)) pss in
             let o = o#with_effects inner_eff in
             let (o, body) = listu o (fun o (p, c) -> let (o, p) = o#pattern p in let (o, c, _) = o#phrase c in (o, (p, c))) body in
             let o = o#restore_envs envs in
-            (o, MatchFunlit (pss, body), Types.unit_type)
+            (o, SwitchFunlit (pss, body), Types.unit_type)
 
     method constant : Constant.t -> ('self_type * Constant.t * Types.datatype) =
       function

From 6310d72d4c2c310376f66fb1b9be350d6f14880a Mon Sep 17 00:00:00 2001
From: Emanon42 <EmanonTang@outlook.com>
Date: Wed, 26 Aug 2020 18:17:38 +0100
Subject: [PATCH 42/50] change switch function arg structure

---
 core/desugarMatching.ml       | 15 ++++++++-------
 core/parser.mly               | 13 ++++++++-----
 core/sugarConstructors.ml     |  8 ++++----
 core/sugarConstructorsIntf.ml |  4 ++--
 core/sugarTraversals.ml       |  6 +++---
 core/sugartypes.ml            |  4 ++--
 core/transformSugar.ml        |  2 +-
 tests/functions.tests         |  5 +++--
 8 files changed, 31 insertions(+), 26 deletions(-)

diff --git a/core/desugarMatching.ml b/core/desugarMatching.ml
index 44b1b6844..cd006b5c2 100644
--- a/core/desugarMatching.ml
+++ b/core/desugarMatching.ml
@@ -48,7 +48,7 @@ let nullary_guard pss pos =
     Errors.desugaring_error ~pos:pos ~stage:Errors.DesugarMatching ~message:"Can't match over nullary function"
   in
   match pss with
-    | [[]] -> raise (nullary_error pos)
+    | [] -> raise (nullary_error pos)
     | _ -> ()
 
 let desugar_matching =
@@ -61,19 +61,20 @@ object ((self : 'self_type))
           pattern_matching_sugar_guard pos;
           nullary_guard patterns pos;
           (* bind the arguments with unique var name *)
-          let name_list = List.map (fun pats -> List.map (fun pat -> (pat, Utility.gensym())) pats) patterns in
-          let switch_tuple = List.map (fun (_, name) -> with_pos (Var name)) (List.flatten name_list) in
+          let name_list = List.map (fun pat -> (pat, Utility.gensym())) patterns in
+          let switch_tuple = List.map (fun (_, name) -> with_pos (Var name)) name_list in
           (* assemble exhaustive handler *)
           let exhaustive_patterns = with_pos (Pattern.Any) in
           let exhaustive_position = Format.sprintf "non-exhaustive pattern matching at %s" (SourceCode.Position.show pos) in
           let exhaustive_case = FnAppl (with_pos (Var "error"), [with_pos (Constant (CommonTypes.Constant.String exhaustive_position))]) in
           let normal_args =
-            List.map (fun pats -> List.map (fun (pat, name) ->
-                                              with_pos (Pattern.As (with_pos (Binder.make ~name ()), pat)))
-                                            pats) name_list in
+            List.map
+              (fun (pat, name) -> with_pos (Pattern.As (with_pos (Binder.make ~name ()), pat)))
+              name_list
+          in
           let cases = cases@[(exhaustive_patterns, with_pos exhaustive_case)] in
           let switch_body = Switch (with_pos (TupleLit switch_tuple), cases, None) in
-          let normal_fnlit = NormalFunlit (normal_args, with_pos switch_body) in
+          let normal_fnlit = NormalFunlit ([normal_args], with_pos switch_body) in
           let normal_fnlit = self#funlit normal_fnlit in
           let node = Fun { fun_binder = fn.fun_binder;
                            fun_linearity = fn.fun_linearity;
diff --git a/core/parser.mly b/core/parser.mly
index 1067098f0..df7ad4887 100644
--- a/core/parser.mly
+++ b/core/parser.mly
@@ -169,7 +169,10 @@ let parseRegexFlags f =
               | 'g' -> RegexGlobal
               | _ -> assert false) (asList f 0 [])
 
-
+let switch_fun_currying_guard p args =
+  match args with
+  | [arg] -> arg
+  | _ -> raise (Errors.Type_error (pos p, "Not support pattern matching function with multiple parameter lists yet"))
 
 let named_typevar name freedom : SugarTypeVar.t =
   SugarTypeVar.mk_unresolved name None freedom
@@ -446,7 +449,7 @@ tlfunbinding:
 | OP pattern OPERATOR perhaps_location block                   { ((dl_unl, false), $3, [[$2]], $4, $5)          }
 
 switch_tlfunbinding:
-| fun_kind VARIABLE arg_lists perhaps_location switch_body     { ($1, $2, $3, $4, $5)   }
+| fun_kind VARIABLE arg_lists perhaps_location switch_body     { ($1, $2, (switch_fun_currying_guard $loc($3) $3), $4, $5)   }
 
 switch_body:
 | SWITCH LBRACE case+ RBRACE                                   { $3 }
@@ -555,7 +558,7 @@ primary_expression:
 | LBRACKET exp DOTDOT exp RBRACKET                             { with_pos $loc (RangeLit($2, $4))   }
 | xml                                                          { $1 }
 | linearity arg_lists block                                    { fun_lit ~ppos:$loc $1 $2 $3 }
-| linearity arg_lists switch_body                              { switch_fun_lit ~ppos:$loc $1 $2 $3 }
+| linearity arg_lists switch_body                              { switch_fun_lit ~ppos:$loc $1 (switch_fun_currying_guard $loc($2) $2) $3 }
 | LEFTTRIANGLE cp_expression RIGHTTRIANGLE                     { with_pos $loc (CP $2) }
 | DOLLAR primary_expression                                    { with_pos $loc (Generalise $2) }
 
@@ -838,8 +841,8 @@ binding:
 | exp SEMICOLON                                                { with_pos $loc (Exp $1) }
 | signatures fun_kind VARIABLE arg_lists block                 { fun_binding ~ppos:$loc (fst $1) ~unsafe_sig:(snd $1) ($2, $3, $4, loc_unknown, $5) }
 | fun_kind VARIABLE arg_lists block                            { fun_binding ~ppos:$loc None ($1, $2, $3, loc_unknown, $4) }
-| signatures fun_kind VARIABLE arg_lists switch_body           { switch_fun_binding ~ppos:$loc (fst $1) ~unsafe_sig:(snd $1) ($2, $3, $4, loc_unknown, $5) }
-| fun_kind VARIABLE arg_lists switch_body                      { switch_fun_binding ~ppos:$loc None ($1, $2, $3, loc_unknown, $4) }
+| signatures fun_kind VARIABLE arg_lists switch_body           { switch_fun_binding ~ppos:$loc (fst $1) ~unsafe_sig:(snd $1) ($2, $3, (switch_fun_currying_guard $loc($4) $4), loc_unknown, $5) }
+| fun_kind VARIABLE arg_lists switch_body                      { switch_fun_binding ~ppos:$loc None ($1, $2, (switch_fun_currying_guard $loc($3) $3), loc_unknown, $4) }
 | typedecl SEMICOLON | links_module
 | links_open SEMICOLON                                         { $1 }
 
diff --git a/core/sugarConstructors.ml b/core/sugarConstructors.ml
index 947f2210a..ab2d17743 100644
--- a/core/sugarConstructors.ml
+++ b/core/sugarConstructors.ml
@@ -136,8 +136,8 @@ module SugarConstructors (Position : Pos)
   let fun_lit ?(ppos=dp) ?args ?(location=loc_unknown) linearity pats blk =
     with_pos ppos (FunLit (args, linearity, NormalFunlit (pats, blk), location))
 
-  let switch_fun_lit ?(ppos=dp) ?args ?(location=loc_unknown) linearity pats switch_funlit_body =
-    with_pos ppos (FunLit (args, linearity, SwitchFunlit (pats, switch_funlit_body), location))
+  let switch_fun_lit ?(ppos=dp) ?args ?(location=loc_unknown) linearity pat switch_funlit_body =
+    with_pos ppos (FunLit (args, linearity, SwitchFunlit (pat, switch_funlit_body), location))
 
   (* Create a Spawn. *)
   let spawn ?(ppos=dp) ?row spawn_kind location blk =
@@ -175,11 +175,11 @@ module SugarConstructors (Position : Pos)
                          fun_frozen = false;
                          fun_unsafe_signature = false })
 
-  let switch_fun_binding ?(ppos=dp) sig_opt ?(unsafe_sig=false) ((linearity, frozen), bndr, args, location, blk) =
+  let switch_fun_binding ?(ppos=dp) sig_opt ?(unsafe_sig=false) ((linearity, frozen), bndr, arg, location, blk) =
     let fun_signature = datatype_opt_of_sig_opt sig_opt bndr in
       with_pos ppos (Fun { fun_binder = binder bndr;
                            fun_linearity = linearity;
-                           fun_definition = ([], SwitchFunlit (args, blk));
+                           fun_definition = ([], SwitchFunlit (arg, blk));
                            fun_location = location;
                            fun_signature;
                            fun_frozen = frozen;
diff --git a/core/sugarConstructorsIntf.ml b/core/sugarConstructorsIntf.ml
index ad0869e89..f5ff56d31 100644
--- a/core/sugarConstructorsIntf.ml
+++ b/core/sugarConstructorsIntf.ml
@@ -96,7 +96,7 @@ module type SugarConstructorsSig = sig
   val switch_fun_lit
       : ?ppos:t -> ?args:((Types.datatype * Types.row) list)
      -> ?location:Location.t -> DeclaredLinearity.t
-     -> Pattern.with_pos list list -> switch_funlit_body
+     -> Pattern.with_pos list -> switch_funlit_body
      -> phrase
   val spawn
       : ?ppos:t
@@ -121,7 +121,7 @@ module type SugarConstructorsSig = sig
      -> binding
   val switch_fun_binding
       : ?ppos:t -> signature -> ?unsafe_sig:bool
-     -> ((DeclaredLinearity.t * bool) * Name.t * Pattern.with_pos list list * Location.t * switch_funlit_body)
+     -> ((DeclaredLinearity.t * bool) * Name.t * Pattern.with_pos list * Location.t * switch_funlit_body)
      -> binding
   val val_binding'
       : ?ppos:t -> signature -> (name_or_pat * phrase * Location.t)
diff --git a/core/sugarTraversals.ml b/core/sugarTraversals.ml
index 7061704bb..3ebf443a6 100644
--- a/core/sugarTraversals.ml
+++ b/core/sugarTraversals.ml
@@ -565,7 +565,7 @@ class map =
             let _x = o#list (fun o -> o#list (fun o -> o#pattern)) _x in
             let _x_i1 = o#phrase _x_i1 in NormalFunlit (_x, _x_i1)
           | SwitchFunlit (pat, body) ->
-            let pat = o#list (fun o -> o#list (fun o -> o#pattern)) pat in
+            let pat = o#list (fun o -> o#pattern) pat in
             let body = o#list (fun o (p, c) -> let p = o#pattern p in let c = o#phrase c in (p, c)) body in SwitchFunlit (pat, body)
 
     method handle_params : handler_parameterisation -> handler_parameterisation =
@@ -1298,7 +1298,7 @@ class fold =
             let o = o#list (fun o -> o#list (fun o -> o#pattern)) _x in
             let o = o#phrase _x_i1 in o
           | SwitchFunlit (pat, body) ->
-            let o = o#list (fun o -> o#list (fun o -> o#pattern)) pat in
+            let o = o#list (fun o -> o#pattern) pat in
             let o = o#list (fun o (p, c) -> let o = o#pattern p in let o = o#phrase c in o) body in o
 
 
@@ -2132,7 +2132,7 @@ class fold_map =
             let (o, _x) = o#list (fun o -> o#list (fun o -> o#pattern)) _x in
             let (o, _x_i1) = o#phrase _x_i1 in (o, NormalFunlit (_x, _x_i1))
           | SwitchFunlit (pat, body) ->
-            let (o, pat) = o#list (fun o -> o#list (fun o -> o#pattern)) pat in
+            let (o, pat) = o#list (fun o -> o#pattern) pat in
             let (o, body) = o#list (fun o (p, c) -> let (o, p) = o#pattern p in let (o, c) = o#phrase c in (o, (p, c))) body in (o, SwitchFunlit (pat, body))
 
     method handle_params : handler_parameterisation -> ('self_type * handler_parameterisation) =
diff --git a/core/sugartypes.ml b/core/sugartypes.ml
index bc6ad88de..1aac09df5 100644
--- a/core/sugartypes.ml
+++ b/core/sugartypes.ml
@@ -370,7 +370,7 @@ and regex =
   | Replace   of regex * replace_rhs
 and clause = Pattern.with_pos * phrase
 and funlit = NormalFunlit of normal_funlit | SwitchFunlit of switch_funlit
-and switch_funlit = Pattern.with_pos list list * switch_funlit_body
+and switch_funlit = Pattern.with_pos list * switch_funlit_body
 and switch_funlit_body = (Pattern.with_pos * phrase) list
 and normal_funlit = Pattern.with_pos list list * phrase
 and handler =
@@ -776,7 +776,7 @@ struct
   and normal_funlit (args, body : normal_funlit) : StringSet.t =
     diff (phrase body) (union_map (union_map pattern) args)
   and switch_funlit (args, body : switch_funlit) : StringSet.t =
-    diff (switch_funlit_body body) (union_map (union_map pattern) args)
+    diff (switch_funlit_body body) (union_map pattern args)
   and switch_funlit_body (body : (Pattern.with_pos * phrase) list) : StringSet.t =
     union_map (fun (pat, phr) -> union (pattern pat) (phrase phr)) body
   and block (binds, expr : binding list * phrase) : StringSet.t =
diff --git a/core/transformSugar.ml b/core/transformSugar.ml
index b9a16ef92..33a7b2eab 100644
--- a/core/transformSugar.ml
+++ b/core/transformSugar.ml
@@ -740,7 +740,7 @@ class transform (env : Types.typing_environment) =
             (o, NormalFunlit (pss, e), t)
           | SwitchFunlit (pss, body) ->
             let envs = o#backup_envs in
-            let (o, pss) = listu o (fun o -> listu o (fun o -> o#pattern)) pss in
+            let (o, pss) = listu o (fun o -> o#pattern) pss in
             let o = o#with_effects inner_eff in
             let (o, body) = listu o (fun o (p, c) -> let (o, p) = o#pattern p in let (o, c, _) = o#phrase c in (o, (p, c))) body in
             let o = o#restore_envs envs in
diff --git a/tests/functions.tests b/tests/functions.tests
index 3844219d1..a6ea14350 100644
--- a/tests/functions.tests
+++ b/tests/functions.tests
@@ -163,9 +163,10 @@ Pattern Matching (3)
 fun ack(_,_) switch { case (0, n) -> n + 1 case (m, 0) -> ack(m - 1, 1) case (m, n) -> ack(m - 1, ack(m, n - 1)) } fun test() { print(intToString(ack(0,1))); print(intToString(ack(1,0))); print(intToString(ack(1,1))) } test()
 stdout : 223() : ()
 
-Pattern Matching (4)
+Pattern Matching (4) - multiple arg list function
 fun foo(_)(_) switch { case (x, y) -> x + y } foo
-stdout : fun : (Int) -> (Int) ~> Int
+stderr : @.*Not support pattern matching function with multiple parameter lists yet.*
+exit : 1
 
 Pattern Matching (5) - runtime non-exhaustive error
 fun foo(_) switch { case 1 -> 1 } foo(0)

From 873eebd049b54a2822a749439a71f34ea97f9eb2 Mon Sep 17 00:00:00 2001
From: Emanon42 <EmanonTang@outlook.com>
Date: Thu, 27 Aug 2020 16:36:56 +0100
Subject: [PATCH 43/50] renaming pass and error

---
 core/desugarMatching.mli                          | 3 ---
 core/{desugarMatching.ml => desugarSwitchFuns.ml} | 8 ++++----
 core/desugarSwitchFuns.mli                        | 3 +++
 core/errors.ml                                    | 4 ++--
 core/errors.mli                                   | 2 +-
 core/frontend.ml                                  | 2 +-
 core/parser.mly                                   | 2 +-
 tests/functions.tests                             | 6 +++---
 8 files changed, 15 insertions(+), 15 deletions(-)
 delete mode 100644 core/desugarMatching.mli
 rename core/{desugarMatching.ml => desugarSwitchFuns.ml} (93%)
 create mode 100644 core/desugarSwitchFuns.mli

diff --git a/core/desugarMatching.mli b/core/desugarMatching.mli
deleted file mode 100644
index 955749d33..000000000
--- a/core/desugarMatching.mli
+++ /dev/null
@@ -1,3 +0,0 @@
-val desugar_matching : SugarTraversals.map
-
-include Transform.Untyped.S
diff --git a/core/desugarMatching.ml b/core/desugarSwitchFuns.ml
similarity index 93%
rename from core/desugarMatching.ml
rename to core/desugarSwitchFuns.ml
index cd006b5c2..f6e419c3a 100644
--- a/core/desugarMatching.ml
+++ b/core/desugarSwitchFuns.ml
@@ -45,13 +45,13 @@ let pattern_matching_sugar_guard pos =
 
 let nullary_guard pss pos =
   let nullary_error pos =
-    Errors.desugaring_error ~pos:pos ~stage:Errors.DesugarMatching ~message:"Can't match over nullary function"
+    Errors.desugaring_error ~pos:pos ~stage:Errors.DesugarSwitchFuns ~message:"Can't match over nullary function"
   in
   match pss with
     | [] -> raise (nullary_error pos)
     | _ -> ()
 
-let desugar_matching =
+let desugar_switching =
 object ((self : 'self_type))
     inherit SugarTraversals.map as super
     method! binding = fun b ->
@@ -90,6 +90,6 @@ end
 
 module Untyped
   = Transform.Untyped.Make.Transformer(struct
-        let name = "desugar_match_functions"
-        let obj = desugar_matching
+        let name = "desugar_switch_functions"
+        let obj = desugar_switching
       end)
diff --git a/core/desugarSwitchFuns.mli b/core/desugarSwitchFuns.mli
new file mode 100644
index 000000000..ee531deed
--- /dev/null
+++ b/core/desugarSwitchFuns.mli
@@ -0,0 +1,3 @@
+val desugar_switching : SugarTraversals.map
+
+include Transform.Untyped.S
diff --git a/core/errors.ml b/core/errors.ml
index 089b4b703..f992bfbb2 100644
--- a/core/errors.ml
+++ b/core/errors.ml
@@ -16,7 +16,7 @@ type sugar_error_stage =
   | CheckXML
   | DesugarInners
   | DesugarModules
-  | DesugarMatching
+  | DesugarSwitchFuns
 
 let string_of_stage = function
   | DesugarFormlets    -> "compiling formlets"
@@ -27,7 +27,7 @@ let string_of_stage = function
   | CheckXML           -> "checking XML"
   | DesugarInners      -> "desugaring inner types"
   | DesugarModules     -> "desugaring modules"
-  | DesugarMatching    -> "desugaring matching"
+  | DesugarSwitchFuns    -> "desugaring pattern-matching"
 
 exception RuntimeError of string
 exception UndefinedVariable of string
diff --git a/core/errors.mli b/core/errors.mli
index e16f47cfc..8ba782b16 100644
--- a/core/errors.mli
+++ b/core/errors.mli
@@ -14,7 +14,7 @@ type sugar_error_stage =
   | CheckXML
   | DesugarInners
   | DesugarModules
-  | DesugarMatching
+  | DesugarSwitchFuns
 
 
 exception RuntimeError of string
diff --git a/core/frontend.ml b/core/frontend.ml
index 8aaf4337a..13dd0247f 100644
--- a/core/frontend.ml
+++ b/core/frontend.ml
@@ -125,7 +125,7 @@ module Untyped = struct
   let transformers : transformer array
     = [| (module ResolvePositions)
        ; (module CheckXmlQuasiquotes)
-       ; (module DesugarMatching)
+       ; (module DesugarSwitchFuns)
        ; (module DesugarModules)
        ; (module Shunting)
        ; (module Collect_FFI_Files)
diff --git a/core/parser.mly b/core/parser.mly
index df7ad4887..982a41b17 100644
--- a/core/parser.mly
+++ b/core/parser.mly
@@ -172,7 +172,7 @@ let parseRegexFlags f =
 let switch_fun_currying_guard p args =
   match args with
   | [arg] -> arg
-  | _ -> raise (Errors.Type_error (pos p, "Not support pattern matching function with multiple parameter lists yet"))
+  | _ -> raise (Errors.Type_error (pos p, "Curried switch functions are not yet supported."))
 
 let named_typevar name freedom : SugarTypeVar.t =
   SugarTypeVar.mk_unresolved name None freedom
diff --git a/tests/functions.tests b/tests/functions.tests
index a6ea14350..9c560c6f7 100644
--- a/tests/functions.tests
+++ b/tests/functions.tests
@@ -165,15 +165,15 @@ stdout : 223() : ()
 
 Pattern Matching (4) - multiple arg list function
 fun foo(_)(_) switch { case (x, y) -> x + y } foo
-stderr : @.*Not support pattern matching function with multiple parameter lists yet.*
+stderr : @.*Curried switch functions are not yet supported.*
 exit : 1
 
 Pattern Matching (5) - runtime non-exhaustive error
 fun foo(_) switch { case 1 -> 1 } foo(0)
-stderr : @.*Runtime error: non-exhaustive pattern matching.*
+stderr : @.*non-exhaustive pattern matching.*
 exit : 1
 
 Pattern Matching (6) - matching over nullary function
 fun f() switch { case n -> 1 }
-stderr : @.*Error desugaring matching: Can't match over nullary function.*
+stderr : @.*Can't match over nullary function.*
 exit : 1
\ No newline at end of file

From 685d429a3444777a3f7538440d384682b1c9d94b Mon Sep 17 00:00:00 2001
From: Emanon42 <EmanonTang@outlook.com>
Date: Fri, 28 Aug 2020 13:38:36 +0100
Subject: [PATCH 44/50] move currying guard to desugar pass

---
 core/desugarSwitchFuns.ml     |  6 ++++++
 core/parser.mly               | 13 ++++---------
 core/sugarConstructors.ml     |  8 ++++----
 core/sugarConstructorsIntf.ml |  4 ++--
 core/sugarTraversals.ml       |  6 +++---
 core/sugartypes.ml            |  4 ++--
 core/transformSugar.ml        |  2 +-
 7 files changed, 22 insertions(+), 21 deletions(-)

diff --git a/core/desugarSwitchFuns.ml b/core/desugarSwitchFuns.ml
index f6e419c3a..8532c9133 100644
--- a/core/desugarSwitchFuns.ml
+++ b/core/desugarSwitchFuns.ml
@@ -51,6 +51,11 @@ let nullary_guard pss pos =
     | [] -> raise (nullary_error pos)
     | _ -> ()
 
+let switch_fun_currying_guard pos args =
+  match args with
+  | [arg] -> arg
+  | _ -> raise (Errors.Type_error (pos, "Curried switch functions are not yet supported."))
+
 let desugar_switching =
 object ((self : 'self_type))
     inherit SugarTraversals.map as super
@@ -59,6 +64,7 @@ object ((self : 'self_type))
       match WithPos.node b with
       |  Fun ({ fun_definition = (tvs, SwitchFunlit (patterns, cases)); _ } as fn) ->
           pattern_matching_sugar_guard pos;
+          let patterns = switch_fun_currying_guard pos patterns in
           nullary_guard patterns pos;
           (* bind the arguments with unique var name *)
           let name_list = List.map (fun pat -> (pat, Utility.gensym())) patterns in
diff --git a/core/parser.mly b/core/parser.mly
index 982a41b17..132e57ee2 100644
--- a/core/parser.mly
+++ b/core/parser.mly
@@ -169,11 +169,6 @@ let parseRegexFlags f =
               | 'g' -> RegexGlobal
               | _ -> assert false) (asList f 0 [])
 
-let switch_fun_currying_guard p args =
-  match args with
-  | [arg] -> arg
-  | _ -> raise (Errors.Type_error (pos p, "Curried switch functions are not yet supported."))
-
 let named_typevar name freedom : SugarTypeVar.t =
   SugarTypeVar.mk_unresolved name None freedom
 
@@ -449,7 +444,7 @@ tlfunbinding:
 | OP pattern OPERATOR perhaps_location block                   { ((dl_unl, false), $3, [[$2]], $4, $5)          }
 
 switch_tlfunbinding:
-| fun_kind VARIABLE arg_lists perhaps_location switch_body     { ($1, $2, (switch_fun_currying_guard $loc($3) $3), $4, $5)   }
+| fun_kind VARIABLE arg_lists perhaps_location switch_body     { ($1, $2, $3, $4, $5)   }
 
 switch_body:
 | SWITCH LBRACE case+ RBRACE                                   { $3 }
@@ -558,7 +553,7 @@ primary_expression:
 | LBRACKET exp DOTDOT exp RBRACKET                             { with_pos $loc (RangeLit($2, $4))   }
 | xml                                                          { $1 }
 | linearity arg_lists block                                    { fun_lit ~ppos:$loc $1 $2 $3 }
-| linearity arg_lists switch_body                              { switch_fun_lit ~ppos:$loc $1 (switch_fun_currying_guard $loc($2) $2) $3 }
+| linearity arg_lists switch_body                              { switch_fun_lit ~ppos:$loc $1 $2 $3 }
 | LEFTTRIANGLE cp_expression RIGHTTRIANGLE                     { with_pos $loc (CP $2) }
 | DOLLAR primary_expression                                    { with_pos $loc (Generalise $2) }
 
@@ -841,8 +836,8 @@ binding:
 | exp SEMICOLON                                                { with_pos $loc (Exp $1) }
 | signatures fun_kind VARIABLE arg_lists block                 { fun_binding ~ppos:$loc (fst $1) ~unsafe_sig:(snd $1) ($2, $3, $4, loc_unknown, $5) }
 | fun_kind VARIABLE arg_lists block                            { fun_binding ~ppos:$loc None ($1, $2, $3, loc_unknown, $4) }
-| signatures fun_kind VARIABLE arg_lists switch_body           { switch_fun_binding ~ppos:$loc (fst $1) ~unsafe_sig:(snd $1) ($2, $3, (switch_fun_currying_guard $loc($4) $4), loc_unknown, $5) }
-| fun_kind VARIABLE arg_lists switch_body                      { switch_fun_binding ~ppos:$loc None ($1, $2, (switch_fun_currying_guard $loc($3) $3), loc_unknown, $4) }
+| signatures fun_kind VARIABLE arg_lists switch_body           { switch_fun_binding ~ppos:$loc (fst $1) ~unsafe_sig:(snd $1) ($2, $3, $4, loc_unknown, $5) }
+| fun_kind VARIABLE arg_lists switch_body                      { switch_fun_binding ~ppos:$loc None ($1, $2, $3, loc_unknown, $4) }
 | typedecl SEMICOLON | links_module
 | links_open SEMICOLON                                         { $1 }
 
diff --git a/core/sugarConstructors.ml b/core/sugarConstructors.ml
index ab2d17743..947f2210a 100644
--- a/core/sugarConstructors.ml
+++ b/core/sugarConstructors.ml
@@ -136,8 +136,8 @@ module SugarConstructors (Position : Pos)
   let fun_lit ?(ppos=dp) ?args ?(location=loc_unknown) linearity pats blk =
     with_pos ppos (FunLit (args, linearity, NormalFunlit (pats, blk), location))
 
-  let switch_fun_lit ?(ppos=dp) ?args ?(location=loc_unknown) linearity pat switch_funlit_body =
-    with_pos ppos (FunLit (args, linearity, SwitchFunlit (pat, switch_funlit_body), location))
+  let switch_fun_lit ?(ppos=dp) ?args ?(location=loc_unknown) linearity pats switch_funlit_body =
+    with_pos ppos (FunLit (args, linearity, SwitchFunlit (pats, switch_funlit_body), location))
 
   (* Create a Spawn. *)
   let spawn ?(ppos=dp) ?row spawn_kind location blk =
@@ -175,11 +175,11 @@ module SugarConstructors (Position : Pos)
                          fun_frozen = false;
                          fun_unsafe_signature = false })
 
-  let switch_fun_binding ?(ppos=dp) sig_opt ?(unsafe_sig=false) ((linearity, frozen), bndr, arg, location, blk) =
+  let switch_fun_binding ?(ppos=dp) sig_opt ?(unsafe_sig=false) ((linearity, frozen), bndr, args, location, blk) =
     let fun_signature = datatype_opt_of_sig_opt sig_opt bndr in
       with_pos ppos (Fun { fun_binder = binder bndr;
                            fun_linearity = linearity;
-                           fun_definition = ([], SwitchFunlit (arg, blk));
+                           fun_definition = ([], SwitchFunlit (args, blk));
                            fun_location = location;
                            fun_signature;
                            fun_frozen = frozen;
diff --git a/core/sugarConstructorsIntf.ml b/core/sugarConstructorsIntf.ml
index f5ff56d31..ad0869e89 100644
--- a/core/sugarConstructorsIntf.ml
+++ b/core/sugarConstructorsIntf.ml
@@ -96,7 +96,7 @@ module type SugarConstructorsSig = sig
   val switch_fun_lit
       : ?ppos:t -> ?args:((Types.datatype * Types.row) list)
      -> ?location:Location.t -> DeclaredLinearity.t
-     -> Pattern.with_pos list -> switch_funlit_body
+     -> Pattern.with_pos list list -> switch_funlit_body
      -> phrase
   val spawn
       : ?ppos:t
@@ -121,7 +121,7 @@ module type SugarConstructorsSig = sig
      -> binding
   val switch_fun_binding
       : ?ppos:t -> signature -> ?unsafe_sig:bool
-     -> ((DeclaredLinearity.t * bool) * Name.t * Pattern.with_pos list * Location.t * switch_funlit_body)
+     -> ((DeclaredLinearity.t * bool) * Name.t * Pattern.with_pos list list * Location.t * switch_funlit_body)
      -> binding
   val val_binding'
       : ?ppos:t -> signature -> (name_or_pat * phrase * Location.t)
diff --git a/core/sugarTraversals.ml b/core/sugarTraversals.ml
index 3ebf443a6..7061704bb 100644
--- a/core/sugarTraversals.ml
+++ b/core/sugarTraversals.ml
@@ -565,7 +565,7 @@ class map =
             let _x = o#list (fun o -> o#list (fun o -> o#pattern)) _x in
             let _x_i1 = o#phrase _x_i1 in NormalFunlit (_x, _x_i1)
           | SwitchFunlit (pat, body) ->
-            let pat = o#list (fun o -> o#pattern) pat in
+            let pat = o#list (fun o -> o#list (fun o -> o#pattern)) pat in
             let body = o#list (fun o (p, c) -> let p = o#pattern p in let c = o#phrase c in (p, c)) body in SwitchFunlit (pat, body)
 
     method handle_params : handler_parameterisation -> handler_parameterisation =
@@ -1298,7 +1298,7 @@ class fold =
             let o = o#list (fun o -> o#list (fun o -> o#pattern)) _x in
             let o = o#phrase _x_i1 in o
           | SwitchFunlit (pat, body) ->
-            let o = o#list (fun o -> o#pattern) pat in
+            let o = o#list (fun o -> o#list (fun o -> o#pattern)) pat in
             let o = o#list (fun o (p, c) -> let o = o#pattern p in let o = o#phrase c in o) body in o
 
 
@@ -2132,7 +2132,7 @@ class fold_map =
             let (o, _x) = o#list (fun o -> o#list (fun o -> o#pattern)) _x in
             let (o, _x_i1) = o#phrase _x_i1 in (o, NormalFunlit (_x, _x_i1))
           | SwitchFunlit (pat, body) ->
-            let (o, pat) = o#list (fun o -> o#pattern) pat in
+            let (o, pat) = o#list (fun o -> o#list (fun o -> o#pattern)) pat in
             let (o, body) = o#list (fun o (p, c) -> let (o, p) = o#pattern p in let (o, c) = o#phrase c in (o, (p, c))) body in (o, SwitchFunlit (pat, body))
 
     method handle_params : handler_parameterisation -> ('self_type * handler_parameterisation) =
diff --git a/core/sugartypes.ml b/core/sugartypes.ml
index 1aac09df5..bc6ad88de 100644
--- a/core/sugartypes.ml
+++ b/core/sugartypes.ml
@@ -370,7 +370,7 @@ and regex =
   | Replace   of regex * replace_rhs
 and clause = Pattern.with_pos * phrase
 and funlit = NormalFunlit of normal_funlit | SwitchFunlit of switch_funlit
-and switch_funlit = Pattern.with_pos list * switch_funlit_body
+and switch_funlit = Pattern.with_pos list list * switch_funlit_body
 and switch_funlit_body = (Pattern.with_pos * phrase) list
 and normal_funlit = Pattern.with_pos list list * phrase
 and handler =
@@ -776,7 +776,7 @@ struct
   and normal_funlit (args, body : normal_funlit) : StringSet.t =
     diff (phrase body) (union_map (union_map pattern) args)
   and switch_funlit (args, body : switch_funlit) : StringSet.t =
-    diff (switch_funlit_body body) (union_map pattern args)
+    diff (switch_funlit_body body) (union_map (union_map pattern) args)
   and switch_funlit_body (body : (Pattern.with_pos * phrase) list) : StringSet.t =
     union_map (fun (pat, phr) -> union (pattern pat) (phrase phr)) body
   and block (binds, expr : binding list * phrase) : StringSet.t =
diff --git a/core/transformSugar.ml b/core/transformSugar.ml
index 33a7b2eab..b9a16ef92 100644
--- a/core/transformSugar.ml
+++ b/core/transformSugar.ml
@@ -740,7 +740,7 @@ class transform (env : Types.typing_environment) =
             (o, NormalFunlit (pss, e), t)
           | SwitchFunlit (pss, body) ->
             let envs = o#backup_envs in
-            let (o, pss) = listu o (fun o -> o#pattern) pss in
+            let (o, pss) = listu o (fun o -> listu o (fun o -> o#pattern)) pss in
             let o = o#with_effects inner_eff in
             let (o, body) = listu o (fun o (p, c) -> let (o, p) = o#pattern p in let (o, c, _) = o#phrase c in (o, (p, c))) body in
             let o = o#restore_envs envs in

From 75895f9f58c55eb9c3ea8ff7a4f75e9587c97e0c Mon Sep 17 00:00:00 2001
From: Emanon42 <EmanonTang@outlook.com>
Date: Sat, 29 Aug 2020 20:24:57 +0100
Subject: [PATCH 45/50] make get_normal_funlit utility func

---
 core/parser.mly        |  2 ++
 core/sugartypes.ml     |  5 +++++
 core/transformSugar.ml |  9 ++-------
 core/typeSugar.ml      | 12 ++----------
 4 files changed, 11 insertions(+), 17 deletions(-)

diff --git a/core/parser.mly b/core/parser.mly
index 132e57ee2..1067098f0 100644
--- a/core/parser.mly
+++ b/core/parser.mly
@@ -169,6 +169,8 @@ let parseRegexFlags f =
               | 'g' -> RegexGlobal
               | _ -> assert false) (asList f 0 [])
 
+
+
 let named_typevar name freedom : SugarTypeVar.t =
   SugarTypeVar.mk_unresolved name None freedom
 
diff --git a/core/sugartypes.ml b/core/sugartypes.ml
index bc6ad88de..6536958f3 100644
--- a/core/sugartypes.ml
+++ b/core/sugartypes.ml
@@ -569,6 +569,11 @@ let tappl' : phrase * tyarg list -> phrasenode = fun (e, tys) ->
        in
        TAppl (e, List.map make_arg tys)
 
+let get_normal_funlit fnlit =
+  match fnlit with
+  | NormalFunlit x -> x
+  | _-> assert false
+
 module Freevars =
 struct
   open Utility
diff --git a/core/transformSugar.ml b/core/transformSugar.ml
index b9a16ef92..d5702623a 100644
--- a/core/transformSugar.ml
+++ b/core/transformSugar.ml
@@ -130,11 +130,6 @@ let on_effects o (eff : Types.row) fn x =
   let (o, x, y) = fn o x in
   (o#with_effects effect_row, x, y)
 
-let get_normal_funlit fnlit =
-  match fnlit with
-  | NormalFunlit x -> x
-  | _-> assert false
-
 let check_type_application (e, t) k =
   begin
     try
@@ -767,7 +762,7 @@ class transform (env : Types.typing_environment) =
           | {node={ rec_definition = ((tyvars, Some (inner, extras)), lam); _ } as fn; pos} :: defs ->
               let (o, tyvars) = o#quantifiers tyvars in
               let (o, inner) = o#datatype inner in
-              let lam_in = get_normal_funlit lam in
+              let lam_in = Sugartypes.get_normal_funlit lam in
               let inner_effects = fun_effects inner (fst lam_in) in
               let (o, lam, _) = o#funlit inner_effects lam in
               let o = o#restore_quantifiers outer_tyvars in
@@ -815,7 +810,7 @@ class transform (env : Types.typing_environment) =
            when Binder.has_type fun_binder ->
          let outer_tyvars = o#backup_quantifiers in
          let (o, tyvars) = o#quantifiers tyvars in
-         let lam_in = get_normal_funlit lam in
+         let lam_in = Sugartypes.get_normal_funlit lam in
          let inner_effects = fun_effects (Binder.to_type fun_binder) (fst lam_in) in
          let (o, lam, _) = o#funlit inner_effects lam in
          let o = o#restore_quantifiers outer_tyvars in
diff --git a/core/typeSugar.ml b/core/typeSugar.ml
index 75afb40c6..19d8a1036 100644
--- a/core/typeSugar.ml
+++ b/core/typeSugar.ml
@@ -2668,11 +2668,7 @@ let rec type_check : context -> phrase -> phrase * Types.datatype * Usage.t =
                   ListLit (List.map erase (e::es), Some (typ e)), T.Application (Types.list, [PrimaryKind.Type, typ e]), Usage.combine_many (List.map usages (e::es))
             end
         | FunLit (argss_prev, lin, fnlit, location) ->
-            let (pats, body) =
-              match fnlit with
-              | NormalFunlit (pat, body) -> (pat, body)
-              | _ -> assert false
-            in
+            let (pats, body) = Sugartypes.get_normal_funlit fnlit in
             let vs = check_for_duplicate_names pos (List.flatten pats) in
             let (pats_init, pats_tail) = from_option ([], []) (unsnoc_opt pats) in
             let tpc' = if DeclaredLinearity.is_linear lin then tpc else tpcu in
@@ -4198,11 +4194,7 @@ and type_binding : context -> binding -> binding * context * Usage.t =
                fun_frozen;
                fun_unsafe_signature = unsafe } =
            Renamer.rename_function_definition def in
-          let (pats, body) =
-            match fnlit with
-            | NormalFunlit (pats, body) -> (pats, body)
-            | _ -> assert false
-          in
+          let (pats, body) = Sugartypes.get_normal_funlit fnlit in
           let name = Binder.to_name bndr in
           let vs = name :: check_for_duplicate_names pos (List.flatten pats) in
           let (pats_init, pats_tail) = from_option ([], []) (unsnoc_opt pats) in

From cc1d2e384249ec971733bab7ee4aaa571f322837 Mon Sep 17 00:00:00 2001
From: Emanon42 <EmanonTang@outlook.com>
Date: Mon, 31 Aug 2020 22:46:59 +0100
Subject: [PATCH 46/50] resolve simon's second review

---
 core/desugarInners.ml     |  6 +-----
 core/desugarSwitchFuns.ml |  4 ++--
 core/parser.mly           | 10 +++++-----
 core/renamer.ml           |  6 +-----
 core/sugarTraversals.ml   | 18 +++++++++++++++---
 core/sugartoir.ml         |  6 +-----
 core/transformSugar.ml    |  6 +++++-
 core/typeSugar.ml         | 12 ++----------
 8 files changed, 32 insertions(+), 36 deletions(-)

diff --git a/core/desugarInners.ml b/core/desugarInners.ml
index 2a5ec9ff5..50d19b1be 100644
--- a/core/desugarInners.ml
+++ b/core/desugarInners.ml
@@ -172,11 +172,7 @@ object (o : 'self_type)
                let o = o#with_visiting (StringSet.add (Binder.to_name rec_binder) visiting_funs) in
                let (o, tyvars) = o#quantifiers tyvars in
                let (o, inner) = o#datatype inner in
-               let lam_in =
-                match lam with
-                | NormalFunlit x -> x
-                | _ -> assert false
-               in
+               let lam_in = Sugartypes.get_normal_funlit lam in
                let inner_effects = TransformSugar.fun_effects inner (fst lam_in) in
                let (o, lam, _) = o#funlit inner_effects lam in
                let o = o#restore_quantifiers outer_tyvars in
diff --git a/core/desugarSwitchFuns.ml b/core/desugarSwitchFuns.ml
index 8532c9133..9b3b5f318 100644
--- a/core/desugarSwitchFuns.ml
+++ b/core/desugarSwitchFuns.ml
@@ -4,7 +4,7 @@ open SourceCode
 
 (* This module desugars pattern-matching functions
 
-  This transformation convert function like that:
+  This transformation convert `switch` functions of the form:
 
   fun foo(a1, ..., an) switch {
     case (p1_1, ..., p1_n) -> b_1
@@ -12,7 +12,7 @@ open SourceCode
     case (pm_1, pm_n) -> b_m
   }
 
-  to function with switch body like that:
+  to standard functions of the form:
 
   fun foo(a1 as x1, ..., an as xn) {
     switch ((x1, ..., xn)) {
diff --git a/core/parser.mly b/core/parser.mly
index 1067098f0..d7f75b2b9 100644
--- a/core/parser.mly
+++ b/core/parser.mly
@@ -446,9 +446,9 @@ tlfunbinding:
 | OP pattern OPERATOR perhaps_location block                   { ((dl_unl, false), $3, [[$2]], $4, $5)          }
 
 switch_tlfunbinding:
-| fun_kind VARIABLE arg_lists perhaps_location switch_body     { ($1, $2, $3, $4, $5)   }
+| fun_kind VARIABLE arg_lists perhaps_location switch_funlit_body     { ($1, $2, $3, $4, $5)   }
 
-switch_body:
+switch_funlit_body:
 | SWITCH LBRACE case+ RBRACE                                   { $3 }
 
 tlvarbinding:
@@ -555,7 +555,7 @@ primary_expression:
 | LBRACKET exp DOTDOT exp RBRACKET                             { with_pos $loc (RangeLit($2, $4))   }
 | xml                                                          { $1 }
 | linearity arg_lists block                                    { fun_lit ~ppos:$loc $1 $2 $3 }
-| linearity arg_lists switch_body                              { switch_fun_lit ~ppos:$loc $1 $2 $3 }
+| linearity arg_lists switch_funlit_body                              { switch_fun_lit ~ppos:$loc $1 $2 $3 }
 | LEFTTRIANGLE cp_expression RIGHTTRIANGLE                     { with_pos $loc (CP $2) }
 | DOLLAR primary_expression                                    { with_pos $loc (Generalise $2) }
 
@@ -838,8 +838,8 @@ binding:
 | exp SEMICOLON                                                { with_pos $loc (Exp $1) }
 | signatures fun_kind VARIABLE arg_lists block                 { fun_binding ~ppos:$loc (fst $1) ~unsafe_sig:(snd $1) ($2, $3, $4, loc_unknown, $5) }
 | fun_kind VARIABLE arg_lists block                            { fun_binding ~ppos:$loc None ($1, $2, $3, loc_unknown, $4) }
-| signatures fun_kind VARIABLE arg_lists switch_body           { switch_fun_binding ~ppos:$loc (fst $1) ~unsafe_sig:(snd $1) ($2, $3, $4, loc_unknown, $5) }
-| fun_kind VARIABLE arg_lists switch_body                      { switch_fun_binding ~ppos:$loc None ($1, $2, $3, loc_unknown, $4) }
+| signatures fun_kind VARIABLE arg_lists switch_funlit_body           { switch_fun_binding ~ppos:$loc (fst $1) ~unsafe_sig:(snd $1) ($2, $3, $4, loc_unknown, $5) }
+| fun_kind VARIABLE arg_lists switch_funlit_body                      { switch_fun_binding ~ppos:$loc None ($1, $2, $3, loc_unknown, $4) }
 | typedecl SEMICOLON | links_module
 | links_open SEMICOLON                                         { $1 }
 
diff --git a/core/renamer.ml b/core/renamer.ml
index df88e3375..de99f053b 100644
--- a/core/renamer.ml
+++ b/core/renamer.ml
@@ -220,11 +220,7 @@ let rename_function_definition : function_definition -> function_definition =
       ; fun_signature
       ; fun_frozen
       ; fun_unsafe_signature } ->
-  let (pats, body) =
-    match f with
-    | NormalFunlit (ps, bd) -> (ps, bd)
-    | _ -> assert false
-  in
+  let (pats, body) = Sugartypes.get_normal_funlit f in
   let qs_from = List.map SugarQuantifier.get_resolved_exn tyvars_from in
   let qs_to, _      = Instantiate.build_fresh_quantifiers qs_from in
   let tyvars_to     = List.map SugarQuantifier.mk_resolved qs_to in
diff --git a/core/sugarTraversals.ml b/core/sugarTraversals.ml
index 7061704bb..750cd6fb1 100644
--- a/core/sugarTraversals.ml
+++ b/core/sugarTraversals.ml
@@ -566,7 +566,11 @@ class map =
             let _x_i1 = o#phrase _x_i1 in NormalFunlit (_x, _x_i1)
           | SwitchFunlit (pat, body) ->
             let pat = o#list (fun o -> o#list (fun o -> o#pattern)) pat in
-            let body = o#list (fun o (p, c) -> let p = o#pattern p in let c = o#phrase c in (p, c)) body in SwitchFunlit (pat, body)
+            let body =
+              o#list (fun o (p, c) ->
+                let p = o#pattern p in
+                let c = o#phrase c in (p, c)) body in
+            SwitchFunlit (pat, body)
 
     method handle_params : handler_parameterisation -> handler_parameterisation =
       fun { shp_bindings; shp_types }->
@@ -1299,7 +1303,10 @@ class fold =
             let o = o#phrase _x_i1 in o
           | SwitchFunlit (pat, body) ->
             let o = o#list (fun o -> o#list (fun o -> o#pattern)) pat in
-            let o = o#list (fun o (p, c) -> let o = o#pattern p in let o = o#phrase c in o) body in o
+            let o = o#list (fun o (p, c) ->
+              let o = o#pattern p in
+              let o = o#phrase c in o) body in
+            o
 
 
     method handle_params : handler_parameterisation -> 'self_type =
@@ -2133,7 +2140,12 @@ class fold_map =
             let (o, _x_i1) = o#phrase _x_i1 in (o, NormalFunlit (_x, _x_i1))
           | SwitchFunlit (pat, body) ->
             let (o, pat) = o#list (fun o -> o#list (fun o -> o#pattern)) pat in
-            let (o, body) = o#list (fun o (p, c) -> let (o, p) = o#pattern p in let (o, c) = o#phrase c in (o, (p, c))) body in (o, SwitchFunlit (pat, body))
+            let (o, body) =
+              o#list (fun o (p, c) ->
+                let (o, p) = o#pattern p in
+                let (o, c) = o#phrase c in
+                (o, (p, c))) body in
+            (o, SwitchFunlit (pat, body))
 
     method handle_params : handler_parameterisation -> ('self_type * handler_parameterisation) =
       fun { shp_bindings; shp_types } ->
diff --git a/core/sugartoir.ml b/core/sugartoir.ml
index 953d30d8c..98dd6135b 100644
--- a/core/sugartoir.ml
+++ b/core/sugartoir.ml
@@ -1183,11 +1183,7 @@ struct
                                rec_definition       = ((tyvars, _), fnlit);
                                rec_location         = location;
                                rec_unsafe_signature = unsafe; _ } ->
-                          let (pss, body) =
-                            match fnlit with
-                            | NormalFunlit (pss, body) -> (pss, body)
-                            | _ -> assert false
-                          in
+                          let (pss, body) = Sugartypes.get_normal_funlit fnlit in
                           assert (List.length pss = 1);
                           let f  = Binder.to_name bndr in
                           let ft = Binder.to_type bndr in
diff --git a/core/transformSugar.ml b/core/transformSugar.ml
index d5702623a..c76f31f23 100644
--- a/core/transformSugar.ml
+++ b/core/transformSugar.ml
@@ -737,7 +737,11 @@ class transform (env : Types.typing_environment) =
             let envs = o#backup_envs in
             let (o, pss) = listu o (fun o -> listu o (fun o -> o#pattern)) pss in
             let o = o#with_effects inner_eff in
-            let (o, body) = listu o (fun o (p, c) -> let (o, p) = o#pattern p in let (o, c, _) = o#phrase c in (o, (p, c))) body in
+            let (o, body) =
+              listu o (fun o (p, c) ->
+                let (o, p) = o#pattern p in
+                let (o, c, _) = o#phrase c in
+                (o, (p, c))) body in
             let o = o#restore_envs envs in
             (o, SwitchFunlit (pss, body), Types.unit_type)
 
diff --git a/core/typeSugar.ml b/core/typeSugar.ml
index 19d8a1036..ae23079a8 100644
--- a/core/typeSugar.ml
+++ b/core/typeSugar.ml
@@ -4363,11 +4363,7 @@ and type_binding : context -> binding -> binding * context * Usage.t =
                             rec_frozen = frozen;
                             _ }; _ } ->
                  let name = Binder.to_name bndr in
-                 let pats =
-                  match fnlit with
-                  | NormalFunlit (pats, _) -> pats
-                  | _ -> assert false
-                 in
+                 let (pats, _) = Sugartypes.get_normal_funlit fnlit in
                  (* recursive functions can't be linear! *)
                  if DeclaredLinearity.is_linear lin then
                    Gripers.linear_recursive_function pos name;
@@ -4436,11 +4432,7 @@ and type_binding : context -> binding -> binding * context * Usage.t =
                         {node={ rec_binder = bndr; rec_linearity = lin;
                                 rec_definition = (_, fnlit); _ } as fn; pos }
                         pats ->
-                      let body =
-                        match fnlit with
-                        | NormalFunlit (_, body) -> body
-                        | _ -> assert false
-                      in
+                      let (_, body) = Sugartypes.get_normal_funlit fnlit in
                       let name = Binder.to_name bndr in
                       let pat_env = List.fold_left (fun env pat -> Env.extend env (pattern_env pat)) Env.empty (List.flatten pats) in
                       let self_env =

From 85c68c359e7a8f0c216fc738916b508b15645aef Mon Sep 17 00:00:00 2001
From: Emanon42 <EmanonTang@outlook.com>
Date: Mon, 31 Aug 2020 22:54:53 +0100
Subject: [PATCH 47/50] fix last get_normal_fnlit

---
 core/renamer.ml | 6 +-----
 1 file changed, 1 insertion(+), 5 deletions(-)

diff --git a/core/renamer.ml b/core/renamer.ml
index de99f053b..a5293e078 100644
--- a/core/renamer.ml
+++ b/core/renamer.ml
@@ -247,11 +247,7 @@ let rename_recursive_functionnode :
       ; rec_signature
       ; rec_frozen
       ; rec_unsafe_signature } ->
-  let (pats, body) =
-    match f with
-    | NormalFunlit (ps, bd) -> (ps, bd)
-    | _ -> assert false
-  in
+  let (pats, body) = Sugartypes.get_normal_funlit f in
   let qs_from = List.map SugarQuantifier.get_resolved_exn tyvars_from in
   let qs_to, _      = Instantiate.build_fresh_quantifiers qs_from in
   let tyvars_to     = List.map SugarQuantifier.mk_resolved qs_to in

From 7f161bdd8c2b990c2d42b028bddfc8fc12a8f7ae Mon Sep 17 00:00:00 2001
From: Emanon42 <EmanonTang@outlook.com>
Date: Wed, 2 Sep 2020 14:37:55 +0100
Subject: [PATCH 48/50] fix phrasenode desugaring

---
 core/desugarSwitchFuns.ml | 72 +++++++++++++++++++++++----------------
 core/parser.mly           |  6 ++--
 tests/functions.tests     |  6 +++-
 3 files changed, 51 insertions(+), 33 deletions(-)

diff --git a/core/desugarSwitchFuns.ml b/core/desugarSwitchFuns.ml
index 9b3b5f318..3e5e7e94c 100644
--- a/core/desugarSwitchFuns.ml
+++ b/core/desugarSwitchFuns.ml
@@ -56,42 +56,56 @@ let switch_fun_currying_guard pos args =
   | [arg] -> arg
   | _ -> raise (Errors.Type_error (pos, "Curried switch functions are not yet supported."))
 
+let construct_normal_funlit pos patterns cases =
+  pattern_matching_sugar_guard pos;
+  let patterns = switch_fun_currying_guard pos patterns in
+  nullary_guard patterns pos;
+  (* bind the arguments with unique var name *)
+  let name_list = List.map (fun pat -> (pat, Utility.gensym())) patterns in
+  let switch_tuple = List.map (fun (_, name) -> with_pos (Var name)) name_list in
+  (* assemble exhaustive handler *)
+  let exhaustive_patterns = with_pos (Pattern.Any) in
+  let exhaustive_position = Format.sprintf "non-exhaustive pattern matching at %s" (SourceCode.Position.show pos) in
+  let exhaustive_case = FnAppl (with_pos (Var "error"), [with_pos (Constant (CommonTypes.Constant.String exhaustive_position))]) in
+  let normal_args =
+    List.map
+      (fun (pat, name) -> with_pos (Pattern.As (with_pos (Binder.make ~name ()), pat)))
+      name_list
+  in
+  let cases = cases@[(exhaustive_patterns, with_pos exhaustive_case)] in
+  let switch_body = Switch (with_pos (TupleLit switch_tuple), cases, None) in
+  let normal_fnlit = NormalFunlit ([normal_args], with_pos switch_body) in
+  normal_fnlit
+
 let desugar_switching =
 object ((self : 'self_type))
     inherit SugarTraversals.map as super
     method! binding = fun b ->
       let pos = WithPos.pos b in
       match WithPos.node b with
-      |  Fun ({ fun_definition = (tvs, SwitchFunlit (patterns, cases)); _ } as fn) ->
-          pattern_matching_sugar_guard pos;
-          let patterns = switch_fun_currying_guard pos patterns in
-          nullary_guard patterns pos;
-          (* bind the arguments with unique var name *)
-          let name_list = List.map (fun pat -> (pat, Utility.gensym())) patterns in
-          let switch_tuple = List.map (fun (_, name) -> with_pos (Var name)) name_list in
-          (* assemble exhaustive handler *)
-          let exhaustive_patterns = with_pos (Pattern.Any) in
-          let exhaustive_position = Format.sprintf "non-exhaustive pattern matching at %s" (SourceCode.Position.show pos) in
-          let exhaustive_case = FnAppl (with_pos (Var "error"), [with_pos (Constant (CommonTypes.Constant.String exhaustive_position))]) in
-          let normal_args =
-            List.map
-              (fun (pat, name) -> with_pos (Pattern.As (with_pos (Binder.make ~name ()), pat)))
-              name_list
-          in
-          let cases = cases@[(exhaustive_patterns, with_pos exhaustive_case)] in
-          let switch_body = Switch (with_pos (TupleLit switch_tuple), cases, None) in
-          let normal_fnlit = NormalFunlit ([normal_args], with_pos switch_body) in
-          let normal_fnlit = self#funlit normal_fnlit in
-          let node = Fun { fun_binder = fn.fun_binder;
-                           fun_linearity = fn.fun_linearity;
-                           fun_definition = (tvs, normal_fnlit);
-                           fun_location = fn.fun_location;
-                           fun_signature = fn.fun_signature;
-                           fun_unsafe_signature = fn.fun_unsafe_signature;
-                           fun_frozen = fn.fun_frozen;
-                           } in
-          WithPos.make ~pos node
+      | Fun ({ fun_definition = (tvs, SwitchFunlit (patterns, cases)); _ } as fn) ->
+        let normal_fnlit = construct_normal_funlit pos patterns cases in
+        let normal_fnlit = self#funlit normal_fnlit in
+        let node = Fun { fun_binder = fn.fun_binder;
+                          fun_linearity = fn.fun_linearity;
+                          fun_definition = (tvs, normal_fnlit);
+                          fun_location = fn.fun_location;
+                          fun_signature = fn.fun_signature;
+                          fun_unsafe_signature = fn.fun_unsafe_signature;
+                          fun_frozen = fn.fun_frozen;
+                          } in
+        WithPos.make ~pos node
       | _ -> super#binding b
+    
+    method! phrase = fun p ->
+      let pos = WithPos.pos p in
+      match WithPos.node p with
+      | FunLit (typing, linearity, SwitchFunlit (patterns, cases), loc) ->
+        let normal_fnlit = construct_normal_funlit pos patterns cases in
+        let normal_fnlit = self#funlit normal_fnlit in
+        let node = FunLit (typing, linearity, normal_fnlit, loc) in
+        WithPos.make ~pos node
+      | _ -> super#phrase p
 end
 
 module Untyped
diff --git a/core/parser.mly b/core/parser.mly
index d7f75b2b9..e15bd426d 100644
--- a/core/parser.mly
+++ b/core/parser.mly
@@ -555,7 +555,7 @@ primary_expression:
 | LBRACKET exp DOTDOT exp RBRACKET                             { with_pos $loc (RangeLit($2, $4))   }
 | xml                                                          { $1 }
 | linearity arg_lists block                                    { fun_lit ~ppos:$loc $1 $2 $3 }
-| linearity arg_lists switch_funlit_body                              { switch_fun_lit ~ppos:$loc $1 $2 $3 }
+| linearity arg_lists switch_funlit_body                       { switch_fun_lit ~ppos:$loc $1 $2 $3 }
 | LEFTTRIANGLE cp_expression RIGHTTRIANGLE                     { with_pos $loc (CP $2) }
 | DOLLAR primary_expression                                    { with_pos $loc (Generalise $2) }
 
@@ -838,8 +838,8 @@ binding:
 | exp SEMICOLON                                                { with_pos $loc (Exp $1) }
 | signatures fun_kind VARIABLE arg_lists block                 { fun_binding ~ppos:$loc (fst $1) ~unsafe_sig:(snd $1) ($2, $3, $4, loc_unknown, $5) }
 | fun_kind VARIABLE arg_lists block                            { fun_binding ~ppos:$loc None ($1, $2, $3, loc_unknown, $4) }
-| signatures fun_kind VARIABLE arg_lists switch_funlit_body           { switch_fun_binding ~ppos:$loc (fst $1) ~unsafe_sig:(snd $1) ($2, $3, $4, loc_unknown, $5) }
-| fun_kind VARIABLE arg_lists switch_funlit_body                      { switch_fun_binding ~ppos:$loc None ($1, $2, $3, loc_unknown, $4) }
+| signatures fun_kind VARIABLE arg_lists switch_funlit_body    { switch_fun_binding ~ppos:$loc (fst $1) ~unsafe_sig:(snd $1) ($2, $3, $4, loc_unknown, $5) }
+| fun_kind VARIABLE arg_lists switch_funlit_body               { switch_fun_binding ~ppos:$loc None ($1, $2, $3, loc_unknown, $4) }
 | typedecl SEMICOLON | links_module
 | links_open SEMICOLON                                         { $1 }
 
diff --git a/tests/functions.tests b/tests/functions.tests
index 9c560c6f7..741127b21 100644
--- a/tests/functions.tests
+++ b/tests/functions.tests
@@ -176,4 +176,8 @@ exit : 1
 Pattern Matching (6) - matching over nullary function
 fun f() switch { case n -> 1 }
 stderr : @.*Can't match over nullary function.*
-exit : 1
\ No newline at end of file
+exit : 1
+
+Pattern Matching (7) - anonymous switch function
+fun(s) switch { case x -> x }
+stdout : fun : (a) ~> a
\ No newline at end of file

From d2ff01f327e4a2d755f18d8c7f888ee46f3d7203 Mon Sep 17 00:00:00 2001
From: Emanon42 <EmanonTang@outlook.com>
Date: Wed, 2 Sep 2020 20:13:11 +0100
Subject: [PATCH 49/50] space nitpick

---
 core/desugarSwitchFuns.ml | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/core/desugarSwitchFuns.ml b/core/desugarSwitchFuns.ml
index 3e5e7e94c..7ada2ca76 100644
--- a/core/desugarSwitchFuns.ml
+++ b/core/desugarSwitchFuns.ml
@@ -96,7 +96,7 @@ object ((self : 'self_type))
                           } in
         WithPos.make ~pos node
       | _ -> super#binding b
-    
+
     method! phrase = fun p ->
       let pos = WithPos.pos p in
       match WithPos.node p with

From e816b0fb4a94c21c5f8c426c6f5c31c556691cc4 Mon Sep 17 00:00:00 2001
From: Emanon42 <EmanonTang@outlook.com>
Date: Thu, 3 Sep 2020 00:58:01 +0100
Subject: [PATCH 50/50] fix error msg

---
 core/desugarSwitchFuns.ml | 17 +++++++++--------
 1 file changed, 9 insertions(+), 8 deletions(-)

diff --git a/core/desugarSwitchFuns.ml b/core/desugarSwitchFuns.ml
index 7ada2ca76..f856f8f20 100644
--- a/core/desugarSwitchFuns.ml
+++ b/core/desugarSwitchFuns.ml
@@ -56,25 +56,26 @@ let switch_fun_currying_guard pos args =
   | [arg] -> arg
   | _ -> raise (Errors.Type_error (pos, "Curried switch functions are not yet supported."))
 
-let construct_normal_funlit pos patterns cases =
-  pattern_matching_sugar_guard pos;
-  let patterns = switch_fun_currying_guard pos patterns in
-  nullary_guard patterns pos;
+let construct_normal_funlit funlit_pos patterns cases =
+  pattern_matching_sugar_guard funlit_pos;
+  let patterns = switch_fun_currying_guard funlit_pos patterns in
+  nullary_guard patterns funlit_pos;
   (* bind the arguments with unique var name *)
+  let pat_first_pos = WithPos.pos (List.nth patterns 0) in
   let name_list = List.map (fun pat -> (pat, Utility.gensym())) patterns in
   let switch_tuple = List.map (fun (_, name) -> with_pos (Var name)) name_list in
   (* assemble exhaustive handler *)
   let exhaustive_patterns = with_pos (Pattern.Any) in
-  let exhaustive_position = Format.sprintf "non-exhaustive pattern matching at %s" (SourceCode.Position.show pos) in
+  let exhaustive_position = Format.sprintf "non-exhaustive pattern matching at %s" (SourceCode.Position.show funlit_pos) in
   let exhaustive_case = FnAppl (with_pos (Var "error"), [with_pos (Constant (CommonTypes.Constant.String exhaustive_position))]) in
   let normal_args =
     List.map
-      (fun (pat, name) -> with_pos (Pattern.As (with_pos (Binder.make ~name ()), pat)))
+      (fun (pat, name) -> with_pos (Pattern.As (with_pos ~pos:funlit_pos (Binder.make ~name ()), pat)))
       name_list
   in
   let cases = cases@[(exhaustive_patterns, with_pos exhaustive_case)] in
-  let switch_body = Switch (with_pos (TupleLit switch_tuple), cases, None) in
-  let normal_fnlit = NormalFunlit ([normal_args], with_pos switch_body) in
+  let switch_body = Switch (with_pos ~pos:pat_first_pos (TupleLit switch_tuple), cases, None) in
+  let normal_fnlit = NormalFunlit ([normal_args], with_pos ~pos:funlit_pos switch_body) in
   normal_fnlit
 
 let desugar_switching =