Fix wildcard pats

Author: lazear

crates/sml-core/src/check.rs

@@ -230,7 +230,7 @@ impl<'a> Check<'a> {
         let mut names = HashSet::new();
         for f in fbs {
             let n = f[0].name;
-            let a = f[0].pats.len();
+            let a = f.iter().map(|fb| fb.pats.len()).max().unwrap_or(1);
             for fb in f.iter() {
                 if n != fb.name {
                     self.diags.push(Diagnostic::error(
@@ -243,13 +243,17 @@ impl<'a> Check<'a> {
                     ));
                 }
                 if a != fb.pats.len() {
-                    self.diags.push(Diagnostic::error(
-                        fb.span,
-                        format!(
-                            "function clause with a different number of args; expected: {}, found {}",
-                            a, fb.pats.len()
-                        )
-                    ));
+                    if fb.pats.len() == 1 && fb.pats[0].data == PatKind::Wild {
+                        // okay, need to expand it
+                    } else {
+                        self.diags.push(Diagnostic::error(
+                            fb.span,
+                            format!(
+                                "function clause with a different number of args; expected: {}, found {}",
+                                a, fb.pats.len()
+                            )
+                        ));
+                    }
                 }
             }
             if !names.insert(n) {

crates/sml-core/src/elaborate.rs

@@ -1187,13 +1187,26 @@ impl<'a> Context<'a> {
                 }
                 _ => {
                     // Rule 34
-                    // let tvar = self.arena.types.fresh_type_var(self.tyvar_rank);
+                    let mut name = *sym;
+                    if bindings
+                        .iter()
+                        .map(|(s, _)| s)
+                        .find(|s| s == &sym)
+                        .is_some()
+                    {
+                        name = self.fresh_var();
+                        self.elab_errors.push(ElabError::new(
+                            pat.span,
+                            "duplicate variable in pattern, emitting bogus value",
+                        ));
+                    }
                     let ty = self.fresh_tyvar();
                     if bind {
-                        self.define_value(*sym, Scheme::Mono(ty), IdStatus::Var);
+                        self.define_value(name, Scheme::Mono(ty), IdStatus::Var);
                     }
-                    bindings.push((*sym, ty));
-                    Pat::new(self.arena.pats.alloc(PatKind::Var(*sym)), ty, pat.span)
+
+                    bindings.push((name, ty));
+                    Pat::new(self.arena.pats.alloc(PatKind::Var(name)), ty, pat.span)
                 }
             },
             Wild => Pat::new(self.arena.pats.wild(), self.fresh_tyvar(), pat.span),
@@ -1399,6 +1412,7 @@ impl<'a> Context<'a> {
 
             let mut pats = Vec::new();
             let mut bindings = Vec::new();
+
             for (idx, pat) in clause.pats.iter().enumerate() {
                 let pat = self.elaborate_pat_inner(pat, false, &mut bindings);
                 self.unify(arg_tys[idx], pat.ty, &|c| {
@@ -1407,6 +1421,16 @@ impl<'a> Context<'a> {
                 });
                 pats.push(pat);
             }
+            if pats.len() < arity {
+                for idx in pats.len()..arity {
+                    let wild = Pat::new(self.arena.pats.wild(), self.fresh_tyvar(), clause.span);
+                    self.unify(arg_tys[idx], wild.ty, &|c| {
+                        c.span(wild.span)
+                            .message("function clause with argument of different type")
+                    });
+                    pats.push(wild);
+                }
+            }
             clauses.push(PartialFnBinding {
                 expr: &clause.expr,
                 pats,
@@ -1536,9 +1560,9 @@ impl<'a> Context<'a> {
             // Check to make sure all of the function clauses are consistent within each
             // binding group
             for f in fbs {
-                let n = f[0].name;
-                let a = f[0].pats.len();
-                let fns = ctx.elab_decl_fnbind_ty(n, a, f);
+                let name = f[0].name;
+                let arity = f.iter().map(|fb| fb.pats.len()).max().unwrap_or(1);
+                let fns = ctx.elab_decl_fnbind_ty(name, arity, f);
 
                 ctx.define_value(fns.name, Scheme::Mono(fns.ty), IdStatus::Var);
                 info.push(fns);

crates/sml-core/src/match_compile.rs

@@ -368,15 +368,10 @@ impl<'a, 'ctx> Matrix<'a, 'ctx> {
         }
         let mut set = set.into_iter().collect::<Vec<_>>();
         set.sort_by(|a, b| a.0.name.cmp(&b.0.name));
-        // We only use `true` and `false` or `cons` and `nil`, so we know
-        // there are only 2 constructors in each datatype. Otherwise we
-        // would need to query a context to determine this
+
         let exhaustive = set.len() == type_arity as usize;
         let mut rules = Vec::new();
         for (con, arg_ty) in set {
-            // In a real system, we would have some context to pull the number
-            // of data constructors for a datatype, and the arity of each
-            // data constructor. We just mock it instead
             let fresh = self.ctx.fresh_var();
             let mut f = facts.clone();
             let expr = self.specialize(&mut f, con, arg_ty.map(|ty| (fresh, ty)));
@@ -442,6 +437,8 @@ impl<'a, 'ctx> Matrix<'a, 'ctx> {
                 _ => continue,
             }
         }
+        let mut set = set.into_iter().collect::<Vec<_>>();
+        set.sort_by(|a, b| a.cmp(&b));
 
         let mut rules = Vec::new();
         for con in set {

crates/sml-frontend/src/ast.rs

@@ -1,7 +1,7 @@
 use sml_util::interner::Symbol;
 use sml_util::span::{Span, Spanned};
 
-#[derive(Copy, Clone, Debug, PartialEq, PartialOrd, Eq, Hash)]
+#[derive(Copy, Clone, Debug, PartialEq, PartialOrd, Eq, Hash, Ord)]
 pub enum Const {
     Unit,
     Int(usize),

tests/elaboration/duplicate.sml

@@ -0,0 +1,12 @@
+(* rebinding of builtin data constructors is prohibited 
+
+-- expected stdout:
+-- 0 warnings, 1 errors
+
+-- expected stderr:
+-- Error
+-- 12,11 duplicate variable in pattern, emitting bogus value
+
+*)
+
+fun dup x x = x

tests/elaboration/rebind.sml

@@ -0,0 +1,21 @@
+(* rebinding of builtin data constructors is prohibited 
+
+-- expected stdout:
+-- 2 warnings, 2 errors
+
+-- expected stderr:
+-- Warn
+-- 21,20 rebound data constructor: ::
+-- 
+-- Warn
+-- 21,41 rebound data constructor: nil
+-- 
+-- Error
+-- 21,20 builtin data constructor '::' cannot be rebound
+-- 
+-- Error
+-- 21,41 builtin data constructor 'nil' cannot be rebound
+-- 
+*)
+
+datatype 'a list = :: of 'a * 'a list | nil;

tests/match_compile/wildcard.sml

@@ -0,0 +1,38 @@
+(* wildcard pats in multi-arity functions
+
+-- args: --vv
+-- expected stdout:
+-- val m: int -> int -> int = fn a => fn b => 
+--   let
+--     val e: int -> int = fn d => 
+--       let
+--         val x: int = d
+--       in 
+--         x
+--       end
+--     val g: int -> int = fn f => 
+--       let
+--         val y: int = f
+--       in 
+--         y
+--       end
+--     val i: unit -> int = fn h => 0
+--   in 
+--     
+--       case a
+--         of 0 => 
+--           case b
+--             of 0 => e a
+--              | _ => g b
+--          | _ => 
+--              case b
+--                of 0 => e a
+--                 | _ => i ()
+--   end
+-- 
+
+*)
+
+fun m x 0 = x
+  | m 0 y = y
+  | m _   = 0

tests/typecheck/value_res.sml

@@ -0,0 +1,33 @@
+(* value restriction. example from MLton
+
+-- expected stdout:
+-- 0 warnings, 1 errors
+
+-- expected stderr:
+-- Error
+-- 33,9 Type unification: can't unify function with argument types. Type constructors differ: int, string
+*)
+
+datatype 'a option = Some of 'a | None
+val 'a := = primitive "Assign" : 'a ref * 'a -> unit
+val 'a ! = primitive "Deref" : 'a ref -> 'a
+
+infix 3 := 
+
+val f: 'a -> 'a =
+   let
+      val r: 'a option ref = ref None
+   in
+      fn x =>
+      let
+         val y = !r
+         val () = r := (Some x)
+      in
+         case y of
+            None => x
+          | Some y => y
+            end
+      end
+   end
+val _ = f 13
+val _ = f "foo"