ref: 576b6afdd977043d4d1c5d04d569b64d11829c54
parent: 40ab729e3177262d5f2ab88be5a2992e8bfb8e9d
author: Lennart Augustsson <lennart.augustsson@epicgames.com>
date: Fri Oct 13 19:47:37 EDT 2023
More error messages tested.
--- a/src/MicroHs/Desugar.hs
+++ b/src/MicroHs/Desugar.hs
@@ -506,6 +506,8 @@
checkDup ds =
case getDups eqIdent (filter (not . eqIdent dummyIdent) $ map fst ds) of
[] -> ds
- (i1:i2:_) : _ ->
- errorMessage (getSLocIdent i1) $ "Duplicate " ++ showIdent i1 ++ " " ++ showSLoc (getSLocIdent i2)
+ (i1:_i2:_) : _ ->
+ errorMessage (getSLocIdent i1) $ "duplicate definition " ++ showIdent i1
+ -- XXX mysteriously the location for i2 is the same as i1
+ -- ++ ", also at " ++ showSLoc (getSLocIdent i2)
_ -> error "checkDup"
--- a/src/MicroHs/TypeCheck.hs
+++ b/src/MicroHs/TypeCheck.hs
@@ -482,6 +482,14 @@
EForall iks t -> EForall iks <$> derefUVar t
_ -> impossible
+tcErrorTK :: SLoc -> String -> T ()
+tcErrorTK loc msg = T.do
+ tcm <- gets tcMode
+ let s = case tcm of
+ TCType -> "kind"
+ _ -> "type"
+ tcError loc $ s ++ " error: " ++ msg
+
unify :: --XHasCallStack =>
SLoc -> EType -> EType -> T ()
unify loc a b = T.do
@@ -498,7 +506,7 @@
unifyR loc (EUVar r1) t2 = unifyVar loc r1 t2
unifyR loc t1 (EUVar r2) = unifyVar loc r2 t1
unifyR loc t1 t2 =
- tcError loc $ "Cannot unify " ++ showExpr t1 ++ " and " ++ showExpr t2 ++ "\n"
+ tcErrorTK loc $ "cannot unify " ++ showExpr t1 ++ " and " ++ showExpr t2
unifyVar :: --XHasCallStack =>
SLoc -> TRef -> EType -> T ()
@@ -519,7 +527,7 @@
unifyUnboundVar loc r1 t2 = T.do
vs <- getMetaTyVars [t2]
if elemBy (==) r1 vs then
- tcError loc $ "Cyclic type"
+ tcErrorTK loc $ "cyclic " ++ showExpr (EUVar r1) ++ " = " ++ showExpr t2
else
setUVar r1 t2
@@ -587,24 +595,25 @@
put (TC mn (n+1) fx tenv senv venv sub m)
T.return n
-tLookupInst :: --XHasCallStack =>
- String -> Ident -> T (Expr, EType)
-tLookupInst msg i = T.do
- (e, s) <- tLookup msg i
--- traceM ("lookup " ++ show (i, s))- t <- tInst s
- T.return (e, t)
-
tLookup :: --XHasCallStack =>
- String -> Ident -> T (Expr, EType)
-tLookup msg i = T.do
+ String -> String -> Ident -> T (Expr, EType)
+tLookup msg0 msgN i = T.do
env <- gets valueTable
case M.lookup i env of
- Nothing -> tcError (getSLocIdent i) $ "undefined " ++ msg ++ ": " ++ showIdent i
+ Nothing -> tcError (getSLocIdent i) $ msg0 ++ ": " ++ showIdent i
-- ++ "\n" ++ show env ;
Just [Entry e s] -> T.return (setSLocExpr (getSLocIdent i) e, s)
- Just _ -> tcError (getSLocIdent i) $ "ambiguous " ++ msg ++ ": " ++ showIdent i
+ Just _ -> tcError (getSLocIdent i) $ msgN ++ ": " ++ showIdent i
+tLookupV :: --XHasCallStack =>
+ Ident -> T (Expr, EType)
+tLookupV i = T.do
+ tcm <- gets tcMode
+ let s = case tcm of
+ TCType -> "type"
+ _ -> "value"
+ tLookup ("undefined " ++ s ++ " identifier") ("ambiguous " ++ s ++ " identifier") i+
tInst :: EType -> T EType
tInst as =
case as of
@@ -818,7 +827,7 @@
case adef of
Fcn i eqns -> T.do
-- traceM $ "tcDefValue: " ++ show i -- ++ " = " ++ showExpr rhs
- (_, tt) <- tLookup "no type signature" i
+ (_, tt) <- tLookup "no type signature" "many type signatures" i
let (iks, tfn) = unForall tt
mn <- gets moduleName
teqns <- withExtTyps iks $ tcEqns tfn eqns
@@ -927,7 +936,8 @@
T.return ae
| isConIdent i -> T.do
- (p, pt) <- tLookupInst "constructor" i
+ (p, cpt) <- tLookupV i
+ pt <- tInst cpt
-- We will only have an expected type for a non-nullary constructor
case mt of
Check ext -> subsCheck loc ext pt
@@ -938,7 +948,7 @@
-- All pattern variables are in the environment as
-- type references. Assign the reference the given type.
ext <- tGetExpTypeSet mt
- (p, t) <- tLookup "IMPOSSIBLE" i
+ (p, t) <- tLookupV i
case t of
EUVar r -> tSetRefType r ext
_ -> impossible
@@ -947,7 +957,7 @@
_ -> T.do
-- Type checking an expression (or type)
T.when (isDummyIdent i) impossible
- (e, t) <- tLookup "variable" i
+ (e, t) <- tLookupV i
-- Variables bound in patterns start with an (EUVar ref) type,
-- which can be instantiated to a polytype.
-- Dereference such a ref.
@@ -996,7 +1006,7 @@
[as] ->
case as of
SThen a -> tcExpr mt a
- _ -> tcError loc $ "bad do "
+ _ -> tcError loc $ "bad final do statement"
as : ss -> T.do
case as of
SBind p a -> T.do
@@ -1076,7 +1086,7 @@
instSigma loc t' mt
checkSigma e t'
EAt i e -> T.do
- (_, ti) <- tLookup "IMPOSSIBLE" i
+ (_, ti) <- tLookupV i
e' <- tcExpr mt e
tt <- tGetExpType mt
case ti of
@@ -1130,7 +1140,7 @@
opfix :: FixTable -> (Ident, Expr) -> T ((Expr, Fixity), Expr)
opfix fixs (i, e) = T.do
- (ei, _) <- tLookup "operator" i
+ (ei, _) <- tLookupV i
let fx = getFixity fixs (getIdent ei)
T.return ((EVar i, fx), e)
@@ -1219,7 +1229,7 @@
esc_tvs <- getFreeTyVars [sigma1,sigma2]
let bad_tvs = filter (\ i -> elemBy eqIdent i esc_tvs) skol_tvs
T.when (not (null bad_tvs)) $
- tcError loc "Subsumption check failed"
+ tcErrorTK loc "Subsumption check failed"
tCheckPat :: forall a . EType -> EPat -> (EPat -> T a) -> T a
tCheckPat t p@(EVar v) ta | not (isConIdent v) = T.do -- simple special case
@@ -1291,7 +1301,7 @@
tcBind abind =
case abind of
BFcn i eqns -> T.do
- (_, tt) <- tLookup "impossible!" i
+ (_, tt) <- tLookupV i
let (iks, tfn) = unForall tt
teqns <- withExtTyps iks $ tcEqns tfn eqns
T.return $ BFcn i teqns
@@ -1467,7 +1477,7 @@
esc_tvs <- getFreeTyVars (sigma : env_tys)
let bad_tvs = filter (\ i -> elemBy eqIdent i esc_tvs) skol_tvs
T.when (not (null bad_tvs)) $
- tcError (getSLocExpr expr) "Type not polymorphic enough"
+ tcErrorTK (getSLocExpr expr) "not polymorphic enough"
T.return expr'
subsCheckRho :: SLoc -> Sigma -> Rho -> T ()
--- a/tests/errmsg.test
+++ b/tests/errmsg.test
@@ -1,8 +1,25 @@
+amodule M() where
+-----
+mhs: "../tmp/E.hs": line 2, col 1:
+ found: amodule
+ expected: module
+
+=====
+module M() where
+x :: Int
+x = 1 +
+y = 0
+-----
+mhs: "../tmp/E.hs": line 5, col 1:
+ found: ;
+ expected: LQIdent ( UQIdent [ literal primitive \ case let if QualDo do
+
+=====
module E() where
import Prelude
x = y
-----
-mhs: "../tmp/E.hs": line 4, col 1: undefined no type signature: x
+mhs: "../tmp/E.hs": line 4, col 1: no type signature: x
=====
module E() where
@@ -10,19 +27,56 @@
x :: Int
x = y
-----
-mhs: "../tmp/E.hs": line 5, col 5: undefined variable: y
+mhs: "../tmp/E.hs": line 5, col 5: undefined value identifier: y
=====
module E() where
import Prelude
+x :: Int
+x = A
+-----
+mhs: "../tmp/E.hs": line 5, col 5: undefined value identifier: A
+
+=====
+module E() where
+import Prelude
+import Control.Monad.State.Strict
+x :: Int
+x = fmap
+-----
+mhs: "../tmp/E.hs": line 6, col 5: ambiguous value identifier: fmap
+
+=====
+module E() where
+import Prelude
x :: T
x = 1
-----
-mhs: "../tmp/E.hs": line 4, col 6: undefined variable: T
+mhs: "../tmp/E.hs": line 4, col 6: undefined type identifier: T
=====
module E() where
import Prelude
+x :: a
+x = 1
+-----
+mhs: "../tmp/E.hs": line 4, col 6: undefined type identifier: a
+
+=====
+module E() where
+import Prelude
+x :: Int
+x = 1
+y :: Int
+y = 2
+x :: Int
+x = 3
+-----
+mhs: "../tmp/E.hs": line 2, col 8: duplicate definition E.x
+
+=====
+module E() where
+import Prelude
type T a = [a]
data D (f :: Type -> Type) = D (f Int)
x :: D T
@@ -60,6 +114,21 @@
x = 1 +++ 2 *** 3
-----
mhs: "../tmp/E.hs": line 11, col 13: ambiguous operator expression
+
+=====
+module E() where
+import Prelude
+a :: Int
+a = 'a'
+-----
+mhs: "../tmp/E.hs": line 5, col 5: type error: cannot unify Primitives.Char and Primitives.Int
+
+=====
+module E() where
+import Prelude
+data T = C Maybe
+-----
+mhs: "../tmp/E.hs": line 4, col 12: kind error: cannot unify Primitives.Type and (a0 -> a1)
=====
END
--
⑨