X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FstgSyn%2FStgLint.lhs;h=326cd44578e7c25004b3a4cf35b1996677b196c6;hb=ca49225cd41123ab6ce229040a93cc4b993b190a;hp=f634185c0c68eaaaf1bec00e2771a94732b679e1;hpb=3f5e4368fd4e87e116ce34be4cf9dd0f9f96726d;p=ghc-hetmet.git

diff --git a/ghc/compiler/stgSyn/StgLint.lhs b/ghc/compiler/stgSyn/StgLint.lhs
index f634185..326cd44 100644
--- a/ghc/compiler/stgSyn/StgLint.lhs
+++ b/ghc/compiler/stgSyn/StgLint.lhs
@@ -13,21 +13,22 @@ import StgSyn
 import Bag		( Bag, emptyBag, isEmptyBag, snocBag, bagToList )
 import Id		( Id, idType, isLocalId )
 import VarSet
-import DataCon		( DataCon, dataConArgTys, dataConRepType )
+import DataCon		( DataCon, dataConInstArgTys, dataConRepType )
 import CoreSyn		( AltCon(..) )
 import PrimOp		( primOpType )
 import Literal		( literalType )
 import Maybes		( catMaybes )
 import Name		( getSrcLoc )
-import ErrUtils		( Message, addErrLocHdrLine )
+import ErrUtils		( Message, mkLocMessage )
 import Type		( mkFunTys, splitFunTys, splitTyConApp_maybe,
 			  isUnLiftedType, isTyVarTy, dropForAlls, Type
 			)
-import TyCon		( TyCon, isAlgTyCon, isNewTyCon, tyConDataCons )
+import TyCon		( isAlgTyCon, isNewTyCon, tyConDataCons )
 import Util		( zipEqual, equalLength )
+import SrcLoc		( srcLocSpan )
 import Outputable
 
-infixr 9 `thenL`, `thenL_`, `thenMaybeL`, `thenMaybeL_`
+infixr 9 `thenL`, `thenL_`, `thenMaybeL`
 \end{code}
 
 Checks for
@@ -58,7 +59,7 @@ generation.  Solution: don't use it!  (KSW 2000-05).
 lintStgBindings :: String -> [StgBinding] -> [StgBinding]
 
 lintStgBindings whodunnit binds
-  = _scc_ "StgLint"
+  = {-# SCC "StgLint" #-}
     case (initL (lint_binds binds)) of
       Nothing  -> binds
       Just msg -> pprPanic "" (vcat [
@@ -216,6 +217,7 @@ lintStgExpr e@(StgCase scrut _ _ bndr _ alts_type alts)
     (case scrut of
 	StgApp _ _    -> returnL ()
 	StgConApp _ _ -> returnL ()
+	StgOpApp _ _ _ -> returnL ()
 	other -> addErrL (mkCaseOfCaseMsg e))   `thenL_`
 
     addInScopeVars [bndr] (lintStgAlts alts scrut_ty)
@@ -257,7 +259,7 @@ lintAlt scrut_ty (DataAlt con, args, _, rhs)
 				  not (isNewTyCon tycon) ->
 	 let
 	   cons    = tyConDataCons tycon
-	   arg_tys = dataConArgTys con tys_applied
+	   arg_tys = dataConInstArgTys con tys_applied
 		-- This almost certainly does not work for existential constructors
 	 in
 	 checkL (con `elem` cons) (mkAlgAltMsg2 scrut_ty con) `thenL_`
@@ -300,12 +302,12 @@ data LintLocInfo
   | BodyOfLetRec [Id]	-- One of the binders
 
 dumpLoc (RhsOf v) =
-  (getSrcLoc v, ptext SLIT(" [RHS of ") <> pp_binders [v] <> char ']' )
+  (srcLocSpan (getSrcLoc v), ptext SLIT(" [RHS of ") <> pp_binders [v] <> char ']' )
 dumpLoc (LambdaBodyOf bs) =
-  (getSrcLoc (head bs), ptext SLIT(" [in body of lambda with binders ") <> pp_binders bs <> char ']' )
+  (srcLocSpan (getSrcLoc (head bs)), ptext SLIT(" [in body of lambda with binders ") <> pp_binders bs <> char ']' )
 
 dumpLoc (BodyOfLetRec bs) =
-  (getSrcLoc (head bs), ptext SLIT(" [in body of letrec with binders ") <> pp_binders bs <> char ']' )
+  (srcLocSpan (getSrcLoc (head bs)), ptext SLIT(" [in body of letrec with binders ") <> pp_binders bs <> char ']' )
 
 
 pp_binders :: [Id] -> SDoc
@@ -345,12 +347,6 @@ thenMaybeL m k loc scope errs
       (Nothing, errs2) -> (Nothing, errs2)
       (Just r,  errs2) -> k r loc scope errs2
 
-thenMaybeL_ :: LintM (Maybe a) -> LintM (Maybe b) -> LintM (Maybe b)
-thenMaybeL_ m k loc scope errs
-  = case m loc scope errs of
-      (Nothing, errs2) -> (Nothing, errs2)
-      (Just _,  errs2) -> k loc scope errs2
-
 mapL :: (a -> LintM b) -> [a] -> LintM [b]
 mapL f [] = returnL []
 mapL f (x:xs)
@@ -381,7 +377,7 @@ addErr errs_so_far msg locs
   = errs_so_far `snocBag` mk_msg locs
   where
     mk_msg (loc:_) = let (l,hdr) = dumpLoc loc 
-		     in addErrLocHdrLine l hdr msg
+		     in  mkLocMessage l (hdr $$ msg)
     mk_msg []      = msg
 
 addLoc :: LintLocInfo -> LintM a -> LintM a
@@ -461,11 +457,6 @@ mkCaseAltMsg alts
   = ($$) (text "In some case alternatives, type of alternatives not all same:")
 	    (empty) -- LATER: ppr alts
 
-mkCaseAbstractMsg :: TyCon -> Message
-mkCaseAbstractMsg tycon
-  = ($$) (ptext SLIT("An algebraic case on an abstract type:"))
-	    (ppr tycon)
-
 mkDefltMsg :: Id -> Message
 mkDefltMsg bndr
   = ($$) (ptext SLIT("Binder of a case expression doesn't match type of scrutinee:"))
@@ -484,12 +475,6 @@ mkRhsConMsg fun_ty arg_tys
 	      hang (ptext SLIT("Constructor type:")) 4 (ppr fun_ty),
 	      hang (ptext SLIT("Arg types:")) 4 (vcat (map (ppr) arg_tys))]
 
-mkUnappTyMsg :: Id -> Type -> Message
-mkUnappTyMsg var ty
-  = vcat [text "Variable has a for-all type, but isn't applied to any types.",
-	      (<>) (ptext SLIT("Var:      ")) (ppr var),
-	      (<>) (ptext SLIT("Its type: ")) (ppr ty)]
-
 mkAltMsg1 :: Type -> Message
 mkAltMsg1 ty
   = ($$) (text "In a case expression, type of scrutinee does not match patterns")