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_`
= _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 ()
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))
-- 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
-> 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
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}
Nothing
else
Just ( \ sty ->
- foldBag ppAbove ( \ msg -> msg sty ) ppNil errs
+ foldBag ($$) ( \ msg -> msg sty ) empty errs
)
}
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
\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)
\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
projects / ghc-hetmet.git / blobdiff