module CoreLint (
lintCoreBindings,
lintUnfolding,
- beginPass, endPass
+ showPass, endPass
) where
#include "HsVersions.h"
-import IO ( hPutStr, stderr )
-
-import CmdLineOpts ( opt_D_show_passes, opt_DoCoreLinting )
import CoreSyn
-import CoreUtils ( idFreeVars )
+import CoreFVs ( idFreeVars )
+import CoreUtils ( findDefault, exprOkForSpeculation, coreBindsSize, mkPiType )
import Bag
-import Const ( Con(..), DataCon, conType, conOkForApp, conOkForAlt )
-import Id ( isConstantId, idMustBeINLINEd )
-import Var ( IdOrTyVar, Id, TyVar, idType, tyVarKind, isTyVar )
+import Literal ( literalType )
+import DataCon ( dataConRepType )
+import Var ( Var, Id, TyVar, idType, tyVarKind, isTyVar, isId, mustHaveLocalBinding )
import VarSet
-import VarEnv ( mkVarEnv )
-import Name ( isLocallyDefined, getSrcLoc )
+import Subst ( substTyWith )
+import Name ( getSrcLoc )
import PprCore
-import ErrUtils ( doIfSet, dumpIfSet, ghcExit )
-import PrimRep ( PrimRep(..) )
-import SrcLoc ( SrcLoc )
-import Type ( Type, Kind, tyVarsOfType,
- splitFunTy_maybe, mkPiType, mkTyVarTy,
- splitForAllTy_maybe, splitTyConApp_maybe,
- isUnLiftedType, typeKind, substTy,
- splitAlgTyConApp_maybe,
+import ErrUtils ( dumpIfSet_core, ghcExit, Message, showPass,
+ addErrLocHdrLine )
+import SrcLoc ( SrcLoc, noSrcLoc )
+import Type ( Type, tyVarsOfType, eqType,
+ splitFunTy_maybe, mkTyVarTy,
+ splitForAllTy_maybe, splitTyConApp_maybe, splitTyConApp,
+ isUnLiftedType, typeKind,
isUnboxedTupleType,
hasMoreBoxityInfo
)
-import TyCon ( TyCon, isPrimTyCon, tyConDataCons )
-import ErrUtils ( ErrMsg )
+import TyCon ( isPrimTyCon )
+import BasicTypes ( RecFlag(..), isNonRec )
+import CmdLineOpts
import Outputable
-infixr 9 `thenL`, `seqL`, `thenMaybeL`
+#ifdef DEBUG
+import Util ( notNull )
+#endif
+
+import Maybe
+import IO ( hPutStrLn, stderr )
+
+infixr 9 `thenL`, `seqL`
\end{code}
%************************************************************************
%* *
-\subsection{Start and end pass}
+\subsection{End pass}
%* *
%************************************************************************
-@beginPass@ and @endPass@ don't really belong here, but it makes a convenient
+@showPass@ and @endPass@ don't really belong here, but it makes a convenient
place for them. They print out stuff before and after core passes,
and do Core Lint when necessary.
\begin{code}
-beginPass :: String -> IO ()
-beginPass pass_name
- | opt_D_show_passes
- = hPutStr stderr ("*** " ++ pass_name ++ "\n")
- | otherwise
- = return ()
-
-
-endPass :: String -> Bool -> [CoreBind] -> IO [CoreBind]
-endPass pass_name dump_flag binds
+endPass :: DynFlags -> String -> DynFlag -> [CoreBind] -> IO [CoreBind]
+endPass dflags pass_name dump_flag binds
= do
+ -- Report result size if required
+ -- This has the side effect of forcing the intermediate to be evaluated
+ if verbosity dflags >= 2 then
+ hPutStrLn stderr (" Result size = " ++ show (coreBindsSize binds))
+ else
+ return ()
+
-- Report verbosely, if required
- dumpIfSet dump_flag pass_name
- (pprCoreBindings binds)
+ dumpIfSet_core dflags dump_flag pass_name (pprCoreBindings binds)
-- Type check
- lintCoreBindings pass_name binds
+ lintCoreBindings dflags pass_name binds
return binds
\end{code}
-- may well be happening...);
\begin{code}
-lintCoreBindings :: String -> [CoreBind] -> IO ()
+lintCoreBindings :: DynFlags -> String -> [CoreBind] -> IO ()
-lintCoreBindings whoDunnit binds
- | not opt_DoCoreLinting
+lintCoreBindings dflags whoDunnit binds
+ | not (dopt Opt_DoCoreLinting dflags)
= return ()
-lintCoreBindings whoDunnit binds
+lintCoreBindings dflags whoDunnit binds
= case (initL (lint_binds binds)) of
- Nothing -> doIfSet opt_D_show_passes
- (hPutStr stderr ("*** Core Linted result of " ++ whoDunnit ++ "\n"))
-
+ Nothing -> showPass dflags ("Core Linted result of " ++ whoDunnit)
Just bad_news -> printDump (display bad_news) >>
ghcExit 1
where
- lint_binds [] = returnL ()
- lint_binds (bind:binds)
- = lintCoreBinding bind `thenL` \binders ->
- addInScopeVars binders (lint_binds binds)
+ -- Put all the top-level binders in scope at the start
+ -- This is because transformation rules can bring something
+ -- into use 'unexpectedly'
+ lint_binds binds = addInScopeVars (bindersOfBinds binds) $
+ mapL lint_bind binds
+
+ lint_bind (Rec prs) = mapL (lintSingleBinding Recursive) prs `seqL`
+ returnL ()
+ lint_bind (NonRec bndr rhs) = lintSingleBinding NonRecursive (bndr,rhs)
display bad_news
- = vcat [
- text ("*** Core Lint Errors: in result of " ++ whoDunnit ++ " ***"),
+ = vcat [ text ("*** Core Lint Errors: in result of " ++ whoDunnit ++ " ***"),
bad_news,
ptext SLIT("*** Offending Program ***"),
pprCoreBindings binds,
(it is very painful to catch errors otherwise):
\begin{code}
-lintUnfolding :: SrcLoc -> CoreExpr -> Maybe CoreExpr
-
-lintUnfolding locn expr
- = case
- initL (addLoc (ImportedUnfolding locn) (lintCoreExpr expr))
- of
- Nothing -> Just expr
- Just msg ->
- pprTrace "WARNING: Discarded bad unfolding from interface:\n"
- (vcat [msg,
- ptext SLIT("*** Bad unfolding ***"),
- ppr expr,
- ptext SLIT("*** End unfolding ***")])
- Nothing
+lintUnfolding :: SrcLoc
+ -> [Var] -- Treat these as in scope
+ -> CoreExpr
+ -> Maybe Message -- Nothing => OK
+
+lintUnfolding locn vars expr
+ = initL (addLoc (ImportedUnfolding locn) $
+ addInScopeVars vars $
+ lintCoreExpr expr)
\end{code}
%************************************************************************
Check a core binding, returning the list of variables bound.
\begin{code}
-lintCoreBinding :: CoreBind -> LintM [Id]
-
-lintCoreBinding (NonRec binder rhs)
- = lintSingleBinding (binder,rhs) `seqL` returnL [binder]
-
-lintCoreBinding (Rec pairs)
- = addInScopeVars binders (
- mapL lintSingleBinding pairs `seqL` returnL binders
- )
- where
- binders = map fst pairs
-
-lintSingleBinding (binder,rhs)
+lintSingleBinding rec_flag (binder,rhs)
= addLoc (RhsOf binder) $
-- Check the rhs
checkTys binder_ty ty (mkRhsMsg binder ty) `seqL`
-- Check (not isUnLiftedType) (also checks for bogus unboxed tuples)
- checkL (not (isUnLiftedType binder_ty))
+ checkL (not (isUnLiftedType binder_ty)
+ || (isNonRec rec_flag && exprOkForSpeculation rhs))
(mkRhsPrimMsg binder rhs) `seqL`
-- Check whether binder's specialisations contain any out-of-scope variables
\begin{code}
lintCoreExpr :: CoreExpr -> LintM Type
-lintCoreExpr (Var var)
- | isConstantId var = returnL (idType var)
- -- Micro-hack here... Class decls generate applications of their
- -- dictionary constructor, but don't generate a binding for the
- -- constructor (since it would never be used). After a single round
- -- of simplification, these dictionary constructors have been
- -- inlined (from their UnfoldInfo) to CoCons. Just between
- -- desugaring and simplfication, though, they appear as naked, unbound
- -- variables as the function in an application.
- -- The hack here simply doesn't check for out-of-scope-ness for
- -- data constructors (at least, in a function position).
- -- Ditto primitive Ids
-
- | otherwise = checkIdInScope var `seqL` returnL (idType var)
+lintCoreExpr (Var var) = checkIdInScope var `seqL` returnL (idType var)
+lintCoreExpr (Lit lit) = returnL (literalType lit)
lintCoreExpr (Note (Coerce to_ty from_ty) expr)
= lintCoreExpr expr `thenL` \ expr_ty ->
lintCoreExpr (Note other_note expr)
= lintCoreExpr expr
-lintCoreExpr (Let binds body)
- = lintCoreBinding binds `thenL` \binders ->
- if (null binders) then
- lintCoreExpr body -- Can't add a new source location
- else
- addLoc (BodyOfLetRec binders)
- (addInScopeVars binders (lintCoreExpr body))
+lintCoreExpr (Let (NonRec bndr rhs) body)
+ = lintSingleBinding NonRecursive (bndr,rhs) `seqL`
+ addLoc (BodyOfLetRec [bndr])
+ (addInScopeVars [bndr] (lintCoreExpr body))
-lintCoreExpr e@(Con con args)
- = addLoc (AnExpr e) $
- checkL (conOkForApp con) (mkConAppMsg e) `seqL`
- lintCoreArgs (conType con) args
+lintCoreExpr (Let (Rec pairs) body)
+ = addInScopeVars bndrs $
+ mapL (lintSingleBinding Recursive) pairs `seqL`
+ addLoc (BodyOfLetRec bndrs) (lintCoreExpr body)
+ where
+ bndrs = map fst pairs
lintCoreExpr e@(App fun arg)
= lintCoreExpr fun `thenL` \ ty ->
lintCoreExpr (Lam var expr)
= addLoc (LambdaBodyOf var) $
- checkL (not (isUnboxedTupleType (idType var))) (mkUnboxedTupleMsg var)
+ (if isId var then
+ checkL (not (isUnboxedTupleType (idType var))) (mkUnboxedTupleMsg var)
+ else
+ returnL ())
`seqL`
(addInScopeVars [var] $
lintCoreExpr expr `thenL` \ ty ->
+
returnL (mkPiType var ty))
lintCoreExpr e@(Case scrut var alts)
addInScopeVars [var] (
-- Check the alternatives
- checkAllCasesCovered e scrut_ty alts `seqL`
+ checkCaseAlts e scrut_ty alts `seqL`
+
mapL (lintCoreAlt scrut_ty) alts `thenL` \ (alt_ty : alt_tys) ->
mapL (check alt_ty) alt_tys `seqL`
returnL alt_ty)
where
check alt_ty1 alt_ty2 = checkTys alt_ty1 alt_ty2 (mkCaseAltMsg e)
+
+lintCoreExpr e@(Type ty)
+ = addErrL (mkStrangeTyMsg e)
\end{code}
%************************************************************************
%* *
%************************************************************************
-The boolean argument indicates whether we should flag type
-applications to primitive types as being errors.
+The basic version of these functions checks that the argument is a
+subtype of the required type, as one would expect.
\begin{code}
lintCoreArgs :: Type -> [CoreArg] -> LintM Type
+lintCoreArgs = lintCoreArgs0 checkTys
-lintCoreArgs ty [] = returnL ty
-lintCoreArgs ty (a : args)
- = lintCoreArg ty a `thenL` \ res ->
- lintCoreArgs res args
+lintCoreArg :: Type -> CoreArg -> LintM Type
+lintCoreArg = lintCoreArg0 checkTys
\end{code}
+The primitive version of these functions takes a check argument,
+allowing a different comparison.
+
\begin{code}
-lintCoreArg :: Type -> CoreArg -> LintM Type
+lintCoreArgs0 check_tys ty [] = returnL ty
+lintCoreArgs0 check_tys ty (a : args)
+ = lintCoreArg0 check_tys ty a `thenL` \ res ->
+ lintCoreArgs0 check_tys res args
-lintCoreArg ty a@(Type arg_ty)
+lintCoreArg0 check_tys ty a@(Type arg_ty)
= lintTy arg_ty `seqL`
lintTyApp ty arg_ty
-lintCoreArg fun_ty arg
+lintCoreArg0 check_tys fun_ty arg
= -- Make sure function type matches argument
lintCoreExpr arg `thenL` \ arg_ty ->
- case (splitFunTy_maybe fun_ty) of
- Just (arg,res) | (arg_ty == arg) -> returnL res
- _ -> addErrL (mkAppMsg fun_ty arg_ty)
+ let
+ err = mkAppMsg fun_ty arg_ty
+ in
+ case splitFunTy_maybe fun_ty of
+ Just (arg,res) -> check_tys arg arg_ty err `seqL`
+ returnL res
+ _ -> addErrL err
\end{code}
\begin{code}
Nothing -> addErrL (mkTyAppMsg ty arg_ty)
Just (tyvar,body) ->
+ if not (isTyVar tyvar) then addErrL (mkTyAppMsg ty arg_ty) else
let
tyvar_kind = tyVarKind tyvar
argty_kind = typeKind arg_ty
-- error :: forall a:*. String -> a
-- and then apply it to both boxed and unboxed types.
then
- returnL (substTy (mkVarEnv [(tyvar,arg_ty)]) body)
+ returnL (substTyWith [tyvar] [arg_ty] body)
else
addErrL (mkKindErrMsg tyvar arg_ty)
%************************************************************************
\begin{code}
-checkAllCasesCovered e ty [] = addErrL (mkNullAltsMsg e)
-
-checkAllCasesCovered e ty [(DEFAULT,_,_)] = nopL
-
-checkAllCasesCovered e scrut_ty alts
- = case splitTyConApp_maybe scrut_ty of {
- Nothing -> addErrL (badAltsMsg e);
- Just (tycon, tycon_arg_tys) ->
-
- if isPrimTyCon tycon then
- checkL (hasDefault alts) (nonExhaustiveAltsMsg e)
- else
-#ifdef DEBUG
- -- Algebraic cases are not necessarily exhaustive, because
- -- the simplifer correctly eliminates case that can't
- -- possibly match.
- -- This code just emits a message to say so
- let
- missing_cons = filter not_in_alts (tyConDataCons tycon)
- not_in_alts con = all (not_in_alt con) alts
- not_in_alt con (DataCon con', _, _) = con /= con'
- not_in_alt con other = True
+checkCaseAlts :: CoreExpr -> Type -> [CoreAlt] -> LintM ()
+-- a) Check that the alts are non-empty
+-- b) Check that the DEFAULT comes first, if it exists
+-- c) Check that there's a default for infinite types
+-- NB: Algebraic cases are not necessarily exhaustive, because
+-- the simplifer correctly eliminates case that can't
+-- possibly match.
+
+checkCaseAlts e ty []
+ = addErrL (mkNullAltsMsg e)
+
+checkCaseAlts e ty alts
+ = checkL (all non_deflt con_alts) (mkNonDefltMsg e) `seqL`
+ checkL (isJust maybe_deflt || not is_infinite_ty)
+ (nonExhaustiveAltsMsg e)
+ where
+ (con_alts, maybe_deflt) = findDefault alts
- case_bndr = case e of { Case _ bndr alts -> bndr }
- in
- if not (hasDefault alts || null missing_cons) then
- pprTrace "Exciting (but not a problem)! Non-exhaustive case:"
- (ppr case_bndr <+> ppr missing_cons)
- nopL
- else
-#endif
- nopL }
+ non_deflt (DEFAULT, _, _) = False
+ non_deflt alt = True
-hasDefault [] = False
-hasDefault ((DEFAULT,_,_) : alts) = True
-hasDefault (alt : alts) = hasDefault alts
+ is_infinite_ty = case splitTyConApp_maybe ty of
+ Nothing -> False
+ Just (tycon, tycon_arg_tys) -> isPrimTyCon tycon
\end{code}
\begin{code}
= checkL (null args) (mkDefaultArgsMsg args) `seqL`
lintCoreExpr rhs
-lintCoreAlt scrut_ty alt@(con, args, rhs)
- = addLoc (CaseAlt alt) (
+lintCoreAlt scrut_ty alt@(LitAlt lit, args, rhs)
+ = checkL (null args) (mkDefaultArgsMsg args) `seqL`
+ checkTys lit_ty scrut_ty
+ (mkBadPatMsg lit_ty scrut_ty) `seqL`
+ lintCoreExpr rhs
+ where
+ lit_ty = literalType lit
- checkL (conOkForAlt con) (mkConAltMsg con) `seqL`
+lintCoreAlt scrut_ty alt@(DataAlt con, args, rhs)
+ = addLoc (CaseAlt alt) (
- mapL (\arg -> checkL (not (isUnboxedTupleType (idType arg)))
+ mapL (\arg -> checkL (not (isUnboxedTupleType (idType arg)))
(mkUnboxedTupleMsg arg)) args `seqL`
addInScopeVars args (
-- Scrutinee type must be a tycon applicn; checked by caller
-- This code is remarkably compact considering what it does!
-- NB: args must be in scope here so that the lintCoreArgs line works.
- case splitTyConApp_maybe scrut_ty of { Just (tycon, tycon_arg_tys) ->
- lintTyApps (conType con) tycon_arg_tys `thenL` \ con_type ->
- lintCoreArgs con_type (map mk_arg args) `thenL` \ con_result_ty ->
+ -- NB: relies on existential type args coming *after* ordinary type args
+ case splitTyConApp scrut_ty of { (tycon, tycon_arg_tys) ->
+ lintTyApps (dataConRepType con) tycon_arg_tys `thenL` \ con_type ->
+ lintCoreArgs con_type (map mk_arg args) `thenL` \ con_result_ty ->
checkTys con_result_ty scrut_ty (mkBadPatMsg con_result_ty scrut_ty)
} `seqL`
))
where
mk_arg b | isTyVar b = Type (mkTyVarTy b)
- | otherwise = Var b
+ | isId b = Var b
+ | otherwise = pprPanic "lintCoreAlt:mk_arg " (ppr b)
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
-lintBinder :: IdOrTyVar -> LintM ()
+lintBinder :: Var -> LintM ()
lintBinder v = nopL
-- ToDo: lint its type
+-- ToDo: lint its rules
lintTy :: Type -> LintM ()
lintTy ty = mapL checkIdInScope (varSetElems (tyVarsOfType ty)) `seqL`
\begin{code}
type LintM a = [LintLocInfo] -- Locations
-> IdSet -- Local vars in scope
- -> Bag ErrMsg -- Error messages so far
- -> (Maybe a, Bag ErrMsg) -- Result and error messages (if any)
+ -> Bag Message -- Error messages so far
+ -> (Maybe a, Bag Message) -- Result and error messages (if any)
data LintLocInfo
= RhsOf Id -- The variable bound
\end{code}
\begin{code}
-initL :: LintM a -> Maybe ErrMsg
+initL :: LintM a -> Maybe Message {- errors -}
initL m
- = case (m [] emptyVarSet emptyBag) of { (_, errs) ->
- if isEmptyBag errs then
- Nothing
- else
- Just (vcat (bagToList errs))
- }
+ = case m [] emptyVarSet emptyBag of
+ (_, errs) | isEmptyBag errs -> Nothing
+ | otherwise -> Just (vcat (punctuate (text "") (bagToList errs)))
returnL :: a -> LintM a
returnL r loc scope errs = (Just r, errs)
\end{code}
\begin{code}
-checkL :: Bool -> ErrMsg -> LintM ()
-checkL True msg loc scope errs = (Nothing, errs)
-checkL False msg loc scope errs = (Nothing, addErr errs msg loc)
+checkL :: Bool -> Message -> LintM ()
+checkL True msg = nopL
+checkL False msg = addErrL msg
-addErrL :: ErrMsg -> LintM a
+addErrL :: Message -> LintM a
addErrL msg loc scope errs = (Nothing, addErr errs msg loc)
-addErr :: Bag ErrMsg -> ErrMsg -> [LintLocInfo] -> Bag ErrMsg
-
+addErr :: Bag Message -> Message -> [LintLocInfo] -> Bag Message
addErr errs_so_far msg locs
- = ASSERT (not (null locs))
- errs_so_far `snocBag` (hang (pprLoc (head locs)) 4 msg)
+ = ASSERT( notNull locs )
+ errs_so_far `snocBag` mk_msg msg
+ where
+ (loc, cxt1) = dumpLoc (head locs)
+ cxts = [snd (dumpLoc loc) | loc <- locs]
+ context | opt_PprStyle_Debug = vcat (reverse cxts) $$ cxt1
+ | otherwise = cxt1
+
+ mk_msg msg = addErrLocHdrLine loc context msg
addLoc :: LintLocInfo -> LintM a -> LintM a
addLoc extra_loc m loc scope errs
= m (extra_loc:loc) scope errs
-addInScopeVars :: [IdOrTyVar] -> LintM a -> LintM a
+addInScopeVars :: [Var] -> LintM a -> LintM a
addInScopeVars ids m loc scope errs
= m loc (scope `unionVarSet` mkVarSet ids) errs
\end{code}
\begin{code}
-checkIdInScope :: IdOrTyVar -> LintM ()
+checkIdInScope :: Var -> LintM ()
checkIdInScope id
= checkInScope (ptext SLIT("is out of scope")) id
-checkBndrIdInScope :: IdOrTyVar -> IdOrTyVar -> LintM ()
+checkBndrIdInScope :: Var -> Var -> LintM ()
checkBndrIdInScope binder id
= checkInScope msg id
where
msg = ptext SLIT("is out of scope inside info for") <+>
ppr binder
-checkInScope :: SDoc -> IdOrTyVar -> LintM ()
-checkInScope loc_msg id loc scope errs
- | isLocallyDefined id
- && not (id `elemVarSet` scope)
- && not (idMustBeINLINEd id) -- Constructors and dict selectors
- -- don't have bindings,
- -- just MustInline prags
- = (Nothing, addErr errs (hsep [ppr id, loc_msg]) loc)
+checkInScope :: SDoc -> Var -> LintM ()
+checkInScope loc_msg var loc scope errs
+ | mustHaveLocalBinding var && not (var `elemVarSet` scope)
+ = (Nothing, addErr errs (hsep [ppr var, loc_msg]) loc)
| otherwise
- = (Nothing,errs)
-
-checkTys :: Type -> Type -> ErrMsg -> LintM ()
-checkTys ty1 ty2 msg loc scope errs
- | ty1 == ty2 = (Nothing, errs)
- | otherwise = (Nothing, addErr errs msg loc)
+ = nopL loc scope errs
+
+checkTys :: Type -> Type -> Message -> LintM ()
+-- check ty2 is subtype of ty1 (ie, has same structure but usage
+-- annotations need only be consistent, not equal)
+checkTys ty1 ty2 msg
+ | ty1 `eqType` ty2 = nopL
+ | otherwise = addErrL msg
\end{code}
%************************************************************************
\begin{code}
-pprLoc (RhsOf v)
- = ppr (getSrcLoc v) <> colon <+>
- brackets (ptext SLIT("RHS of") <+> pp_binders [v])
+dumpLoc (RhsOf v)
+ = (getSrcLoc v, brackets (ptext SLIT("RHS of") <+> pp_binders [v]))
+
+dumpLoc (LambdaBodyOf b)
+ = (getSrcLoc b, brackets (ptext SLIT("in body of lambda with binder") <+> pp_binder b))
-pprLoc (LambdaBodyOf b)
- = ppr (getSrcLoc b) <> colon <+>
- brackets (ptext SLIT("in body of lambda with binder") <+> pp_binder b)
+dumpLoc (BodyOfLetRec [])
+ = (noSrcLoc, brackets (ptext SLIT("In body of a letrec with no binders")))
-pprLoc (BodyOfLetRec bs)
- = ppr (getSrcLoc (head bs)) <> colon <+>
- brackets (ptext SLIT("in body of letrec with binders") <+> pp_binders bs)
+dumpLoc (BodyOfLetRec bs@(_:_))
+ = ( getSrcLoc (head bs), brackets (ptext SLIT("in body of letrec with binders") <+> pp_binders bs))
-pprLoc (AnExpr e)
- = text "In the expression:" <+> ppr e
+dumpLoc (AnExpr e)
+ = (noSrcLoc, text "In the expression:" <+> ppr e)
-pprLoc (CaseAlt (con, args, rhs))
- = text "In a case pattern:" <+> parens (ppr con <+> ppr args)
+dumpLoc (CaseAlt (con, args, rhs))
+ = (noSrcLoc, text "In a case pattern:" <+> parens (ppr con <+> ppr args))
-pprLoc (ImportedUnfolding locn)
- = ppr locn <> colon <+>
- brackets (ptext SLIT("in an imported unfolding"))
+dumpLoc (ImportedUnfolding locn)
+ = (locn, brackets (ptext SLIT("in an imported unfolding")))
-pp_binders :: [Id] -> SDoc
+pp_binders :: [Var] -> SDoc
pp_binders bs = sep (punctuate comma (map pp_binder bs))
-pp_binder :: Id -> SDoc
-pp_binder b = hsep [ppr b, text "::", ppr (idType b)]
+pp_binder :: Var -> SDoc
+pp_binder b | isId b = hsep [ppr b, dcolon, ppr (idType b)]
+ | isTyVar b = hsep [ppr b, dcolon, ppr (tyVarKind b)]
\end{code}
\begin{code}
------------------------------------------------------
-- Messages for case expressions
-mkConAppMsg :: CoreExpr -> ErrMsg
-mkConAppMsg e
- = hang (text "Application of newtype constructor:")
- 4 (ppr e)
-
-mkConAltMsg :: Con -> ErrMsg
-mkConAltMsg con
- = text "PrimOp in case pattern:" <+> ppr con
-
-mkNullAltsMsg :: CoreExpr -> ErrMsg
+mkNullAltsMsg :: CoreExpr -> Message
mkNullAltsMsg e
= hang (text "Case expression with no alternatives:")
4 (ppr e)
-mkDefaultArgsMsg :: [IdOrTyVar] -> ErrMsg
+mkDefaultArgsMsg :: [Var] -> Message
mkDefaultArgsMsg args
= hang (text "DEFAULT case with binders")
4 (ppr args)
-mkCaseAltMsg :: CoreExpr -> ErrMsg
+mkCaseAltMsg :: CoreExpr -> Message
mkCaseAltMsg e
= hang (text "Type of case alternatives not the same:")
4 (ppr e)
-mkScrutMsg :: Id -> Type -> ErrMsg
+mkScrutMsg :: Id -> Type -> Message
mkScrutMsg var scrut_ty
= vcat [text "Result binder in case doesn't match scrutinee:" <+> ppr var,
text "Result binder type:" <+> ppr (idType var),
text "Scrutinee type:" <+> ppr scrut_ty]
-badAltsMsg :: CoreExpr -> ErrMsg
-badAltsMsg e
- = hang (text "Case statement scrutinee is not a data type:")
- 4 (ppr e)
-nonExhaustiveAltsMsg :: CoreExpr -> ErrMsg
+mkNonDefltMsg e
+ = hang (text "Case expression with DEFAULT not at the beginnning") 4 (ppr e)
+
+nonExhaustiveAltsMsg :: CoreExpr -> Message
nonExhaustiveAltsMsg e
- = hang (text "Case expression with non-exhaustive alternatives")
- 4 (ppr e)
+ = hang (text "Case expression with non-exhaustive alternatives") 4 (ppr e)
-mkBadPatMsg :: Type -> Type -> ErrMsg
+mkBadPatMsg :: Type -> Type -> Message
mkBadPatMsg con_result_ty scrut_ty
= vcat [
text "In a case alternative, pattern result type doesn't match scrutinee type:",
------------------------------------------------------
-- Other error messages
-mkAppMsg :: Type -> Type -> ErrMsg
+mkAppMsg :: Type -> Type -> Message
mkAppMsg fun arg
= vcat [ptext SLIT("Argument value doesn't match argument type:"),
hang (ptext SLIT("Fun type:")) 4 (ppr fun),
hang (ptext SLIT("Arg type:")) 4 (ppr arg)]
-mkKindErrMsg :: TyVar -> Type -> ErrMsg
+mkKindErrMsg :: TyVar -> Type -> Message
mkKindErrMsg tyvar arg_ty
= vcat [ptext SLIT("Kinds don't match in type application:"),
hang (ptext SLIT("Type variable:"))
- 4 (ppr tyvar <+> ptext SLIT("::") <+> ppr (tyVarKind tyvar)),
+ 4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)),
hang (ptext SLIT("Arg type:"))
- 4 (ppr arg_ty <+> ptext SLIT("::") <+> ppr (typeKind arg_ty))]
+ 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
-mkTyAppMsg :: Type -> Type -> ErrMsg
+mkTyAppMsg :: Type -> Type -> Message
mkTyAppMsg ty arg_ty
= vcat [text "Illegal type application:",
hang (ptext SLIT("Exp type:"))
- 4 (ppr ty <+> ptext SLIT("::") <+> ppr (typeKind ty)),
+ 4 (ppr ty <+> dcolon <+> ppr (typeKind ty)),
hang (ptext SLIT("Arg type:"))
- 4 (ppr arg_ty <+> ptext SLIT("::") <+> ppr (typeKind arg_ty))]
+ 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
-mkRhsMsg :: Id -> Type -> ErrMsg
+mkRhsMsg :: Id -> Type -> Message
mkRhsMsg binder ty
= vcat
[hsep [ptext SLIT("The type of this binder doesn't match the type of its RHS:"),
hsep [ptext SLIT("Binder's type:"), ppr (idType binder)],
hsep [ptext SLIT("Rhs type:"), ppr ty]]
-mkRhsPrimMsg :: Id -> CoreExpr -> ErrMsg
+mkRhsPrimMsg :: Id -> CoreExpr -> Message
mkRhsPrimMsg binder rhs
= vcat [hsep [ptext SLIT("The type of this binder is primitive:"),
ppr binder],
hsep [ptext SLIT("Binder's type:"), ppr (idType binder)]
]
-mkUnboxedTupleMsg :: Id -> ErrMsg
+mkUnboxedTupleMsg :: Id -> Message
mkUnboxedTupleMsg binder
= vcat [hsep [ptext SLIT("A variable has unboxed tuple type:"), ppr binder],
hsep [ptext SLIT("Binder's type:"), ppr (idType binder)]]
ptext SLIT("From-type:") <+> ppr from_ty,
ptext SLIT("Type of enclosed expr:") <+> ppr expr_ty
]
+
+mkStrangeTyMsg e
+ = ptext SLIT("Type where expression expected:") <+> ppr e
\end{code}