#include "HsVersions.h"
-import IO ( hPutStr, hPutStrLn, stdout )
-
import CoreSyn
import CoreFVs ( idFreeVars )
import CoreUtils ( findDefault, exprOkForSpeculation, coreBindsSize, mkPiType )
import Subst ( substTyWith )
import Name ( getSrcLoc )
import PprCore
-import ErrUtils ( doIfSet, dumpIfSet_core, ghcExit, Message, showPass,
- addErrLocHdrLine )
-import SrcLoc ( SrcLoc, noSrcLoc )
+import ErrUtils ( dumpIfSet_core, ghcExit, Message, showPass,
+ mkLocMessage )
+import SrcLoc ( SrcLoc, noSrcLoc, mkSrcSpan )
import Type ( Type, tyVarsOfType, eqType,
splitFunTy_maybe, mkTyVarTy,
splitForAllTy_maybe, splitTyConApp_maybe, splitTyConApp,
isUnLiftedType, typeKind,
isUnboxedTupleType,
- hasMoreBoxityInfo
+ isSubKind
)
import TyCon ( isPrimTyCon )
import BasicTypes ( RecFlag(..), isNonRec )
import CmdLineOpts
-import Maybe
-import Util ( notNull )
import Outputable
+#ifdef DEBUG
+import Util ( notNull )
+#endif
+
+import Maybe
+import IO ( hPutStrLn, stderr )
+
infixr 9 `thenL`, `seqL`
\end{code}
lintCoreBindings dflags whoDunnit binds
= case (initL (lint_binds binds)) of
- Nothing -> done_lint
+ Nothing -> showPass dflags ("Core Linted result of " ++ whoDunnit)
Just bad_news -> printDump (display bad_news) >>
ghcExit 1
where
returnL ()
lint_bind (NonRec bndr rhs) = lintSingleBinding NonRecursive (bndr,rhs)
- done_lint = doIfSet (verbosity dflags >= 2)
- (hPutStr stdout ("*** Core Linted result of " ++ whoDunnit ++ "\n"))
-
display bad_news
= vcat [ text ("*** Core Lint Errors: in result of " ++ whoDunnit ++ " ***"),
bad_news,
tyvar_kind = tyVarKind tyvar
argty_kind = typeKind arg_ty
in
- if argty_kind `hasMoreBoxityInfo` tyvar_kind
+ if argty_kind `isSubKind` tyvar_kind
-- Arg type might be boxed for a function with an uncommitted
-- tyvar; notably this is used so that we can give
-- error :: forall a:*. String -> a
lintCoreAlt scrut_ty alt@(DataAlt con, args, rhs)
= addLoc (CaseAlt alt) (
- mapL (\arg -> checkL (not (isUnboxedTupleType (idType arg)))
- (mkUnboxedTupleMsg arg)) args `seqL`
+ mapL (\arg -> checkL (not (isId arg && isUnboxedTupleType (idType arg)))
+ (mkUnboxedTupleMsg arg)) args `seqL`
addInScopeVars args (
context | opt_PprStyle_Debug = vcat (reverse cxts) $$ cxt1
| otherwise = cxt1
- mk_msg msg = addErrLocHdrLine loc context msg
+ mk_msg msg = mkLocMessage (mkSrcSpan loc loc) (context $$ msg)
addLoc :: LintLocInfo -> LintM a -> LintM a
addLoc extra_loc m loc scope errs
addInScopeVars :: [Var] -> LintM a -> LintM a
addInScopeVars ids m loc scope errs
- = m loc (scope `unionVarSet` mkVarSet ids) errs
+ = m loc (extendVarSetList scope ids) errs
\end{code}
\begin{code}