X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FstgSyn%2FStgLint.lhs;h=70bbf41a5879af7db2ced3cd0549c28bea4c005a;hb=bd8ead09270aec70f5495f1a2b20b6d2ea1ff44f;hp=d549f56a25a1c11f1676aebef0d1a078d7e207c1;hpb=e7498a3ee1d0484d02a9e86633cc179c76ebf36e;p=ghc-hetmet.git

diff --git a/ghc/compiler/stgSyn/StgLint.lhs b/ghc/compiler/stgSyn/StgLint.lhs
index d549f56..70bbf41 100644
--- a/ghc/compiler/stgSyn/StgLint.lhs
+++ b/ghc/compiler/stgSyn/StgLint.lhs
@@ -12,24 +12,25 @@ IMP_Ubiq(){-uitous-}
 
 import StgSyn
 
-import Bag		( emptyBag, isEmptyBag, snocBag, foldBag )
-import Id		( idType, isDataCon, dataConArgTys,
+import Bag		( Bag, emptyBag, isEmptyBag, snocBag, foldBag )
+import Id		( idType, isAlgCon, dataConArgTys,
 			  emptyIdSet, isEmptyIdSet, elementOfIdSet,
-			  mkIdSet, intersectIdSets,
-			  unionIdSets, idSetToList, IdSet(..),
-			  GenId{-instanced NamedThing-}
+			  mkIdSet, intersectIdSets, 
+			  unionIdSets, idSetToList, SYN_IE(IdSet),
+			  GenId{-instanced NamedThing-}, SYN_IE(Id)
 			)
 import Literal		( literalType, Literal{-instance Outputable-} )
 import Maybes		( catMaybes )
 import Name		( isLocallyDefined, getSrcLoc )
-import Outputable	( Outputable(..){-instance * []-} )
+import Outputable	( PprStyle, Outputable(..){-instance * []-} )
 import PprType		( GenType{-instance Outputable-}, TyCon )
 import Pretty		-- quite a bit of it
 import PrimOp		( primOpType )
 import SrcLoc		( SrcLoc{-instance Outputable-} )
 import Type		( mkFunTys, splitFunTy, maybeAppDataTyConExpandingDicts,
-			  isTyVarTy, eqTy, splitFunTyExpandingDicts
+			  isTyVarTy, eqTy, splitFunTyExpandingDicts, SYN_IE(Type)
 			)
+import TyCon		( isDataTyCon )
 import Util		( zipEqual, pprPanic, panic, panic# )
 
 infixr 9 `thenL`, `thenL_`, `thenMaybeL`, `thenMaybeL_`
@@ -56,12 +57,12 @@ lintStgBindings sty whodunnit binds
   = _scc_ "StgLint"
     case (initL (lint_binds binds)) of
       Nothing  -> binds
-      Just msg -> pprPanic "" (ppAboves [
-			ppStr ("*** Stg Lint Errors: in "++whodunnit++" ***"),
+      Just msg -> pprPanic "" (vcat [
+			ptext SLIT("*** Stg Lint Errors: in "),text whodunnit, ptext SLIT(" ***"),
 			msg sty,
-			ppStr "*** Offending Program ***",
-			ppAboves (map (pprPlainStgBinding sty) binds),
-			ppStr "*** End of Offense ***"])
+			ptext SLIT("*** Offending Program ***"),
+			pprStgBindings sty binds,
+			ptext SLIT("*** End of Offense ***")])
   where
     lint_binds :: [StgBinding] -> LintM ()
 
@@ -78,6 +79,7 @@ lintStgBindings sty whodunnit binds
 lintStgArg :: StgArg -> LintM (Maybe Type)
 
 lintStgArg (StgLitArg lit)       = returnL (Just (literalType lit))
+lintStgArg (StgConArg con)       = returnL (Just (idType con))
 lintStgArg a@(StgVarArg v)
   = checkInScope v	`thenL_`
     returnL (Just (idType v))
@@ -180,10 +182,10 @@ lintStgExpr e@(StgCase scrut _ _ _ alts)
 
 	-- Check that it is a data type
     case (maybeAppDataTyConExpandingDicts scrut_ty) of
-      Nothing -> addErrL (mkCaseDataConMsg e)	`thenL_`
-		 returnL Nothing
-      Just (tycon, _, _)
+      Just (tycon, _, _) | isDataTyCon tycon
 	      -> lintStgAlts alts scrut_ty tycon
+      other   -> addErrL (mkCaseDataConMsg e)	`thenL_`
+		 returnL Nothing
   where
     scrut_ty = get_ty alts
 
@@ -269,7 +271,7 @@ type LintM a = [LintLocInfo] 	-- Locations
 	    -> Bag ErrMsg	-- Error messages so far
 	    -> (a, Bag ErrMsg)	-- Result and error messages (if any)
 
-type ErrMsg = PprStyle -> Pretty
+type ErrMsg = PprStyle -> Doc
 
 data LintLocInfo
   = RhsOf Id		-- The variable bound
@@ -278,22 +280,22 @@ data LintLocInfo
 
 instance Outputable LintLocInfo where
     ppr sty (RhsOf v)
-      = ppBesides [ppr sty (getSrcLoc v), ppStr ": [RHS of ", pp_binders sty [v], ppStr "]"]
+      = hcat [ppr sty (getSrcLoc v), ptext SLIT(": [RHS of "), pp_binders sty [v], char ']']
 
     ppr sty (LambdaBodyOf bs)
-      = ppBesides [ppr sty (getSrcLoc (head bs)),
-		ppStr ": [in body of lambda with binders ", pp_binders sty bs, ppStr "]"]
+      = hcat [ppr sty (getSrcLoc (head bs)),
+		ptext SLIT(": [in body of lambda with binders "), pp_binders sty bs, char ']']
 
     ppr sty (BodyOfLetRec bs)
-      = ppBesides [ppr sty (getSrcLoc (head bs)),
-		ppStr ": [in body of letrec with binders ", pp_binders sty bs, ppStr "]"]
+      = hcat [ppr sty (getSrcLoc (head bs)),
+		ptext SLIT(": [in body of letrec with binders "), pp_binders sty bs, char ']']
 
-pp_binders :: PprStyle -> [Id] -> Pretty
+pp_binders :: PprStyle -> [Id] -> Doc
 pp_binders sty bs
-  = ppInterleave ppComma (map pp_binder bs)
+  = sep (punctuate comma (map pp_binder bs))
   where
     pp_binder b
-      = ppCat [ppr sty b, ppStr "::", ppr sty (idType b)]
+      = hsep [ppr sty b, ptext SLIT("::"), ppr sty (idType b)]
 \end{code}
 
 \begin{code}
@@ -304,7 +306,7 @@ initL m
 	Nothing
     else
 	Just ( \ sty ->
-	  foldBag ppAbove ( \ msg -> msg sty ) ppNil errs
+	  foldBag ($$) ( \ msg -> msg sty ) empty errs
 	)
     }
 
@@ -361,7 +363,7 @@ addErr :: Bag ErrMsg -> ErrMsg -> [LintLocInfo] -> Bag ErrMsg
 
 addErr errs_so_far msg locs
   = errs_so_far `snocBag` ( \ sty ->
-    ppHang (ppr sty (head locs)) 4 (msg sty)
+    hang (ppr sty (head locs)) 4 (msg sty)
     )
 
 addLoc :: LintLocInfo -> LintM a -> LintM a
@@ -421,8 +423,8 @@ checkFunApp fun_ty arg_tys msg loc scope errs
 \begin{code}
 checkInScope :: Id -> LintM ()
 checkInScope id loc scope errs
-  = if isLocallyDefined id && not (isDataCon id) && not (id `elementOfIdSet` scope) then
-	((), addErr errs (\ sty -> ppCat [ppr sty id, ppStr "is out of scope"]) loc)
+  = if isLocallyDefined id && not (isAlgCon id) && not (id `elementOfIdSet` scope) then
+	((), addErr errs (\ sty -> hsep [ppr sty id, ptext SLIT("is out of scope")]) loc)
     else
 	((), errs)
 
@@ -436,93 +438,93 @@ checkTys ty1 ty2 msg loc scope errs
 \begin{code}
 mkCaseAltMsg :: StgCaseAlts -> ErrMsg
 mkCaseAltMsg alts sty
-  = ppAbove (ppStr "In some case alternatives, type of alternatives not all same:")
+  = ($$) (text "In some case alternatives, type of alternatives not all same:")
 	    -- LATER: (ppr sty alts)
 	    (panic "mkCaseAltMsg")
 
 mkCaseDataConMsg :: StgExpr -> ErrMsg
 mkCaseDataConMsg expr sty
-  = ppAbove (ppStr "A case scrutinee not a type-constructor type:")
+  = ($$) (ptext SLIT("A case scrutinee not a type-constructor type:"))
 	    (pp_expr sty expr)
 
 mkCaseAbstractMsg :: TyCon -> ErrMsg
 mkCaseAbstractMsg tycon sty
-  = ppAbove (ppStr "An algebraic case on an abstract type:")
+  = ($$) (ptext SLIT("An algebraic case on an abstract type:"))
 	    (ppr sty tycon)
 
 mkDefltMsg :: StgCaseDefault -> ErrMsg
 mkDefltMsg deflt sty
-  = ppAbove (ppStr "Binder in default case of a case expression doesn't match type of scrutinee:")
+  = ($$) (ptext SLIT("Binder in default case of a case expression doesn't match type of scrutinee:"))
 	    --LATER: (ppr sty deflt)
 	    (panic "mkDefltMsg")
 
 mkFunAppMsg :: Type -> [Type] -> StgExpr -> ErrMsg
 mkFunAppMsg fun_ty arg_tys expr sty
-  = ppAboves [ppStr "In a function application, function type doesn't match arg types:",
-	      ppHang (ppStr "Function type:") 4 (ppr sty fun_ty),
-	      ppHang (ppStr "Arg types:") 4 (ppAboves (map (ppr sty) arg_tys)),
-	      ppHang (ppStr "Expression:") 4 (pp_expr sty expr)]
+  = vcat [text "In a function application, function type doesn't match arg types:",
+	      hang (ptext SLIT("Function type:")) 4 (ppr sty fun_ty),
+	      hang (ptext SLIT("Arg types:")) 4 (vcat (map (ppr sty) arg_tys)),
+	      hang (ptext SLIT("Expression:")) 4 (pp_expr sty expr)]
 
 mkRhsConMsg :: Type -> [Type] -> ErrMsg
 mkRhsConMsg fun_ty arg_tys sty
-  = ppAboves [ppStr "In a RHS constructor application, con type doesn't match arg types:",
-	      ppHang (ppStr "Constructor type:") 4 (ppr sty fun_ty),
-	      ppHang (ppStr "Arg types:") 4 (ppAboves (map (ppr sty) arg_tys))]
+  = vcat [text "In a RHS constructor application, con type doesn't match arg types:",
+	      hang (ptext SLIT("Constructor type:")) 4 (ppr sty fun_ty),
+	      hang (ptext SLIT("Arg types:")) 4 (vcat (map (ppr sty) arg_tys))]
 
 mkUnappTyMsg :: Id -> Type -> ErrMsg
 mkUnappTyMsg var ty sty
-  = ppAboves [ppStr "Variable has a for-all type, but isn't applied to any types.",
-	      ppBeside (ppStr "Var:      ") (ppr sty var),
-	      ppBeside (ppStr "Its type: ") (ppr sty ty)]
+  = vcat [text "Variable has a for-all type, but isn't applied to any types.",
+	      (<>) (ptext SLIT("Var:      ")) (ppr sty var),
+	      (<>) (ptext SLIT("Its type: ")) (ppr sty ty)]
 
 mkAlgAltMsg1 :: Type -> ErrMsg
 mkAlgAltMsg1 ty sty
-  = ppAbove (ppStr "In some case statement, type of scrutinee is not a data type:")
+  = ($$) (text "In some case statement, type of scrutinee is not a data type:")
 	    (ppr sty ty)
 
 mkAlgAltMsg2 :: Type -> Id -> ErrMsg
 mkAlgAltMsg2 ty con sty
-  = ppAboves [
-	ppStr "In some algebraic case alternative, constructor is not a constructor of scrutinee type:",
+  = vcat [
+	text "In some algebraic case alternative, constructor is not a constructor of scrutinee type:",
 	ppr sty ty,
 	ppr sty con
     ]
 
 mkAlgAltMsg3 :: Id -> [Id] -> ErrMsg
 mkAlgAltMsg3 con alts sty
-  = ppAboves [
-	ppStr "In some algebraic case alternative, number of arguments doesn't match constructor:",
+  = vcat [
+	text "In some algebraic case alternative, number of arguments doesn't match constructor:",
 	ppr sty con,
 	ppr sty alts
     ]
 
 mkAlgAltMsg4 :: Type -> Id -> ErrMsg
 mkAlgAltMsg4 ty arg sty
-  = ppAboves [
-	ppStr "In some algebraic case alternative, type of argument doesn't match data constructor:",
+  = vcat [
+	text "In some algebraic case alternative, type of argument doesn't match data constructor:",
 	ppr sty ty,
 	ppr sty arg
     ]
 
 mkPrimAltMsg :: (Literal, StgExpr) -> ErrMsg
 mkPrimAltMsg alt sty
-  = ppAbove (ppStr "In a primitive case alternative, type of literal doesn't match type of scrutinee:")
+  = ($$) (text "In a primitive case alternative, type of literal doesn't match type of scrutinee:")
 	    (ppr sty alt)
 
 mkRhsMsg :: Id -> Type -> ErrMsg
 mkRhsMsg binder ty sty
-  = ppAboves [ppCat [ppStr "The type of this binder doesn't match the type of its RHS:",
+  = vcat [hsep [ptext SLIT("The type of this binder doesn't match the type of its RHS:"),
 		     ppr sty binder],
-	      ppCat [ppStr "Binder's type:", ppr sty (idType binder)],
-	      ppCat [ppStr "Rhs type:", ppr sty ty]
+	      hsep [ptext SLIT("Binder's type:"), ppr sty (idType binder)],
+	      hsep [ptext SLIT("Rhs type:"), ppr sty ty]
 	     ]
 
-pp_expr :: PprStyle -> StgExpr -> Pretty
+pp_expr :: PprStyle -> StgExpr -> Doc
 pp_expr sty expr = ppr sty expr
 
 sleazy_eq_ty ty1 ty2
 	-- NB: probably severe overkill (WDP 95/04)
-  = _trace "StgLint.sleazy_eq_ty:use eqSimplTy?" $
+  = trace "StgLint.sleazy_eq_ty:use eqSimplTy?" $
     case (splitFunTyExpandingDicts ty1) of { (tyargs1,tyres1) ->
     case (splitFunTyExpandingDicts ty2) of { (tyargs2,tyres2) ->
     let