-- 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
= 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)]
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
-- 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!
| 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'),
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
= 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
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]
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)
-- 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)))
=> 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
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}
%************************************************************************
\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")
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}
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 ->
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
PprStyle, CodeStyle(..), PrintUnqualified, alwaysQualify,
getPprStyle, withPprStyle, withPprStyleDoc, pprDeeper,
- codeStyle, ifaceStyle, userStyle, debugStyle, asmStyle,
+ codeStyle, userStyle, debugStyle, asmStyle,
ifPprDebug, unqualStyle,
SDoc, -- Abstract
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,
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
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))
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}
-- conversion
lexemeToString, -- :: StringBuffer -> String
- lexemeToByteArray, -- :: StringBuffer -> _ByteArray Int
lexemeToFastString, -- :: StringBuffer -> FastString
- lexemeToBuffer, -- :: StringBuffer -> StringBuffer
-
- FastString,
- ByteArray
) where
#include "HsVersions.h"
import GlaExts
import Foreign
import IO ( openFile, isEOFError )
-import IOExts ( slurpFile )
import Addr
import Exception ( bracket )
\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
-- 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 -})
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}
projects / ghc-hetmet.git / commitdiff