Proposal 869: pattern-matching syntax

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,12 @@ 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
+                | _ -> 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
                let o = o#with_visiting visiting_funs in

core/desugarMatching.ml

@@ -0,0 +1,94 @@
+open Sugartypes
+open Utility
+open SourceCode
+
+(* This module desugars pattern-matching functions
+
+  This transformation convert function like that:
+
+  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:
+
+  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.DesugarMatching ~message:"Can't match over nullary function"
+  in
+  match pss with
+    | [[]] -> raise (nullary_error pos)
+    | _ -> ()
+
+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, 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
+          (* 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
+          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
+      | _ -> super#binding b
+end
+
+module Untyped
+  = Transform.Untyped.Make.Transformer(struct
+        let name = "desugar_match_functions"
+        let obj = desugar_matching
+      end)

core/desugarMatching.mli

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

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

core/errors.mli

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

core/frontend.ml

@@ -125,6 +125,7 @@ module Untyped = struct
   let transformers : transformer array
     = [| (module ResolvePositions)
        ; (module CheckXmlQuasiquotes)
+       ; (module DesugarMatching)
        ; (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_body     { ($1, $2, $3, $4, $5)   }
+
+switch_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_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_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 }
 

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
+        | _ -> assert false in
      let function_definition' =
        { fun_binder = Binder.set_type fun_binder typ'
        ; fun_linearity
-       ; fun_definition = (tyvars', (pats', body'))
+       ; fun_definition = (tyvars', NormalFunlit (pats', body'))
        ; 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
+          | _ -> assert false in
        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'))
          ; rec_location
          ; rec_signature = signature'
          ; rec_unsafe_signature
@@ -213,11 +215,16 @@ 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)
+    | _ -> 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
@@ -228,7 +235,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'))
   ; fun_location
   ; fun_signature = signature'
   ; fun_frozen
@@ -239,11 +246,16 @@ 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)
+    | _ -> 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
@@ -255,7 +267,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'))
   ; rec_location
   ; rec_signature = signature'
   ; rec_frozen