From 0e8e53db37d75d506d3a5b2804342442a5142d59 Mon Sep 17 00:00:00 2001 From: simonmar Date: Thu, 14 Mar 2002 16:22:34 +0000 Subject: [PATCH] [project @ 2002-03-14 16:22:31 by simonmar] Misc cleanup: remove the iface pretty-printing style, and clean up bits of StringBuffer that aren't required any more. --- ghc/compiler/basicTypes/IdInfo.lhs | 5 +--- ghc/compiler/basicTypes/Literal.lhs | 4 +--- ghc/compiler/basicTypes/MkId.lhs | 2 +- ghc/compiler/basicTypes/Name.lhs | 4 +--- ghc/compiler/coreSyn/PprCore.lhs | 2 +- ghc/compiler/hsSyn/HsBinds.lhs | 9 +++---- ghc/compiler/hsSyn/HsDecls.lhs | 21 +++++----------- ghc/compiler/main/HscMain.lhs | 2 +- ghc/compiler/main/MkIface.lhs | 11 --------- ghc/compiler/main/ParsePkgConf.y | 2 +- ghc/compiler/rename/RnHiFiles.lhs | 2 +- ghc/compiler/types/PprType.lhs | 2 +- ghc/compiler/utils/Outputable.lhs | 19 +++------------ ghc/compiler/utils/StringBuffer.lhs | 45 +++-------------------------------- 14 files changed, 24 insertions(+), 106 deletions(-) diff --git a/ghc/compiler/basicTypes/IdInfo.lhs b/ghc/compiler/basicTypes/IdInfo.lhs index d364222..b39b60c 100644 --- a/ghc/compiler/basicTypes/IdInfo.lhs +++ b/ghc/compiler/basicTypes/IdInfo.lhs @@ -741,10 +741,7 @@ noLBVarInfo = NoLBVarInfo -- property of the definition, but a property of the context. pprLBVarInfo NoLBVarInfo = empty pprLBVarInfo (LBVarInfo u) | u `eqUsage` usOnce - = getPprStyle $ \ sty -> - if ifaceStyle sty - then empty - else ptext SLIT("OneShot") + = ptext SLIT("OneShot") | otherwise = empty diff --git a/ghc/compiler/basicTypes/Literal.lhs b/ghc/compiler/basicTypes/Literal.lhs index 76b7e48..7954743 100644 --- a/ghc/compiler/basicTypes/Literal.lhs +++ b/ghc/compiler/basicTypes/Literal.lhs @@ -367,7 +367,6 @@ pprLit lit = getPprStyle $ \ sty -> let code_style = codeStyle sty - iface_style = ifaceStyle sty in case lit of MachChar ch | code_style -> hcat [ptext SLIT("(C_)"), text (show ch)] @@ -395,8 +394,7 @@ pprLit lit MachFloat f | code_style -> ptext SLIT("(StgFloat)") <> rational f | otherwise -> ptext SLIT("__float") <+> rational f - MachDouble d | iface_style && d < 0 -> parens (rational d) - | otherwise -> rational d + MachDouble d -> rational d MachAddr p | code_style -> ptext SLIT("(void*)") <> integer p | otherwise -> ptext SLIT("__addr") <+> integer p diff --git a/ghc/compiler/basicTypes/MkId.lhs b/ghc/compiler/basicTypes/MkId.lhs index 610fe38..f9a9e87 100644 --- a/ghc/compiler/basicTypes/MkId.lhs +++ b/ghc/compiler/basicTypes/MkId.lhs @@ -673,7 +673,7 @@ mkFCallId uniq fcall ty -- when doing substitutions won't substitute over it mkGlobalId (FCallId fcall) name ty info where - occ_str = showSDocIface (braces (ppr fcall <+> ppr ty)) + occ_str = showSDoc (braces (ppr fcall <+> ppr ty)) -- The "occurrence name" of a ccall is the full info about the -- ccall; it is encoded, but may have embedded spaces etc! diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs index e3708ca..816b87b 100644 --- a/ghc/compiler/basicTypes/Name.lhs +++ b/ghc/compiler/basicTypes/Name.lhs @@ -315,13 +315,11 @@ pprInternal sty uniq occ | codeStyle sty = pprUnique uniq | debugStyle sty = pprOccName occ <> text "{-" <> pprUnique uniq <> text "-}" - | otherwise = pprOccName occ -- User and Iface styles + | otherwise = pprOccName occ -- User style -- Like Internal, except that we only omit the unique in Iface style pprSystem sty uniq occ | codeStyle sty = pprUnique uniq - | ifaceStyle sty = pprOccName occ -- The tidy phase has ensured - -- that OccNames are enough | otherwise = pprOccName occ <> char '_' <> pprUnique uniq -- If the tidy phase hasn't run, the OccName -- is unlikely to be informative (like 's'), diff --git a/ghc/compiler/coreSyn/PprCore.lhs b/ghc/compiler/coreSyn/PprCore.lhs index 25d79f4..b04c186 100644 --- a/ghc/compiler/coreSyn/PprCore.lhs +++ b/ghc/compiler/coreSyn/PprCore.lhs @@ -260,7 +260,7 @@ ppr_expr add_par pe (Note (SCC cc) expr) ppr_expr add_par pe (Note (Coerce to_ty from_ty) expr) = add_par $ getPprStyle $ \ sty -> - if debugStyle sty && not (ifaceStyle sty) then + if debugStyle sty then sep [ptext SLIT("__coerce") <+> sep [pTy pe to_ty, pTy pe from_ty], ppr_parend_expr pe expr] else diff --git a/ghc/compiler/hsSyn/HsBinds.lhs b/ghc/compiler/hsSyn/HsBinds.lhs index 773a946..b5456d2 100644 --- a/ghc/compiler/hsSyn/HsBinds.lhs +++ b/ghc/compiler/hsSyn/HsBinds.lhs @@ -335,12 +335,9 @@ ppr_sig (Sig var ty _) = sep [ppr var <+> dcolon, nest 4 (ppr ty)] ppr_sig (ClassOpSig var dm ty _) - = getPprStyle $ \ sty -> - if ifaceStyle sty - then sep [ ppr var <+> pp_dm <+> dcolon, nest 4 (ppr ty) ] - else sep [ ppr_var var <+> dcolon, - nest 4 (ppr ty), - nest 4 (pp_dm_comment) ] + = sep [ ppr_var var <+> dcolon, + nest 4 (ppr ty), + nest 4 (pp_dm_comment) ] where pp_dm = case dm of DefMeth _ -> equals -- Default method indicator diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs index 9160f4a..061ee4f 100644 --- a/ghc/compiler/hsSyn/HsDecls.lhs +++ b/ghc/compiler/hsSyn/HsDecls.lhs @@ -470,9 +470,7 @@ instance (NamedThing name, Outputable name, Outputable pat) ppr (IfaceSig {tcdName = var, tcdType = ty, tcdIdInfo = info}) = getPprStyle $ \ sty -> - hsep [ if ifaceStyle sty then ppr var else ppr_var var, - dcolon, ppr ty, pprHsIdInfo info - ] + hsep [ ppr_var var, dcolon, ppr ty, pprHsIdInfo info ] ppr (ForeignType {tcdName = tycon}) = hsep [ptext SLIT("foreign import type dotnet"), ppr tycon] @@ -504,8 +502,7 @@ instance (NamedThing name, Outputable name, Outputable pat) top_matter = ptext SLIT("class") <+> pp_decl_head context clas tyvars <+> pprFundeps fds ppr_sig sig = ppr sig <> semi - pp_methods = getPprStyle $ \ sty -> - if ifaceStyle sty || isNothing methods + pp_methods = if isNothing methods then empty else ppr (fromJust methods) @@ -629,9 +626,7 @@ ppr_con_details con (InfixCon ty1 ty2) -- we don't distinguish between the two. Hence when printing these for the -- user, we need to parenthesise infix constructor names. ppr_con_details con (VanillaCon tys) - = getPprStyle $ \ sty -> - hsep ((if ifaceStyle sty then ppr con else ppr_var con) - : map (ppr_bang) tys) + = hsep (ppr_var con : map (ppr_bang) tys) ppr_con_details con (RecCon fields) = ppr con <+> braces (sep (punctuate comma (map ppr_field fields))) @@ -677,13 +672,9 @@ instance (Outputable name, Outputable pat) => Outputable (InstDecl name pat) where ppr (InstDecl inst_ty binds uprags maybe_dfun_name src_loc) - = getPprStyle $ \ sty -> - if ifaceStyle sty then - hsep [ptext SLIT("instance"), ppr inst_ty, equals, pp_dfun] - else - vcat [hsep [ptext SLIT("instance"), ppr inst_ty, ptext SLIT("where")], - nest 4 (ppr uprags), - nest 4 (ppr binds) ] + = vcat [hsep [ptext SLIT("instance"), ppr inst_ty, ptext SLIT("where")], + nest 4 (ppr uprags), + nest 4 (ppr binds) ] where pp_dfun = case maybe_dfun_name of Just df -> ppr df diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index f6faffe..cbaea17 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -425,7 +425,7 @@ myParseModule dflags src_filename showPass dflags "Parser" _scc_ "Parser" do - buf <- hGetStringBuffer True{-expand tabs-} src_filename + buf <- hGetStringBuffer src_filename let exts = ExtFlags {glasgowExtsEF = dopt Opt_GlasgowExts dflags, parrEF = dopt Opt_PArr dflags} diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index 549d2af..8050e50 100644 --- a/ghc/compiler/main/MkIface.lhs +++ b/ghc/compiler/main/MkIface.lhs @@ -551,17 +551,6 @@ dump_rules rs = vcat [ptext SLIT("{-# RULES"), %************************************************************************ \begin{code} -writeIface :: FilePath -> ModIface -> IO () -writeIface hi_path mod_iface - = do { if_hdl <- openFile hi_path WriteMode - ; 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 = vcat [ ptext SLIT("__interface") diff --git a/ghc/compiler/main/ParsePkgConf.y b/ghc/compiler/main/ParsePkgConf.y index c6e6580..f710b15 100644 --- a/ghc/compiler/main/ParsePkgConf.y +++ b/ghc/compiler/main/ParsePkgConf.y @@ -80,7 +80,7 @@ happyError buf PState{ loc = loc } = PFailed (srcParseErr buf loc) loadPackageConfig :: FilePath -> IO [PackageConfig] loadPackageConfig conf_filename = do - buf <- hGetStringBuffer False conf_filename + buf <- hGetStringBuffer conf_filename let loc = mkSrcLoc (_PK_ conf_filename) 1 exts = ExtFlags {glasgowExtsEF = False, parrEF = False} diff --git a/ghc/compiler/rename/RnHiFiles.lhs b/ghc/compiler/rename/RnHiFiles.lhs index a373788..057fae3 100644 --- a/ghc/compiler/rename/RnHiFiles.lhs +++ b/ghc/compiler/rename/RnHiFiles.lhs @@ -570,7 +570,7 @@ readIface file_path if ".hi-boot" `isSuffixOf` file_path || hi_boot_ver `isSuffixOf` file_path then - ioToRnM (hGetStringBuffer False file_path) `thenRn` \ read_result -> + ioToRnM (hGetStringBuffer file_path) `thenRn` \ read_result -> case read_result of { Left io_error -> bale_out (text (show io_error)); Right contents -> diff --git a/ghc/compiler/types/PprType.lhs b/ghc/compiler/types/PprType.lhs index f57223c..c8edc3e 100644 --- a/ghc/compiler/types/PprType.lhs +++ b/ghc/compiler/types/PprType.lhs @@ -220,7 +220,7 @@ and when in debug mode. pprTyVarBndr :: TyVar -> SDoc pprTyVarBndr tyvar = getPprStyle $ \ sty -> - if (ifaceStyle sty && not (kind `eqKind` liftedTypeKind)) || debugStyle sty then + if debugStyle sty then hsep [ppr tyvar, dcolon, pprParendKind kind] -- See comments with ppDcolon in PprCore.lhs else diff --git a/ghc/compiler/utils/Outputable.lhs b/ghc/compiler/utils/Outputable.lhs index 96d611f..d96a14a 100644 --- a/ghc/compiler/utils/Outputable.lhs +++ b/ghc/compiler/utils/Outputable.lhs @@ -13,7 +13,7 @@ module Outputable ( PprStyle, CodeStyle(..), PrintUnqualified, alwaysQualify, getPprStyle, withPprStyle, withPprStyleDoc, pprDeeper, - codeStyle, ifaceStyle, userStyle, debugStyle, asmStyle, + codeStyle, userStyle, debugStyle, asmStyle, ifPprDebug, unqualStyle, SDoc, -- Abstract @@ -33,9 +33,9 @@ module Outputable ( speakNth, speakNTimes, printSDoc, printErrs, printDump, - printForC, printForAsm, printForIface, printForUser, + printForC, printForAsm, printForUser, pprCode, mkCodeStyle, - showSDoc, showSDocForUser, showSDocDebug, showSDocIface, + showSDoc, showSDocForUser, showSDocDebug, showSDocUnqual, showsPrecSDoc, pprHsChar, pprHsString, @@ -151,10 +151,6 @@ asmStyle :: PprStyle -> Bool asmStyle (PprCode AsmStyle) = True asmStyle other = False -ifaceStyle :: PprStyle -> Bool -ifaceStyle (PprInterface _) = True -ifaceStyle other = False - debugStyle :: PprStyle -> Bool debugStyle PprDebug = True debugStyle other = False @@ -191,12 +187,6 @@ printForUser :: Handle -> PrintUnqualified -> SDoc -> IO () printForUser handle unqual doc = Pretty.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 - = Pretty.printDoc LeftMode handle (doc (PprInterface unqual)) - -- printForC, printForAsm do what they sound like printForC :: Handle -> SDoc -> IO () printForC handle doc = Pretty.printDoc LeftMode handle (doc (PprCode CStyle)) @@ -226,9 +216,6 @@ 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 alwaysQualify)) - showSDocDebug :: SDoc -> String showSDocDebug d = show (d PprDebug) \end{code} diff --git a/ghc/compiler/utils/StringBuffer.lhs b/ghc/compiler/utils/StringBuffer.lhs index d89b938..2ab170b 100644 --- a/ghc/compiler/utils/StringBuffer.lhs +++ b/ghc/compiler/utils/StringBuffer.lhs @@ -59,12 +59,7 @@ module StringBuffer -- conversion lexemeToString, -- :: StringBuffer -> String - lexemeToByteArray, -- :: StringBuffer -> _ByteArray Int lexemeToFastString, -- :: StringBuffer -> FastString - lexemeToBuffer, -- :: StringBuffer -> StringBuffer - - FastString, - ByteArray ) where #include "HsVersions.h" @@ -92,7 +87,6 @@ import FastString import GlaExts import Foreign import IO ( openFile, isEOFError ) -import IOExts ( slurpFile ) import Addr import Exception ( bracket ) @@ -124,17 +118,9 @@ instance Show StringBuffer where \end{code} \begin{code} -hGetStringBuffer :: Bool -> FilePath -> IO StringBuffer -hGetStringBuffer expand_tabs fname = do - (a, read) <- if expand_tabs - then slurpFileExpandTabs fname -#if __GLASGOW_HASKELL__ < 411 - else slurpFile fname -#else - else do - (Ptr a#, read) <- slurpFile fname - return (A# a#, read) -#endif +hGetStringBuffer :: FilePath -> IO StringBuffer +hGetStringBuffer fname = do + (a, read) <- slurpFileExpandTabs fname -- urk! slurpFile gives us a buffer that doesn't have room for -- the sentinel. Assume it has a final newline for now, and overwrite @@ -289,9 +275,6 @@ trySlurp handle sz_i chunk = -- and add 1 to allow room for the final sentinel \NUL at -- the end of the file. (chunk', rc) <- slurpFile 0# 0# chunk chunk_sz (chunk_sz -# (tAB_SIZE +# 1#)) -#if __GLASGOW_HASKELL__ < 404 - writeHandle handle handle_ -#endif return (chunk', rc+1 {- room for sentinel -}) @@ -513,32 +496,10 @@ lexemeToString (StringBuffer fo _ start_pos# current#) = else unpackCStringBA (copySubStr (A# fo) (I# start_pos#) (I# (current# -# start_pos#))) -lexemeToByteArray :: StringBuffer -> ByteArray Int -lexemeToByteArray (StringBuffer fo _ start_pos# current#) = - if start_pos# ==# current# then - error "lexemeToByteArray" - else - copySubStr (A# fo) (I# start_pos#) (I# (current# -# start_pos#)) - lexemeToFastString :: StringBuffer -> FastString lexemeToFastString (StringBuffer fo l# start_pos# current#) = if start_pos# ==# current# then mkFastString "" else mkFastSubString (A# fo) (I# start_pos#) (I# (current# -# start_pos#)) - -{- - Create a StringBuffer from the current lexeme, and add a sentinel - at the end. Know What You're Doing before taking this function - into use.. --} -lexemeToBuffer :: StringBuffer -> StringBuffer -lexemeToBuffer (StringBuffer fo l# start_pos# current#) = - if start_pos# ==# current# then - StringBuffer fo 0# start_pos# current# -- an error, really. - else - unsafeWriteBuffer (StringBuffer fo (current# -# start_pos#) start_pos# start_pos#) - (current# -# 1#) - '\NUL'# - \end{code} -- 1.7.10.4