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
| 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")