#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 )
-- 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')
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
%
% (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 $
%
%********************************************************
%* *
[ 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
import TyCon ( TyCon, isDataTyCon )
import BasicTypes ( TopLevelFlag(..) )
import UniqSupply ( mkSplitUniqSupply )
-import ErrUtils ( dumpIfSet_dyn )
+import ErrUtils ( dumpIfSet_dyn, showPass )
import Panic ( assertPanic )
\end{code}
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
module CoreLint (
lintCoreBindings,
lintUnfolding,
- beginPass, endPass, endPassWithRules
+ showPass, endPass, endPassWithRules
) where
#include "HsVersions.h"
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 )
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
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
import Module ( Module )
import UniqSupply ( mkSplitUniqSupply )
import Unique ( Uniquable(..) )
+import ErrUtils ( showPass )
import SrcLoc ( noSrcLoc )
import Util ( mapAccumL )
\end{code}
= do
us <- mkSplitUniqSupply 'u'
- beginPass dflags "Tidy Core"
+ showPass dflags "Tidy Core"
binds_in1 <- if opt_UsageSPOn
then _scc_ "CoreUsageSPInf"
#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,
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)
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}
\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
| 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
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}
%************************************************************************
-- others:
import Name ( Name, isLexSym )
import Outputable
-import PprType ( pprType, pprParendType )
+import PprType ( pprParendType )
import Type ( Type )
import Var ( TyVar )
import DataCon ( DataCon )
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)))
\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.
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 )
-- 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
\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
\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 )
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
)
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
\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 ()
#include "HsVersions.h"
import Maybe ( isJust )
-import IO ( hPutStr, hPutStrLn, stderr )
+import IO ( hPutStrLn, stderr )
import HsSyn
import StringBuffer ( hGetStringBuffer )
import Module ( ModuleName, moduleName, mkModuleInThisPackage )
import CmdLineOpts
-import ErrUtils ( dumpIfSet_dyn )
+import ErrUtils ( dumpIfSet_dyn, showPass )
import Util ( unJust )
import UniqSupply ( mkSplitUniqSupply )
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 {
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 {
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)
+ }}}}}}}
myParseModule dflags src_filename
= do -------------------------- Parser ----------------
- show_pass dflags "Parser"
+ showPass dflags "Parser"
-- _scc_ "Parser"
buf <- hGetStringBuffer True{-expand tabs-} src_filename
| 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
(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
-- 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}
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
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.
| NonLocalDef -- Defined non-locally
ImportReason
- PrintUnqualified
-- Just used for grouping error messages (in RnEnv.warnUnusedBinds)
instance Eq Provenance 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
-- 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}
-- 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
)
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
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
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
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,
%************************************************************************
%* *
+\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}
%* *
%************************************************************************
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
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 )
pcTyCon new_or_data is_rec name tyvars argvrcs cons
= tycon
where
- tycon = mkAlgTyConRep name kind
+ tycon = mkAlgTyCon name kind
tyvars
[] -- No context
argvrcs
instDeclFVs, tyClDeclFVs, ruleDeclFVs
)
-import CmdLineOpts ( DynFlags, DynFlag(..), dopt )
+import CmdLineOpts ( DynFlags, DynFlag(..) )
import RnMonad
import RnNames ( getGlobalNames )
import RnSource ( rnSourceDecls, rnTyClDecl, rnIfaceRuleDecl, rnInstDecl )
)
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
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
)
-> 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 $
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 ->
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_`
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}
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}
-- 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
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,
-- 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
%*********************************************************
\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
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
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]
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
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}
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,
\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}
= 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
#include "HsVersions.h"
-import CmdLineOpts ( DynFlag(..), opt_IgnoreIfacePragmas )
+import CmdLineOpts ( opt_IgnoreIfacePragmas )
import HscTypes ( ModuleLocation(..),
ModIface(..), emptyModIface,
VersionInfo(..),
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}
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
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}
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,
import UniqSupply
import Outputable
import PrelNames ( mkUnboundName )
-import ErrUtils ( printErrorsAndWarnings )
infixr 9 `thenRn`, `thenRn_`
\end{code}
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}
-- 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),
%************************************************************************
\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
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
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(..) )
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
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) ->
\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) ->
let
mk_provenance name = NonLocalDef (UserImport imp_mod iloc (name `elemNameSet` explicits))
- (is_unqual name)
in
qualifyImports imp_mod_name
= 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.
-- 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 ->
import RnExpr
import HsSyn
+import HscTypes ( GlobalRdrEnv )
import HsTypes ( hsTyVarNames, pprHsContext )
import RdrName ( RdrName, isRdrDataCon, rdrNameOcc, mkRdrNameWkr, elemRdrEnv )
import RdrHsSyn ( RdrNameContext, RdrNameHsType, RdrNameConDecl, RdrNameTyClDecl,
%*********************************************************
\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)
extendInScopeSet, elemInScopeSet )
import CoreSyn
import VarEnv
-import CoreLint ( beginPass, endPass )
+import CoreLint ( showPass, endPass )
import Outputable
import Util ( mapAccumL )
import UniqFM
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)
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 )
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)
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
)
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)
#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 )
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)
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
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(..) )
-- 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...
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;
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) ->
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 )
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'))
= 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
Id
)
import IdInfo ( neverInlinePrag )
-import CoreLint ( beginPass, endPass )
+import CoreLint ( showPass, endPass )
import ErrUtils ( dumpIfSet_dyn )
import SaAbsInt
import SaLib
saBinds dflags binds
= do {
- beginPass dflags "Strictness analysis";
+ showPass dflags "Strictness analysis";
-- Mark each binder with its strictness
#ifndef OMIT_STRANAL_STATS
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,
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]
import RdrHsSyn ( mkHsOpApp, RdrNameMonoBinds, RdrNameHsExpr, RdrNamePat )
import RdrName ( RdrName, mkUnqual )
import BasicTypes ( RecFlag(..), Fixity(..), FixityDirection(..)
- , maxPrecedence
+ , maxPrecedence, defaultFixity
, Boxity(..)
)
import FieldLabel ( fieldLabelName )
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 )
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 =
methods_lie = plusLIEs insts_needed_s
in
- -- Ditto method bindings
+ -- Simplify the constraints from methods
tcAddErrCtxt methodCtxt (
tcSimplifyAndCheck
(ptext SLIT("instance declaration context"))
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
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}
-
-
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 )
-> 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)
\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
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,
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
(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
isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, tupleTyConBoxity,
isRecursiveTyCon, newTyConRep,
- mkAlgTyConRep, --mkAlgTyCon,
+ mkAlgTyCon, --mkAlgTyCon,
mkClassTyCon,
mkFunTyCon,
mkPrimTyCon,
-- 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,
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}
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
}
= do
let binds1 = doUnAnnotBinds binds
- beginPass dflags "UsageSPInf"
+ showPass dflags "UsageSPInf"
dumpIfSet_dyn dflags Opt_D_dump_usagesp "UsageSPInf unannot'd" $
pprCoreBindings binds1
doCheckIfWorseUSP binds binds'
= case checkIfWorseUSP binds binds' of
Nothing -> return ()
- Just warns -> printErrs warns
+ Just warns -> printDump warns
\end{code}
======================================================================
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,
printSDoc, printErrs, printDump,
printForC, printForAsm, printForIface, printForUser,
pprCode, pprCols,
- showSDoc, showSDocDebug, showSDocIface, showsPrecSDoc,
+ showSDoc, showSDocDebug, showSDocIface, showSDocUnqual, showsPrecSDoc,
pprHsChar, pprHsString,
#include "HsVersions.h"
+import {-# SOURCE #-} Name( Name )
+
import IO ( Handle, hPutChar, hPutStr, stderr, stdout )
import CmdLineOpts ( opt_PprStyle_Debug, opt_PprUserLength )
import FastString
\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
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
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
-- 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 ()
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
-- 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}
projects / ghc-hetmet.git / commitdiff