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
lintStgBindings :: String -> [StgBinding] -> [StgBinding]
lintStgBindings whodunnit binds
- = _scc_ "StgLint"
+ = {-# SCC "StgLint" #-}
case (initL (lint_binds binds)) of
Nothing -> binds
Just msg -> pprPanic "" (vcat [
(case scrut of
StgApp _ _ -> returnL ()
StgConApp _ _ -> returnL ()
+ StgOpApp _ _ _ -> returnL ()
other -> addErrL (mkCaseOfCaseMsg e)) `thenL_`
addInScopeVars [bndr] (lintStgAlts alts scrut_ty)
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_`
| 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
(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)
= 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
= ($$) (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:"))
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")