[improve unification error messages
John Meacham <john@repetae.net>**20051210055312] hunk ./FrontEnd/Tc/Monad.hs 17
-    unify,
hunk ./FrontEnd/Tc/Monad.hs 21
-    unifyList,
+    unificationError,
hunk ./FrontEnd/Tc/Monad.hs 143
-unify      :: Tau -> Tau -> Tc ()
-unify t1 t2 = do
-    t1' <- findType t1
-    t2' <- findType t2
-    b <- mgu t1' t2'
-    case b of
-        Nothing -> return ()
-        Just err -> do
-                  diagnosis <- getErrorContext
-                  typeError (Unification $ "attempted to unify " ++
-                                           pretty t1' ++
-                                           " with " ++
-                                           pretty t2' ++ "\n" ++ err)
-                            diagnosis
-
-unifyList :: [Type] -> Tc ()
-unifyList (t1:t2:ts) = unify t1 t2 >> unifyList (t2:ts)
-unifyList _ = return ()
-
hunk ./FrontEnd/Tc/Monad.hs 151
+
+
+
+throwError s t1 t2 = do
+    diagnosis <- getErrorContext
+    typeError (Unification $ "attempted to unify " ++ prettyPrintType t1 ++ " with " ++ prettyPrintType t2) diagnosis
hunk ./FrontEnd/Tc/Monad.hs 158
-mgu     :: (MonadIO m) => Type -> Type -> m (Maybe String)
hunk ./FrontEnd/Tc/Monad.hs 159
-mgu x y = do
-    r <- runErrorT (mgu'' x y)
-    case r of
-        Right _ -> return Nothing
-        Left (err::String) -> return (Just err)
-mgu'' x y = do
-    x' <- findType x
-    y' <- findType y
-    mgu' x' y'
-mgu' (TAp l r) (TAp l' r')
-   = do s1 <- mgu'' l l'
-        s2 <- mgu'' r r'
-        return ()
-mgu' (TArrow l r) (TArrow l' r')
-   = do s1 <- mgu'' l l'
-        s2 <- mgu'' r r'
-        return ()
-mgu' (TVar u) t | isMetaTV u  = varBind u t
-mgu' t (TVar u) | isMetaTV u  = varBind u t
-mgu' (TVar a) (TVar b) | a == b = return ()
-mgu' c1@(TCon tc1) c2@(TCon tc2)
-           | tc1==tc2 = return ()
-           | otherwise = fail $ "mgu: Constructors don't match:" ++ show (c1,c2)
-mgu' TForAll {} _ = error "attempt to unify TForall"
-mgu' _ TForAll {} = error "attempt to unify TForall"
-mgu' _ TBox {} = error "attempt to unify TBox"
-mgu' TBox {} _ = error "attempt to unify TBox"
-mgu' t1 t2  = fail $ "mgu: types do not unify:" ++ show (t1,t2)
+unificationError t1 t2 = do
+    diagnosis <- getErrorContext
+    typeError (Unification $ "attempted to unify " ++ prettyPrintType t1 ++ " with " ++ prettyPrintType t2) diagnosis
hunk ./FrontEnd/Tc/Monad.hs 163
-{-
-
-unify      :: Type -> Type -> TI ()
-unify t1 t2 = do
-    t1' <- findType t1
-    t2' <- findType t2
-    b <- mgu t1' t2'
-    case b of
-        Just u -> return () -- extSubst u
-        Nothing -> do
-                  diagnosis <- getErrorContext
-                  typeError (Unification $ "attempted to unify " ++
-                                           pretty t1' ++
-                                           " with " ++
-                                           pretty t2')
-                            diagnosis
-
-unifyList :: [Type] -> TI ()
-unifyList [] = return ()
-unifyList [_] = return ()
-unifyList (t1:t2:ts) = do
-       unify t1 t2
-       unifyList (t2:ts)
-
--}
-
hunk ./FrontEnd/Tc/Monad.hs 288
-varBind :: (MonadIO m) => Tyvar -> Type -> m ()
+varBind :: Tyvar -> Type -> Tc ()
hunk ./FrontEnd/Tc/Monad.hs 291
-            | u `elem` freeMetaVars t = fail "varBind: occurs check fails"
+            | u `elem` freeMetaVars t = unificationError (TVar u) t -- occurs check
hunk ./FrontEnd/Tc/Monad.hs 295
-                    Just r -> fail $ "varBind: bining unfree: " ++ show (u,t,r)
+                    Just r -> error $ "varBind: bining unfree: " ++ show (u,t,r)
hunk ./FrontEnd/Tc/Unify.hs 35
+    sub t (TArrow a b) | Just t <- extractMetaTV t = do
+        a' <- newTVar (kind a)
+        b' <- newTVar (kind b)
+        varBind t (TArrow a' b')
+        (TArrow a' b') `subsumes` (TArrow a b)
+    sub t (TAp a b) | Just t <- extractMetaTV t = do
+        a' <- newTVar (kind a)
+        b' <- newTVar (kind b)
+        varBind t (TAp a' b')
+        (TAp a' b') `subsumes` (TAp a b)
hunk ./FrontEnd/Tc/Unify.hs 139
-        False -> fail $ "constructor mismatch: " ++ show (a,b)
+        -- False -> fail $ "constructor mismatch: " ++ show (a,b)
+        False -> unificationError a b
hunk ./FrontEnd/Tc/Unify.hs 142
-        _ ->   fail $ "constructor args mismatch: " ++ show (a,b)
+        -- _ ->   fail $ "constructor args mismatch: " ++ show (a,b)
+        _ -> unificationError a b
hunk ./FrontEnd/Tc/Unify.hs 177
+    -- XXX app
+    bm (TAp a b) (TAp c d) = do
+        a `boxyMatch` c
+        b `boxyMatch` d
+        return False
+
hunk ./FrontEnd/Tc/Unify.hs 191
+unify      :: Tau -> Tau -> Tc ()
+unify t1 t2 = do
+    t1' <- findType t1
+    t2' <- findType t2
+    mgu t1' t2'
+
+mgu (TAp l r) (TAp l' r')
+   = do s1 <- unify l l'
+        s2 <- unify r r'
+        return ()
+mgu (TArrow l r) (TArrow l' r')
+   = do s1 <- unify l l'
+        s2 <- unify r r'
+        return ()
+mgu (TVar u) t | isMetaTV u  = varBind u t
+mgu t (TVar u) | isMetaTV u  = varBind u t
+mgu (TVar a) (TVar b) | a == b = return ()
+mgu c1@(TCon tc1) c2@(TCon tc2)
+           | tc1==tc2 = return ()
+           -- | otherwise = fail $ "mgu: Constructors don't match:" ++ show (c1,c2)
+           | otherwise = unificationError c1 c2
+mgu TForAll {} _ = error "attempt to unify TForall"
+mgu _ TForAll {} = error "attempt to unify TForall"
+mgu _ TBox {} = error "attempt to unify TBox"
+mgu TBox {} _ = error "attempt to unify TBox"
+mgu t1 t2  = unificationError t1 t2
+
+unifyList :: [Type] -> Tc ()
+unifyList (t1:t2:ts) = unify t1 t2 >> unifyList (t2:ts)
+unifyList _ = return ()