ref: 71f73ada48fb5df5141c9fabffb9e3bb3a2201cb
parent: 45e53d3e3082b902eca6a1c3702894b7b92283a2
author: Lennart Augustsson <lennart@augustsson.net>
date: Fri Sep 1 14:13:18 EDT 2023
More locations in errors.
--- a/comb/mhs.comb
+++ b/comb/mhs.comb
@@ -1,3 +1,3 @@
v3.2
-744
-(($A :0 ((_552 _505) (($B ((($S' ($C ((($C' ($S' _552)) (($B ($C _2)) _492)) (($B ($B (_552 _580))) ((($C' ($S' $C)) ((($C' ($C' $C)) ((($C' ($C' ($C' $S'))) (($B ($B ($B $C))) ((($C' ($C' ($C' ($C' $C)))) ((($C' ($C' ($C' ($C' ($S' $B))))) ((($C' ($C' ($C' ($C' ($C' $S))))) ((($C' ($C' ($C' $B))) (($B ($B ($B ($C' $C)))) ((($C' ($C' ($C' ($C' ($C' $S'))))) (($B ($B ($B ($B ($B $C))))) ((($C' ($C' ($C' ($C' ($C' ($C' $B)))))) ((($C' ($C' ($C' ($S' ($C' $B))))) (($B ($B ($B ($B $B')))) ((($C' ($C' ($C' ($C' $B)))) ((($S' $B) ($B' ($B' (($B $C') (($B ($S' _553)) ((($C' $B) (($B _641) (($B _570) ((($C' _679) _8) 0)))) (($B (_641 _573)) (($B (_586 "top level defns: ")) _534)))))))) ((($S' $B) ($B' (($B ($C' $B)) (($B $B') (($B ($B _553)) ((($C' $B) (($B _641) (($B _570) ((($C' _679) _8) 1)))) (_569 ($T (($B ($B (_641 _573))) ((($C' $B) (($B _586) _496)) (($B (_586 " = ")) _350))))))))))) ((($C' $B) ((($S' $C') (($B $C') (($B $C') _9))) ((($S' $B) (($B ($C' ($C' _553))) ((($C' $B) ($B' (($B _641) (($B _575) _11)))) (($B ($B (_586 _1))) (($B (($C' _586) _534)) (_586 (($O 10) $K))))))) (($B ($B (_552 _580))) ((($C' $B) ($B' (($B _641) (($B _570) ((($C' _679) _8) 0))))) (($B ($B (_641 _573))) (($B ($B (_586 "final pass "))) ((($C' ($C' _586)) (($B ($B (_547 6))) (($B ($B _534)) _673))) "ms")))))))) _3)))) _531))) (($B (($C' $C) (($B ($C _591)) _350))) (($C _604) (_621 0))))) (($B ($C $B)) (($B ($B ($C $B))) (($B ($B $BK)) (($B ($B ($B ($B (_586 "(($A :"))))) (($B ($B (($C' $B) (($B _586) _534)))) (($B ($B ($B (_586 (($O 32) $K))))) ((($C' $B) (($B ($C' _586)) ($B _350))) (($B (_586 ") ")) (($C _586) (($O 41) $K))))))))))))) (($B $Y) ((($C' ($C' $S)) ((($C' ($C' $S)) ((($C' $B) $P) ((($S' ($C' $B)) ($B _327)) $I))) ($BK $K))) $K))))) $T)) (($B (($S' _641) (($B _638) (($B (_641 _688)) (($B (_586 "main: findIdent: ")) _496))))) (($C' _524) _494)))) (($B ($B _528)) (($B (($C' _588) (($B $T) (($B ($C $B)) (($B ($B $BK)) ((($C' ($C' ($C' $O))) ($B (($C' $P) _494))) $K)))))) (($C _604) (_621 0)))))) (($B (_641 _326)) (($B (_641 _492)) (($B (_586 (($O 95) $K))) _534)))))) ($T $A))) ($T $K))) (($B $Y) $K)))))) (($S (($S ((($S' _7) (($B _603) (_590 (_545 "-v")))) ((_620 _545) "-r"))) (($B (_584 (($O 46) $K))) (($B _640) (_589 ((_608 _664) "-i")))))) (($B (_641 _615)) ((($C' _586) (($B _640) (_589 ((_608 _664) "-o")))) (($O "out.comb") $K))))) (($B (($S (($C ((($C' _675) _603) 1)) (_688 "Usage: uhs [-v] [-r] [-iPATH] [-oFILE] ModuleName"))) _615)) (_590 ((_642 _684) ((_642 (_545 (($O 45) $K))) (_601 1))))))) (_611 ((_642 _684) (_545 "--")))))) (($A :1 "v3.2\10&") (($A :2 ((($S' ($S' _552)) _16) (($B ($B ($B (_552 _580)))) ((($C' ($C' $B)) (($B ($B ($C' (($S' _553) (($B (_641 _571)) (($B (_641 (_602 1000000))) _189)))))) (($B ($B ($B ($B (_552 _580))))) ((($C' $B) (($B ($C' $B)) (($B ($B ($C' _553))) ((($C' $B) ($B' (($B _641) (($B _570) ((($C' _679) _8) 0))))) (($B ($B (_641 _573))) (($B ($B (_586 "combinator conversion "))) ((($C' ($C' _586)) (($B ($B (_547 6))) (($B ($B _534)) _673))) "ms"))))))) (($B ($B _554)) (($B $P) (($C _498) (_492 "main")))))))) (_588 ($T ((($C' ($C' $O)) ((($C' $B) $P) _353)) $K))))))) (($A :3 ($T (($C ((($C' $C') (($B ($S' ($B (_552 _505)))) (($B ($B ($B (($C' _506) ((($C' _668) (($B _603) (_611 ((_642 _684) (_545 "--"))))) 1))))) (($B ($B ($B (_641 _6)))) ($C $C))))) (($B ($B $Y)) (($B ($B ($B _483))) (($C' ($C' _588)) (($B ($B $T)) ((($C' ($C' ($C' ($C' $O)))) (($B ($B (($C' $B) $P))) ($B _4))) $K))))))) (($B (($S' _641) (($B _638) (($B (_641 _688)) (($B (_586 "not found ")) _496))))) ($C _484))))) (($A :4 ((($C' $C) ((($S' $C) ((($C' ($C' $S')) (($S $P) ((($S' ($C' $B)) (($B ($B _6)) _4)) _4))) ($BK $K))) ((($C' ($C' $C)) (($B (($C' $C) (($B ($P _6)) $K))) ((($C' $B) _4) _352))) (($B (_641 (_638 (_688 "primlookup")))) (($C (_624 _545)) _5))))) (_688 "trans: impossible"))) (($A :5 (($O (($P (($O 66) $K)) $B)) (($O (($P (($O 79) $K)) $O)) (($O (($P (($O 75) $K)) $K)) (($O (($P "C'") $C')) (($O (($P (($O 67) $K)) $C)) (($O (($P (($O 65) $K)) $A)) (($O (($P "S'") $S')) (($O (($P (($O 80) $K)) $P)) (($
\ No newline at end of file
+745
+(($A :0 ((_553 _506) (($B ((($S' ($C ((($C' ($S' _553)) (($B ($C _2)) _493)) (($B ($B (_553 _581))) ((($C' ($S' $C)) ((($C' ($C' $C)) ((($C' ($C' ($C' $S'))) (($B ($B ($B $C))) ((($C' ($C' ($C' ($C' $C)))) ((($C' ($C' ($C' ($C' ($S' $B))))) ((($C' ($C' ($C' ($C' ($C' $S))))) ((($C' ($C' ($C' $B))) (($B ($B ($B ($C' $C)))) ((($C' ($C' ($C' ($C' ($C' $S'))))) (($B ($B ($B ($B ($B $C))))) ((($C' ($C' ($C' ($C' ($C' ($C' $B)))))) ((($C' ($C' ($C' ($S' ($C' $B))))) (($B ($B ($B ($B $B')))) ((($C' ($C' ($C' ($C' $B)))) ((($S' $B) ($B' ($B' (($B $C') (($B ($S' _554)) ((($C' $B) (($B _642) (($B _571) ((($C' _680) _8) 0)))) (($B (_642 _574)) (($B (_587 "top level defns: ")) _535)))))))) ((($S' $B) ($B' (($B ($C' $B)) (($B $B') (($B ($B _554)) ((($C' $B) (($B _642) (($B _571) ((($C' _680) _8) 1)))) (_570 ($T (($B ($B (_642 _574))) ((($C' $B) (($B _587) _497)) (($B (_587 " = ")) _350))))))))))) ((($C' $B) ((($S' $C') (($B $C') (($B $C') _9))) ((($S' $B) (($B ($C' ($C' _554))) ((($C' $B) ($B' (($B _642) (($B _576) _11)))) (($B ($B (_587 _1))) (($B (($C' _587) _535)) (_587 (($O 10) $K))))))) (($B ($B (_553 _581))) ((($C' $B) ($B' (($B _642) (($B _571) ((($C' _680) _8) 0))))) (($B ($B (_642 _574))) (($B ($B (_587 "final pass "))) ((($C' ($C' _587)) (($B ($B (_548 6))) (($B ($B _535)) _674))) "ms")))))))) _3)))) _532))) (($B (($C' $C) (($B ($C _592)) _350))) (($C _605) (_622 0))))) (($B ($C $B)) (($B ($B ($C $B))) (($B ($B $BK)) (($B ($B ($B ($B (_587 "(($A :"))))) (($B ($B (($C' $B) (($B _587) _535)))) (($B ($B ($B (_587 (($O 32) $K))))) ((($C' $B) (($B ($C' _587)) ($B _350))) (($B (_587 ") ")) (($C _587) (($O 41) $K))))))))))))) (($B $Y) ((($C' ($C' $S)) ((($C' ($C' $S)) ((($C' $B) $P) ((($S' ($C' $B)) ($B _327)) $I))) ($BK $K))) $K))))) $T)) (($B (($S' _642) (($B _639) (($B (_642 _689)) (($B (_587 "main: findIdent: ")) _497))))) (($C' _525) _495)))) (($B ($B _529)) (($B (($C' _589) (($B $T) (($B ($C $B)) (($B ($B $BK)) ((($C' ($C' ($C' $O))) ($B (($C' $P) _495))) $K)))))) (($C _605) (_622 0)))))) (($B (_642 _326)) (($B (_642 _493)) (($B (_587 (($O 95) $K))) _535)))))) ($T $A))) ($T $K))) (($B $Y) $K)))))) (($S (($S ((($S' _7) (($B _604) (_591 (_546 "-v")))) ((_621 _546) "-r"))) (($B (_585 (($O 46) $K))) (($B _641) (_590 ((_609 _665) "-i")))))) (($B (_642 _616)) ((($C' _587) (($B _641) (_590 ((_609 _665) "-o")))) (($O "out.comb") $K))))) (($B (($S (($C ((($C' _676) _604) 1)) (_689 "Usage: uhs [-v] [-r] [-iPATH] [-oFILE] ModuleName"))) _616)) (_591 ((_643 _685) ((_643 (_546 (($O 45) $K))) (_602 1))))))) (_612 ((_643 _685) (_546 "--")))))) (($A :1 "v3.2\10&") (($A :2 ((($S' ($S' _553)) _16) (($B ($B ($B (_553 _581)))) ((($C' ($C' $B)) (($B ($B ($C' (($S' _554) (($B (_642 _572)) (($B (_642 (_603 1000000))) _189)))))) (($B ($B ($B ($B (_553 _581))))) ((($C' $B) (($B ($C' $B)) (($B ($B ($C' _554))) ((($C' $B) ($B' (($B _642) (($B _571) ((($C' _680) _8) 0))))) (($B ($B (_642 _574))) (($B ($B (_587 "combinator conversion "))) ((($C' ($C' _587)) (($B ($B (_548 6))) (($B ($B _535)) _674))) "ms"))))))) (($B ($B _555)) (($B $P) (($C _499) (_493 "main")))))))) (_589 ($T ((($C' ($C' $O)) ((($C' $B) $P) _353)) $K))))))) (($A :3 ($T (($C ((($C' $C') (($B ($S' ($B (_553 _506)))) (($B ($B ($B (($C' _507) ((($C' _669) (($B _604) (_612 ((_643 _685) (_546 "--"))))) 1))))) (($B ($B ($B (_642 _6)))) ($C $C))))) (($B ($B $Y)) (($B ($B ($B _484))) (($C' ($C' _589)) (($B ($B $T)) ((($C' ($C' ($C' ($C' $O)))) (($B ($B (($C' $B) $P))) ($B _4))) $K))))))) (($B (($S' _642) (($B _639) (($B (_642 _689)) (($B (_587 "not found ")) _497))))) ($C _485))))) (($A :4 ((($C' $C) ((($S' $C) ((($C' ($C' $S')) (($S $P) ((($S' ($C' $B)) (($B ($B _6)) _4)) _4))) ($BK $K))) ((($C' ($C' $C)) (($B (($C' $C) (($B ($P _6)) $K))) ((($C' $B) _4) _352))) (($B (_642 (_639 (_689 "primlookup")))) (($C (_625 _546)) _5))))) (_689 "trans: impossible"))) (($A :5 (($O (($P (($O 66) $K)) $B)) (($O (($P (($O 79) $K)) $O)) (($O (($P (($O 75) $K)) $K)) (($O (($P "C'") $C')) (($O (($P (($O 67) $K)) $C)) (($O (($P (($O 65) $K)) $A)) (($O (($P "S'") $S')) (($O (($P (($O 80) $K)) $P)) (($
\ No newline at end of file
--- a/src/MicroHs/Expr.hs
+++ b/src/MicroHs/Expr.hs
@@ -23,7 +23,8 @@
tupleConstr, untupleConstr,
subst,
allVarsExpr, allVarsBind,
- getSLocExpr
+ getSLocExpr,
+ errorMessage
) where
import Prelude --Xhiding (Monad(..), Applicative(..), MonadFail(..), Functor(..), (<$>), showString, showChar, showList)
import Data.List
@@ -244,6 +245,9 @@
-- XXX Should use locations in ELit
getSLocExpr :: Expr -> SLoc
getSLocExpr e = head $ map getSLocIdent (allVarsExpr e) ++ [noSLoc]
+
+errorMessage :: forall a . SLoc -> String -> a
+errorMessage loc msg = error $ showSLoc loc ++ msg
----------------
--- a/src/MicroHs/TypeCheck.hs
+++ b/src/MicroHs/TypeCheck.hs
@@ -81,7 +81,7 @@
expLookup i m =
case M.lookup i m of
Just [e] -> e
- Just _ -> error $ "export ambig " ++ showIdent i
+ Just _ -> errorMessage (getSLocIdent i) $ ": Ambiguous export " ++ showIdent i
Nothing -> expErr i
tyQIdent :: Entry -> Ident
@@ -107,7 +107,7 @@
eVarI = EVar . mkIdent
expErr :: forall a . Ident -> a
-expErr i = error $ "export: " ++ showIdent i
+expErr i = errorMessage (getSLocIdent i) $ ": export undefined " ++ showIdent i
mkTModule :: forall a . IdentModule -> [EDef] -> a -> TModule a
mkTModule mn tds a =
@@ -350,7 +350,7 @@
case M.lookup i syns of
Nothing -> T.return $ foldl tApp t ts
Just (ETypeScheme vs tt) ->
- if length vs /= length ts then error $ "bad syn app: " --X ++ show (i, vs, ts)
+ if length vs /= length ts then errorMessage (getSLocIdent i) $ ": bad synonym use: " --X ++ show (i, vs, ts)
else expandSyn $ subst (zip vs ts) tt
EUVar _ -> T.return $ foldl tApp t ts
_ -> impossible
@@ -379,7 +379,8 @@
bb <- expandType b
-- traceM ("unify2 " ++ showExpr aa ++ " = " ++ showExpr bb)unifyR loc aa bb
-
+
+-- XXX should do occur check
unifyR :: --XHasCallStack =>
SLoc -> EType -> EType -> T ()
unifyR loc a b = T.do
@@ -387,7 +388,7 @@
-- tenv <- gets typeTable
-- senv <- gets synTable
let
- bad = error $ showSLoc loc ++ ": "
+ bad = errorMessage loc $ ": "
++ "Cannot unify " ++ showExpr a ++ " and " ++ showExpr b ++ "\n"
-- ++ show a ++ " - " ++ show b ++ "\n"
-- ++ show tenv ++ "\n"
@@ -437,7 +438,7 @@
tLookup msg i = T.do
env <- gets valueTable
case M.lookup i env of
- Nothing -> error $ showSLoc (getSLocIdent i) ++ ": undefined " ++ msg ++ ": " ++ showIdent i
+ Nothing -> errorMessage (getSLocIdent i) $ ": undefined " ++ msg ++ ": " ++ showIdent i
-- ++ "\n" ++ show env ;
Just aes ->
case aes of
@@ -448,7 +449,7 @@
if null es then
T.return (e, s)
else
- error "ambiguous"
+ errorMessage (getSLocIdent i) $ ": ambiguous " ++ showIdent i
tInst :: ETypeScheme -> T EType
tInst as =
@@ -694,7 +695,7 @@
let
mn = moduleOf qi
T.return (EDo (Just mn) [SThen ea], ta)
- _ -> error $ "bad do "
+ _ -> errorMessage (getSLocExpr ae) $ "bad do "
--X++ show as
else
case as of
@@ -843,13 +844,13 @@
env <- T.mapM (\ v -> (pair v . ETypeScheme []) <$> newUVar) $ filter (not . isUnderscore) $ patVars ap
withExtVals env $ T.do
(pp, _) <- tcExpr (Just t) ap
- () <- checkArity 0 pp
+ () <- checkArity (getSLocExpr ap) 0 pp
ta pp
-checkArity :: Int -> EPat -> T ()
-checkArity n (EApp f _) = checkArity (n+1) f
-checkArity n (ECon c) = if n == conArity c then T.return () else error "con arity"
-checkArity _ _ = T.return ()
+checkArity :: SLoc -> Int -> EPat -> T ()
+checkArity loc n (EApp f _) = checkArity loc (n+1) f
+checkArity loc n (ECon c) = if n == conArity c then T.return () else errorMessage loc ": con arity"
+checkArity _ _ _ = T.return ()
-- XXX No mutual recursion yet
tcBinds :: forall a . [EBind] -> ([EBind] -> T a) -> T a
--
⑨