Proposal 869: pattern-matching syntax (#908)

This patch implements named and anonymous switch functions, which provide convenient syntax for defining functions on a case-by-case basis on their input.

Closes #869.

core/desugarFuns.ml

@@ -59,17 +59,14 @@ 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))
+        | _ -> assert false
     in make_lam rt lam
   in (binder ~ty:ft f, linearity, (tyvars, lam), location)
 
@@ -141,7 +138,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 +183,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 >}

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 = 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
                let o = o#with_visiting visiting_funs in

core/desugarModules.ml

@@ -307,16 +307,19 @@ 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')
+        | _ -> assert false
 
     method cases : (Pattern.with_pos * phrase) list -> (Pattern.with_pos * phrase) list
       = fun cases ->

core/desugarSwitchFuns.ml

@@ -0,0 +1,116 @@
+open Sugartypes
+open Utility
+open SourceCode
+
+(* This module desugars pattern-matching functions
+
+  This transformation convert `switch` functions of the form:
+
+  fun foo(a1, ..., an) switch {
+    case (p1_1, ..., p1_n) -> b_1
+    ...
+    case (pm_1, pm_n) -> b_m
+  }
+
+  to standard functions of the form:
+
+  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 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 nullary_guard pss pos =
+  let nullary_error pos =
+    Errors.desugaring_error ~pos:pos ~stage:Errors.DesugarSwitchFuns ~message:"Can't match over nullary function"
+  in
+  match pss with
+    | [] -> 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 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 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 ~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 ~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 =
+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) ->
+        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
+  = Transform.Untyped.Make.Transformer(struct
+        let name = "desugar_switch_functions"
+        let obj = desugar_switching
+      end)

core/desugarSwitchFuns.mli

@@ -0,0 +1,3 @@
+val desugar_switching : SugarTraversals.map
+
+include Transform.Untyped.S

core/errors.ml

@@ -16,6 +16,7 @@ type sugar_error_stage =
   | CheckXML
   | DesugarInners
   | DesugarModules
+  | DesugarSwitchFuns
 
 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"
+  | DesugarSwitchFuns    -> "desugaring pattern-matching"
 
 exception RuntimeError of string
 exception UndefinedVariable of string

core/errors.mli

@@ -14,6 +14,7 @@ type sugar_error_stage =
   | CheckXML
   | DesugarInners
   | DesugarModules
+  | DesugarSwitchFuns
 
 
 exception RuntimeError of string

core/frontend.ml

@@ -125,6 +125,7 @@ module Untyped = struct
   let transformers : transformer array
     = [| (module ResolvePositions)
        ; (module CheckXmlQuasiquotes)
+       ; (module DesugarSwitchFuns)
        ; (module DesugarModules)
        ; (module Shunting)
        ; (module Collect_FFI_Files)

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,13 +105,14 @@ 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 ->
           lens_sugar_phrase_of_body (S.Binder.to_name x) body
       | _ ->
           Format.asprintf "Unsupported binder: %a" S.pp_phrase p
           |> Error.internal_error_res )
+  | S.FunLit (_, _, Sugartypes.SwitchFunlit (_, _), _) -> assert false
   | _ -> lens_sugar_phrase_of_body "" p )
   |> Result.ok_exn

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 }
+| 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 }
@@ -443,6 +445,12 @@ 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)          }
 
+switch_tlfunbinding:
+| fun_kind VARIABLE arg_lists perhaps_location switch_funlit_body     { ($1, $2, $3, $4, $5)   }
+
+switch_funlit_body:
+| SWITCH LBRACE case+ RBRACE                                   { $3 }
+
 tlvarbinding:
 | VAR VARIABLE perhaps_location EQ exp                         { (PatName $2, $5, $3) }
 
@@ -547,6 +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 }
 | LEFTTRIANGLE cp_expression RIGHTTRIANGLE                     { with_pos $loc (CP $2) }
 | DOLLAR primary_expression                                    { with_pos $loc (Generalise $2) }
 
@@ -829,6 +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) }
 | typedecl SEMICOLON | links_module
 | links_open SEMICOLON                                         { $1 }