+
%
% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 1993-1998
module CoreLint (
lintCoreBindings,
lintUnfolding,
- showPass, endPass
+ showPass, endPass, endIteration
) where
#include "HsVersions.h"
import TyCon
import BasicTypes
import StaticFlags
+import ListSetOps
import DynFlags
import Outputable
import Util
\begin{code}
endPass :: DynFlags -> String -> DynFlag -> [CoreBind] -> IO [CoreBind]
-endPass dflags pass_name dump_flag binds
+endPass = dumpAndLint dumpIfSet_core
+
+endIteration :: DynFlags -> String -> DynFlag -> [CoreBind] -> IO [CoreBind]
+endIteration = dumpAndLint dumpIfSet_dyn
+
+dumpAndLint :: (DynFlags -> DynFlag -> String -> SDoc -> IO ())
+ -> DynFlags -> String -> DynFlag -> [CoreBind] -> IO [CoreBind]
+dumpAndLint dump dflags pass_name dump_flag binds
= do
-- Report result size if required
-- This has the side effect of forcing the intermediate to be evaluated
(text " Result size =" <+> int (coreBindsSize binds))
-- Report verbosely, if required
- dumpIfSet_core dflags dump_flag pass_name (pprCoreBindings binds)
+ dump dflags dump_flag pass_name (pprCoreBindings binds)
-- Type check
lintCoreBindings dflags pass_name 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) $
+ lint_binds binds = addLoc TopLevelBindings $
+ addInScopeVars (bindersOfBinds binds) $
mapM lint_bind binds
lint_bind (Rec prs) = mapM_ (lintSingleBinding TopLevel Recursive) prs
else lintAndScopeId var
; scope $ \_ ->
do { -- Check the alternatives
- checkCaseAlts e scrut_ty alts
- ; mapM (lintCoreAlt scrut_ty alt_ty) alts
+ mapM (lintCoreAlt scrut_ty alt_ty) alts
+ ; checkCaseAlts e scrut_ty alts
; return alt_ty } }
where
pass_var f = f var
{ -- Check the pattern
-- 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.
- -- NB: relies on existential type args coming *after* ordinary type args
-
+ -- NB: args must be in scope here so that the lintCoreArgs
+ -- line works.
+ -- NB: relies on existential type args coming *after*
+ -- ordinary type args
; con_result_ty <- lintCoreArgs con_payload_ty (varsToCoreExprs args)
; checkTys con_result_ty scrut_ty (mkBadPatMsg con_result_ty scrut_ty)
}
| CasePat CoreAlt -- *Pattern* of the case alternative
| AnExpr CoreExpr -- Some expression
| ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which)
+ | TopLevelBindings
\end{code}
LintM (\ loc subst errs -> unLintM m (extra_loc:loc) subst errs)
addInScopeVars :: [Var] -> LintM a -> LintM a
-addInScopeVars vars m =
- LintM (\ loc subst errs -> unLintM m loc (extendTvInScope subst vars) errs)
+addInScopeVars vars m
+ | null dups
+ = LintM (\ loc subst errs -> unLintM m loc (extendTvInScope subst vars) errs)
+ | otherwise
+ = addErrL (dupVars dups)
+ where
+ (_, dups) = removeDups compare vars
updateTvSubst :: TvSubst -> LintM a -> LintM a
updateTvSubst subst' m =
dumpLoc (ImportedUnfolding locn)
= (locn, brackets (ptext SLIT("in an imported unfolding")))
+dumpLoc TopLevelBindings
+ = (noSrcLoc, empty)
pp_binders :: [Var] -> SDoc
pp_binders bs = sep (punctuate comma (map pp_binder bs))
ptext SLIT("Type of enclosed expr:") <+> ppr expr_ty
]
+dupVars vars
+ = hang (ptext SLIT("Duplicate variables brought into scope"))
+ 2 (ppr vars)
+
mkStrangeTyMsg e
= ptext SLIT("Type where expression expected:") <+> ppr e
\end{code}