Warn about variable patterns which match only a single data constructor
Florian Weimer <[email protected]> Sun, 29 Jan 2012 16:12:38 +0100
| Newsgroups | gmane.comp.lang.ml.mlton.devel |
|---|---|
| Message-ID | <[email protected]> |
I'm working on patch which adds another pattern match warning,
intended to cover this case:
datatype t = A | B
fun i A = 0
| i C = 1
As it stands, this produces many false positives. I guess the warning
should fire only if the variable pattern matches a single,
parameter-less data constructor. Any ideas how to implement that?
diff --git a/mlton/control/control-flags.sig b/mlton/control/control-flags.sig
index b976cbd..7901da7 100644
--- a/mlton/control/control-flags.sig
+++ b/mlton/control/control-flags.sig
@@ -96,6 +96,7 @@ signature CONTROL_FLAGS =
val nonexhaustiveExnMatch: (DiagDI.t,DiagDI.t) t
val nonexhaustiveMatch: (DiagEIW.t,DiagEIW.t) t
val redundantMatch: (DiagEIW.t,DiagEIW.t) t
+ val singleConMatch: (DiagEIW.t,DiagEIW.t) t
val sequenceNonUnit: (DiagEIW.t,DiagEIW.t) t
val warnUnused: (bool,bool) t
diff --git a/mlton/control/control-flags.sml b/mlton/control/control-flags.sml
index a525268..576d8ce 100644
--- a/mlton/control/control-flags.sml
+++ b/mlton/control/control-flags.sml
@@ -466,6 +466,9 @@ structure Elaborate =
val (redundantMatch, ac) =
makeDiagEIW ({name = "redundantMatch",
default = DiagEIW.Warn, expert = false}, ac)
+ val (singleConMatch, ac) =
+ makeDiagEIW ({name = "singleConMatch",
+ default = DiagEIW.Warn, expert = false}, ac)
val (sequenceNonUnit, ac) =
makeDiagEIW ({name = "sequenceNonUnit",
default = DiagEIW.Ignore, expert = false}, ac)
diff --git a/mlton/core-ml/core-ml.fun b/mlton/core-ml/core-ml.fun
index c8339e9..8d50e0c 100644
--- a/mlton/core-ml/core-ml.fun
+++ b/mlton/core-ml/core-ml.fun
@@ -154,6 +154,7 @@ datatype dec =
tyvars: unit -> Tyvar.t vector}
| Val of {nonexhaustiveExnMatch: Control.Elaborate.DiagDI.t,
nonexhaustiveMatch: Control.Elaborate.DiagEIW.t,
+ singleConMatch: Control.Elaborate.DiagEIW.t,
rvbs: {lambda: lambda,
var: Var.t} vector,
tyvars: unit -> Tyvar.t vector,
@@ -173,6 +174,7 @@ and expNode =
nonexhaustiveExnMatch: Control.Elaborate.DiagDI.t,
nonexhaustiveMatch: Control.Elaborate.DiagEIW.t,
redundantMatch: Control.Elaborate.DiagEIW.t,
+ singleConMatch: Control.Elaborate.DiagEIW.t,
region: Region.t,
rules: {exp: exp,
lay: (unit -> Layout.t) option,
@@ -403,6 +405,7 @@ structure Exp =
nonexhaustiveExnMatch = Control.Elaborate.DiagDI.Default,
nonexhaustiveMatch = Control.Elaborate.DiagEIW.Ignore,
redundantMatch = Control.Elaborate.DiagEIW.Ignore,
+ singleConMatch = Control.Elaborate.DiagEIW.Ignore,
region = Region.bogus,
rules = Vector.new2 ({exp = thenCase,
lay = NONE,
diff --git a/mlton/core-ml/core-ml.sig b/mlton/core-ml/core-ml.sig
index a2163bb..c1ac3c9 100644
--- a/mlton/core-ml/core-ml.sig
+++ b/mlton/core-ml/core-ml.sig
@@ -79,6 +79,7 @@ signature CORE_ML =
nonexhaustiveExnMatch: Control.Elaborate.DiagDI.t,
nonexhaustiveMatch: Control.Elaborate.DiagEIW.t,
redundantMatch: Control.Elaborate.DiagEIW.t,
+ singleConMatch: Control.Elaborate.DiagEIW.t,
region: Region.t,
rules: {exp: t,
lay: (unit -> Layout.t) option,
@@ -109,6 +110,7 @@ signature CORE_ML =
nonexhaustiveExnMatch: Control.Elaborate.DiagDI.t,
nonexhaustiveMatch: Control.Elaborate.DiagEIW.t,
redundantMatch: Control.Elaborate.DiagEIW.t,
+ singleConMatch: Control.Elaborate.DiagEIW.t,
region: Region.t,
rules: {exp: t,
lay: (unit -> Layout.t) option,
@@ -164,6 +166,7 @@ signature CORE_ML =
tyvars: unit -> Tyvar.t vector}
| Val of {nonexhaustiveExnMatch: Control.Elaborate.DiagDI.t,
nonexhaustiveMatch: Control.Elaborate.DiagEIW.t,
+ singleConMatch: Control.Elaborate.DiagEIW.t,
rvbs: {lambda: Lambda.t,
var: Var.t} vector,
tyvars: unit -> Tyvar.t vector,
diff --git a/mlton/defunctorize/defunctorize.fun b/mlton/defunctorize/defunctorize.fun
index 66ef7b6..3b5a87b 100644
--- a/mlton/defunctorize/defunctorize.fun
+++ b/mlton/defunctorize/defunctorize.fun
@@ -115,6 +115,7 @@ fun casee {caseType: Xtype.t,
nonexhaustiveExnMatch: Control.Elaborate.DiagDI.t,
nonexhaustiveMatch: Control.Elaborate.DiagEIW.t,
redundantMatch: Control.Elaborate.DiagEIW.t,
+ singleConMatch: Control.Elaborate.DiagEIW.t,
region: Region.t,
test = (test: Xexp.t, testType: Xtype.t),
tyconCons}: Xexp.t =
@@ -340,6 +341,30 @@ fun casee {caseType: Xtype.t,
lay ()])
end
end
+ fun diagnoseSingleConMatch () =
+ let
+ datatype z = datatype NestedPat.node
+ val count = Vector.fold (cases, 0,
+ fn ({isDefault, ...}, c) =>
+ if isDefault then c else c + 1)
+ in
+ if count > 1
+ then case Vector.peeki (cases,
+ fn (_, {isDefault, numUses, pat, ...}) =>
+ not isDefault andalso !numUses = 1
+ andalso case NestedPat.node pat of
+ Var _ => true
+ | _ => false) of
+ NONE => ()
+ | SOME (i, _) =>
+ (if singleConMatch = Control.Elaborate.DiagEIW.Error
+ then Control.error
+ else Control.warning)
+ (region,
+ Layout.str (concat [kind, " matches only one pattern "]),
+ Layout.align [])
+ else ()
+ end
in
if redundantMatch <> Control.Elaborate.DiagEIW.Ignore
then List.push (diagnostics, diagnoseRedundantMatch)
@@ -347,6 +372,9 @@ fun casee {caseType: Xtype.t,
; if nonexhaustiveMatch <> Control.Elaborate.DiagEIW.Ignore
then List.push (diagnostics, diagnoseNonexhaustiveMatch)
else ()
+ ; if singleConMatch <> Control.Elaborate.DiagEIW.Ignore
+ then List.push (diagnostics, diagnoseSingleConMatch)
+ else ()
; exp
end
@@ -733,7 +761,7 @@ fun defunctorize (CoreML.Program.T {decs}) =
| Fun {decs, tyvars} =>
prefix (Xdec.Fun {decs = processLambdas decs,
tyvars = tyvars ()})
- | Val {nonexhaustiveExnMatch, nonexhaustiveMatch, rvbs, tyvars, vbs} =>
+ | Val {nonexhaustiveExnMatch, nonexhaustiveMatch, singleConMatch, rvbs, tyvars, vbs} =>
let
val tyvars = tyvars ()
val bodyType = et
@@ -760,6 +788,9 @@ fun defunctorize (CoreML.Program.T {decs}) =
then nonexhaustiveMatch
else Control.Elaborate.DiagEIW.Ignore,
redundantMatch = Control.Elaborate.DiagEIW.Ignore,
+ singleConMatch = if mayWarn
+ then singleConMatch
+ else Control.Elaborate.DiagEIW.Ignore,
region = patRegion,
test = (e, NestedPat.ty p),
tyconCons = tyconCons}
@@ -949,7 +980,7 @@ fun defunctorize (CoreML.Program.T {decs}) =
ty = ty}
end
| Case {kind, lay, nest, noMatch,
- nonexhaustiveExnMatch, nonexhaustiveMatch, redundantMatch,
+ nonexhaustiveExnMatch, nonexhaustiveMatch, redundantMatch, singleConMatch,
region, rules, test, ...} =>
casee {caseType = ty,
cases = Vector.map (rules, fn {exp, lay, pat} =>
@@ -964,6 +995,7 @@ fun defunctorize (CoreML.Program.T {decs}) =
nonexhaustiveExnMatch = nonexhaustiveExnMatch,
nonexhaustiveMatch = nonexhaustiveMatch,
redundantMatch = redundantMatch,
+ singleConMatch = singleConMatch,
region = region,
test = loopExp test,
tyconCons = tyconCons}
diff --git a/mlton/elaborate/elaborate-core.fun b/mlton/elaborate/elaborate-core.fun
index 9feaa29..9543430 100644
--- a/mlton/elaborate/elaborate-core.fun
+++ b/mlton/elaborate/elaborate-core.fun
@@ -19,6 +19,7 @@ in
val nonexhaustiveExnMatch = fn () => current nonexhaustiveExnMatch
val nonexhaustiveMatch = fn () => current nonexhaustiveMatch
val redundantMatch = fn () => current redundantMatch
+ val singleConMatch = fn () => current singleConMatch
val sequenceNonUnit = fn () => current sequenceNonUnit
end
@@ -1086,6 +1087,7 @@ local
nonexhaustiveExnMatch = Control.Elaborate.DiagDI.Default,
nonexhaustiveMatch = Control.Elaborate.DiagEIW.Ignore,
redundantMatch = Control.Elaborate.DiagEIW.Ignore,
+ singleConMatch = Control.Elaborate.DiagEIW.Ignore,
region = Region.bogus,
rules = Vector.new2
({exp = Cexp.truee, lay = NONE, pat = Cpat.falsee},
@@ -1108,6 +1110,7 @@ local
nonexhaustiveExnMatch = Control.Elaborate.DiagDI.Default,
nonexhaustiveMatch = Control.Elaborate.DiagEIW.Ignore,
redundantMatch = Control.Elaborate.DiagEIW.Ignore,
+ singleConMatch = Control.Elaborate.DiagEIW.Ignore,
region = Region.bogus,
rules = Vector.new2
({exp = oneExpBool, lay = NONE, pat = Cpat.truee},
@@ -2167,6 +2170,7 @@ fun elaborateDec (d, {env = E, nest}) =
nonexhaustiveExnMatch = nonexhaustiveExnMatch (),
nonexhaustiveMatch = nonexhaustiveMatch (),
redundantMatch = redundantMatch (),
+ singleConMatch = singleConMatch (),
region = region,
rules =
Vector.map
@@ -2433,6 +2437,7 @@ fun elaborateDec (d, {env = E, nest}) =
nonexhaustiveExnMatch = nonexhaustiveExnMatch (),
nonexhaustiveMatch = nonexhaustiveMatch (),
redundantMatch = redundantMatch (),
+ singleConMatch = singleConMatch (),
region = region,
rules = rules,
test = Cexp.var (arg, argType)},
@@ -2526,6 +2531,7 @@ fun elaborateDec (d, {env = E, nest}) =
Decs.single
(Cdec.Val {nonexhaustiveExnMatch = nonexhaustiveExnMatch (),
nonexhaustiveMatch = nonexhaustiveMatch (),
+ singleConMatch = singleConMatch (),
rvbs = rvbs,
tyvars = bound,
vbs = vbs})
@@ -2618,6 +2624,7 @@ fun elaborateDec (d, {env = E, nest}) =
nonexhaustiveExnMatch = nonexhaustiveExnMatch (),
nonexhaustiveMatch = nonexhaustiveMatch (),
redundantMatch = redundantMatch (),
+ singleConMatch = singleConMatch (),
region = region,
rules = rules,
test = e}
@@ -2818,6 +2825,7 @@ fun elaborateDec (d, {env = E, nest}) =
nonexhaustiveExnMatch = Control.Elaborate.DiagDI.Default,
nonexhaustiveMatch = Control.Elaborate.DiagEIW.Ignore,
redundantMatch = Control.Elaborate.DiagEIW.Ignore,
+ singleConMatch = Control.Elaborate.DiagEIW.Ignore,
region = Region.bogus,
rules = Vector.new1
{exp = app (Vector.map
@@ -3313,6 +3321,7 @@ fun elaborateDec (d, {env = E, nest}) =
nonexhaustiveExnMatch = nonexhaustiveExnMatch (),
nonexhaustiveMatch = nonexhaustiveMatch (),
redundantMatch = redundantMatch (),
+ singleConMatch = singleConMatch (),
region = region,
rules = rules,
test = Cexp.var (arg, argType)}
diff --git a/mlton/elaborate/elaborate-env.fun b/mlton/elaborate/elaborate-env.fun
index 9ec5984..020234c 100644
--- a/mlton/elaborate/elaborate-env.fun
+++ b/mlton/elaborate/elaborate-env.fun
@@ -17,6 +17,7 @@ local
in
val nonexhaustiveExnMatch = fn () => current nonexhaustiveExnMatch
val nonexhaustiveMatch = fn () => current nonexhaustiveMatch
+ val singleConMatch = fn () => current singleConMatch
val warnUnused = fn () => current warnUnused
end
@@ -2974,6 +2975,7 @@ fun transparentCut (E: t, S: Structure.t, I: Interface.t, {isFunctor: bool},
(decs,
Dec.Val {nonexhaustiveExnMatch = nonexhaustiveExnMatch (),
nonexhaustiveMatch = nonexhaustiveMatch (),
+ singleConMatch = singleConMatch (),
rvbs = Vector.new0 (),
tyvars = fn () => sigArgs,
vbs = (Vector.new1
------------------------------------------------------------------------------
Try before you buy = See our experts in action!
The most comprehensive online learning library for Microsoft developers
is just $99.99! Visual Studio, SharePoint, SQL - plus HTML5, CSS3, MVC3,
Metro Style Apps, more. Free future releases when you subscribe now!
http://p.sf.net/sfu/learndevnow-dev2