AST-38: Significant parenthesis around tuple patterns in func arguments

README.md

@@ -250,7 +250,7 @@ and open the path printed on the last line of that command.
 * Conditionals and switches
   - `if b ...`
   - `if b ... else ...`
-  - `switch x case 1 ... case 2 ... case _ ...`
+  - `switch x { case 1 ...; case 2 ...; case _ ...}`
 
 * While loops and iterations
   - `while (p()) ...`

src/arrange.ml

@@ -10,8 +10,8 @@ let rec exp e = match e.it with
   | VarE x              -> "VarE"    $$ [id x]
   | LitE l              -> "LitE"    $$ [lit !l]
   | UnE (ot, uo, e)     -> "UnE"     $$ [operator_type !ot; unop uo; exp e]
-  | BinE (ot, e1, bo, e2) -> "BinE"    $$ [operator_type !ot; exp e1; binop bo; exp e2]
-  | RelE (ot, e1, ro, e2) -> "RelE"    $$ [operator_type !ot; exp e1; relop ro; exp e2]
+  | BinE (ot, e1, bo, e2) -> "BinE"  $$ [operator_type !ot; exp e1; binop bo; exp e2]
+  | RelE (ot, e1, ro, e2) -> "RelE"  $$ [operator_type !ot; exp e1; relop ro; exp e2]
   | TupE es             -> "TupE"    $$ List.map exp es
   | ProjE (e, i)        -> "ProjE"   $$ [exp e; Atom (string_of_int i)]
   | ObjE (s, i, efs)    -> "ObjE"    $$ [obj_sort s; id i] @ List.map exp_field efs
@@ -49,6 +49,7 @@ and pat p = match p.it with
   | SignP (uo, l) -> "SignP"      $$ [unop uo ; lit !l]
   | OptP p        -> "OptP"       $$ [pat p]
   | AltP (p1,p2)  -> "AltP"       $$ [pat p1; pat p2]
+  | ParP p        -> "ParP"       $$ [pat p]
 
 and lit (l:lit) = match l with
   | NullLit       -> Atom "NullLit"

src/check_ir.ml

@@ -740,7 +740,7 @@ and check_block_exps env t decs at =
   | [dec] ->
     check_dec env dec;
     check env at (T.is_unit t || T.sub (typ dec) t)
-      "declaration does not produce expect type"
+      "declaration does not produce expected type"
   | dec::decs' ->
     check_dec env dec;
     check_block_exps env t decs' at

src/coverage.ml

@@ -90,7 +90,8 @@ let rec match_pat ctxt desc pat t sets =
   | AltP (pat1, pat2) ->
     sets.alts <- AtSet.add pat1.at (AtSet.add pat2.at sets.alts);
     match_pat (InAlt1 (ctxt, pat1.at, pat2, t)) desc pat1 t sets
-  | AnnotP (pat1, _) ->
+  | AnnotP (pat1, _)
+  | ParP pat1 ->
     match_pat ctxt desc pat1 t sets
 
 and match_lit ctxt desc v t sets =

src/definedness.ml

@@ -125,7 +125,8 @@ and pat msgs p : fd = match p.it with
   | WildP         -> (M.empty, S.empty)
   | VarP i        -> (M.empty, S.singleton i.it)
   | TupP ps       -> pats msgs ps
-  | AnnotP (p, t) -> pat msgs p
+  | AnnotP (p, _)
+  | ParP p        -> pat msgs p
   | LitP l        -> (M.empty, S.empty)
   | SignP (uo, l) -> (M.empty, S.empty)
   | OptP p        -> pat msgs p

src/desugar.ml

@@ -173,13 +173,20 @@ and decs ds =
     | _ -> (phrase' dec' d) :: (decs ds)
 
 and dec d = phrase' dec' d
-and dec' at n d = match d with
+and dec' at n d =
+  let fix_unary p = match p.it, p.note with
+    | S.TupP [p1], Type.Tup [n] -> { p with it = p1.it; note = n }
+    | _ -> p in
+  let param p = match p.it with
+    | S.ParP p1 -> pat (fix_unary { p with it = S.TupP [p1]; note = Type.Tup [p.note] })
+    | _ ->  pat (fix_unary p)
+  in match d with
   | S.ExpD e -> I.ExpD (exp e)
   | S.LetD (p, e) -> I.LetD (pat p, exp e)
   | S.VarD (i, e) -> I.VarD (i, exp e)
   | S.FuncD (s, i, tbs, p, ty, e) ->
     let cc = Value.call_conv_of_typ n.S.note_typ in
-    I.FuncD (cc, i, typ_binds tbs, pat p, ty.note, exp e)
+    I.FuncD (cc, i, typ_binds tbs, param p, ty.note, exp e)
   | S.TypD (id, typ_bind, t) ->
     let c = Lib.Option.value id.note in
     I.TypD c
@@ -199,7 +206,7 @@ and dec' at n d = match d with
         T.promote (T.open_ inst rng)
       | _ -> assert false
     in
-    I.FuncD (cc, id', typ_binds tbs, pat p, obj_typ, (* TBR *)
+    I.FuncD (cc, id', typ_binds tbs, param p, obj_typ, (* TBR *)
              { it = obj at s (Some id') self_id es obj_typ;
                at = at;
                note = { S.note_typ = obj_typ; S.note_eff = T.Triv } })
@@ -222,7 +229,8 @@ and pat' = function
   | S.TupP ps -> I.TupP (pats ps)
   | S.OptP p -> I.OptP (pat p)
   | S.AltP (p1, p2) -> I.AltP (pat p1, pat p2)
-  | S.AnnotP (p, _) -> pat' p.it
+  | S.AnnotP (p, _)
+  | S.ParP p -> pat' p.it
 
 and prog p = (decs p.it,
   { I.has_await = true

src/interpret.ml

@@ -430,9 +430,10 @@ and declare_pat pat : val_env =
   | WildP | LitP _ | SignP _ ->  V.Env.empty
   | VarP id -> declare_id id
   | TupP pats -> declare_pats pats V.Env.empty
-  | OptP pat1 -> declare_pat pat1
-  | AltP (pat1, pat2) -> declare_pat pat1
-  | AnnotP (pat1, _typ) -> declare_pat pat1
+  | OptP pat1
+  | AltP (pat1, _)    (* both have empty binders *)
+  | AnnotP (pat1, _)
+  | ParP pat1 -> declare_pat pat1
 
 and declare_pats pats ve : val_env =
   match pats with
@@ -461,7 +462,8 @@ and define_pat env pat v =
       trap pat.at "value %s does not match pattern" (V.string_of_val v)
     | _ -> assert false
     )
-  | AnnotP (pat1, _typ) -> define_pat env pat1 v
+  | AnnotP (pat1, _)
+  | ParP pat1 -> define_pat env pat1 v
 
 and define_pats env pats vs =
   List.iter2 (define_pat env) pats vs
@@ -507,8 +509,9 @@ and match_pat pat v : val_env option =
     | None -> match_pat pat2 v
     | some -> some
     )
-  | AnnotP (pat1, _typ) ->
-    match_pat pat1 v
+  | AnnotP (pat1, _)
+  | ParP pat1 ->
+     match_pat pat1 v
 
 and match_pats pats vs ve : val_env option =
   match pats, vs with

src/operator.ml

@@ -14,7 +14,7 @@ let word_unop fword8 fword16 fword32 fword64 = function
   | T.Word16 -> fun v -> Word16 (fword16 (as_word16 v))
   | T.Word32 -> fun v -> Word32 (fword32 (as_word32 v))
   | T.Word64 -> fun v -> Word64 (fword64 (as_word64 v))
-  | _ -> raise (Invalid_argument "unop")
+  | _ -> raise (Invalid_argument "word_unop")
 
 let num_unop fint fword8 fword16 fword32 fword64 ffloat = function
   | T.Int -> fun v -> Int (fint (as_int v))
@@ -37,14 +37,14 @@ let unop t op =
 
 let text_binop ftext = function
   | T.Text -> fun v1 v2 -> Text (ftext (as_text v1) (as_text v2))
-  | _ -> raise (Invalid_argument "binop")
+  | _ -> raise (Invalid_argument "text_binop")
 
 let word_binop fword8 fword16 fword32 fword64 = function
   | T.Word8 -> fun v1 v2 -> Word8 (fword8 (as_word8 v1) (as_word8 v2))
   | T.Word16 -> fun v1 v2 -> Word16 (fword16 (as_word16 v1) (as_word16 v2))
   | T.Word32 -> fun v1 v2 -> Word32 (fword32 (as_word32 v1) (as_word32 v2))
   | T.Word64 -> fun v1 v2 -> Word64 (fword64 (as_word64 v1) (as_word64 v2))
-  | _ -> raise (Invalid_argument "binop")
+  | _ -> raise (Invalid_argument "word_binop")
 
 let num_binop fnat fint fword8 fword16 fword32 fword64 ffloat = function
   | T.Nat -> fun v1 v2 -> Int (fnat (as_int v1) (as_int v2))
@@ -82,7 +82,7 @@ let word_relop fword8 fword16 fword32 fword64 = function
   | T.Word16 -> fun v1 v2 -> Bool (fword16 (as_word16 v1) (as_word16 v2))
   | T.Word32 -> fun v1 v2 -> Bool (fword32 (as_word32 v1) (as_word32 v2))
   | T.Word64 -> fun v1 v2 -> Bool (fword64 (as_word64 v1) (as_word64 v2))
-  | _ -> raise (Invalid_argument "relop")
+  | _ -> raise (Invalid_argument "word_relop")
 
 let num_relop fnat fint fword8 fword16 fword32 fword64 ffloat = function
   | T.Nat -> fun v1 v2 -> Bool (fnat (as_int v1) (as_int v2))

src/parser.mly

@@ -481,7 +481,10 @@ pat_nullary :
   | l=lit
     { LitP(ref l) @! at $sloc }
   | LPAR p=pat RPAR
-    { p }
+    { match p.it with
+      | TupP _ -> { p with it = ParP p; at = at $sloc }
+      | _ -> p
+    }
   | LPAR ps=seplist1(pat_bin, COMMA) RPAR
     { TupP(ps) @! at $sloc }
 

src/syntax.ml

@@ -103,6 +103,7 @@ and pat' =
   | OptP of pat                                (* option *)
   | AltP of pat * pat                          (* disjunctive *)
   | AnnotP of pat * typ                        (* type annotation *)
+  | ParP of pat                                (* parenthesis *)
 (*
   | AsP of pat * pat                           (* conjunctive *)
   | ObjP of pat_field list                     (* object *)

src/typing.ml

@@ -732,6 +732,8 @@ and infer_pat' env pat : T.typ * val_env =
   | AnnotP (pat1, typ) ->
     let t = check_typ env typ in
     t, check_pat env t pat1
+  | ParP pat1 ->
+     infer_pat env pat1
 
 and infer_pats at env pats ts ve : T.typ list * val_env =
   match pats with
@@ -798,6 +800,8 @@ and check_pat' env t pat : val_env =
     if ve1 <> T.Env.empty || ve2 <> T.Env.empty then
       error env pat.at "variables are not allowed in pattern alternatives";
     T.Env.empty
+  | ParP pat1 ->
+     check_pat' env t pat1
   | _ ->
     let t', ve = infer_pat env pat in
     if not (T.sub t t') then
@@ -848,7 +852,9 @@ and pub_pat pat xs : region T.Env.t * region T.Env.t =
   | TupP pats -> List.fold_right pub_pat pats xs
   | AltP (pat1, _)
   | OptP pat1
-  | AnnotP (pat1, _) -> pub_pat pat1 xs
+  | AnnotP (pat1, _)
+  | ParP pat1
+    -> pub_pat pat1 xs
 
 and pub_typ_id id (xs, ys) : region T.Env.t * region T.Env.t =
   (T.Env.add id.it id.at xs, ys)
@@ -1091,7 +1097,8 @@ and gather_pat env ve pat : val_env =
     List.fold_left (gather_pat env) ve pats
   | AltP (pat1, _)
   | OptP pat1
-  | AnnotP (pat1, _) ->
+  | AnnotP (pat1, _)
+  | ParP pat1 ->
     gather_pat env ve pat1
 
 and gather_id env ve id : val_env =

test/run/AST-56.as

@@ -0,0 +1,6 @@
+func p((),) {};
+func p1(()) {};
+func p2((())) {};
+func p3(((()))) {};
+
+let ps : [((),) -> ()] = [p, p1, p2, p3];

test/run/empty-tup-args.as

@@ -1,9 +1,87 @@
 func f() {};
 func g(()) {};
+func g1((())) {}; // only top-level parenthesis signifies arity
 func h(u:()) {};
+func h1((u:())) {}; // dito, intermediate parentheses are redundant
+
 let _ = f : () -> ();
-let _ = g : () -> ();
+let _ = g : (()) -> ();
 let _ = h : (()) -> ();
+
+let _ : [() -> ()] = [f];
+let gh : [(()) -> ()] = [g, g1, h, h1];
+
 f();
-g();
-h();
+g(); // accepted, because "At calls there is an implicit coercion
+     //                    between tuples and n-ary arguments"
+h(); // dito
+gh[0](); // dito
+gh[1](); // dito
+
+// Correct:
+g(());
+h(());
+h1(());
+gh[0](());
+gh[1](());
+gh[2](());
+gh[3](());
+
+func j(a:Int) {};
+func k(a:(Int)) {};
+func l(a:((Int))) {};
+
+let jkl : [Int -> ()] = [j, k, l];
+
+j(5);
+k(8);
+l(13);
+jkl[1](21);
+
+func m((a:Int, b:Bool)) {};
+func m1((a:Int, b:Bool,)) {};
+let ms : [((Int, Bool)) -> ()] = [m, m1];
+
+func n(a:Int, b:Bool) {};
+func n1(a:Int, b:Bool,) {};
+
+let ns : [(Int, Bool) -> ()] = [n, n1];
+
+func o((a:Int,)) {};
+let os : [((Int,)) -> ()] = [o];
+
+// class tests, these have the same argument regime
+class F() {};
+class G(()) {};
+class H(a:()) {};
+class G1((())) {};
+class H1((u:())) {};
+let _ : [() -> F] = [F];
+let _ : [(()) -> G] = [G];
+let _ : [(()) -> G1] = [G1];
+let _ : [(()) -> H] = [H];
+let _ : [(()) -> H1] = [H1];
+
+func annih<A,B>(f : A -> B) : (A -> ()) { func (a : A) { ignore (f a) } };
+let _ : [(()) -> ()] = [annih<(),G> G, annih<(),G1> G1, annih<(),H> H, annih<(),H1> H1];
+
+
+// test that parens are not significant deeper into the pattern,
+// even around tuples
+
+func p(a:Int,  () ) {};
+func q(a:Int, (())) {};
+func r(a:Int,  (b:Int,) ) {};
+func s(a:Int, ((b:Int,))) {};
+let _ : [(Int, ()) -> ()] = [p, q];
+let _ : [(Int, (Int,)) -> ()] = [r, s];
+
+// redundant parens for anonymous functions
+
+let _ = (func (a:Nat, ()) : Nat { a }) (42, ());
+let _ = (func ((a:Nat, (()))) : Nat { a }) (42, ());
+
+// test that switch expressions also behave correctly with redundant parens
+
+let _ = switch (42,) { case (3,) 3; case ((5,)) 5; case (a,) a};
+let _ = switch (42,) { case (3,) 3; case ((5,)) 5; case (((a,))) a};