diff options
| author | simonpj <unknown> | 2000-11-10 15:12:55 +0000 |
|---|---|---|
| committer | simonpj <unknown> | 2000-11-10 15:12:55 +0000 |
| commit | f23ba2b294429ccbdeb80f0344ec08f6abf61bb7 (patch) | |
| tree | 30e94ffff421c99ae25f35759e52b7e267e9e8af | |
| parent | 6bd12a0cb5115d08a9ee84dbc1920e83bb7c1616 (diff) | |
| download | haskell-f23ba2b294429ccbdeb80f0344ec08f6abf61bb7.tar.gz | |
[project @ 2000-11-10 15:12:50 by simonpj]
1. Outputable.PprStyle now carries a bit more information
In particular, the printing style tells whether to print
a name in unqualified form. This used to be embedded in
a Name, but since Names now outlive a single compilation unit,
that's no longer appropriate.
So now the print-unqualified predicate is passed in the printing
style, not embedded in the Name.
2. I tidied up HscMain a little. Many of the showPass messages
have migraged into the repective pass drivers
44 files changed, 484 insertions, 439 deletions
diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs index 5888124fc3..dcf672e5d4 100644 --- a/ghc/compiler/basicTypes/Name.lhs +++ b/ghc/compiler/basicTypes/Name.lhs @@ -43,8 +43,7 @@ module Name ( #include "HsVersions.h" import OccName -- All of it -import Module ( Module, moduleName, mkVanillaModule, - printModulePrefix, isModuleInThisPackage ) +import Module ( Module, moduleName, mkVanillaModule, isModuleInThisPackage ) import RdrName ( RdrName, mkRdrOrig, mkRdrUnqual, rdrNameOcc, rdrNameModule ) import CmdLineOpts ( opt_Static, opt_OmitInterfacePragmas, opt_EnsureSplittableC ) import SrcLoc ( builtinSrcLoc, noSrcLoc, SrcLoc ) @@ -456,10 +455,10 @@ instance Outputable Name where -- When printing interfaces, all Locals have been given nice print-names ppr name = pprName name -pprName (Name {n_sort = sort, n_uniq = uniq, n_occ = occ}) +pprName name@(Name {n_sort = sort, n_uniq = uniq, n_occ = occ}) = getPprStyle $ \ sty -> case sort of - Global mod -> pprGlobal sty uniq mod occ + Global mod -> pprGlobal sty name uniq mod occ System -> pprSysLocal sty uniq occ Local -> pprLocal sty uniq occ empty Exported -> pprLocal sty uniq occ (char 'x') @@ -470,16 +469,14 @@ pprLocal sty uniq occ pp_export text "{-" <> pp_export <+> pprUnique10 uniq <> text "-}" | otherwise = pprOccName occ -pprGlobal sty uniq mod occ - | codeStyle sty = ppr (moduleName mod) <> char '_' <> pprOccName occ +pprGlobal sty name uniq mod occ + | codeStyle sty = ppr (moduleName mod) <> char '_' <> pprOccName occ - | debugStyle sty = ppr (moduleName mod) <> dot <> pprOccName occ <> + | debugStyle sty = ppr (moduleName mod) <> dot <> pprOccName occ <> text "{-" <> pprUnique10 uniq <> text "-}" - | ifaceStyle sty - || printModulePrefix mod = ppr (moduleName mod) <> dot <> pprOccName occ - - | otherwise = pprOccName occ + | unqualStyle sty name = pprOccName occ + | otherwise = ppr (moduleName mod) <> dot <> pprOccName occ pprSysLocal sty uniq occ | codeStyle sty = pprUnique uniq diff --git a/ghc/compiler/codeGen/CgCase.lhs b/ghc/compiler/codeGen/CgCase.lhs index ecd4a1cd01..07b1db4135 100644 --- a/ghc/compiler/codeGen/CgCase.lhs +++ b/ghc/compiler/codeGen/CgCase.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: CgCase.lhs,v 1.48 2000/11/07 15:21:39 simonmar Exp $ +% $Id: CgCase.lhs,v 1.49 2000/11/10 15:12:51 simonpj Exp $ % %******************************************************** %* * @@ -402,7 +402,7 @@ getPrimAppResultAmodes uniq (StgAlgAlts ty alts some_default) [ CTemp (getUnique arg) (idPrimRep arg) | arg <- args ] _ -> panic "getPrimAppResultAmodes: case of unboxed tuple has multiple branches" - | otherwise = panic ("getPrimAppResultAmodes: case of primop has strange type: " ++ showSDoc (ppr ty)) + | otherwise = pprPanic "getPrimAppResultAmodes: case of primop has strange type:" (ppr ty) where (tycon, _, _) = splitAlgTyConApp ty diff --git a/ghc/compiler/codeGen/CodeGen.lhs b/ghc/compiler/codeGen/CodeGen.lhs index 8eab80e904..462f0ff4d7 100644 --- a/ghc/compiler/codeGen/CodeGen.lhs +++ b/ghc/compiler/codeGen/CodeGen.lhs @@ -40,7 +40,7 @@ import PrimRep ( PrimRep(..) ) import TyCon ( TyCon, isDataTyCon ) import BasicTypes ( TopLevelFlag(..) ) import UniqSupply ( mkSplitUniqSupply ) -import ErrUtils ( dumpIfSet_dyn ) +import ErrUtils ( dumpIfSet_dyn, showPass ) import Panic ( assertPanic ) \end{code} @@ -60,26 +60,28 @@ codeGen :: DynFlags codeGen dflags mod_name imported_modules cost_centre_info fe_binders tycons stg_binds - = mkSplitUniqSupply 'f' >>= \ fl_uniqs -> -- absC flattener - let - datatype_stuff = genStaticConBits cinfo data_tycons - code_stuff = initC cinfo (cgTopBindings maybe_split stg_binds) - init_stuff = mkModuleInit fe_binders mod_name imported_modules - cost_centre_info - - abstractC = mkAbstractCs [ maybe_split, - init_stuff, - code_stuff, - datatype_stuff] + = do { showPass dflags "CodeGen" + + ; fl_uniqs <- mkSplitUniqSupply 'f' + ; let + datatype_stuff = genStaticConBits cinfo data_tycons + code_stuff = initC cinfo (cgTopBindings maybe_split stg_binds) + init_stuff = mkModuleInit fe_binders mod_name imported_modules + cost_centre_info + + abstractC = mkAbstractCs [ maybe_split, + init_stuff, + code_stuff, + datatype_stuff] -- Put datatype_stuff after code_stuff, because the -- datatype closure table (for enumeration types) -- to (say) PrelBase_True_closure, which is defined in code_stuff - flat_abstractC = flattenAbsC fl_uniqs abstractC - in - dumpIfSet_dyn dflags Opt_D_dump_absC "Abstract C" (dumpRealC abstractC) >> - return flat_abstractC + flat_abstractC = flattenAbsC fl_uniqs abstractC + ; dumpIfSet_dyn dflags Opt_D_dump_absC "Abstract C" (dumpRealC abstractC) + ; return flat_abstractC + } where data_tycons = filter isDataTyCon tycons diff --git a/ghc/compiler/coreSyn/CoreLint.lhs b/ghc/compiler/coreSyn/CoreLint.lhs index 015e6a699c..ccd3afa458 100644 --- a/ghc/compiler/coreSyn/CoreLint.lhs +++ b/ghc/compiler/coreSyn/CoreLint.lhs @@ -7,7 +7,7 @@ module CoreLint ( lintCoreBindings, lintUnfolding, - beginPass, endPass, endPassWithRules + showPass, endPass, endPassWithRules ) where #include "HsVersions.h" @@ -27,7 +27,7 @@ import VarSet import Subst ( mkTyVarSubst, substTy ) import Name ( getSrcLoc ) import PprCore -import ErrUtils ( doIfSet_dyn, dumpIfSet, ghcExit, Message, +import ErrUtils ( doIfSet_dyn, dumpIfSet, ghcExit, Message, showPass, ErrMsg, addErrLocHdrLine, pprBagOfErrors, WarnMsg, pprBagOfWarnings) import SrcLoc ( SrcLoc, noSrcLoc ) @@ -58,14 +58,6 @@ place for them. They print out stuff before and after core passes, and do Core Lint when necessary. \begin{code} -beginPass :: DynFlags -> String -> IO () -beginPass dflags pass_name - | dopt Opt_D_show_passes dflags - = hPutStrLn stdout ("*** " ++ pass_name) - | otherwise - = return () - - endPass :: DynFlags -> String -> Bool -> [CoreBind] -> IO [CoreBind] endPass dflags pass_name dump_flag binds = do diff --git a/ghc/compiler/coreSyn/CoreTidy.lhs b/ghc/compiler/coreSyn/CoreTidy.lhs index b120ca72cc..4f08fb4ec9 100644 --- a/ghc/compiler/coreSyn/CoreTidy.lhs +++ b/ghc/compiler/coreSyn/CoreTidy.lhs @@ -14,7 +14,7 @@ module CoreTidy ( import CmdLineOpts ( DynFlags, DynFlag(..), opt_UsageSPOn, dopt ) import CoreSyn import CoreUnfold ( noUnfolding ) -import CoreLint ( beginPass, endPass ) +import CoreLint ( showPass, endPass ) import UsageSPInf ( doUsageSPInf ) import VarEnv import VarSet @@ -35,6 +35,7 @@ import Type ( tidyTopType, tidyType, tidyTyVar ) import Module ( Module ) import UniqSupply ( mkSplitUniqSupply ) import Unique ( Uniquable(..) ) +import ErrUtils ( showPass ) import SrcLoc ( noSrcLoc ) import Util ( mapAccumL ) \end{code} @@ -72,7 +73,7 @@ tidyCorePgm dflags module_name binds_in orphans_in = do us <- mkSplitUniqSupply 'u' - beginPass dflags "Tidy Core" + showPass dflags "Tidy Core" binds_in1 <- if opt_UsageSPOn then _scc_ "CoreUsageSPInf" diff --git a/ghc/compiler/cprAnalysis/CprAnalyse.lhs b/ghc/compiler/cprAnalysis/CprAnalyse.lhs index a390179129..c90aec6557 100644 --- a/ghc/compiler/cprAnalysis/CprAnalyse.lhs +++ b/ghc/compiler/cprAnalysis/CprAnalyse.lhs @@ -7,7 +7,7 @@ module CprAnalyse ( cprAnalyse ) where #include "HsVersions.h" import CmdLineOpts ( DynFlags, DynFlag(..), dopt ) -import CoreLint ( beginPass, endPass ) +import CoreLint ( showPass, endPass ) import CoreSyn import CoreUtils ( exprIsValue ) import Id ( Id, setIdCprInfo, idCprInfo, idArity, @@ -137,7 +137,7 @@ ids decorated with their CprInfo pragmas. cprAnalyse :: DynFlags -> [CoreBind] -> IO [CoreBind] cprAnalyse dflags binds = do { - beginPass dflags "Constructed Product analysis" ; + showPass dflags "Constructed Product analysis" ; let { binds_plus_cpr = do_prog binds } ; endPass dflags "Constructed Product analysis" (dopt Opt_D_dump_cpranal dflags || dopt Opt_D_verbose_core2core dflags) diff --git a/ghc/compiler/deSugar/Desugar.lhs b/ghc/compiler/deSugar/Desugar.lhs index b658121ec8..1745615d5f 100644 --- a/ghc/compiler/deSugar/Desugar.lhs +++ b/ghc/compiler/deSugar/Desugar.lhs @@ -28,10 +28,10 @@ import Id ( Id ) import VarEnv import VarSet import Bag ( isEmptyBag ) -import CoreLint ( beginPass, endPass ) +import CoreLint ( showPass, endPass ) import ErrUtils ( doIfSet, pprBagOfWarnings ) import Outputable -import UniqSupply ( UniqSupply ) +import UniqSupply ( mkSplitUniqSupply ) import HscTypes ( HomeSymbolTable ) \end{code} @@ -46,34 +46,36 @@ start. \begin{code} deSugar :: DynFlags - -> Module - -> UniqSupply + -> Module -> PrintUnqualified -> HomeSymbolTable -> TcResults -> IO ([CoreBind], [(Id,CoreRule)], SDoc, SDoc, [CoreBndr]) -deSugar dflags mod_name us hst +deSugar dflags mod_name unqual hst (TcResults {tc_env = global_val_env, tc_pcs = pcs, tc_binds = all_binds, tc_rules = rules, tc_fords = fo_decls}) = do - beginPass dflags "Desugar" + showPass dflags "Desugar" + us <- mkSplitUniqSupply 'd' + -- Do desugaring let (result, ds_warns) = initDs dflags us (hst,pcs,global_val_env) mod_name (dsProgram mod_name all_binds rules fo_decls) (ds_binds, ds_rules, _, _, _) = result - -- Display any warnings + -- Display any warnings doIfSet (not (isEmptyBag ds_warns)) - (printErrs (pprBagOfWarnings ds_warns)) + (printErrs unqual (pprBagOfWarnings ds_warns)) - -- Lint result if necessary + -- Lint result if necessary let do_dump_ds = dopt Opt_D_dump_ds dflags endPass dflags "Desugar" do_dump_ds ds_binds + -- Dump output doIfSet do_dump_ds (printDump (ppr_ds_rules ds_rules)) return result diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs index 67f48517a4..487794f3cb 100644 --- a/ghc/compiler/deSugar/Match.lhs +++ b/ghc/compiler/deSugar/Match.lhs @@ -108,7 +108,7 @@ dsIncompleteWarn ctx@(DsMatchContext kind _ _) pats = dsWarn warn | otherwise = empty pp_context NoMatchContext msg rest_of_msg_fun - = dontAddErrLoc "" (ptext SLIT("Some match(es)") <+> hang msg 8 (rest_of_msg_fun id)) + = dontAddErrLoc (ptext SLIT("Some match(es)") <+> hang msg 8 (rest_of_msg_fun id)) pp_context (DsMatchContext kind pats loc) msg rest_of_msg_fun = case pp_match kind pats of diff --git a/ghc/compiler/hsSyn/HsBinds.lhs b/ghc/compiler/hsSyn/HsBinds.lhs index 0d91edfc74..f1e9191605 100644 --- a/ghc/compiler/hsSyn/HsBinds.lhs +++ b/ghc/compiler/hsSyn/HsBinds.lhs @@ -74,16 +74,18 @@ instance (Outputable pat, Outputable id) => ppr_binds EmptyBinds = empty ppr_binds (ThenBinds binds1 binds2) - = ($$) (ppr_binds binds1) (ppr_binds binds2) + = ppr_binds binds1 $$ ppr_binds binds2 ppr_binds (MonoBind bind sigs is_rec) - = vcat [ifNotPprForUser (ptext rec_str), + = vcat [ppr_isrec, vcat (map ppr sigs), ppr bind ] where - rec_str = case is_rec of - Recursive -> SLIT("{- rec -}") - NonRecursive -> SLIT("{- nonrec -}") + ppr_isrec = getPprStyle $ \ sty -> + if userStyle sty then empty else + case is_rec of + Recursive -> ptext SLIT("{- rec -}") + NonRecursive -> ptext SLIT("{- nonrec -}") \end{code} %************************************************************************ diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs index 43592185cd..4ba2e2a19f 100644 --- a/ghc/compiler/hsSyn/HsExpr.lhs +++ b/ghc/compiler/hsSyn/HsExpr.lhs @@ -19,7 +19,7 @@ import HsTypes ( HsType ) -- others: import Name ( Name, isLexSym ) import Outputable -import PprType ( pprType, pprParendType ) +import PprType ( pprParendType ) import Type ( Type ) import Var ( TyVar ) import DataCon ( DataCon ) @@ -305,8 +305,7 @@ ppr_expr (HsDoOut do_or_list_comp stmts _ _ _ _ _) = pprDo do_or_list_comp stmts ppr_expr (ExplicitList exprs) = brackets (fsep (punctuate comma (map ppr_expr exprs))) ppr_expr (ExplicitListOut ty exprs) - = hcat [ brackets (fsep (punctuate comma (map ppr_expr exprs))), - ifNotPprForUser ((<>) space (parens (pprType ty))) ] + = brackets (fsep (punctuate comma (map ppr_expr exprs))) ppr_expr (ExplicitTuple exprs boxity) = tupleParens boxity (sep (punctuate comma (map ppr_expr exprs))) @@ -394,7 +393,7 @@ pprParendExpr expr \begin{code} isOperator :: Outputable a => a -> Bool -isOperator v = isLexSym (_PK_ (showSDoc (ppr v))) +isOperator v = isLexSym (_PK_ (showSDocUnqual (ppr v))) -- We use (showSDoc (ppr v)), rather than isSymOcc (getOccName v) simply so -- that we don't need NamedThing in the context of all these functions. -- Gruesome, but simple. diff --git a/ghc/compiler/main/CodeOutput.lhs b/ghc/compiler/main/CodeOutput.lhs index a8a1a0a3b3..0d865b99ac 100644 --- a/ghc/compiler/main/CodeOutput.lhs +++ b/ghc/compiler/main/CodeOutput.lhs @@ -27,7 +27,7 @@ import AbsCSyn ( AbstractC ) import PprAbsC ( dumpRealC, writeRealC ) import Module ( Module ) import CmdLineOpts -import ErrUtils ( dumpIfSet_dyn ) +import ErrUtils ( dumpIfSet_dyn, showPass ) import Outputable import CmdLineOpts ( DynFlags, HscLang(..), dopt_OutName ) import TmpFiles ( newTempName ) @@ -61,16 +61,18 @@ codeOutput dflags mod_name tycons core_binds stg_binds -- Dunno if the above comment is still meaningful now. JRS 001024. - do let filenm = dopt_OutName dflags - stub_names <- outputForeignStubs dflags c_code h_code - case dopt_HscLang dflags of - HscInterpreted -> return stub_names - HscAsm -> outputAsm dflags filenm flat_abstractC - >> return stub_names - HscC -> outputC dflags filenm flat_abstractC - >> return stub_names - HscJava -> outputJava dflags filenm mod_name tycons core_binds - >> return stub_names + do { showPass dflags "CodeOutput" + ; let filenm = dopt_OutName dflags + ; stub_names <- outputForeignStubs dflags c_code h_code + ; case dopt_HscLang dflags of + HscInterpreted -> return stub_names + HscAsm -> outputAsm dflags filenm flat_abstractC + >> return stub_names + HscC -> outputC dflags filenm flat_abstractC + >> return stub_names + HscJava -> outputJava dflags filenm mod_name tycons core_binds + >> return stub_names + } doOutput :: String -> (Handle -> IO ()) -> IO () doOutput filenm io_action @@ -130,7 +132,7 @@ outputAsm dflags filenm flat_absC \begin{code} outputJava dflags filenm mod tycons core_binds - = doOutput filenm (\ f -> printForUser f pp_java) + = doOutput filenm (\ f -> printForUser f alwaysQualify pp_java) -- User style printing for now to keep indentation where java_code = javaGen mod [{- Should be imports-}] tycons core_binds diff --git a/ghc/compiler/main/ErrUtils.lhs b/ghc/compiler/main/ErrUtils.lhs index b6d9bade5a..b0e0b3a638 100644 --- a/ghc/compiler/main/ErrUtils.lhs +++ b/ghc/compiler/main/ErrUtils.lhs @@ -5,22 +5,24 @@ \begin{code} module ErrUtils ( - ErrMsg, WarnMsg, Message, + ErrMsg, WarnMsg, Message, Messages, errorsFound, + addShortErrLocLine, addShortWarnLocLine, - addErrLocHdrLine, - dontAddErrLoc, + addErrLocHdrLine, dontAddErrLoc, + printErrorsAndWarnings, pprBagOfErrors, pprBagOfWarnings, + ghcExit, - doIfSet, doIfSet_dyn, dumpIfSet, dumpIfSet_dyn + doIfSet, doIfSet_dyn, dumpIfSet, dumpIfSet_dyn, showPass ) where #include "HsVersions.h" import Bag ( Bag, bagToList, isEmptyBag ) -import SrcLoc ( SrcLoc, noSrcLoc ) +import SrcLoc ( SrcLoc, noSrcLoc, isGoodSrcLoc ) import Util ( sortLt ) import Outputable -import CmdLineOpts ( DynFlags, DynFlag, dopt ) +import CmdLineOpts ( DynFlags, DynFlag(..), dopt ) import System ( ExitCode(..), exitWith ) import IO ( hPutStr, stderr ) @@ -38,10 +40,9 @@ addErrLocHdrLine :: SrcLoc -> Message -> Message -> ErrMsg addShortWarnLocLine :: SrcLoc -> Message -> WarnMsg addShortErrLocLine locn rest_of_err_msg - = ( locn - , hang (ppr locn <> colon) - 4 rest_of_err_msg - ) + | isGoodSrcLoc locn = (locn, hang (ppr locn <> colon) 4 + rest_of_err_msg) + | otherwise = (locn, rest_of_err_msg) addErrLocHdrLine locn hdr rest_of_err_msg = ( locn @@ -50,23 +51,28 @@ addErrLocHdrLine locn hdr rest_of_err_msg ) addShortWarnLocLine locn rest_of_err_msg - = ( locn - , hang (ppr locn <> colon) - 4 (ptext SLIT("Warning:") <+> rest_of_err_msg) - ) + | isGoodSrcLoc locn = (locn, hang (ppr locn <> colon) 4 + (ptext SLIT("Warning:") <+> rest_of_err_msg)) + | otherwise = (locn, rest_of_err_msg) -dontAddErrLoc :: String -> Message -> ErrMsg -dontAddErrLoc title rest_of_err_msg - | null title = (noSrcLoc, rest_of_err_msg) - | otherwise = - ( noSrcLoc, hang (text title <> colon) 4 rest_of_err_msg ) +dontAddErrLoc :: Message -> ErrMsg +dontAddErrLoc msg = (noSrcLoc, msg) -printErrorsAndWarnings :: (Bag WarnMsg, Bag ErrMsg) -> IO () +\end{code} + + +\begin{code} +type Messages = (Bag WarnMsg, Bag ErrMsg) + +errorsFound :: Messages -> Bool +errorsFound (warns, errs) = not (isEmptyBag errs) + +printErrorsAndWarnings :: PrintUnqualified -> Messages -> IO () -- Don't print any warnings if there are errors -printErrorsAndWarnings (warns, errs) +printErrorsAndWarnings unqual (warns, errs) | no_errs && no_warns = return () - | no_errs = printErrs (pprBagOfWarnings warns) - | otherwise = printErrs (pprBagOfErrors errs) + | no_errs = printErrs unqual (pprBagOfWarnings warns) + | otherwise = printErrs unqual (pprBagOfErrors errs) where no_warns = isEmptyBag warns no_errs = isEmptyBag errs @@ -103,6 +109,11 @@ doIfSet_dyn dflags flag action | dopt flag dflags = action \end{code} \begin{code} +showPass :: DynFlags -> String -> IO () +showPass dflags what + | dopt Opt_D_show_passes dflags = hPutStr stderr ("*** "++what++":\n") + | otherwise = return () + dumpIfSet :: Bool -> String -> SDoc -> IO () dumpIfSet flag hdr doc | not flag = return () diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index 2fcff8b0dc..e762afd235 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -10,7 +10,7 @@ module HscMain ( HscResult(..), hscMain, #include "HsVersions.h" import Maybe ( isJust ) -import IO ( hPutStr, hPutStrLn, stderr ) +import IO ( hPutStrLn, stderr ) import HsSyn import StringBuffer ( hGetStringBuffer ) @@ -39,7 +39,7 @@ import CodeOutput ( codeOutput ) import Module ( ModuleName, moduleName, mkModuleInThisPackage ) import CmdLineOpts -import ErrUtils ( dumpIfSet_dyn ) +import ErrUtils ( dumpIfSet_dyn, showPass ) import Util ( unJust ) import UniqSupply ( mkSplitUniqSupply ) @@ -93,10 +93,11 @@ hscMain hscMain dflags source_unchanged location maybe_old_iface hst hit pcs = do { putStrLn "CHECKING OLD IFACE"; - (pcs_ch, check_errs, (recomp_reqd, maybe_checked_iface)) + (pcs_ch, errs_found, (recomp_reqd, maybe_checked_iface)) <- checkOldIface dflags hit hst pcs (unJust (ml_hi_file location) "hscMain") source_unchanged maybe_old_iface; - if check_errs then + + if errs_found then return (HscFail pcs_ch) else do { @@ -126,8 +127,8 @@ hscNoRecomp dflags location maybe_checked_iface hst hit pcs_ch else do { -- TYPECHECK - maybe_tc_result - <- typecheckModule dflags this_mod pcs_cl hst old_iface cl_hs_decls; + maybe_tc_result <- typecheckModule dflags this_mod pcs_cl hst + old_iface alwaysQualify cl_hs_decls; case maybe_tc_result of { Nothing -> return (HscFail pcs_cl); Just tc_result -> do { @@ -149,71 +150,81 @@ hscNoRecomp dflags location maybe_checked_iface hst hit pcs_ch hscRecomp dflags location maybe_checked_iface hst hit pcs_ch - = do { - hPutStrLn stderr "COMPILATION IS REQUIRED"; - - -- what target are we shooting for? - let toInterp = dopt_HscLang dflags == HscInterpreted - ; - -- PARSE - maybe_parsed - <- myParseModule dflags (unJust (ml_hspp_file location) "hscRecomp:hspp"); - case maybe_parsed of { - Nothing -> return (HscFail pcs_ch); - Just rdr_module -> do { - - -- RENAME - let this_mod = mkModuleInThisPackage (hsModuleName rdr_module) - ; - show_pass dflags "Renamer"; - (pcs_rn, maybe_rn_result) - <- renameModule dflags hit hst pcs_ch this_mod rdr_module; - case maybe_rn_result of { - Nothing -> return (HscFail pcs_rn); - Just (new_iface, rn_hs_decls) -> do { - - -- TYPECHECK - show_pass dflags "Typechecker"; - maybe_tc_result - <- typecheckModule dflags this_mod pcs_rn hst new_iface rn_hs_decls; - case maybe_tc_result of { - Nothing -> do { hPutStrLn stderr "Typechecked failed" - ; return (HscFail pcs_rn) } ; - Just tc_result -> do { - - let pcs_tc = tc_pcs tc_result - env_tc = tc_env tc_result - local_insts = tc_insts tc_result - ; - -- DESUGAR, SIMPLIFY, TIDY-CORE - -- We grab the the unfoldings at this point. - (tidy_binds, orphan_rules, foreign_stuff) - <- dsThenSimplThenTidy dflags (pcs_rules pcs_tc) this_mod tc_result hst - ; - -- CONVERT TO STG - (stg_binds, oa_tidy_binds, cost_centre_info, top_level_ids) - <- myCoreToStg dflags this_mod tidy_binds - ; - -- cook up a new ModDetails now we (finally) have all the bits - let new_details = mkModDetails env_tc local_insts tidy_binds - top_level_ids orphan_rules - ; - -- and the final interface - final_iface - <- mkFinalIface dflags location maybe_checked_iface new_iface new_details - ; - -- do the rest of code generation/emission - (maybe_stub_h_filename, maybe_stub_c_filename, maybe_ibinds) - <- restOfCodeGeneration dflags toInterp this_mod - (map ideclName (hsModuleImports rdr_module)) - cost_centre_info foreign_stuff env_tc stg_binds oa_tidy_binds - hit (pcs_PIT pcs_tc) - ; - -- and the answer is ... - return (HscOK new_details (Just final_iface) - maybe_stub_h_filename maybe_stub_c_filename - maybe_ibinds pcs_tc) - }}}}}}} + = do { + ; hPutStrLn stderr "COMPILATION IS REQUIRED"; + + -- what target are we shooting for? + ; let toInterp = dopt_HscLang dflags == HscInterpreted + + ------------------- + -- PARSE + ------------------- + ; maybe_parsed <- myParseModule dflags (unJust (ml_hspp_file location) "hscRecomp:hspp") + ; case maybe_parsed of { + Nothing -> return (HscFail pcs_ch); + Just rdr_module -> do { + ; let this_mod = mkModuleInThisPackage (hsModuleName rdr_module) + + ------------------- + -- RENAME + ------------------- + ; (pcs_rn, maybe_rn_result) + <- renameModule dflags hit hst pcs_ch this_mod rdr_module + ; case maybe_rn_result of { + Nothing -> return (HscFail pcs_rn); + Just (print_unqualified, new_iface, rn_hs_decls) -> do { + + ------------------- + -- TYPECHECK + ------------------- + ; maybe_tc_result <- typecheckModule dflags this_mod pcs_rn hst new_iface + print_unqualified rn_hs_decls + ; case maybe_tc_result of { + Nothing -> do { hPutStrLn stderr "Typechecked failed" + ; return (HscFail pcs_rn) } ; + Just tc_result -> do { + + ; let pcs_tc = tc_pcs tc_result + env_tc = tc_env tc_result + local_insts = tc_insts tc_result + + ------------------- + -- DESUGAR, SIMPLIFY, TIDY-CORE + ------------------- + -- We grab the the unfoldings at this point. + ; simpl_result <- dsThenSimplThenTidy dflags (pcs_rules pcs_tc) this_mod + print_unqualified tc_result hst + ; let (tidy_binds, orphan_rules, foreign_stuff) = simpl_result + + ------------------- + -- CONVERT TO STG + ------------------- + ; (stg_binds, oa_tidy_binds, cost_centre_info, top_level_ids) + <- myCoreToStg dflags this_mod tidy_binds + + + ------------------- + -- BUILD THE NEW ModDetails AND ModIface + ------------------- + ; let new_details = mkModDetails env_tc local_insts tidy_binds + top_level_ids orphan_rules + ; final_iface <- mkFinalIface dflags location maybe_checked_iface + new_iface new_details + + ------------------- + -- COMPLETE CODE GENERATION + ------------------- + ; (maybe_stub_h_filename, maybe_stub_c_filename, maybe_ibinds) + <- restOfCodeGeneration dflags toInterp this_mod + (map ideclName (hsModuleImports rdr_module)) + cost_centre_info foreign_stuff env_tc stg_binds oa_tidy_binds + hit (pcs_PIT pcs_tc) + + -- and the answer is ... + ; return (HscOK new_details (Just final_iface) + maybe_stub_h_filename maybe_stub_c_filename + maybe_ibinds pcs_tc) + }}}}}}} @@ -233,7 +244,7 @@ mkFinalIface dflags location maybe_old_iface new_iface new_details myParseModule dflags src_filename = do -------------------------- Parser ---------------- - show_pass dflags "Parser" + showPass dflags "Parser" -- _scc_ "Parser" buf <- hGetStringBuffer True{-expand tabs-} src_filename @@ -268,14 +279,12 @@ restOfCodeGeneration dflags toInterp this_mod imported_module_names cost_centre_ | otherwise = do -------------------------- Code generation ------------------------------- - show_pass dflags "CodeGen" -- _scc_ "CodeGen" abstractC <- codeGen dflags this_mod imported_modules cost_centre_info fe_binders local_tycons stg_binds -------------------------- Code output ------------------------------- - show_pass dflags "CodeOutput" -- _scc_ "CodeOutput" (maybe_stub_h_name, maybe_stub_c_name) <- codeOutput dflags this_mod local_tycons @@ -301,22 +310,18 @@ restOfCodeGeneration dflags toInterp this_mod imported_module_names cost_centre_ (ppr nm) -dsThenSimplThenTidy dflags rule_base this_mod tc_result hst +dsThenSimplThenTidy dflags rule_base this_mod print_unqual tc_result hst = do -------------------------- Desugaring ---------------- -- _scc_ "DeSugar" - show_pass dflags "DeSugar" - ds_uniqs <- mkSplitUniqSupply 'd' (desugared, rules, h_code, c_code, fe_binders) - <- deSugar dflags this_mod ds_uniqs hst tc_result + <- deSugar dflags this_mod print_unqual hst tc_result -------------------------- Main Core-language transformations ---------------- -- _scc_ "Core2Core" - show_pass dflags "Core2Core" (simplified, orphan_rules) <- core2core dflags rule_base hst desugared rules -- Do the final tidy-up - show_pass dflags "CoreTidy" (tidy_binds, tidy_orphan_rules) <- tidyCorePgm dflags this_mod simplified orphan_rules @@ -334,22 +339,16 @@ myCoreToStg dflags this_mod tidy_binds -- simplifier, which for reasons I don't understand, persists -- thoroughout code generation - show_pass dflags "Core2Stg" + showPass dflags "Core2Stg" -- _scc_ "Core2Stg" let stg_binds = topCoreBindsToStg c2s_uniqs occ_anal_tidy_binds - show_pass dflags "Stg2Stg" + showPass dflags "Stg2Stg" -- _scc_ "Stg2Stg" (stg_binds2, cost_centre_info) <- stg2stg dflags this_mod st_uniqs stg_binds let final_ids = collectFinalStgBinders (map fst stg_binds2) return (stg_binds2, occ_anal_tidy_binds, cost_centre_info, final_ids) - - -show_pass dflags what - = if dopt Opt_D_show_passes dflags - then hPutStr stderr ("*** "++what++":\n") - else return () \end{code} diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs index 498add4732..28cdcba795 100644 --- a/ghc/compiler/main/HscTypes.lhs +++ b/ghc/compiler/main/HscTypes.lhs @@ -34,17 +34,17 @@ module HscTypes ( InstEnv, ClsInstEnv, DFunId, PackageInstEnv, PackageRuleBase, - GlobalRdrEnv, RdrAvailInfo, + GlobalRdrEnv, RdrAvailInfo, pprGlobalRdrEnv, -- Provenance - Provenance(..), ImportReason(..), PrintUnqualified, + Provenance(..), ImportReason(..), pprNameProvenance, hasBetterProv ) where #include "HsVersions.h" -import RdrName ( RdrNameEnv, emptyRdrEnv ) +import RdrName ( RdrNameEnv, emptyRdrEnv, rdrEnvToList ) import Name ( Name, NamedThing, isLocallyDefined, getName, nameModule, nameSrcLoc ) import Name -- Env @@ -520,6 +520,12 @@ one for each module, corresponding to that module's top-level scope. type GlobalRdrEnv = RdrNameEnv [(Name,Provenance)] -- The list is because there may be name clashes -- These only get reported on lookup, -- not on construction + +pprGlobalRdrEnv env + = vcat (map pp (rdrEnvToList env)) + where + pp (rn, nps) = ppr rn <> colon <+> + vcat [ppr n <+> pprNameProvenance n p | (n,p) <- nps] \end{code} The "provenance" of something says how it came to be in scope. @@ -530,7 +536,6 @@ data Provenance | NonLocalDef -- Defined non-locally ImportReason - PrintUnqualified -- Just used for grouping error messages (in RnEnv.warnUnusedBinds) instance Eq Provenance where @@ -541,10 +546,10 @@ instance Eq ImportReason where instance Ord Provenance where compare LocalDef LocalDef = EQ - compare LocalDef (NonLocalDef _ _) = LT - compare (NonLocalDef _ _) LocalDef = GT + compare LocalDef (NonLocalDef _) = LT + compare (NonLocalDef _) LocalDef = GT - compare (NonLocalDef reason1 _) (NonLocalDef reason2 _) + compare (NonLocalDef reason1) (NonLocalDef reason2) = compare reason1 reason2 instance Ord ImportReason where @@ -568,11 +573,6 @@ data ImportReason -- This info is used when warning of unused names. | ImplicitImport -- Imported implicitly for some other reason - - -type PrintUnqualified = Bool -- True <=> the unqualified name of this thing is - -- in scope in this module, so print it - -- unqualified in error messages \end{code} \begin{code} @@ -581,15 +581,14 @@ hasBetterProv :: Provenance -> Provenance -> Bool -- a local thing over an imported thing -- a user-imported thing over a non-user-imported thing -- an explicitly-imported thing over an implicitly imported thing -hasBetterProv LocalDef _ = True -hasBetterProv (NonLocalDef (UserImport _ _ True) _) _ = True -hasBetterProv (NonLocalDef (UserImport _ _ _ ) _) (NonLocalDef ImplicitImport _) = True -hasBetterProv _ _ = False +hasBetterProv LocalDef _ = True +hasBetterProv (NonLocalDef (UserImport _ _ _ )) (NonLocalDef ImplicitImport) = True +hasBetterProv _ _ = False pprNameProvenance :: Name -> Provenance -> SDoc -pprNameProvenance name LocalDef = ptext SLIT("defined at") <+> ppr (nameSrcLoc name) -pprNameProvenance name (NonLocalDef why _) = sep [ppr_reason why, - nest 2 (parens (ppr_defn (nameSrcLoc name)))] +pprNameProvenance name LocalDef = ptext SLIT("defined at") <+> ppr (nameSrcLoc name) +pprNameProvenance name (NonLocalDef why) = sep [ppr_reason why, + nest 2 (parens (ppr_defn (nameSrcLoc name)))] ppr_reason ImplicitImport = ptext SLIT("implicitly imported") ppr_reason (UserImport mod loc _) = ptext SLIT("imported from") <+> ppr mod <+> ptext SLIT("at") <+> ppr loc diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index fb1e504c43..5db70c4230 100644 --- a/ghc/compiler/main/MkIface.lhs +++ b/ghc/compiler/main/MkIface.lhs @@ -41,7 +41,7 @@ import CoreSyn ( CoreExpr, CoreBind, Bind(..), CoreRule(..), IdCoreRule, ) import CoreFVs ( exprSomeFreeVars, ruleSomeLhsFreeVars, ruleSomeFreeVars ) import CoreUnfold ( okToUnfoldInHiFile, mkTopUnfolding, neverUnfold, unfoldingTemplate, noUnfolding ) -import Name ( isLocallyDefined, getName, +import Name ( isLocallyDefined, getName, nameModule, Name, NamedThing(..) ) import Name -- Env @@ -80,9 +80,10 @@ mkModDetails type_env dfun_ids tidy_binds stg_ids orphan_rules where -- The competed type environment is gotten from -- a) keeping the types and classes - -- b) removing all Ids, and Ids with correct IdInfo + -- b) removing all Ids, + -- c) adding Ids with correct IdInfo, including unfoldings, -- gotten from the bindings - -- From (b) we keep only those Ids with Global names, plus Ids + -- From (c) we keep only those Ids with Global names, plus Ids -- accessible from them (notably via unfoldings) -- This truncates the type environment to include only the -- exported Ids and things needed from them, which saves space @@ -612,9 +613,13 @@ diffDecls old_vers old_fixities new_fixities old new writeIface :: FilePath -> ModIface -> IO () writeIface hi_path mod_iface = do { if_hdl <- openFile hi_path WriteMode - ; printForIface if_hdl (pprIface mod_iface) + ; printForIface if_hdl from_this_mod (pprIface mod_iface) ; hClose if_hdl } + where + -- Print names unqualified if they are from this module + from_this_mod n = nameModule n == this_mod + this_mod = mi_module mod_iface pprIface :: ModIface -> SDoc pprIface iface diff --git a/ghc/compiler/prelude/PrelNames.lhs b/ghc/compiler/prelude/PrelNames.lhs index 391a77d20c..1ad075d69a 100644 --- a/ghc/compiler/prelude/PrelNames.lhs +++ b/ghc/compiler/prelude/PrelNames.lhs @@ -38,7 +38,7 @@ module PrelNames ( import Module ( ModuleName, mkPrelModule, mkModuleName ) import OccName ( NameSpace, UserFS, varName, dataName, tcName, clsName, mkKindOccFS ) -import RdrName ( RdrName, mkOrig, mkRdrOrig ) +import RdrName ( RdrName, mkOrig, mkRdrOrig, mkUnqual ) import UniqFM import Unique ( Unique, Uniquable(..), hasKey, mkPreludeMiscIdUnique, mkPreludeDataConUnique, @@ -241,6 +241,21 @@ mkTupConRdrName space boxity arity = case mkTupNameStr boxity arity of %************************************************************************ %* * +\subsection{Unqualified RdrNames} +%* * +%************************************************************************ + +\begin{code} +main_RDR_Unqual :: RdrName +main_RDR_Unqual = mkUnqual varName SLIT("main") +-- Don't get a RdrName from PrelNames.mainName, because nameRdrName +-- gets an Orig RdrName, and we want a Qual or Unqual one. An Unqual +-- one will do fine. +\end{code} + + +%************************************************************************ +%* * \subsection{Commonly-used RdrNames} %* * %************************************************************************ @@ -548,7 +563,6 @@ deRefStablePtr_RDR = nameRdrName deRefStablePtrName newStablePtr_RDR = nameRdrName newStablePtrName bindIO_RDR = nameRdrName bindIOName returnIO_RDR = nameRdrName returnIOName -main_RDR = nameRdrName mainName fromInteger_RDR = nameRdrName fromIntegerName fromRational_RDR = nameRdrName fromRationalName minus_RDR = nameRdrName minusName diff --git a/ghc/compiler/prelude/TysWiredIn.lhs b/ghc/compiler/prelude/TysWiredIn.lhs index 507a567f81..cd2c6eb950 100644 --- a/ghc/compiler/prelude/TysWiredIn.lhs +++ b/ghc/compiler/prelude/TysWiredIn.lhs @@ -99,7 +99,7 @@ import RdrName ( rdrNameOcc ) import DataCon ( DataCon, StrictnessMark(..), mkDataCon, dataConId ) import Var ( TyVar, tyVarKind ) import TyCon ( TyCon, AlgTyConFlavour(..), tyConDataCons, - mkTupleTyCon, isUnLiftedTyCon, mkAlgTyConRep + mkTupleTyCon, isUnLiftedTyCon, mkAlgTyCon ) import BasicTypes ( Arity, RecFlag(..), Boxity(..), isBoxed ) @@ -163,7 +163,7 @@ pcRecDataTyCon = pcTyCon DataTyCon Recursive pcTyCon new_or_data is_rec name tyvars argvrcs cons = tycon where - tycon = mkAlgTyConRep name kind + tycon = mkAlgTyCon name kind tyvars [] -- No context argvrcs diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs index 3900bb30df..ad60177718 100644 --- a/ghc/compiler/rename/Rename.lhs +++ b/ghc/compiler/rename/Rename.lhs @@ -17,7 +17,7 @@ import RnHsSyn ( RenamedHsDecl, RenamedTyClDecl, RenamedRuleDecl, RenamedInstDe instDeclFVs, tyClDeclFVs, ruleDeclFVs ) -import CmdLineOpts ( DynFlags, DynFlag(..), dopt ) +import CmdLineOpts ( DynFlags, DynFlag(..) ) import RnMonad import RnNames ( getGlobalNames ) import RnSource ( rnSourceDecls, rnTyClDecl, rnIfaceRuleDecl, rnInstDecl ) @@ -27,31 +27,31 @@ import RnIfaces ( slurpImpDecls, mkImportInfo, ) import RnHiFiles ( readIface, removeContext, loadInterface, loadExports, loadFixDecls, loadDeprecs ) -import RnEnv ( availsToNameSet, availName, +import RnEnv ( availsToNameSet, availName, emptyAvailEnv, unitAvailEnv, availEnvElts, plusAvailEnv, groupAvails, warnUnusedImports, warnUnusedLocalBinds, warnUnusedModules, - lookupOrigNames, lookupSrcName, newGlobalName + lookupOrigNames, lookupSrcName, newGlobalName, unQualInScope ) import Module ( Module, ModuleName, WhereFrom(..), moduleNameUserString, moduleName, - mkModuleInThisPackage, mkModuleName, moduleEnvElts + moduleEnvElts ) import Name ( Name, NamedThing(..), getSrcLoc, nameIsLocalOrFrom, nameOccName, nameModule, ) import Name ( mkNameEnv, nameEnvElts, extendNameEnv ) -import RdrName ( rdrEnvToList, elemRdrEnv, foldRdrEnv, isQual ) +import RdrName ( elemRdrEnv, foldRdrEnv, isQual ) import OccName ( occNameFlavour ) import NameSet import TysWiredIn ( unitTyCon, intTyCon, boolTyCon ) import PrelNames ( mAIN_Name, pREL_MAIN_Name, pRELUDE_Name, - ioTyCon_RDR, main_RDR, + ioTyCon_RDR, main_RDR_Unqual, unpackCString_RDR, unpackCStringFoldr_RDR, unpackCStringUtf8_RDR, eqString_RDR ) import PrelInfo ( derivingOccurrences ) import Type ( funTyCon ) -import ErrUtils ( dumpIfSet ) +import ErrUtils ( dumpIfSet, showPass, printErrorsAndWarnings, errorsFound ) import Bag ( bagToList ) import FiniteMap ( FiniteMap, fmToList, emptyFM, lookupFM, addToFM_C, elemFM, addToFM @@ -64,7 +64,8 @@ import HscTypes ( PersistentCompilerState, HomeIfaceTable, HomeSymbolTable, ModIface(..), WhatsImported(..), VersionInfo(..), ImportVersion, IfaceDecls, mkIfaceDecls, dcl_tycl, dcl_rules, dcl_insts, - GlobalRdrEnv, AvailEnv, GenAvailInfo(..), AvailInfo, Avails, + GlobalRdrEnv, pprGlobalRdrEnv, + AvailEnv, GenAvailInfo(..), AvailInfo, Avails, Provenance(..), ImportReason(..), initialVersionInfo, Deprecations(..), lookupDeprec, lookupIface ) @@ -84,25 +85,35 @@ renameModule :: DynFlags -> HomeIfaceTable -> HomeSymbolTable -> PersistentCompilerState -> Module -> RdrNameHsModule - -> IO (PersistentCompilerState, Maybe (ModIface, [RenamedHsDecl])) + -> IO (PersistentCompilerState, Maybe (PrintUnqualified, ModIface, [RenamedHsDecl])) -- Nothing => some error occurred in the renamer renameModule dflags hit hst old_pcs this_module rdr_module - = -- Initialise the renamer monad - do { - (new_pcs, errors_found, maybe_rn_stuff) - <- initRn dflags hit hst old_pcs this_module (rename this_module rdr_module) ; + = do { showPass dflags "Renamer" - -- Return results. No harm in updating the PCS - if errors_found then + -- Initialise the renamer monad + ; (new_pcs, msgs, maybe_rn_stuff) <- initRn dflags hit hst old_pcs this_module + (rename this_module rdr_module) + + ; let print_unqualified :: Name -> Bool -- Is this chap in scope unqualified? + print_unqualified = case maybe_rn_stuff of + Just (unqual, _, _) -> unqual + Nothing -> alwaysQualify + + + -- Print errors from renaming + ; printErrorsAndWarnings print_unqualified msgs ; + + -- Return results. No harm in updating the PCS + ; if errorsFound msgs then return (new_pcs, Nothing) - else + else return (new_pcs, maybe_rn_stuff) } \end{code} \begin{code} -rename :: Module -> RdrNameHsModule -> RnMG (Maybe (ModIface, [RenamedHsDecl])) +rename :: Module -> RdrNameHsModule -> RnMG (Maybe (PrintUnqualified, ModIface, [RenamedHsDecl])) rename this_module contents@(HsModule _ _ _ imports local_decls mod_deprec loc) = pushSrcLocRn loc $ @@ -118,6 +129,9 @@ rename this_module contents@(HsModule _ _ _ imports local_decls mod_deprec loc) returnRn Nothing else + traceRn (text "Local top-level environment" $$ + nest 4 (pprGlobalRdrEnv local_gbl_env)) `thenRn_` + -- DEAL WITH DEPRECATIONS rnDeprecs local_gbl_env mod_deprec [d | DeprecD d <- local_decls] `thenRn` \ my_deprecs -> @@ -126,9 +140,7 @@ rename this_module contents@(HsModule _ _ _ imports local_decls mod_deprec loc) fixitiesFromLocalDecls local_gbl_env local_decls `thenRn` \ local_fixity_env -> -- RENAME THE SOURCE - initRnMS gbl_env local_fixity_env SourceMode ( - rnSourceDecls local_decls - ) `thenRn` \ (rn_local_decls, source_fvs) -> + rnSourceDecls gbl_env local_fixity_env local_decls `thenRn` \ (rn_local_decls, source_fvs) -> -- CHECK THAT main IS DEFINED, IF REQUIRED checkMain this_module local_gbl_env `thenRn_` @@ -180,13 +192,16 @@ rename this_module contents@(HsModule _ _ _ imports local_decls mod_deprec loc) mi_deprecs = my_deprecs, mi_decls = panic "mi_decls" } + + print_unqualified = unQualInScope gbl_env in -- REPORT UNUSED NAMES, AND DEBUG DUMP - reportUnusedNames mod_iface imports global_avail_env + reportUnusedNames mod_iface print_unqualified + imports global_avail_env source_fvs export_avails rn_imp_decls `thenRn_` - returnRn (Just (mod_iface, final_decls)) + returnRn (Just (print_unqualified, mod_iface, final_decls)) where mod_name = moduleName this_module \end{code} @@ -197,7 +212,7 @@ Checking that main is defined checkMain :: Module -> GlobalRdrEnv -> RnMG () checkMain this_mod local_env | moduleName this_mod == mAIN_Name - = checkRn (main_RDR `elemRdrEnv` local_env) noMainErr + = checkRn (main_RDR_Unqual `elemRdrEnv` local_env) noMainErr | otherwise = returnRn () \end{code} @@ -360,18 +375,20 @@ checkOldIface :: DynFlags -- True <=> errors happened checkOldIface dflags hit hst pcs iface_path source_unchanged maybe_iface - = case maybe_iface of + = runRn dflags hit hst pcs (panic "Bogus module") $ + case maybe_iface of Just old_iface -> -- Use the one we already have - startRn (mi_module old_iface) $ - check_versions old_iface + setModuleRn (mi_module old_iface) (check_versions old_iface) + Nothing -- try and read it from a file - -> do read_result <- readIface do_traceRn iface_path - case read_result of - Left err -> -- Old interface file not found, or garbled; give up - do { ioTraceRn (text "Bad old interface file" $$ nest 4 err) ; - return (pcs, False, (outOfDate, Nothing)) } - Right parsed_iface - -> startRn (pi_mod parsed_iface) $ + -> readIface iface_path `thenRn` \ read_result -> + case read_result of + Left err -> -- Old interface file not found, or garbled; give up + traceRn (text "Bad old interface file" $$ nest 4 err) `thenRn_` + returnRn (outOfDate, Nothing) + + Right parsed_iface + -> setModuleRn (pi_mod parsed_iface) $ loadOldIface parsed_iface `thenRn` \ m_iface -> check_versions m_iface where @@ -381,10 +398,6 @@ checkOldIface dflags hit hst pcs iface_path source_unchanged maybe_iface recompileRequired iface_path source_unchanged iface `thenRn` \ recompile -> returnRn (recompile, Just iface) - - do_traceRn = dopt Opt_D_dump_rn_trace dflags - ioTraceRn sdoc = if do_traceRn then printErrs sdoc else return () - startRn mod = initRn dflags hit hst pcs mod \end{code} I think the following function should now have a more representative name, @@ -487,7 +500,7 @@ closeIfaceDecls :: DynFlags -- True <=> errors happened closeIfaceDecls dflags hit hst pcs mod_iface@(ModIface { mi_module = mod, mi_decls = iface_decls }) - = initRn dflags hit hst pcs mod $ + = runRn dflags hit hst pcs mod $ let rule_decls = dcl_rules iface_decls @@ -510,18 +523,19 @@ closeIfaceDecls dflags hit hst pcs %********************************************************* \begin{code} -reportUnusedNames :: ModIface -> [RdrNameImportDecl] +reportUnusedNames :: ModIface -> PrintUnqualified + -> [RdrNameImportDecl] -> AvailEnv -> NameSet -- Used in this module -> Avails -- Exported by this module -> [RenamedHsDecl] -> RnMG () -reportUnusedNames my_mod_iface imports avail_env +reportUnusedNames my_mod_iface unqual imports avail_env source_fvs export_avails imported_decls = warnUnusedModules unused_imp_mods `thenRn_` warnUnusedLocalBinds bad_locals `thenRn_` warnUnusedImports bad_imp_names `thenRn_` - printMinimalImports this_mod minimal_imports `thenRn_` + printMinimalImports this_mod unqual minimal_imports `thenRn_` warnDeprecations this_mod export_avails my_deprecs really_used_names @@ -570,7 +584,7 @@ reportUnusedNames my_mod_iface imports avail_env bad_locals = [n | (n,LocalDef) <- defined_but_not_used] bad_imp_names :: [(Name,Provenance)] - bad_imp_names = [(n,p) | (n,p@(NonLocalDef (UserImport mod _ True) _)) <- defined_but_not_used, + bad_imp_names = [(n,p) | (n,p@(NonLocalDef (UserImport mod _ True))) <- defined_but_not_used, not (module_unused mod)] -- inst_mods are directly-imported modules that @@ -603,9 +617,9 @@ reportUnusedNames my_mod_iface imports avail_env minimal_imports1 = foldr add_name minimal_imports0 defined_and_used minimal_imports = foldr add_inst_mod minimal_imports1 inst_mods - add_name (n,NonLocalDef (UserImport m _ _) _) acc = addToFM_C plusAvailEnv acc (moduleName (nameModule n)) - (unitAvailEnv (mk_avail n)) - add_name (n,other_prov) acc = acc + add_name (n,NonLocalDef (UserImport m _ _)) acc = addToFM_C plusAvailEnv acc (moduleName (nameModule n)) + (unitAvailEnv (mk_avail n)) + add_name (n,other_prov) acc = acc mk_avail n = case lookupNameEnv avail_env n of Just (AvailTC m _) | n==m -> AvailTC n [n] @@ -667,13 +681,13 @@ warnDeprecations this_mod export_avails my_deprecs used_names Nothing -> pprPanic "warnDeprecations:" (ppr n) -- ToDo: deal with original imports with 'qualified' and 'as M' clauses -printMinimalImports this_mod imps +printMinimalImports this_mod unqual imps = doptRn Opt_D_dump_minimal_imports `thenRn` \ dump_minimal -> if not dump_minimal then returnRn () else mapRn to_ies (fmToList imps) `thenRn` \ mod_ies -> ioToRnM (do { h <- openFile filename WriteMode ; - printForUser h (vcat (map ppr_mod_ie mod_ies)) + printForUser h unqual (vcat (map ppr_mod_ie mod_ies)) }) `thenRn_` returnRn () where @@ -764,19 +778,6 @@ getRnStats imported_decls ifaces hsep [ int n_rules_slurped, text "rule decls imported, out of", int (n_rules_slurped + n_rules_left), text "read"] ] - -count_decls decls - = (class_decls, - data_decls, - newtype_decls, - syn_decls, - val_decls, - inst_decls) - where - tycl_decls = [d | TyClD d <- decls] - (class_decls, data_decls, newtype_decls, syn_decls, val_decls) = countTyClDecls tycl_decls - - inst_decls = length [() | InstD _ <- decls] \end{code} diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index 782ae26d96..82d8993d53 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -11,7 +11,7 @@ module RnEnv where -- Export everything import HsSyn import RdrHsSyn ( RdrNameIE ) import RdrName ( RdrName, rdrNameModule, rdrNameOcc, isQual, isUnqual, isOrig, - mkRdrUnqual, mkRdrUnqual, qualifyRdrName, lookupRdrEnv + mkRdrUnqual, mkRdrUnqual, qualifyRdrName, lookupRdrEnv, foldRdrEnv ) import HsTypes ( hsTyVarName, replaceTyVarName ) import HscTypes ( Provenance(..), pprNameProvenance, hasBetterProv, @@ -539,11 +539,12 @@ in error messages. \begin{code} unQualInScope :: GlobalRdrEnv -> Name -> Bool unQualInScope env - = lookup + = (`elemNameSet` unqual_names) where - lookup name = case lookupRdrEnv env (mkRdrUnqual (nameOccName name)) of - Just [(name',_)] -> name == name' - other -> False + unqual_names :: NameSet + unqual_names = foldRdrEnv add emptyNameSet env + add rdr_name [(name,_)] unquals | isUnqual rdr_name = addOneToNameSet unquals name + add _ _ unquals = unquals \end{code} @@ -746,7 +747,7 @@ warnUnusedGroup names = case prov1 of LocalDef -> (True, getSrcLoc name1, text "Defined but not used") - NonLocalDef (UserImport mod loc _) _ + NonLocalDef (UserImport mod loc _) -> (True, loc, text "Imported from" <+> quotes (ppr mod) <+> text "but not used") reportable (name,_) = case occNameUserString (nameOccName name) of diff --git a/ghc/compiler/rename/RnHiFiles.lhs b/ghc/compiler/rename/RnHiFiles.lhs index bb16c9f19d..dc0e71d53a 100644 --- a/ghc/compiler/rename/RnHiFiles.lhs +++ b/ghc/compiler/rename/RnHiFiles.lhs @@ -17,7 +17,7 @@ module RnHiFiles ( #include "HsVersions.h" -import CmdLineOpts ( DynFlag(..), opt_IgnoreIfacePragmas ) +import CmdLineOpts ( opt_IgnoreIfacePragmas ) import HscTypes ( ModuleLocation(..), ModIface(..), emptyModIface, VersionInfo(..), @@ -56,13 +56,10 @@ import StringBuffer ( hGetStringBuffer ) import FastString ( mkFastString ) import ErrUtils ( Message ) import Finder ( findModule ) -import Util ( unJust ) import Lex import FiniteMap import Outputable import Bag - -import Monad ( when ) \end{code} @@ -478,16 +475,12 @@ findAndReadIface :: SDoc -> ModuleName findAndReadIface doc_str mod_name hi_boot_file = traceRn trace_msg `thenRn_` + ioToRnM (findModule mod_name) `thenRn` \ maybe_found -> - doptRn Opt_D_dump_rn_trace `thenRn` \ rn_trace -> case maybe_found of + Right (Just (wanted_mod,locn)) - -> ioToRnM_no_fail ( - readIface rn_trace - (unJust (ml_hi_file locn) "findAndReadIface" - ++ if hi_boot_file then "-boot" else "") - ) - `thenRn` \ read_result -> + -> readIface (mkHiPath hi_boot_file (ml_hi_file locn)) `thenRn` \ read_result -> case read_result of Left bad -> returnRn (Left bad) Right iface @@ -506,35 +499,42 @@ findAndReadIface doc_str mod_name hi_boot_file ptext SLIT("interface for"), ppr mod_name <> semi], nest 4 (ptext SLIT("reason:") <+> doc_str)] + +mkHiPath hi_boot_file (Just path) + | hi_boot_file = path ++ "-boot" + | otherwise = path \end{code} @readIface@ tries just the one file. \begin{code} -readIface :: Bool -> String -> IO (Either Message ParsedIface) +readIface :: String -> RnM d (Either Message ParsedIface) -- Nothing <=> file not found, or unreadable, or illegible -- Just x <=> successfully found and parsed -readIface tr file_path - = when tr (printErrs (ptext SLIT("readIFace") <+> text file_path)) - >> - ((hGetStringBuffer False file_path >>= \ contents -> - case parseIface contents - PState{ bol = 0#, atbol = 1#, +readIface file_path + = traceRn (ptext SLIT("readIFace") <+> text file_path) `thenRn_` + + ioToRnM (hGetStringBuffer False file_path) `thenRn` \ read_result -> + case read_result of { + Left io_error -> bale_out (text (show io_error)) ; + Right contents -> + + case parseIface contents init_parser_state of + POk _ (PIface iface) -> returnRn (Right iface) + PFailed err -> bale_out err + parse_result -> bale_out empty + -- This last case can happen if the interface file is (say) empty + -- in which case the parser thinks it looks like an IdInfo or + -- something like that. Just an artefact of the fact that the + -- parser is used for several purposes at once. + } + where + init_parser_state = PState{ bol = 0#, atbol = 1#, context = [], glasgow_exts = 1#, - loc = mkSrcLoc (mkFastString file_path) 1 } of - POk _ (PIface iface) -> return (Right iface) - PFailed err -> bale_out err - parse_result -> bale_out empty - -- This last case can happen if the interface file is (say) empty - -- in which case the parser thinks it looks like an IdInfo or - -- something like that. Just an artefact of the fact that the - -- parser is used for several purposes at once. - ) - `catch` - (\ io_err -> bale_out (text (show io_err)))) - where - bale_out err = return (Left (badIfaceFile file_path err)) + loc = mkSrcLoc (mkFastString file_path) 1 } + + bale_out err = returnRn (Left (badIfaceFile file_path err)) \end{code} diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs index 0b96e1668a..6b2fa195c0 100644 --- a/ghc/compiler/rename/RnMonad.lhs +++ b/ghc/compiler/rename/RnMonad.lhs @@ -46,7 +46,8 @@ import HscTypes ( AvailEnv, lookupType, RdrAvailInfo ) import BasicTypes ( Version, defaultFixity ) import ErrUtils ( addShortErrLocLine, addShortWarnLocLine, - pprBagOfErrors, ErrMsg, WarnMsg, Message + pprBagOfErrors, Message, Messages, errorsFound, + printErrorsAndWarnings ) import RdrName ( RdrName, dummyRdrVarName, rdrNameModule, rdrNameOcc, RdrNameEnv, emptyRdrEnv, extendRdrEnv, @@ -67,7 +68,6 @@ import Bag ( Bag, emptyBag, isEmptyBag, snocBag ) import UniqSupply import Outputable import PrelNames ( mkUnboundName ) -import ErrUtils ( printErrorsAndWarnings ) infixr 9 `thenRn`, `thenRn_` \end{code} @@ -102,7 +102,7 @@ traceHiDiffsRn msg if b then putDocRn msg else returnRn () putDocRn :: SDoc -> RnM d () -putDocRn msg = ioToRnM (printErrs msg) `thenRn_` +putDocRn msg = ioToRnM (printDump msg) `thenRn_` returnRn () \end{code} @@ -139,7 +139,7 @@ data RnDown -- The Name passed to rn_done is guaranteed to be a Global, -- so it has a Module, so it can be looked up - rn_errs :: IORef (Bag WarnMsg, Bag ErrMsg), + rn_errs :: IORef Messages, -- The second and third components are a flattened-out OrigNameEnv rn_ns :: IORef (UniqSupply, OrigNameNameEnv, OrigNameIParamEnv), @@ -300,13 +300,18 @@ type ImportedModuleInfo = FiniteMap ModuleName (WhetherHasOrphans, IsBootInterfa %************************************************************************ \begin{code} +runRn dflags hit hst pcs mod do_rn + = do { (pcs, msgs, r) <- initRn dflags hit hst pcs mod do_rn ; + printErrorsAndWarnings alwaysQualify msgs ; + return (pcs, errorsFound msgs, r) + } + initRn :: DynFlags -> HomeIfaceTable -> HomeSymbolTable -> PersistentCompilerState -> Module -> RnMG t - -> IO (PersistentCompilerState, Bool, t) - -- True <=> found errors + -> IO (PersistentCompilerState, Messages, t) initRn dflags hit hst pcs mod do_rn = do @@ -358,10 +363,7 @@ initRn dflags hit hst pcs mod do_rn let new_pcs = pcs { pcs_PIT = iPIT new_ifaces, pcs_PRS = new_prs } - -- Check for warnings - printErrorsAndWarnings (warns, errs) ; - - return (new_pcs, not (isEmptyBag errs), res) + return (new_pcs, (warns, errs), res) initRnMS rn_env fixity_env mode thing_inside rn_down g_down -- The fixity_env appears in both the rn_fixenv field diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index 0e4d05111d..cccffc3ef1 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -25,7 +25,7 @@ import RnEnv import RnMonad import FiniteMap -import PrelNames ( pRELUDE_Name, mAIN_Name, main_RDR ) +import PrelNames ( pRELUDE_Name, mAIN_Name, main_RDR_Unqual, isUnboundName ) import UniqFM ( lookupUFM ) import Bag ( bagToList ) import Module ( ModuleName, moduleName, WhereFrom(..) ) @@ -67,9 +67,6 @@ getGlobalNames this_mod (HsModule _ _ exports imports decls _ mod_loc) fixRn ( \ ~(rec_gbl_env, _, rec_export_avails, _) -> let - rec_unqual_fn :: Name -> Bool -- Is this chap in scope unqualified? - rec_unqual_fn = unQualInScope rec_gbl_env - rec_exp_fn :: Name -> Bool rec_exp_fn = mk_export_fn (availsToNameSet rec_export_avails) in @@ -89,7 +86,7 @@ getGlobalNames this_mod (HsModule _ _ exports imports decls _ mod_loc) is_source_import (ImportDecl _ ImportByUserSource _ _ _ _) = True is_source_import other = False - get_imports = importsFromImportDecl this_mod_name rec_unqual_fn + get_imports = importsFromImportDecl this_mod_name in mapAndUnzipRn get_imports ordinary `thenRn` \ (imp_gbl_envs1, imp_avails_s1) -> mapAndUnzipRn get_imports source `thenRn` \ (imp_gbl_envs2, imp_avails_s2) -> @@ -144,12 +141,11 @@ getGlobalNames this_mod (HsModule _ _ exports imports decls _ mod_loc) \begin{code} importsFromImportDecl :: ModuleName - -> (Name -> Bool) -- OK to omit qualifier -> RdrNameImportDecl -> RnMG (GlobalRdrEnv, ExportAvails) -importsFromImportDecl this_mod_name is_unqual (ImportDecl imp_mod_name from qual_only as_mod import_spec iloc) +importsFromImportDecl this_mod_name (ImportDecl imp_mod_name from qual_only as_mod import_spec iloc) = pushSrcLocRn iloc $ getInterfaceExports imp_mod_name from `thenRn` \ (imp_mod, avails_by_module) -> @@ -186,7 +182,6 @@ importsFromImportDecl this_mod_name is_unqual (ImportDecl imp_mod_name from qual let mk_provenance name = NonLocalDef (UserImport imp_mod iloc (name `elemNameSet` explicits)) - (is_unqual name) in qualifyImports imp_mod_name @@ -506,7 +501,7 @@ exportsFromAvail this_mod Nothing export_avails global_name_env = exportsFromAvail this_mod true_exports export_avails global_name_env where true_exports = Just $ if this_mod == mAIN_Name - then [IEVar main_RDR] + then [IEVar main_RDR_Unqual] -- export Main.main *only* unless otherwise specified, else [IEModuleContents this_mod] -- but for all other modules export everything. @@ -547,9 +542,10 @@ exportsFromAvail this_mod (Just export_items) -- See what's available in the current environment case lookupUFM entity_avail_env name of { - Nothing -> -- I can't see why this should ever happen; if the thing - -- is in scope at all it ought to have some availability - pprTrace "exportsFromAvail: curious Nothing:" (ppr name) + Nothing -> -- Presumably this happens because lookupSrcName didn't find + -- the name and returned an unboundName, which won't be in + -- the entity_avail_env, of course + WARN( not (isUnboundName name), ppr name ) returnRn acc ; Just avail -> diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index 42f8ce7f87..c60d850105 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -12,6 +12,7 @@ module RnSource ( rnDecl, rnTyClDecl, rnIfaceRuleDecl, rnInstDecl, rnSourceDecls import RnExpr import HsSyn +import HscTypes ( GlobalRdrEnv ) import HsTypes ( hsTyVarNames, pprHsContext ) import RdrName ( RdrName, isRdrDataCon, rdrNameOcc, mkRdrNameWkr, elemRdrEnv ) import RdrHsSyn ( RdrNameContext, RdrNameHsType, RdrNameConDecl, RdrNameTyClDecl, @@ -73,11 +74,13 @@ Checks the @(..)@ etc constraints in the export list. %********************************************************* \begin{code} -rnSourceDecls :: [RdrNameHsDecl] -> RnMS ([RenamedHsDecl], FreeVars) +rnSourceDecls :: GlobalRdrEnv -> LocalFixityEnv + -> [RdrNameHsDecl] + -> RnMG ([RenamedHsDecl], FreeVars) -- The decls get reversed, but that's ok -rnSourceDecls decls - = go emptyFVs [] decls +rnSourceDecls gbl_env local_fixity_env decls + = initRnMS gbl_env local_fixity_env SourceMode (go emptyFVs [] decls) where -- Fixity and deprecations have been dealt with already; ignore them go fvs ds' [] = returnRn (ds', fvs) diff --git a/ghc/compiler/simplCore/CSE.lhs b/ghc/compiler/simplCore/CSE.lhs index b2e124a52f..c659230c42 100644 --- a/ghc/compiler/simplCore/CSE.lhs +++ b/ghc/compiler/simplCore/CSE.lhs @@ -19,7 +19,7 @@ import Subst ( InScopeSet, uniqAway, emptyInScopeSet, extendInScopeSet, elemInScopeSet ) import CoreSyn import VarEnv -import CoreLint ( beginPass, endPass ) +import CoreLint ( showPass, endPass ) import Outputable import Util ( mapAccumL ) import UniqFM @@ -107,7 +107,7 @@ cseProgram :: DynFlags -> [CoreBind] -> IO [CoreBind] cseProgram dflags binds = do { - beginPass dflags "Common sub-expression"; + showPass dflags "Common sub-expression"; let { binds' = cseBinds emptyCSEnv binds }; endPass dflags "Common sub-expression" (dopt Opt_D_dump_cse dflags || dopt Opt_D_verbose_core2core dflags) diff --git a/ghc/compiler/simplCore/FloatIn.lhs b/ghc/compiler/simplCore/FloatIn.lhs index 796cddf9fa..f974d12f1b 100644 --- a/ghc/compiler/simplCore/FloatIn.lhs +++ b/ghc/compiler/simplCore/FloatIn.lhs @@ -19,7 +19,7 @@ module FloatIn ( floatInwards ) where import CmdLineOpts ( DynFlags, DynFlag(..), dopt ) import CoreSyn import CoreUtils ( exprIsValue, exprIsDupable ) -import CoreLint ( beginPass, endPass ) +import CoreLint ( showPass, endPass ) import CoreFVs ( CoreExprWithFVs, freeVars, freeVarsOf ) import Id ( isOneShotLambda ) import Var ( Id, idType, isTyVar ) @@ -37,7 +37,7 @@ floatInwards :: DynFlags -> [CoreBind] -> IO [CoreBind] floatInwards dflags binds = do { - beginPass dflags "Float inwards"; + showPass dflags "Float inwards"; let { binds' = map fi_top_bind binds }; endPass dflags "Float inwards" (dopt Opt_D_verbose_core2core dflags) diff --git a/ghc/compiler/simplCore/FloatOut.lhs b/ghc/compiler/simplCore/FloatOut.lhs index 2d593e03b4..fdc20bf707 100644 --- a/ghc/compiler/simplCore/FloatOut.lhs +++ b/ghc/compiler/simplCore/FloatOut.lhs @@ -18,7 +18,7 @@ import ErrUtils ( dumpIfSet_dyn ) import CostCentre ( dupifyCC, CostCentre ) import Id ( Id ) import VarEnv -import CoreLint ( beginPass, endPass ) +import CoreLint ( showPass, endPass ) import SetLevels ( setLevels, Level(..), tOP_LEVEL, ltMajLvl, ltLvl, isTopLvl ) @@ -80,7 +80,7 @@ floatOutwards :: DynFlags floatOutwards dflags float_lams us pgm = do { - beginPass dflags float_msg ; + showPass dflags float_msg ; let { annotated_w_levels = setLevels float_lams pgm us ; (fss, binds_s') = unzip (map floatTopBind annotated_w_levels) diff --git a/ghc/compiler/simplCore/LiberateCase.lhs b/ghc/compiler/simplCore/LiberateCase.lhs index e15843bb99..5d4d921110 100644 --- a/ghc/compiler/simplCore/LiberateCase.lhs +++ b/ghc/compiler/simplCore/LiberateCase.lhs @@ -9,7 +9,7 @@ module LiberateCase ( liberateCase ) where #include "HsVersions.h" import CmdLineOpts ( DynFlags, DynFlag(..), dopt, opt_LiberateCaseThreshold ) -import CoreLint ( beginPass, endPass ) +import CoreLint ( showPass, endPass ) import CoreSyn import CoreUnfold ( couldBeSmallEnoughToInline ) import Var ( Id ) @@ -151,7 +151,7 @@ Programs liberateCase :: DynFlags -> [CoreBind] -> IO [CoreBind] liberateCase dflags binds = do { - beginPass dflags "Liberate case" ; + showPass dflags "Liberate case" ; let { binds' = do_prog (initEnv opt_LiberateCaseThreshold) binds } ; endPass dflags "Liberate case" (dopt Opt_D_verbose_core2core dflags) diff --git a/ghc/compiler/simplCore/SAT.lhs b/ghc/compiler/simplCore/SAT.lhs index ed76213bf5..81f3c4c406 100644 --- a/ghc/compiler/simplCore/SAT.lhs +++ b/ghc/compiler/simplCore/SAT.lhs @@ -57,7 +57,7 @@ doStaticArgs :: [CoreBind] -> UniqSupply -> [CoreBind] doStaticArgs binds = do { - beginPass "Static argument"; + showPass "Static argument"; let { binds' = initSAT (mapSAT sat_bind binds) }; endPass "Static argument" False -- No specific flag for dumping SAT diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs index 2bb6b9351a..7b9ae306d8 100644 --- a/ghc/compiler/simplCore/SimplCore.lhs +++ b/ghc/compiler/simplCore/SimplCore.lhs @@ -13,7 +13,7 @@ import CmdLineOpts ( CoreToDo(..), SimplifierSwitch(..), opt_UsageSPOn, DynFlags, DynFlag(..), dopt, dopt_CoreToDo ) -import CoreLint ( beginPass, endPass ) +import CoreLint ( showPass, endPass ) import CoreSyn import CoreFVs ( ruleSomeFreeVars ) import HscTypes ( PackageRuleBase, HomeSymbolTable, ModDetails(..) ) @@ -297,7 +297,7 @@ glomBinds :: DynFlags -> [CoreBind] -> IO [CoreBind] -- analyser as free in f. glomBinds dflags binds - = do { beginPass dflags "GlomBinds" ; + = do { showPass dflags "GlomBinds" ; let { recd_binds = [Rec (flattenBinds binds)] } ; return recd_binds } -- Not much point in printing the result... @@ -322,7 +322,7 @@ simplifyPgm :: DynFlags simplifyPgm dflags rule_base sw_chkr us binds = do { - beginPass dflags "Simplify"; + showPass dflags "Simplify"; (termination_msg, it_count, counts_out, binds') <- iteration us 1 (zeroSimplCount dflags) binds; diff --git a/ghc/compiler/simplStg/SimplStg.lhs b/ghc/compiler/simplStg/SimplStg.lhs index 07c5be3182..e766257dca 100644 --- a/ghc/compiler/simplStg/SimplStg.lhs +++ b/ghc/compiler/simplStg/SimplStg.lhs @@ -44,7 +44,7 @@ stg2stg :: DynFlags -- includes spec of what stg-to-stg passes to do stg2stg dflags module_name us binds = case (splitUniqSupply us) of { (us4now, us4later) -> - doIfSet_dyn dflags Opt_D_verbose_stg2stg (printErrs (text "VERBOSE STG-TO-STG:")) >> + doIfSet_dyn dflags Opt_D_verbose_stg2stg (printDump (text "VERBOSE STG-TO-STG:")) >> end_pass us4now "Core2Stg" ([],[],[]) binds >>= \ (binds', us, ccs) -> diff --git a/ghc/compiler/specialise/Specialise.lhs b/ghc/compiler/specialise/Specialise.lhs index 9952c924cc..095b7e2b43 100644 --- a/ghc/compiler/specialise/Specialise.lhs +++ b/ghc/compiler/specialise/Specialise.lhs @@ -29,7 +29,7 @@ import CoreSyn import CoreUtils ( applyTypeToArgs ) import CoreUnfold ( certainlyWillInline ) import CoreFVs ( exprFreeVars, exprsFreeVars ) -import CoreLint ( beginPass, endPass ) +import CoreLint ( showPass, endPass ) import PprCore ( pprCoreRules ) import Rules ( addIdSpecialisations, lookupRule ) @@ -580,7 +580,7 @@ Hence, the invariant is this: specProgram :: DynFlags -> UniqSupply -> [CoreBind] -> IO [CoreBind] specProgram dflags us binds = do - beginPass dflags "Specialise" + showPass dflags "Specialise" let binds' = initSM us (go binds `thenSM` \ (binds', uds') -> returnSM (dumpAllDictBinds uds' binds')) diff --git a/ghc/compiler/stgSyn/StgLint.lhs b/ghc/compiler/stgSyn/StgLint.lhs index 433ab2a1da..7818f32a13 100644 --- a/ghc/compiler/stgSyn/StgLint.lhs +++ b/ghc/compiler/stgSyn/StgLint.lhs @@ -375,7 +375,7 @@ addErr errs_so_far msg locs = errs_so_far `snocBag` mk_msg locs where mk_msg (loc:_) = let (l,hdr) = dumpLoc loc in addErrLocHdrLine l hdr msg - mk_msg [] = dontAddErrLoc "" msg + mk_msg [] = dontAddErrLoc msg addLoc :: LintLocInfo -> LintM a -> LintM a addLoc extra_loc m loc scope errs diff --git a/ghc/compiler/stranal/StrictAnal.lhs b/ghc/compiler/stranal/StrictAnal.lhs index 2c319992c4..4c85197f05 100644 --- a/ghc/compiler/stranal/StrictAnal.lhs +++ b/ghc/compiler/stranal/StrictAnal.lhs @@ -18,7 +18,7 @@ import Id ( setIdStrictness, setInlinePragma, Id ) import IdInfo ( neverInlinePrag ) -import CoreLint ( beginPass, endPass ) +import CoreLint ( showPass, endPass ) import ErrUtils ( dumpIfSet_dyn ) import SaAbsInt import SaLib @@ -83,7 +83,7 @@ saBinds :: DynFlags -> [CoreBind] -> IO [CoreBind] saBinds dflags binds = do { - beginPass dflags "Strictness analysis"; + showPass dflags "Strictness analysis"; -- Mark each binder with its strictness #ifndef OMIT_STRANAL_STATS diff --git a/ghc/compiler/stranal/WorkWrap.lhs b/ghc/compiler/stranal/WorkWrap.lhs index 305261cec7..a128688ba6 100644 --- a/ghc/compiler/stranal/WorkWrap.lhs +++ b/ghc/compiler/stranal/WorkWrap.lhs @@ -10,7 +10,7 @@ module WorkWrap ( wwTopBinds, mkWrapper ) where import CoreSyn import CoreUnfold ( certainlyWillInline ) -import CoreLint ( beginPass, endPass ) +import CoreLint ( showPass, endPass ) import CoreUtils ( exprType ) import MkId ( mkWorkerId ) import Id ( Id, idType, idStrictness, idArity, isOneShotLambda, @@ -63,7 +63,7 @@ wwTopBinds :: DynFlags wwTopBinds dflags us binds = do { - beginPass dflags "Worker Wrapper binds"; + showPass dflags "Worker Wrapper binds"; -- Create worker/wrappers, and mark binders with their -- "strictness info" [which encodes their worker/wrapper-ness] diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs index 41e366eecb..758dbaa6bf 100644 --- a/ghc/compiler/typecheck/TcGenDeriv.lhs +++ b/ghc/compiler/typecheck/TcGenDeriv.lhs @@ -34,7 +34,7 @@ import HsSyn ( InPat(..), HsExpr(..), MonoBinds(..), import RdrHsSyn ( mkHsOpApp, RdrNameMonoBinds, RdrNameHsExpr, RdrNamePat ) import RdrName ( RdrName, mkUnqual ) import BasicTypes ( RecFlag(..), Fixity(..), FixityDirection(..) - , maxPrecedence + , maxPrecedence, defaultFixity , Boxity(..) ) import FieldLabel ( fieldLabelName ) @@ -60,7 +60,7 @@ import TysPrim ( charPrimTy, intPrimTy, wordPrimTy, addrPrimTy, import Util ( mapAccumL, zipEqual, zipWithEqual, zipWith3Equal, nOfThem ) import Panic ( panic, assertPanic ) -import Maybes ( maybeToBool ) +import Maybes ( maybeToBool, orElse ) import Constants import List ( partition, intersperse ) import Outputable ( pprPanic, ppr, pprTrace ) @@ -1060,15 +1060,14 @@ getPrecedence :: (Name -> Maybe Fixity) -> Name -> Integer getPrecedence get_fixity nm = case get_fixity nm of Just (Fixity x _) -> fromInt x - other -> pprTrace "TcGenDeriv.getPrecedence" (ppr nm) defaultPrecedence + other -> defaultPrecedence isLRAssoc :: (Name -> Maybe Fixity) -> Name -> (Bool, Bool) isLRAssoc get_fixity nm = - case get_fixity nm of - Just (Fixity _ InfixN) -> (False, False) - Just (Fixity _ InfixR) -> (False, True) - Just (Fixity _ InfixL) -> (True, False) - other -> pprPanic "TcGenDeriv.isLRAssoc" (ppr nm) + case get_fixity nm `orElse` defaultFixity of + Fixity _ InfixN -> (False, False) + Fixity _ InfixR -> (False, True) + Fixity _ InfixL -> (True, False) isInfixOccName :: String -> Bool isInfixOccName str = diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index 8b145d504d..f8ec3040e7 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -580,7 +580,7 @@ tcInstDecl2 (InstInfo { iLocal = is_local, iDFunId = dfun_id, methods_lie = plusLIEs insts_needed_s in - -- Ditto method bindings + -- Simplify the constraints from methods tcAddErrCtxt methodCtxt ( tcSimplifyAndCheck (ptext SLIT("instance declaration context")) @@ -589,11 +589,9 @@ tcInstDecl2 (InstInfo { iLocal = is_local, iDFunId = dfun_id, methods_lie ) `thenTc` \ (const_lie1, lie_binds1) -> - -- Now do the simplification again, this time to get the - -- bindings; this time we use an enhanced "avails" - -- Ignore errors because they come from the *previous* tcSimplify - discardErrsTc ( - tcSimplifyAndCheck + -- Figure out bindings for the superclass context + tcAddErrCtxt superClassCtxt ( + tcSimplifyAndCheck (ptext SLIT("instance declaration context")) inst_tyvars_set dfun_arg_dicts -- NB! Don't include this_dict here, else the sc_dicts @@ -788,6 +786,5 @@ nonBoxedPrimCCallErr clas inst_ty ppr inst_ty]) methodCtxt = ptext SLIT("When checking the methods of an instance declaration") +superClassCtxt = ptext SLIT("When checking the super-classes of an instance declaration") \end{code} - - diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs index 65257fdcf7..6ecaff177a 100644 --- a/ghc/compiler/typecheck/TcModule.lhs +++ b/ghc/compiler/typecheck/TcModule.lhs @@ -40,7 +40,7 @@ import TcTyDecls ( mkImplicitDataBinds ) import CoreUnfold ( unfoldingTemplate ) import Type ( funResultTy, splitForAllTys ) import Bag ( isEmptyBag ) -import ErrUtils ( printErrorsAndWarnings, dumpIfSet_dyn ) +import ErrUtils ( printErrorsAndWarnings, dumpIfSet_dyn, showPass ) import Id ( idType, idUnfolding ) import Module ( Module ) import Name ( Name, toRdrName ) @@ -81,26 +81,29 @@ typecheckModule -> PersistentCompilerState -> HomeSymbolTable -> ModIface -- Iface for this module + -> PrintUnqualified -- For error printing -> [RenamedHsDecl] -> IO (Maybe TcResults) -typecheckModule dflags this_mod pcs hst mod_iface decls - = do env <- initTcEnv hst (pcs_PTE pcs) +typecheckModule dflags this_mod pcs hst mod_iface unqual decls + = do { showPass dflags "Typechecker"; + ; env <- initTcEnv hst (pcs_PTE pcs) - (maybe_result, (warns,errs)) <- initTc dflags env tc_module + ; (maybe_result, (warns,errs)) <- initTc dflags env tc_module - let { maybe_tc_result :: Maybe TcResults ; - maybe_tc_result = case maybe_result of - Nothing -> Nothing - Just (_,r) -> Just r } + ; let { maybe_tc_result :: Maybe TcResults ; + maybe_tc_result = case maybe_result of + Nothing -> Nothing + Just (_,r) -> Just r } - printErrorsAndWarnings (errs,warns) - printTcDump dflags maybe_tc_result + ; printErrorsAndWarnings unqual (errs,warns) + ; printTcDump dflags maybe_tc_result - if isEmptyBag errs then + ; if isEmptyBag errs then return maybe_tc_result else return Nothing + } where tc_module :: TcM (RecTcEnv, TcResults) tc_module = fixTc (\ ~(unf_env ,_) -> tcModule pcs hst get_fixity this_mod decls unf_env) diff --git a/ghc/compiler/typecheck/TcMonad.lhs b/ghc/compiler/typecheck/TcMonad.lhs index 4d38539e6c..c50e6fe502 100644 --- a/ghc/compiler/typecheck/TcMonad.lhs +++ b/ghc/compiler/typecheck/TcMonad.lhs @@ -270,7 +270,7 @@ forkNF_Tc m (TcDown dflags deflts u_var df_var src_loc err_cxt err_var) env \begin{code} traceTc :: SDoc -> NF_TcM () -traceTc doc down env = printErrs doc +traceTc doc down env = printDump doc ioToTc :: IO a -> NF_TcM a ioToTc io down env = io diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs index 5d430e6336..d046461651 100644 --- a/ghc/compiler/typecheck/TcSimplify.lhs +++ b/ghc/compiler/typecheck/TcSimplify.lhs @@ -1262,8 +1262,8 @@ addTopInstanceErr dict addNoInstanceErr str givens dict = tcGetInstEnv `thenNF_Tc` \ inst_env -> let - doc = vcat [herald <+> quotes (pprInst tidy_dict), - nest 4 $ ptext SLIT("from the context") <+> pprInsts tidy_givens, + doc = vcat [sep [herald <+> quotes (pprInst tidy_dict), + nest 4 $ ptext SLIT("from the context") <+> pprInsts tidy_givens], ambig_doc, ptext SLIT("Probable fix:"), nest 4 fix1, diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs index 785a5695b3..0698390094 100644 --- a/ghc/compiler/typecheck/TcTyClsDecls.lhs +++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs @@ -35,7 +35,7 @@ import Type ( Kind, mkArrowKind, boxedTypeKind, zipFunTys ) import Variance ( calcTyConArgVrcs ) import Class ( Class, mkClass, classTyCon ) import TyCon ( TyCon, tyConKind, ArgVrcs, AlgTyConFlavour(..), - mkSynTyCon, mkAlgTyConRep, mkClassTyCon ) + mkSynTyCon, mkAlgTyCon, mkClassTyCon ) import DataCon ( isNullaryDataCon ) import Var ( varName ) import FiniteMap @@ -311,7 +311,7 @@ buildTyConOrClass dflags is_rec kenv rec_vrcs rec_details (TyData data_or_new context tycon_name tyvar_names _ nconstrs _ src_loc name1 name2) = (tycon_name, ATyCon tycon) where - tycon = mkAlgTyConRep tycon_name tycon_kind tyvars ctxt argvrcs + tycon = mkAlgTyCon tycon_name tycon_kind tyvars ctxt argvrcs data_cons nconstrs flavour is_rec gen_info diff --git a/ghc/compiler/types/TyCon.lhs b/ghc/compiler/types/TyCon.lhs index bee967c94d..b5f09088ee 100644 --- a/ghc/compiler/types/TyCon.lhs +++ b/ghc/compiler/types/TyCon.lhs @@ -13,7 +13,7 @@ module TyCon( isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, tupleTyConBoxity, isRecursiveTyCon, newTyConRep, - mkAlgTyConRep, --mkAlgTyCon, + mkAlgTyCon, --mkAlgTyCon, mkClassTyCon, mkFunTyCon, mkPrimTyCon, @@ -238,7 +238,7 @@ tyConGenIds tycon = case tyConGenInfo tycon of -- This is the making of a TyCon. Just the same as the old mkAlgTyCon, -- but now you also have to pass in the generic information about the type -- constructor - you can get hold of it easily (see Generics module) -mkAlgTyConRep name kind tyvars theta argvrcs cons ncons flavour rec +mkAlgTyCon name kind tyvars theta argvrcs cons ncons flavour rec gen_info = AlgTyCon { tyConName = name, diff --git a/ghc/compiler/usageSP/UsageSPInf.lhs b/ghc/compiler/usageSP/UsageSPInf.lhs index 5ef0c4b5b5..ba3291d679 100644 --- a/ghc/compiler/usageSP/UsageSPInf.lhs +++ b/ghc/compiler/usageSP/UsageSPInf.lhs @@ -37,7 +37,7 @@ import Outputable import Maybes ( expectJust ) import List ( unzip4 ) import CmdLineOpts ( DynFlags, DynFlag(..), dopt, opt_UsageSPOn ) -import CoreLint ( beginPass, endPass ) +import CoreLint ( showPass, endPass ) import ErrUtils ( doIfSet_dyn, dumpIfSet_dyn ) import PprCore ( pprCoreBindings ) \end{code} @@ -93,7 +93,7 @@ doUsageSPInf :: DynFlags doUsageSPInf dflags us binds | not opt_UsageSPOn - = do { printErrs (text "WARNING: ignoring requested -fusagesp pass; requires -fusagesp-on") ; + = do { printDump (text "WARNING: ignoring requested -fusagesp pass; requires -fusagesp-on") ; return binds } @@ -108,7 +108,7 @@ doUsageSPInf dflags us binds = do let binds1 = doUnAnnotBinds binds - beginPass dflags "UsageSPInf" + showPass dflags "UsageSPInf" dumpIfSet_dyn dflags Opt_D_dump_usagesp "UsageSPInf unannot'd" $ pprCoreBindings binds1 diff --git a/ghc/compiler/usageSP/UsageSPLint.lhs b/ghc/compiler/usageSP/UsageSPLint.lhs index bfbb5e7988..97da3eea15 100644 --- a/ghc/compiler/usageSP/UsageSPLint.lhs +++ b/ghc/compiler/usageSP/UsageSPLint.lhs @@ -74,7 +74,7 @@ doCheckIfWorseUSP :: [CoreBind] -> [CoreBind] -> IO () doCheckIfWorseUSP binds binds' = case checkIfWorseUSP binds binds' of Nothing -> return () - Just warns -> printErrs warns + Just warns -> printDump warns \end{code} ====================================================================== diff --git a/ghc/compiler/utils/Outputable.lhs b/ghc/compiler/utils/Outputable.lhs index 2ec5c52289..1c989b4bad 100644 --- a/ghc/compiler/utils/Outputable.lhs +++ b/ghc/compiler/utils/Outputable.lhs @@ -14,10 +14,10 @@ Defines classes for pretty-printing and forcing, both forms of module Outputable ( Outputable(..), -- Class - PprStyle, CodeStyle(..), + PprStyle, CodeStyle(..), PrintUnqualified, alwaysQualify, getPprStyle, withPprStyle, pprDeeper, codeStyle, ifaceStyle, userStyle, debugStyle, asmStyle, - ifPprDebug, ifNotPprForUser, + ifPprDebug, unqualStyle, SDoc, -- Abstract interppSP, interpp'SP, pprQuotedList, pprWithCommas, @@ -37,7 +37,7 @@ module Outputable ( printSDoc, printErrs, printDump, printForC, printForAsm, printForIface, printForUser, pprCode, pprCols, - showSDoc, showSDocDebug, showSDocIface, showsPrecSDoc, + showSDoc, showSDocDebug, showSDocIface, showSDocUnqual, showsPrecSDoc, pprHsChar, pprHsString, @@ -49,6 +49,8 @@ module Outputable ( #include "HsVersions.h" +import {-# SOURCE #-} Name( Name ) + import IO ( Handle, hPutChar, hPutStr, stderr, stdout ) import CmdLineOpts ( opt_PprStyle_Debug, opt_PprUserLength ) import FastString @@ -67,23 +69,36 @@ import Char ( chr, ord, isDigit ) \begin{code} data PprStyle - = PprUser Depth -- Pretty-print in a way that will - -- make sense to the ordinary user; - -- must be very close to Haskell - -- syntax, etc. - - | PprDebug -- Standard debugging output + = PprUser PrintUnqualified Depth -- Pretty-print in a way that will + -- make sense to the ordinary user; + -- must be very close to Haskell + -- syntax, etc. - | PprInterface -- Interface generation + | PprInterface PrintUnqualified -- Interface generation | PprCode CodeStyle -- Print code; either C or assembler + | PprDebug -- Standard debugging output data CodeStyle = CStyle -- The format of labels differs for C and assembler | AsmStyle data Depth = AllTheWay | PartWay Int -- 0 => stop + + +type PrintUnqualified = Name -> Bool + -- This function tells when it's ok to print + -- a (Global) name unqualified + +alwaysQualify,neverQualify :: PrintUnqualified +alwaysQualify n = False +neverQualify n = True + +defaultUserStyle = mkUserStyle alwaysQualify AllTheWay + +mkUserStyle unqual depth | opt_PprStyle_Debug = PprDebug + | otherwise = PprUser unqual depth \end{code} Orthogonal to the above printing styles are (possibly) some @@ -107,15 +122,20 @@ withPprStyle :: PprStyle -> SDoc -> SDoc withPprStyle sty d sty' = d sty pprDeeper :: SDoc -> SDoc -pprDeeper d (PprUser (PartWay 0)) = Pretty.text "..." -pprDeeper d (PprUser (PartWay n)) = d (PprUser (PartWay (n-1))) -pprDeeper d other_sty = d other_sty +pprDeeper d (PprUser unqual (PartWay 0)) = Pretty.text "..." +pprDeeper d (PprUser unqual (PartWay n)) = d (PprUser unqual (PartWay (n-1))) +pprDeeper d other_sty = d other_sty getPprStyle :: (PprStyle -> SDoc) -> SDoc getPprStyle df sty = df sty sty \end{code} \begin{code} +unqualStyle :: PprStyle -> Name -> Bool +unqualStyle (PprUser unqual _) n = unqual n +unqualStyle (PprInterface unqual) n = unqual n +unqualStyle other n = False + codeStyle :: PprStyle -> Bool codeStyle (PprCode _) = True codeStyle _ = False @@ -125,22 +145,16 @@ asmStyle (PprCode AsmStyle) = True asmStyle other = False ifaceStyle :: PprStyle -> Bool -ifaceStyle PprInterface = True -ifaceStyle other = False +ifaceStyle (PprInterface _) = True +ifaceStyle other = False debugStyle :: PprStyle -> Bool debugStyle PprDebug = True debugStyle other = False userStyle :: PprStyle -> Bool -userStyle (PprUser _) = True -userStyle other = False -\end{code} - -\begin{code} -ifNotPprForUser :: SDoc -> SDoc -- Returns empty document for User style -ifNotPprForUser d sty@(PprUser _) = Pretty.empty -ifNotPprForUser d sty = d sty +userStyle (PprUser _ _) = True +userStyle other = False ifPprDebug :: SDoc -> SDoc -- Empty for non-debug style ifPprDebug d sty@PprDebug = d sty @@ -153,20 +167,28 @@ printSDoc d sty = printDoc PageMode stdout (d sty) -- I'm not sure whether the direct-IO approach of printDoc -- above is better or worse than the put-big-string approach here -printErrs :: SDoc -> IO () -printErrs doc = printDoc PageMode stderr (final_doc user_style) - where - final_doc = doc -- $$ text "" - user_style = mkUserStyle (PartWay opt_PprUserLength) +printErrs :: PrintUnqualified -> SDoc -> IO () +printErrs unqual doc = printDoc PageMode stderr (doc style) + where + style = mkUserStyle unqual (PartWay opt_PprUserLength) printDump :: SDoc -> IO () -printDump doc = printForUser stdout (doc $$ text "") - -- We used to always print in debug style, but I want - -- to try the effect of a more user-ish style (unless you - -- say -dppr-debug +printDump doc = printDoc PageMode stdout (better_doc defaultUserStyle) + where + better_doc = doc $$ text "" + -- We used to always print in debug style, but I want + -- to try the effect of a more user-ish style (unless you + -- say -dppr-debug -printForUser :: Handle -> SDoc -> IO () -printForUser handle doc = printDoc PageMode handle (doc (mkUserStyle AllTheWay)) +printForUser :: Handle -> PrintUnqualified -> SDoc -> IO () +printForUser handle unqual doc + = printDoc PageMode handle (doc (mkUserStyle unqual AllTheWay)) + +-- printForIface prints all on one line for interface files. +-- It's called repeatedly for successive lines +printForIface :: Handle -> PrintUnqualified -> SDoc -> IO () +printForIface handle unqual doc + = printDoc LeftMode handle (doc (PprInterface unqual)) -- printForC, printForAsm do what they sound like printForC :: Handle -> SDoc -> IO () @@ -175,11 +197,6 @@ printForC handle doc = printDoc LeftMode handle (doc (PprCode CStyle)) printForAsm :: Handle -> SDoc -> IO () printForAsm handle doc = printDoc LeftMode handle (doc (PprCode AsmStyle)) --- printForIface prints all on one line for interface files. --- It's called repeatedly for successive lines -printForIface :: Handle -> SDoc -> IO () -printForIface handle doc = printDoc LeftMode handle (doc PprInterface) - pprCode :: CodeStyle -> SDoc -> SDoc pprCode cs d = withPprStyle (PprCode cs) d @@ -187,19 +204,20 @@ pprCode cs d = withPprStyle (PprCode cs) d -- However, Doc *is* an instance of Show -- showSDoc just blasts it out as a string showSDoc :: SDoc -> String -showSDoc d = show (d (mkUserStyle AllTheWay)) +showSDoc d = show (d defaultUserStyle) + +showSDocUnqual :: SDoc -> String +-- Only used in the gruesome HsExpr.isOperator +showSDocUnqual d = show (d (mkUserStyle neverQualify AllTheWay)) + +showsPrecSDoc :: Int -> SDoc -> ShowS +showsPrecSDoc p d = showsPrec p (d defaultUserStyle) showSDocIface :: SDoc -> String -showSDocIface doc = showDocWith OneLineMode (doc PprInterface) +showSDocIface doc = showDocWith OneLineMode (doc (PprInterface alwaysQualify)) showSDocDebug :: SDoc -> String showSDocDebug d = show (d PprDebug) - -showsPrecSDoc :: Int -> SDoc -> ShowS -showsPrecSDoc p d = showsPrec p (d (mkUserStyle AllTheWay)) - -mkUserStyle depth | opt_PprStyle_Debug = PprDebug - | otherwise = PprUser depth \end{code} \begin{code} |