X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FstgSyn%2FStgLint.lhs;h=29f683f2d44977ef72808ce2d56ec11afa0f4e52;hp=f2cecf9b0110f073e43cdb189d321194dc87be8b;hb=c5b178be60a5a44abd2f4ddf8c399857678326e2;hpb=9d0c8f842e35dde3d570580cf62a32779f66a6de

diff --git a/compiler/stgSyn/StgLint.lhs b/compiler/stgSyn/StgLint.lhs
index f2cecf9..29f683f 100644
--- a/compiler/stgSyn/StgLint.lhs
+++ b/compiler/stgSyn/StgLint.lhs
@@ -19,8 +19,8 @@ import Maybes
 import Name             ( getSrcLoc )
 import ErrUtils         ( Message, mkLocMessage )
 import TypeRep
-import Type             ( mkFunTys, splitFunTys, splitTyConApp_maybe,
-                          isUnLiftedType, isTyVarTy, dropForAlls, Type
+import Type             ( mkFunTys, splitFunTy_maybe, splitTyConApp_maybe,
+                          isUnLiftedType, isTyVarTy, dropForAlls
                         )
 import TyCon            ( isAlgTyCon, isNewTyCon, tyConDataCons )
 import Util             ( zipEqual, equalLength )
@@ -200,7 +200,7 @@ lintStgExpr e@(StgCase scrut _ _ bndr _ alts_type alts) = runMaybeT $ do
         UbxTupAlt tc -> check_bndr tc
         PolyAlt      -> return ()
 
-    MaybeT $ trace (showSDoc (ppr e)) $ do
+    MaybeT $ do
         -- we only allow case of tail-call or primop.
      case scrut of
         StgApp _ _     -> return ()
@@ -316,7 +316,7 @@ initL (LintM m)
     if isEmptyBag errs then
         Nothing
     else
-        Just (vcat (punctuate (text "") (bagToList errs)))
+        Just (vcat (punctuate blankLine (bagToList errs)))
     }
 
 instance Monad LintM where
@@ -387,26 +387,21 @@ checkFunApp :: Type                 -- The function type
 checkFunApp fun_ty arg_tys msg = LintM checkFunApp'
  where
   checkFunApp' loc _scope errs
-   = cfa res_ty expected_arg_tys arg_tys
+   = cfa fun_ty arg_tys
    where
-    (expected_arg_tys, res_ty) = splitFunTys (dropForAlls fun_ty)
+    cfa fun_ty []      -- Args have run out; that's fine
+      = (Just fun_ty, errs)
 
-    cfa res_ty expected []      -- Args have run out; that's fine
-      = (Just (mkFunTys expected res_ty), errs)
+    cfa fun_ty (_:arg_tys)   
+      | Just (_arg_ty, res_ty) <- splitFunTy_maybe (dropForAlls fun_ty)
+      = cfa res_ty arg_tys
 
-    cfa res_ty [] arg_tys       -- Expected arg tys ran out first;
-                                -- first see if res_ty is a tyvar template;
-                                -- otherwise, maybe res_ty is a
-                                -- dictionary type which is actually a function?
-      | isTyVarTy res_ty
-      = (Just res_ty, errs)
+      | isTyVarTy fun_ty      -- Expected arg tys ran out first;
+      = (Just fun_ty, errs)   -- first see if fun_ty is a tyvar template;
+                              -- otherwise, maybe fun_ty is a
+                              -- dictionary type which is actually a function?
       | otherwise
-      = case splitFunTys res_ty of
-          ([], _)                 -> (Nothing, addErr errs msg loc)     -- Too many args
-          (new_expected, new_res) -> cfa new_res new_expected arg_tys
-
-    cfa res_ty (_:expected_arg_tys) (_:arg_tys)
-      = cfa res_ty expected_arg_tys arg_tys
+      = (Nothing, addErr errs msg loc)     -- Too many args
 \end{code}
 
 \begin{code}