-{-# OPTIONS_GHC -w #-}
--- Temporary, until rtsIsProfiled is fixed
-
-- |
-- Dynamic flags
--
DPHBackend(..), dphPackageMaybe,
wayNames,
+ Settings(..),
+ ghcUsagePath, ghciUsagePath, topDir, tmpDir, rawSettings,
+ extraGccViaCFlags, systemPackageConfig,
+ pgm_L, pgm_P, pgm_F, pgm_c, pgm_s, pgm_a, pgm_l, pgm_dll, pgm_T,
+ pgm_sysman, pgm_windres, pgm_lo, pgm_lc,
+ opt_L, opt_P, opt_F, opt_c, opt_m, opt_a, opt_l,
+ opt_windres, opt_lo, opt_lc,
+
+
-- ** Manipulating DynFlags
- defaultDynFlags, -- DynFlags
+ defaultDynFlags, -- Settings -> DynFlags
initDynFlags, -- DynFlags -> IO DynFlags
getOpts, -- DynFlags -> (DynFlags -> [a]) -> [a]
- getVerbFlag,
+ getVerbFlags,
updOptLevel,
setTmpDir,
setPackageName,
supportedLanguagesAndExtensions,
-- ** DynFlag C compiler options
- machdepCCOpts, picCCOpts,
+ picCCOpts,
-- * Configuration of the stg-to-stg passes
StgToDo(..),
getStgToDo,
-- * Compiler configuration suitable for display to the user
- Printable(..),
compilerInfo
#ifdef GHCI
-- Only in stage 2 can we be sure that the RTS
#include "HsVersions.h"
-#ifndef OMIT_NATIVE_CODEGEN
import Platform
-#endif
import Module
import PackageConfig
import PrelNames ( mAIN )
import SrcLoc
import FastString
import Outputable
+#ifdef GHCI
import Foreign.C ( CInt )
+#endif
import {-# SOURCE #-} ErrUtils ( Severity(..), Message, mkLocMessage )
+#ifdef GHCI
import System.IO.Unsafe ( unsafePerformIO )
+#endif
import Data.IORef
import Control.Monad ( when )
import Data.List
import Data.Map (Map)
import qualified Data.Map as Map
-import Data.Maybe
import System.FilePath
import System.IO ( stderr, hPutChar )
| Opt_Pp
| Opt_ForceRecomp
| Opt_DryRun
- | Opt_DoAsmMangling
| Opt_ExcessPrecision
| Opt_EagerBlackHoling
| Opt_ReadUserPackageConf
| Opt_KeepHiDiffs
| Opt_KeepHcFiles
| Opt_KeepSFiles
- | Opt_KeepRawSFiles
| Opt_KeepTmpFiles
| Opt_KeepRawTokenStream
| Opt_KeepLlvmFiles
| Opt_KindSignatures
| Opt_ParallelListComp
| Opt_TransformListComp
+ | Opt_MonadComprehensions
| Opt_GeneralizedNewtypeDeriving
| Opt_RecursiveDo
| Opt_DoRec
floatLamArgs :: Maybe Int, -- ^ Arg count for lambda floating
-- See CoreMonad.FloatOutSwitches
-#ifndef OMIT_NATIVE_CODEGEN
- targetPlatform :: Platform, -- ^ The platform we're compiling for. Used by the NCG.
-#endif
- stolen_x86_regs :: Int,
+ targetPlatform :: Platform.Platform, -- ^ The platform we're compiling for. Used by the NCG.
cmdlineHcIncludes :: [String], -- ^ @\-\#includes@
importPaths :: [FilePath],
mainModIs :: Module,
libraryPaths :: [String],
frameworkPaths :: [String], -- used on darwin only
cmdlineFrameworks :: [String], -- ditto
- tmpDir :: String, -- no trailing '/'
- ghcUsagePath :: FilePath, -- Filled in by SysTools
- ghciUsagePath :: FilePath, -- ditto
rtsOpts :: Maybe String,
rtsOptsEnabled :: RtsOptsEnabled,
hpcDir :: String, -- ^ Path to store the .mix files
- -- options for particular phases
- opt_L :: [String],
- opt_P :: [String],
- opt_F :: [String],
- opt_c :: [String],
- opt_m :: [String],
- opt_a :: [String],
- opt_l :: [String],
- opt_windres :: [String],
- opt_lo :: [String], -- LLVM: llvm optimiser
- opt_lc :: [String], -- LLVM: llc static compiler
-
- -- commands for particular phases
- pgm_L :: String,
- pgm_P :: (String,[Option]),
- pgm_F :: String,
- pgm_c :: (String,[Option]),
- pgm_m :: (String,[Option]),
- pgm_s :: (String,[Option]),
- pgm_a :: (String,[Option]),
- pgm_l :: (String,[Option]),
- pgm_dll :: (String,[Option]),
- pgm_T :: String,
- pgm_sysman :: String,
- pgm_windres :: String,
- pgm_lo :: (String,[Option]), -- LLVM: opt llvm optimiser
- pgm_lc :: (String,[Option]), -- LLVM: llc static compiler
+ settings :: Settings,
-- For ghc -M
depMakefile :: FilePath,
-- Package flags
extraPkgConfs :: [FilePath],
- topDir :: FilePath, -- filled in by SysTools
- systemPackageConfig :: FilePath, -- ditto
-- ^ The @-package-conf@ flags given on the command line, in the order
-- they appeared.
haddockOptions :: Maybe String
}
+data Settings = Settings {
+ sGhcUsagePath :: FilePath, -- Filled in by SysTools
+ sGhciUsagePath :: FilePath, -- ditto
+ sTopDir :: FilePath,
+ sTmpDir :: String, -- no trailing '/'
+ -- You shouldn't need to look things up in rawSettings directly.
+ -- They should have their own fields instead.
+ sRawSettings :: [(String, String)],
+ sExtraGccViaCFlags :: [String],
+ sSystemPackageConfig :: FilePath,
+ -- commands for particular phases
+ sPgm_L :: String,
+ sPgm_P :: (String,[Option]),
+ sPgm_F :: String,
+ sPgm_c :: (String,[Option]),
+ sPgm_s :: (String,[Option]),
+ sPgm_a :: (String,[Option]),
+ sPgm_l :: (String,[Option]),
+ sPgm_dll :: (String,[Option]),
+ sPgm_T :: String,
+ sPgm_sysman :: String,
+ sPgm_windres :: String,
+ sPgm_lo :: (String,[Option]), -- LLVM: opt llvm optimiser
+ sPgm_lc :: (String,[Option]), -- LLVM: llc static compiler
+ -- options for particular phases
+ sOpt_L :: [String],
+ sOpt_P :: [String],
+ sOpt_F :: [String],
+ sOpt_c :: [String],
+ sOpt_m :: [String],
+ sOpt_a :: [String],
+ sOpt_l :: [String],
+ sOpt_windres :: [String],
+ sOpt_lo :: [String], -- LLVM: llvm optimiser
+ sOpt_lc :: [String] -- LLVM: llc static compiler
+
+ }
+
+ghcUsagePath :: DynFlags -> FilePath
+ghcUsagePath dflags = sGhcUsagePath (settings dflags)
+ghciUsagePath :: DynFlags -> FilePath
+ghciUsagePath dflags = sGhciUsagePath (settings dflags)
+topDir :: DynFlags -> FilePath
+topDir dflags = sTopDir (settings dflags)
+tmpDir :: DynFlags -> String
+tmpDir dflags = sTmpDir (settings dflags)
+rawSettings :: DynFlags -> [(String, String)]
+rawSettings dflags = sRawSettings (settings dflags)
+extraGccViaCFlags :: DynFlags -> [String]
+extraGccViaCFlags dflags = sExtraGccViaCFlags (settings dflags)
+systemPackageConfig :: DynFlags -> FilePath
+systemPackageConfig dflags = sSystemPackageConfig (settings dflags)
+pgm_L :: DynFlags -> String
+pgm_L dflags = sPgm_L (settings dflags)
+pgm_P :: DynFlags -> (String,[Option])
+pgm_P dflags = sPgm_P (settings dflags)
+pgm_F :: DynFlags -> String
+pgm_F dflags = sPgm_F (settings dflags)
+pgm_c :: DynFlags -> (String,[Option])
+pgm_c dflags = sPgm_c (settings dflags)
+pgm_s :: DynFlags -> (String,[Option])
+pgm_s dflags = sPgm_s (settings dflags)
+pgm_a :: DynFlags -> (String,[Option])
+pgm_a dflags = sPgm_a (settings dflags)
+pgm_l :: DynFlags -> (String,[Option])
+pgm_l dflags = sPgm_l (settings dflags)
+pgm_dll :: DynFlags -> (String,[Option])
+pgm_dll dflags = sPgm_dll (settings dflags)
+pgm_T :: DynFlags -> String
+pgm_T dflags = sPgm_T (settings dflags)
+pgm_sysman :: DynFlags -> String
+pgm_sysman dflags = sPgm_sysman (settings dflags)
+pgm_windres :: DynFlags -> String
+pgm_windres dflags = sPgm_windres (settings dflags)
+pgm_lo :: DynFlags -> (String,[Option])
+pgm_lo dflags = sPgm_lo (settings dflags)
+pgm_lc :: DynFlags -> (String,[Option])
+pgm_lc dflags = sPgm_lc (settings dflags)
+opt_L :: DynFlags -> [String]
+opt_L dflags = sOpt_L (settings dflags)
+opt_P :: DynFlags -> [String]
+opt_P dflags = sOpt_P (settings dflags)
+opt_F :: DynFlags -> [String]
+opt_F dflags = sOpt_F (settings dflags)
+opt_c :: DynFlags -> [String]
+opt_c dflags = sOpt_c (settings dflags)
+opt_m :: DynFlags -> [String]
+opt_m dflags = sOpt_m (settings dflags)
+opt_a :: DynFlags -> [String]
+opt_a dflags = sOpt_a (settings dflags)
+opt_l :: DynFlags -> [String]
+opt_l dflags = sOpt_l (settings dflags)
+opt_windres :: DynFlags -> [String]
+opt_windres dflags = sOpt_windres (settings dflags)
+opt_lo :: DynFlags -> [String]
+opt_lo dflags = sOpt_lo (settings dflags)
+opt_lc :: DynFlags -> [String]
+opt_lc dflags = sOpt_lc (settings dflags)
+
wayNames :: DynFlags -> [WayName]
wayNames = map wayName . ways
| HscNothing -- ^ Don't generate any code. See notes above.
deriving (Eq, Show)
+showHscTargetFlag :: HscTarget -> String
+showHscTargetFlag HscC = "-fvia-c"
+showHscTargetFlag HscAsm = "-fasm"
+showHscTargetFlag HscLlvm = "-fllvm"
+showHscTargetFlag HscJava = panic "No flag for HscJava"
+showHscTargetFlag HscInterpreted = "-fbyte-code"
+showHscTargetFlag HscNothing = "-fno-code"
+
-- | Will this target result in an object file on the disk?
isObjectTarget :: HscTarget -> Bool
isObjectTarget HscC = True
-- object files on the current platform.
defaultObjectTarget :: HscTarget
defaultObjectTarget
+ | cGhcUnregisterised == "YES" = HscC
| cGhcWithNativeCodeGen == "YES" = HscAsm
- | otherwise = HscC
+ | otherwise = HscLlvm
data DynLibLoader
= Deployable
deriving Eq
data RtsOptsEnabled = RtsOptsNone | RtsOptsSafeOnly | RtsOptsAll
+ deriving (Show)
-- | Used by 'GHC.newSession' to partially initialize a new 'DynFlags' value
initDynFlags :: DynFlags -> IO DynFlags
-- | The normal 'DynFlags'. Note that they is not suitable for use in this form
-- and must be fully initialized by 'GHC.newSession' first.
-defaultDynFlags :: DynFlags
-defaultDynFlags =
+defaultDynFlags :: Settings -> DynFlags
+defaultDynFlags mySettings =
DynFlags {
ghcMode = CompManager,
ghcLink = LinkBinary,
floatLamArgs = Just 0, -- Default: float only if no fvs
strictnessBefore = [],
-#ifndef OMIT_NATIVE_CODEGEN
targetPlatform = defaultTargetPlatform,
-#endif
- stolen_x86_regs = 4,
cmdlineHcIncludes = [],
importPaths = ["."],
mainModIs = mAIN,
libraryPaths = [],
frameworkPaths = [],
cmdlineFrameworks = [],
- tmpDir = cDEFAULT_TMPDIR,
rtsOpts = Nothing,
rtsOptsEnabled = RtsOptsSafeOnly,
hpcDir = ".hpc",
- opt_L = [],
- opt_P = (if opt_PIC
- then ["-D__PIC__", "-U __PIC__"] -- this list is reversed
- else []),
- opt_F = [],
- opt_c = [],
- opt_a = [],
- opt_m = [],
- opt_l = [],
- opt_windres = [],
- opt_lo = [],
- opt_lc = [],
-
extraPkgConfs = [],
packageFlags = [],
pkgDatabase = Nothing,
buildTag = panic "defaultDynFlags: No buildTag",
rtsBuildTag = panic "defaultDynFlags: No rtsBuildTag",
splitInfo = Nothing,
- -- initSysTools fills all these in
- ghcUsagePath = panic "defaultDynFlags: No ghciUsagePath",
- ghciUsagePath = panic "defaultDynFlags: No ghciUsagePath",
- topDir = panic "defaultDynFlags: No topDir",
- systemPackageConfig = panic "no systemPackageConfig: call GHC.setSessionDynFlags",
- pgm_L = panic "defaultDynFlags: No pgm_L",
- pgm_P = panic "defaultDynFlags: No pgm_P",
- pgm_F = panic "defaultDynFlags: No pgm_F",
- pgm_c = panic "defaultDynFlags: No pgm_c",
- pgm_m = panic "defaultDynFlags: No pgm_m",
- pgm_s = panic "defaultDynFlags: No pgm_s",
- pgm_a = panic "defaultDynFlags: No pgm_a",
- pgm_l = panic "defaultDynFlags: No pgm_l",
- pgm_dll = panic "defaultDynFlags: No pgm_dll",
- pgm_T = panic "defaultDynFlags: No pgm_T",
- pgm_sysman = panic "defaultDynFlags: No pgm_sysman",
- pgm_windres = panic "defaultDynFlags: No pgm_windres",
- pgm_lo = panic "defaultDynFlags: No pgm_lo",
- pgm_lc = panic "defaultDynFlags: No pgm_lc",
- -- end of initSysTools values
+ settings = mySettings,
-- ghc -M values
depMakefile = "Makefile",
depIncludePkgDeps = False,
log_action = \severity srcSpan style msg ->
case severity of
- SevOutput -> printOutput (msg style)
- SevInfo -> printErrs (msg style)
- SevFatal -> printErrs (msg style)
+ SevOutput -> printSDoc msg style
+ SevInfo -> printErrs msg style
+ SevFatal -> printErrs msg style
_ -> do
hPutChar stderr '\n'
- printErrs ((mkLocMessage srcSpan msg) style)
+ printErrs (mkLocMessage srcSpan msg) style
-- careful (#2302): printErrs prints in UTF-8, whereas
-- converting to string first and using hPutStr would
-- just emit the low 8 bits of each unicode char.
-- | Gets the verbosity flag for the current verbosity level. This is fed to
-- other tools, so GHC-specific verbosity flags like @-ddump-most@ are not included
-getVerbFlag :: DynFlags -> String
-getVerbFlag dflags
- | verbosity dflags >= 3 = "-v"
- | otherwise = ""
+getVerbFlags :: DynFlags -> [String]
+getVerbFlags dflags
+ | verbosity dflags >= 4 = ["-v"]
+ | otherwise = []
setObjectDir, setHiDir, setStubDir, setOutputDir, setDylibInstallName,
setObjectSuf, setHiSuf, setHcSuf, parseDynLibLoaderMode,
-- XXX HACK: Prelude> words "'does not' work" ===> ["'does","not'","work"]
-- Config.hs should really use Option.
-setPgmP f d = let (pgm:args) = words f in d{ pgm_P = (pgm, map Option args)}
-addOptl f d = d{ opt_l = f : opt_l d}
-addOptP f d = d{ opt_P = f : opt_P d}
+setPgmP f = let (pgm:args) = words f in alterSettings (\s -> s { sPgm_P = (pgm, map Option args)})
+addOptl f = alterSettings (\s -> s { sOpt_l = f : sOpt_l s})
+addOptP f = alterSettings (\s -> s { sOpt_P = f : sOpt_P s})
setDepMakefile :: FilePath -> DynFlags -> DynFlags
= runCmdLine (processArgs flag_spec args') dflags0
when (not (null errs)) $ ghcError $ errorsToGhcException errs
- let (pic_warns, dflags2)
-#if !(x86_64_TARGET_ARCH && linux_TARGET_OS)
- | (not opt_Static || opt_PIC) && hscTarget dflags1 == HscLlvm
- = ([L noSrcSpan $ "Warning: -fllvm is incompatible with -fPIC and -"
- ++ "dynamic on this platform;\n ignoring -fllvm"],
- dflags1{ hscTarget = HscAsm })
-#endif
- | otherwise = ([], dflags1)
-
- return (dflags2, leftover, pic_warns ++ warns)
+ return (dflags1, leftover, warns)
{- **********************************************************************
------- Specific phases --------------------------------------------
-- need to appear before -pgmL to be parsed as LLVM flags.
- , Flag "pgmlo" (hasArg (\f d -> d{ pgm_lo = (f,[])}))
- , Flag "pgmlc" (hasArg (\f d -> d{ pgm_lc = (f,[])}))
- , Flag "pgmL" (hasArg (\f d -> d{ pgm_L = f}))
+ , Flag "pgmlo" (hasArg (\f -> alterSettings (\s -> s { sPgm_lo = (f,[])})))
+ , Flag "pgmlc" (hasArg (\f -> alterSettings (\s -> s { sPgm_lc = (f,[])})))
+ , Flag "pgmL" (hasArg (\f -> alterSettings (\s -> s { sPgm_L = f})))
, Flag "pgmP" (hasArg setPgmP)
- , Flag "pgmF" (hasArg (\f d -> d{ pgm_F = f}))
- , Flag "pgmc" (hasArg (\f d -> d{ pgm_c = (f,[])}))
- , Flag "pgmm" (hasArg (\f d -> d{ pgm_m = (f,[])}))
- , Flag "pgms" (hasArg (\f d -> d{ pgm_s = (f,[])}))
- , Flag "pgma" (hasArg (\f d -> d{ pgm_a = (f,[])}))
- , Flag "pgml" (hasArg (\f d -> d{ pgm_l = (f,[])}))
- , Flag "pgmdll" (hasArg (\f d -> d{ pgm_dll = (f,[])}))
- , Flag "pgmwindres" (hasArg (\f d -> d{ pgm_windres = f}))
+ , Flag "pgmF" (hasArg (\f -> alterSettings (\s -> s { sPgm_F = f})))
+ , Flag "pgmc" (hasArg (\f -> alterSettings (\s -> s { sPgm_c = (f,[])})))
+ , Flag "pgmm" (HasArg (\_ -> addWarn "The -keep-raw-s-files flag does nothing; it will be removed in a future GHC release"))
+ , Flag "pgms" (hasArg (\f -> alterSettings (\s -> s { sPgm_s = (f,[])})))
+ , Flag "pgma" (hasArg (\f -> alterSettings (\s -> s { sPgm_a = (f,[])})))
+ , Flag "pgml" (hasArg (\f -> alterSettings (\s -> s { sPgm_l = (f,[])})))
+ , Flag "pgmdll" (hasArg (\f -> alterSettings (\s -> s { sPgm_dll = (f,[])})))
+ , Flag "pgmwindres" (hasArg (\f -> alterSettings (\s -> s { sPgm_windres = f})))
-- need to appear before -optl/-opta to be parsed as LLVM flags.
- , Flag "optlo" (hasArg (\f d -> d{ opt_lo = f : opt_lo d}))
- , Flag "optlc" (hasArg (\f d -> d{ opt_lc = f : opt_lc d}))
- , Flag "optL" (hasArg (\f d -> d{ opt_L = f : opt_L d}))
+ , Flag "optlo" (hasArg (\f -> alterSettings (\s -> s { sOpt_lo = f : sOpt_lo s})))
+ , Flag "optlc" (hasArg (\f -> alterSettings (\s -> s { sOpt_lc = f : sOpt_lc s})))
+ , Flag "optL" (hasArg (\f -> alterSettings (\s -> s { sOpt_L = f : sOpt_L s})))
, Flag "optP" (hasArg addOptP)
- , Flag "optF" (hasArg (\f d -> d{ opt_F = f : opt_F d}))
- , Flag "optc" (hasArg (\f d -> d{ opt_c = f : opt_c d}))
- , Flag "optm" (hasArg (\f d -> d{ opt_m = f : opt_m d}))
- , Flag "opta" (hasArg (\f d -> d{ opt_a = f : opt_a d}))
+ , Flag "optF" (hasArg (\f -> alterSettings (\s -> s { sOpt_F = f : sOpt_F s})))
+ , Flag "optc" (hasArg (\f -> alterSettings (\s -> s { sOpt_c = f : sOpt_c s})))
+ , Flag "optm" (hasArg (\f -> alterSettings (\s -> s { sOpt_m = f : sOpt_m s})))
+ , Flag "opta" (hasArg (\f -> alterSettings (\s -> s { sOpt_a = f : sOpt_a s})))
, Flag "optl" (hasArg addOptl)
- , Flag "optwindres" (hasArg (\f d -> d{ opt_windres = f : opt_windres d}))
+ , Flag "optwindres" (hasArg (\f -> alterSettings (\s -> s { sOpt_windres = f : sOpt_windres s})))
, Flag "split-objs"
(NoArg (if can_split
, Flag "keep-hc-files" (NoArg (setDynFlag Opt_KeepHcFiles))
, Flag "keep-s-file" (NoArg (setDynFlag Opt_KeepSFiles))
, Flag "keep-s-files" (NoArg (setDynFlag Opt_KeepSFiles))
- , Flag "keep-raw-s-file" (NoArg (setDynFlag Opt_KeepRawSFiles))
- , Flag "keep-raw-s-files" (NoArg (setDynFlag Opt_KeepRawSFiles))
+ , Flag "keep-raw-s-file" (NoArg (addWarn "The -keep-raw-s-file flag does nothing; it will be removed in a future GHC release"))
+ , Flag "keep-raw-s-files" (NoArg (addWarn "The -keep-raw-s-files flag does nothing; it will be removed in a future GHC release"))
, Flag "keep-llvm-file" (NoArg (setDynFlag Opt_KeepLlvmFiles))
, Flag "keep-llvm-files" (NoArg (setDynFlag Opt_KeepLlvmFiles))
-- This only makes sense as plural
------ Machine dependant (-m<blah>) stuff ---------------------------
- , Flag "monly-2-regs" (noArg (\s -> s{stolen_x86_regs = 2}))
- , Flag "monly-3-regs" (noArg (\s -> s{stolen_x86_regs = 3}))
- , Flag "monly-4-regs" (noArg (\s -> s{stolen_x86_regs = 4}))
+ , Flag "monly-2-regs" (NoArg (addWarn "The -monly-2-regs flag does nothing; it will be removed in a future GHC release"))
+ , Flag "monly-3-regs" (NoArg (addWarn "The -monly-3-regs flag does nothing; it will be removed in a future GHC release"))
+ , Flag "monly-4-regs" (NoArg (addWarn "The -monly-4-regs flag does nothing; it will be removed in a future GHC release"))
, Flag "msse2" (NoArg (setDynFlag Opt_SSE2))
------ Warning opts -------------------------------------------------
, Flag "w" (NoArg (mapM_ unSetDynFlag minuswRemovesOpts))
------ Optimisation flags ------------------------------------------
- , Flag "O" (noArg (setOptLevel 1))
- , Flag "Onot" (noArgDF (setOptLevel 0) "Use -O0 instead")
- , Flag "Odph" (noArg setDPHOpt)
- , Flag "O" (OptIntSuffix (\mb_n -> upd (setOptLevel (mb_n `orElse` 1))))
+ , Flag "O" (noArgM (setOptLevel 1))
+ , Flag "Onot" (noArgM (\dflags -> do deprecate "Use -O0 instead"
+ setOptLevel 0 dflags))
+ , Flag "Odph" (noArgM setDPHOpt)
+ , Flag "O" (optIntSuffixM (\mb_n -> setOptLevel (mb_n `orElse` 1)))
-- If the number is missing, use 1
, Flag "fsimplifier-phases" (intSuffix (\n d -> d{ simplPhases = n }))
, Flag "fcontext-stack" (intSuffix (\n d -> d{ ctxtStkDepth = n }))
, Flag "fstrictness-before" (intSuffix (\n d -> d{ strictnessBefore = n : strictnessBefore d }))
, Flag "ffloat-lam-args" (intSuffix (\n d -> d{ floatLamArgs = Just n }))
- , Flag "ffloat-all-lams" (intSuffix (\n d -> d{ floatLamArgs = Nothing }))
+ , Flag "ffloat-all-lams" (noArg (\d -> d{ floatLamArgs = Nothing }))
------ Profiling ----------------------------------------------------
( "dicts-cheap", Opt_DictsCheap, nop ),
( "excess-precision", Opt_ExcessPrecision, nop ),
( "eager-blackholing", Opt_EagerBlackHoling, nop ),
- ( "asm-mangling", Opt_DoAsmMangling, nop ),
( "print-bind-result", Opt_PrintBindResult, nop ),
( "force-recomp", Opt_ForceRecomp, nop ),
( "hpc-no-auto", Opt_Hpc_No_Auto, nop ),
( "EmptyDataDecls", Opt_EmptyDataDecls, nop ),
( "ParallelListComp", Opt_ParallelListComp, nop ),
( "TransformListComp", Opt_TransformListComp, nop ),
+ ( "MonadComprehensions", Opt_MonadComprehensions, nop),
( "ForeignFunctionInterface", Opt_ForeignFunctionInterface, nop ),
( "UnliftedFFITypes", Opt_UnliftedFFITypes, nop ),
( "GHCForeignImportPrim", Opt_GHCForeignImportPrim, nop ),
( "RankNTypes", Opt_RankNTypes, nop ),
( "ImpredicativeTypes", Opt_ImpredicativeTypes, nop),
( "TypeOperators", Opt_TypeOperators, nop ),
- ( "RecursiveDo", Opt_RecursiveDo,
+ ( "RecursiveDo", Opt_RecursiveDo, -- Enables 'mdo'
deprecatedForExtension "DoRec"),
- ( "DoRec", Opt_DoRec, nop ),
+ ( "DoRec", Opt_DoRec, nop ), -- Enables 'rec' keyword
( "Arrows", Opt_Arrows, nop ),
( "ParallelArrays", Opt_ParallelArrays, nop ),
( "TemplateHaskell", Opt_TemplateHaskell, checkTemplateHaskellOk ),
= [ Opt_AutoLinkPackages,
Opt_ReadUserPackageConf,
- Opt_DoAsmMangling,
-
Opt_SharedImplib,
+#if GHC_DEFAULT_NEW_CODEGEN
+ Opt_TryNewCodeGen,
+#endif
+
Opt_GenManifest,
Opt_EmbedManifest,
Opt_PrintBindContents,
rtsIsProfiled :: Bool
rtsIsProfiled = unsafePerformIO rtsIsProfiledIO /= 0
+#endif
checkTemplateHaskellOk :: Bool -> DynP ()
-checkTemplateHaskellOk turn_on
+#ifdef GHCI
+checkTemplateHaskellOk turn_on
| turn_on && rtsIsProfiled
= addErr "You can't use Template Haskell with a profiled compiler"
| otherwise
= return ()
#else
--- In stage 1 we don't know that the RTS has rts_isProfiled,
+-- In stage 1 we don't know that the RTS has rts_isProfiled,
-- so we simply say "ok". It doesn't matter because TH isn't
-- available in stage 1 anyway.
-checkTemplateHaskellOk turn_on = return ()
+checkTemplateHaskellOk _ = return ()
#endif
{- **********************************************************************
type DynP = EwM (CmdLineP DynFlags)
upd :: (DynFlags -> DynFlags) -> DynP ()
-upd f = liftEwM (do { dfs <- getCmdLineState
- ; putCmdLineState $! (f dfs) })
+upd f = liftEwM (do dflags <- getCmdLineState
+ putCmdLineState $! f dflags)
+
+updM :: (DynFlags -> DynP DynFlags) -> DynP ()
+updM f = do dflags <- liftEwM getCmdLineState
+ dflags' <- f dflags
+ liftEwM $ putCmdLineState $! dflags'
--------------- Constructor functions for OptKind -----------------
noArg :: (DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags)
noArg fn = NoArg (upd fn)
+noArgM :: (DynFlags -> DynP DynFlags) -> OptKind (CmdLineP DynFlags)
+noArgM fn = NoArg (updM fn)
+
noArgDF :: (DynFlags -> DynFlags) -> String -> OptKind (CmdLineP DynFlags)
noArgDF fn deprec = NoArg (upd fn >> deprecate deprec)
intSuffix :: (Int -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags)
intSuffix fn = IntSuffix (\n -> upd (fn n))
+optIntSuffixM :: (Maybe Int -> DynFlags -> DynP DynFlags)
+ -> OptKind (CmdLineP DynFlags)
+optIntSuffixM fn = OptIntSuffix (\mi -> updM (fn mi))
+
setDumpFlag :: DynFlag -> OptKind (CmdLineP DynFlags)
setDumpFlag dump_flag = NoArg (setDumpFlag' dump_flag)
-- (except for -fno-glasgow-exts, which is treated specially)
--------------------------
+alterSettings :: (Settings -> Settings) -> DynFlags -> DynFlags
+alterSettings f dflags = dflags { settings = f (settings dflags) }
+
+--------------------------
setDumpFlag' :: DynFlag -> DynP ()
setDumpFlag' dump_flag
= do { setDynFlag dump_flag
-- not from bytecode to object-code. The idea is that -fasm/-fllvm
-- can be safely used in an OPTIONS_GHC pragma.
setObjTarget :: HscTarget -> DynP ()
-setObjTarget l = upd set
+setObjTarget l = updM set
where
- set dfs
- | isObjectTarget (hscTarget dfs) = dfs { hscTarget = l }
- | otherwise = dfs
-
-setOptLevel :: Int -> DynFlags -> DynFlags
+ set dflags
+ | isObjectTarget (hscTarget dflags)
+ = case l of
+ HscC
+ | cGhcUnregisterised /= "YES" ->
+ do addWarn ("Compiler not unregisterised, so ignoring " ++ flag)
+ return dflags
+ HscAsm
+ | cGhcWithNativeCodeGen /= "YES" ->
+ do addWarn ("Compiler has no native codegen, so ignoring " ++
+ flag)
+ return dflags
+ HscLlvm
+ | cGhcUnregisterised == "YES" ->
+ do addWarn ("Compiler unregisterised, so ignoring " ++ flag)
+ return dflags
+ | not ((arch == ArchX86_64) && (os == OSLinux || os == OSDarwin)) &&
+ (not opt_Static || opt_PIC)
+ ->
+ do addWarn ("Ignoring " ++ flag ++ " as it is incompatible with -fPIC and -dynamic on this platform")
+ return dflags
+ _ -> return $ dflags { hscTarget = l }
+ | otherwise = return dflags
+ where platform = targetPlatform dflags
+ arch = platformArch platform
+ os = platformOS platform
+ flag = showHscTargetFlag l
+
+setOptLevel :: Int -> DynFlags -> DynP DynFlags
setOptLevel n dflags
| hscTarget dflags == HscInterpreted && n > 0
- = dflags
- -- not in IO any more, oh well:
- -- putStr "warning: -O conflicts with --interactive; -O ignored.\n"
+ = do addWarn "-O conflicts with --interactive; -O ignored."
+ return dflags
| otherwise
- = updOptLevel n dflags
+ = return (updOptLevel n dflags)
-- -Odph is equivalent to
-- -fmax-simplifier-iterations20 this is necessary sometimes
-- -fsimplifier-phases=3 we use an additional simplifier phase for fusion
--
-setDPHOpt :: DynFlags -> DynFlags
+setDPHOpt :: DynFlags -> DynP DynFlags
setDPHOpt dflags = setOptLevel 2 (dflags { maxSimplIterations = 20
, simplPhases = 3
})
-- tmpDir, where we store temporary files.
setTmpDir :: FilePath -> DynFlags -> DynFlags
-setTmpDir dir dflags = dflags{ tmpDir = normalise dir }
+setTmpDir dir = alterSettings (\s -> s { sTmpDir = normalise dir })
-- we used to fix /cygdrive/c/.. on Windows, but this doesn't
-- seem necessary now --SDM 7/2/2008
-- There are some options that we need to pass to gcc when compiling
-- Haskell code via C, but are only supported by recent versions of
-- gcc. The configure script decides which of these options we need,
--- and puts them in the file "extra-gcc-opts" in $topdir, which is
--- read before each via-C compilation. The advantage of having these
--- in a separate file is that the file can be created at install-time
--- depending on the available gcc version, and even re-generated later
--- if gcc is upgraded.
+-- and puts them in the "settings" file in $topdir. The advantage of
+-- having these in a separate file is that the file can be created at
+-- install-time depending on the available gcc version, and even
+-- re-generated later if gcc is upgraded.
--
-- The options below are not dependent on the version of gcc, only the
-- platform.
-machdepCCOpts :: DynFlags -> ([String], -- flags for all C compilations
- [String]) -- for registerised HC compilations
-machdepCCOpts dflags = let (flagsAll, flagsRegHc) = machdepCCOpts' dflags
- in (cCcOpts ++ flagsAll, flagsRegHc)
-
-machdepCCOpts' :: DynFlags -> ([String], -- flags for all C compilations
- [String]) -- for registerised HC compilations
-machdepCCOpts' _dflags
-#if alpha_TARGET_ARCH
- = ( ["-w", "-mieee"
-#ifdef HAVE_THREADED_RTS_SUPPORT
- , "-D_REENTRANT"
-#endif
- ], [] )
- -- For now, to suppress the gcc warning "call-clobbered
- -- register used for global register variable", we simply
- -- disable all warnings altogether using the -w flag. Oh well.
-
-#elif hppa_TARGET_ARCH
- -- ___HPUX_SOURCE, not _HPUX_SOURCE, is #defined if -ansi!
- -- (very nice, but too bad the HP /usr/include files don't agree.)
- = ( ["-D_HPUX_SOURCE"], [] )
-
-#elif m68k_TARGET_ARCH
- -- -fno-defer-pop : for the .hc files, we want all the pushing/
- -- popping of args to routines to be explicit; if we let things
- -- be deferred 'til after an STGJUMP, imminent death is certain!
- --
- -- -fomit-frame-pointer : *don't*
- -- It's better to have a6 completely tied up being a frame pointer
- -- rather than let GCC pick random things to do with it.
- -- (If we want to steal a6, then we would try to do things
- -- as on iX86, where we *do* steal the frame pointer [%ebp].)
- = ( [], ["-fno-defer-pop", "-fno-omit-frame-pointer"] )
-
-#elif i386_TARGET_ARCH
- -- -fno-defer-pop : basically the same game as for m68k
- --
- -- -fomit-frame-pointer : *must* in .hc files; because we're stealing
- -- the fp (%ebp) for our register maps.
- = let n_regs = stolen_x86_regs _dflags
- in
- (
- [ if opt_Static then "-DDONT_WANT_WIN32_DLL_SUPPORT" else ""
- ],
- [ "-fno-defer-pop",
- "-fomit-frame-pointer",
- -- we want -fno-builtin, because when gcc inlines
- -- built-in functions like memcpy() it tends to
- -- run out of registers, requiring -monly-n-regs
- "-fno-builtin",
- "-DSTOLEN_X86_REGS="++show n_regs ]
- )
-
-#elif ia64_TARGET_ARCH
- = ( [], ["-fomit-frame-pointer", "-G0"] )
-
-#elif x86_64_TARGET_ARCH
- = (
- [],
- ["-fomit-frame-pointer",
- "-fno-asynchronous-unwind-tables",
- -- the unwind tables are unnecessary for HC code,
- -- and get in the way of -split-objs. Another option
- -- would be to throw them away in the mangler, but this
- -- is easier.
- "-fno-builtin"
- -- calling builtins like strlen() using the FFI can
- -- cause gcc to run out of regs, so use the external
- -- version.
- ] )
-
-#elif sparc_TARGET_ARCH
- = ( [], ["-w"] )
- -- For now, to suppress the gcc warning "call-clobbered
- -- register used for global register variable", we simply
- -- disable all warnings altogether using the -w flag. Oh well.
-
-#elif powerpc_apple_darwin_TARGET
- -- -no-cpp-precomp:
- -- Disable Apple's precompiling preprocessor. It's a great thing
- -- for "normal" programs, but it doesn't support register variable
- -- declarations.
- = ( [], ["-no-cpp-precomp"] )
-#else
- = ( [], [] )
-#endif
-
picCCOpts :: DynFlags -> [String]
picCCOpts _dflags
#if darwin_TARGET_OS
-- -----------------------------------------------------------------------------
-- Compiler Info
-data Printable = String String
- | FromDynFlags (DynFlags -> String)
-
-compilerInfo :: [(String, Printable)]
-compilerInfo = [("Project name", String cProjectName),
- ("Project version", String cProjectVersion),
- ("Booter version", String cBooterVersion),
- ("Stage", String cStage),
- ("Build platform", String cBuildPlatformString),
- ("Host platform", String cHostPlatformString),
- ("Target platform", String cTargetPlatformString),
- ("Have interpreter", String cGhcWithInterpreter),
- ("Object splitting supported", String cSupportsSplitObjs),
- ("Have native code generator", String cGhcWithNativeCodeGen),
- ("Support SMP", String cGhcWithSMP),
- ("Unregisterised", String cGhcUnregisterised),
- ("Tables next to code", String cGhcEnableTablesNextToCode),
- ("RTS ways", String cGhcRTSWays),
- ("Leading underscore", String cLeadingUnderscore),
- ("Debug on", String (show debugIsOn)),
- ("LibDir", FromDynFlags topDir),
- ("Global Package DB", FromDynFlags systemPackageConfig),
- ("C compiler flags", String (show cCcOpts)),
- ("Gcc Linker flags", String (show cGccLinkerOpts)),
- ("Ld Linker flags", String (show cLdLinkerOpts))
- ]
+compilerInfo :: DynFlags -> [(String, String)]
+compilerInfo dflags
+ = -- We always make "Project name" be first to keep parsing in
+ -- other languages simple, i.e. when looking for other fields,
+ -- you don't have to worry whether there is a leading '[' or not
+ ("Project name", cProjectName)
+ -- Next come the settings, so anything else can be overridden
+ -- in the settings file (as "lookup" uses the first match for the
+ -- key)
+ : rawSettings dflags
+ ++ [("Project version", cProjectVersion),
+ ("Booter version", cBooterVersion),
+ ("Stage", cStage),
+ ("Build platform", cBuildPlatformString),
+ ("Host platform", cHostPlatformString),
+ ("Target platform", cTargetPlatformString),
+ ("Have interpreter", cGhcWithInterpreter),
+ ("Object splitting supported", cSupportsSplitObjs),
+ ("Have native code generator", cGhcWithNativeCodeGen),
+ ("Support SMP", cGhcWithSMP),
+ ("Unregisterised", cGhcUnregisterised),
+ ("Tables next to code", cGhcEnableTablesNextToCode),
+ ("RTS ways", cGhcRTSWays),
+ ("Leading underscore", cLeadingUnderscore),
+ ("Debug on", show debugIsOn),
+ ("LibDir", topDir dflags),
+ ("Global Package DB", systemPackageConfig dflags),
+ ("Gcc Linker flags", show cGccLinkerOpts),
+ ("Ld Linker flags", show cLdLinkerOpts)
+ ]
Outputable(..), OutputableBndr(..),
-- * Pretty printing combinators
- SDoc,
+ SDoc, runSDoc, initSDocContext,
docToSDoc,
interppSP, interpp'SP, pprQuotedList, pprWithCommas, quotedListWithOr,
empty, nest,
hang, punctuate, ppWhen, ppUnless,
speakNth, speakNTimes, speakN, speakNOf, plural,
+ coloured, PprColour, colType, colCoerc, colDataCon,
+ colBinder, bold, keyword,
+
-- * Converting 'SDoc' into strings and outputing it
printSDoc, printErrs, printOutput, hPrintDump, printDump,
printForC, printForAsm, printForUser, printForUserPartWay,
showSDocForUser, showSDocDebug, showSDocDump, showSDocDumpOneLine,
showPpr,
showSDocUnqual, showsPrecSDoc,
+ renderWithStyle,
pprInfixVar, pprPrefixVar,
pprHsChar, pprHsString, pprHsInfix, pprHsVar,
-- * Error handling and debugging utilities
pprPanic, pprSorry, assertPprPanic, pprPanicFastInt, pprPgmError,
- pprTrace, warnPprTrace,
+ pprTrace, pprDefiniteTrace, warnPprTrace,
trace, pgmError, panic, sorry, panicFastInt, assertPanic
) where
%************************************************************************
\begin{code}
- type SDoc = PprStyle -> Doc
+ newtype SDoc = SDoc { runSDoc :: SDocContext -> Doc }
+
+ data SDocContext = SDC
+ { sdocStyle :: !PprStyle
+ , sdocLastColour :: !PprColour
+ -- ^ The most recently used colour. This allows nesting colours.
+ }
+
+ initSDocContext :: PprStyle -> SDocContext
+ initSDocContext sty = SDC
+ { sdocStyle = sty
+ , sdocLastColour = colReset
+ }
withPprStyle :: PprStyle -> SDoc -> SDoc
- withPprStyle sty d _sty' = d sty
+ withPprStyle sty d = SDoc $ \ctxt -> runSDoc d ctxt{sdocStyle=sty}
withPprStyleDoc :: PprStyle -> SDoc -> Doc
- withPprStyleDoc sty d = d sty
+ withPprStyleDoc sty d = runSDoc d (initSDocContext sty)
pprDeeper :: SDoc -> SDoc
- pprDeeper _ (PprUser _ (PartWay 0)) = Pretty.text "..."
- pprDeeper d (PprUser q (PartWay n)) = d (PprUser q (PartWay (n-1)))
- pprDeeper d other_sty = d other_sty
+ pprDeeper d = SDoc $ \ctx -> case ctx of
+ SDC{sdocStyle=PprUser _ (PartWay 0)} -> Pretty.text "..."
+ SDC{sdocStyle=PprUser q (PartWay n)} ->
+ runSDoc d ctx{sdocStyle = PprUser q (PartWay (n-1))}
+ _ -> runSDoc d ctx
pprDeeperList :: ([SDoc] -> SDoc) -> [SDoc] -> SDoc
-- Truncate a list that list that is longer than the current depth
- pprDeeperList f ds (PprUser q (PartWay n))
- | n==0 = Pretty.text "..."
- | otherwise = f (go 0 ds) (PprUser q (PartWay (n-1)))
- where
- go _ [] = []
- go i (d:ds) | i >= n = [text "...."]
- | otherwise = d : go (i+1) ds
-
- pprDeeperList f ds other_sty
- = f ds other_sty
+ pprDeeperList f ds = SDoc work
+ where
+ work ctx@SDC{sdocStyle=PprUser q (PartWay n)}
+ | n==0 = Pretty.text "..."
+ | otherwise =
+ runSDoc (f (go 0 ds)) ctx{sdocStyle = PprUser q (PartWay (n-1))}
+ where
+ go _ [] = []
+ go i (d:ds) | i >= n = [text "...."]
+ | otherwise = d : go (i+1) ds
+ work other_ctx = runSDoc (f ds) other_ctx
pprSetDepth :: Depth -> SDoc -> SDoc
- pprSetDepth depth doc (PprUser q _) = doc (PprUser q depth)
- pprSetDepth _depth doc other_sty = doc other_sty
+ pprSetDepth depth doc = SDoc $ \ctx -> case ctx of
+ SDC{sdocStyle=PprUser q _} ->
+ runSDoc doc ctx{sdocStyle = PprUser q depth}
+ _ ->
+ runSDoc doc ctx
getPprStyle :: (PprStyle -> SDoc) -> SDoc
- getPprStyle df sty = df sty sty
+ getPprStyle df = SDoc $ \ctx -> runSDoc (df (sdocStyle ctx)) ctx
\end{code}
\begin{code}
userStyle _other = False
ifPprDebug :: SDoc -> SDoc -- Empty for non-debug style
- ifPprDebug d sty@PprDebug = d sty
- ifPprDebug _ _ = Pretty.empty
+ ifPprDebug d = SDoc $ \ctx -> case ctx of
+ SDC{sdocStyle=PprDebug} -> runSDoc d ctx
+ _ -> Pretty.empty
\end{code}
\begin{code}
-- Unused [7/02 sof]
printSDoc :: SDoc -> PprStyle -> IO ()
printSDoc d sty = do
- Pretty.printDoc PageMode stdout (d sty)
+ Pretty.printDoc PageMode stdout (runSDoc d (initSDocContext sty))
hFlush stdout
-- I'm not sure whether the direct-IO approach of Pretty.printDoc
-- above is better or worse than the put-big-string approach here
- printErrs :: Doc -> IO ()
- printErrs doc = do Pretty.printDoc PageMode stderr doc
- hFlush stderr
+ printErrs :: SDoc -> PprStyle -> IO ()
+ printErrs doc sty = do
+ Pretty.printDoc PageMode stderr (runSDoc doc (initSDocContext sty))
+ hFlush stderr
printOutput :: Doc -> IO ()
printOutput doc = Pretty.printDoc PageMode stdout doc
hPrintDump :: Handle -> SDoc -> IO ()
hPrintDump h doc = do
- Pretty.printDoc PageMode h (better_doc defaultDumpStyle)
+ Pretty.printDoc PageMode h
+ (runSDoc better_doc (initSDocContext defaultDumpStyle))
hFlush h
where
better_doc = doc $$ blankLine
printForUser :: Handle -> PrintUnqualified -> SDoc -> IO ()
printForUser handle unqual doc
- = Pretty.printDoc PageMode handle (doc (mkUserStyle unqual AllTheWay))
+ = Pretty.printDoc PageMode handle
+ (runSDoc doc (initSDocContext (mkUserStyle unqual AllTheWay)))
printForUserPartWay :: Handle -> Int -> PrintUnqualified -> SDoc -> IO ()
printForUserPartWay handle d unqual doc
- = Pretty.printDoc PageMode handle (doc (mkUserStyle unqual (PartWay d)))
+ = Pretty.printDoc PageMode handle
+ (runSDoc doc (initSDocContext (mkUserStyle unqual (PartWay d))))
-- printForC, printForAsm do what they sound like
printForC :: Handle -> SDoc -> IO ()
- printForC handle doc = Pretty.printDoc LeftMode handle (doc (PprCode CStyle))
+ printForC handle doc =
+ Pretty.printDoc LeftMode handle
+ (runSDoc doc (initSDocContext (PprCode CStyle)))
printForAsm :: Handle -> SDoc -> IO ()
- printForAsm handle doc = Pretty.printDoc LeftMode handle (doc (PprCode AsmStyle))
+ printForAsm handle doc =
+ Pretty.printDoc LeftMode handle
+ (runSDoc doc (initSDocContext (PprCode AsmStyle)))
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 = Pretty.showDocWith PageMode (d defaultUserStyle)
+ showSDoc d =
+ Pretty.showDocWith PageMode
+ (runSDoc d (initSDocContext defaultUserStyle))
+
+ renderWithStyle :: SDoc -> PprStyle -> String
+ renderWithStyle sdoc sty =
+ Pretty.render (runSDoc sdoc (initSDocContext sty))
-- This shows an SDoc, but on one line only. It's cheaper than a full
-- showSDoc, designed for when we're getting results like "Foo.bar"
-- and "foo{uniq strictness}" so we don't want fancy layout anyway.
showSDocOneLine :: SDoc -> String
- showSDocOneLine d = Pretty.showDocWith PageMode (d defaultUserStyle)
+ showSDocOneLine d =
+ Pretty.showDocWith PageMode
+ (runSDoc d (initSDocContext defaultUserStyle))
showSDocForUser :: PrintUnqualified -> SDoc -> String
- showSDocForUser unqual doc = show (doc (mkUserStyle unqual AllTheWay))
+ showSDocForUser unqual doc =
+ show (runSDoc doc (initSDocContext (mkUserStyle unqual AllTheWay)))
showSDocUnqual :: SDoc -> String
-- Only used in the gruesome isOperator
- showSDocUnqual d = show (d (mkUserStyle neverQualify AllTheWay))
+ showSDocUnqual d =
+ show (runSDoc d (initSDocContext (mkUserStyle neverQualify AllTheWay)))
showsPrecSDoc :: Int -> SDoc -> ShowS
- showsPrecSDoc p d = showsPrec p (d defaultUserStyle)
+ showsPrecSDoc p d = showsPrec p (runSDoc d (initSDocContext defaultUserStyle))
showSDocDump :: SDoc -> String
- showSDocDump d = Pretty.showDocWith PageMode (d PprDump)
+ showSDocDump d =
+ Pretty.showDocWith PageMode (runSDoc d (initSDocContext PprDump))
showSDocDumpOneLine :: SDoc -> String
- showSDocDumpOneLine d = Pretty.showDocWith OneLineMode (d PprDump)
+ showSDocDumpOneLine d =
+ Pretty.showDocWith OneLineMode (runSDoc d (initSDocContext PprDump))
showSDocDebug :: SDoc -> String
- showSDocDebug d = show (d PprDebug)
+ showSDocDebug d = show (runSDoc d (initSDocContext PprDebug))
showPpr :: Outputable a => a -> String
showPpr = showSDoc . ppr
\begin{code}
docToSDoc :: Doc -> SDoc
- docToSDoc d = \_ -> d
+ docToSDoc d = SDoc (\_ -> d)
empty :: SDoc
char :: Char -> SDoc
double :: Double -> SDoc
rational :: Rational -> SDoc
- empty _sty = Pretty.empty
- char c _sty = Pretty.char c
- text s _sty = Pretty.text s
- ftext s _sty = Pretty.ftext s
- ptext s _sty = Pretty.ptext s
- int n _sty = Pretty.int n
- integer n _sty = Pretty.integer n
- float n _sty = Pretty.float n
- double n _sty = Pretty.double n
- rational n _sty = Pretty.rational n
+ empty = docToSDoc $ Pretty.empty
+ char c = docToSDoc $ Pretty.char c
+ text s = docToSDoc $ Pretty.text s
+ ftext s = docToSDoc $ Pretty.ftext s
+ ptext s = docToSDoc $ Pretty.ptext s
+ int n = docToSDoc $ Pretty.int n
+ integer n = docToSDoc $ Pretty.integer n
+ float n = docToSDoc $ Pretty.float n
+ double n = docToSDoc $ Pretty.double n
+ rational n = docToSDoc $ Pretty.rational n
parens, braces, brackets, quotes, doubleQuotes, angleBrackets :: SDoc -> SDoc
- parens d sty = Pretty.parens (d sty)
- braces d sty = Pretty.braces (d sty)
- brackets d sty = Pretty.brackets (d sty)
- doubleQuotes d sty = Pretty.doubleQuotes (d sty)
- angleBrackets d = char '<' <> d <> char '>'
+ parens d = SDoc $ Pretty.parens . runSDoc d
+ braces d = SDoc $ Pretty.braces . runSDoc d
+ brackets d = SDoc $ Pretty.brackets . runSDoc d
+ doubleQuotes d = SDoc $ Pretty.doubleQuotes . runSDoc d
+ angleBrackets d = char '<' <> d <> char '>'
cparen :: Bool -> SDoc -> SDoc
- cparen b d sty = Pretty.cparen b (d sty)
+ cparen b d = SDoc $ Pretty.cparen b . runSDoc d
-- quotes encloses something in single quotes...
-- but it omits them if the thing ends in a single quote
-- so that we don't get `foo''. Instead we just have foo'.
- quotes d sty = case show pp_d of
- ('\'' : _) -> pp_d
- _other -> Pretty.quotes pp_d
- where
- pp_d = d sty
+ quotes d = SDoc $ \sty ->
+ let pp_d = runSDoc d sty in
+ case show pp_d of
+ ('\'' : _) -> pp_d
+ _other -> Pretty.quotes pp_d
semi, comma, colon, equals, space, dcolon, arrow, underscore, dot :: SDoc
darrow, lparen, rparen, lbrack, rbrack, lbrace, rbrace, blankLine :: SDoc
- blankLine _sty = Pretty.ptext (sLit "")
- dcolon _sty = Pretty.ptext (sLit "::")
- arrow _sty = Pretty.ptext (sLit "->")
- darrow _sty = Pretty.ptext (sLit "=>")
- semi _sty = Pretty.semi
- comma _sty = Pretty.comma
- colon _sty = Pretty.colon
- equals _sty = Pretty.equals
- space _sty = Pretty.space
- underscore = char '_'
- dot = char '.'
- lparen _sty = Pretty.lparen
- rparen _sty = Pretty.rparen
- lbrack _sty = Pretty.lbrack
- rbrack _sty = Pretty.rbrack
- lbrace _sty = Pretty.lbrace
- rbrace _sty = Pretty.rbrace
+ blankLine = docToSDoc $ Pretty.ptext (sLit "")
+ dcolon = docToSDoc $ Pretty.ptext (sLit "::")
+ arrow = docToSDoc $ Pretty.ptext (sLit "->")
+ darrow = docToSDoc $ Pretty.ptext (sLit "=>")
+ semi = docToSDoc $ Pretty.semi
+ comma = docToSDoc $ Pretty.comma
+ colon = docToSDoc $ Pretty.colon
+ equals = docToSDoc $ Pretty.equals
+ space = docToSDoc $ Pretty.space
+ underscore = char '_'
+ dot = char '.'
+ lparen = docToSDoc $ Pretty.lparen
+ rparen = docToSDoc $ Pretty.rparen
+ lbrack = docToSDoc $ Pretty.lbrack
+ rbrack = docToSDoc $ Pretty.rbrack
+ lbrace = docToSDoc $ Pretty.lbrace
+ rbrace = docToSDoc $ Pretty.rbrace
nest :: Int -> SDoc -> SDoc
-- ^ Indent 'SDoc' some specified amount
($+$) :: SDoc -> SDoc -> SDoc
-- ^ Join two 'SDoc' together vertically
- nest n d sty = Pretty.nest n (d sty)
- (<>) d1 d2 sty = (Pretty.<>) (d1 sty) (d2 sty)
- (<+>) d1 d2 sty = (Pretty.<+>) (d1 sty) (d2 sty)
- ($$) d1 d2 sty = (Pretty.$$) (d1 sty) (d2 sty)
- ($+$) d1 d2 sty = (Pretty.$+$) (d1 sty) (d2 sty)
+ nest n d = SDoc $ Pretty.nest n . runSDoc d
+ (<>) d1 d2 = SDoc $ \sty -> (Pretty.<>) (runSDoc d1 sty) (runSDoc d2 sty)
+ (<+>) d1 d2 = SDoc $ \sty -> (Pretty.<+>) (runSDoc d1 sty) (runSDoc d2 sty)
+ ($$) d1 d2 = SDoc $ \sty -> (Pretty.$$) (runSDoc d1 sty) (runSDoc d2 sty)
+ ($+$) d1 d2 = SDoc $ \sty -> (Pretty.$+$) (runSDoc d1 sty) (runSDoc d2 sty)
hcat :: [SDoc] -> SDoc
-- ^ Concatenate 'SDoc' horizontally
-- ^ This behaves like 'fsep', but it uses '<>' for horizontal conposition rather than '<+>'
- hcat ds sty = Pretty.hcat [d sty | d <- ds]
- hsep ds sty = Pretty.hsep [d sty | d <- ds]
- vcat ds sty = Pretty.vcat [d sty | d <- ds]
- sep ds sty = Pretty.sep [d sty | d <- ds]
- cat ds sty = Pretty.cat [d sty | d <- ds]
- fsep ds sty = Pretty.fsep [d sty | d <- ds]
- fcat ds sty = Pretty.fcat [d sty | d <- ds]
+ hcat ds = SDoc $ \sty -> Pretty.hcat [runSDoc d sty | d <- ds]
+ hsep ds = SDoc $ \sty -> Pretty.hsep [runSDoc d sty | d <- ds]
+ vcat ds = SDoc $ \sty -> Pretty.vcat [runSDoc d sty | d <- ds]
+ sep ds = SDoc $ \sty -> Pretty.sep [runSDoc d sty | d <- ds]
+ cat ds = SDoc $ \sty -> Pretty.cat [runSDoc d sty | d <- ds]
+ fsep ds = SDoc $ \sty -> Pretty.fsep [runSDoc d sty | d <- ds]
+ fcat ds = SDoc $ \sty -> Pretty.fcat [runSDoc d sty | d <- ds]
hang :: SDoc -- ^ The header
-> Int -- ^ Amount to indent the hung body
-> SDoc -- ^ The hung body, indented and placed below the header
-> SDoc
- hang d1 n d2 sty = Pretty.hang (d1 sty) n (d2 sty)
+ hang d1 n d2 = SDoc $ \sty -> Pretty.hang (runSDoc d1 sty) n (runSDoc d2 sty)
punctuate :: SDoc -- ^ The punctuation
-> [SDoc] -- ^ The list that will have punctuation added between every adjacent pair of elements
ppUnless True _ = empty
ppUnless False doc = doc
+
+ -- | A colour\/style for use with 'coloured'.
+ newtype PprColour = PprColour String
+
+ -- Colours
+
+ colType :: PprColour
+ colType = PprColour "\27[34m"
+
+ colBold :: PprColour
+ colBold = PprColour "\27[;1m"
+
+ colCoerc :: PprColour
+ colCoerc = PprColour "\27[34m"
+
+ colDataCon :: PprColour
+ colDataCon = PprColour "\27[31m"
+
+ colBinder :: PprColour
+ colBinder = PprColour "\27[32m"
+
+ colReset :: PprColour
+ colReset = PprColour "\27[0m"
+
+ -- | Apply the given colour\/style for the argument.
+ --
+ -- Only takes effect if colours are enabled.
+ coloured :: PprColour -> SDoc -> SDoc
+ -- TODO: coloured _ sdoc ctxt | coloursDisabled = sdoc ctxt
+ coloured col@(PprColour c) sdoc =
+ SDoc $ \ctx@SDC{ sdocLastColour = PprColour lc } ->
+ let ctx' = ctx{ sdocLastColour = col } in
+ Pretty.zeroWidthText c Pretty.<> runSDoc sdoc ctx' Pretty.<> Pretty.zeroWidthText lc
+
+ bold :: SDoc -> SDoc
+ bold = coloured colBold
+
+ keyword :: SDoc -> SDoc
+ keyword = bold
+
\end{code}
| opt_NoDebugOutput = x
| otherwise = pprAndThen trace str doc x
+pprDefiniteTrace :: String -> SDoc -> a -> a
+-- ^ Same as pprTrace, but show even if -dno-debug-output is on
+pprDefiniteTrace str doc x = pprAndThen trace str doc x
pprPanicFastInt :: String -> SDoc -> FastInt
-- ^ Specialization of pprPanic that can be safely used with 'FastInt'
- pprPanicFastInt heading pretty_msg = panicFastInt (show (doc PprDebug))
- where
- doc = text heading <+> pretty_msg
+ pprPanicFastInt heading pretty_msg =
+ panicFastInt (show (runSDoc doc (initSDocContext PprDebug)))
+ where
+ doc = text heading <+> pretty_msg
pprAndThen :: (String -> a) -> String -> SDoc -> a
- pprAndThen cont heading pretty_msg = cont (show (doc PprDebug))
- where
+ pprAndThen cont heading pretty_msg =
+ cont (show (runSDoc doc (initSDocContext PprDebug)))
+ where
doc = sep [text heading, nest 4 pretty_msg]
assertPprPanic :: String -> Int -> SDoc -> a
-- ^ Panic with an assertation failure, recording the given file and line number.
-- Should typically be accessed with the ASSERT family of macros
assertPprPanic file line msg
- = panic (show (doc PprDebug))
+ = panic (show (runSDoc doc (initSDocContext PprDebug)))
where
doc = sep [hsep[text "ASSERT failed! file",
text file,
warnPprTrace _ _file _line _msg x | opt_NoDebugOutput = x
warnPprTrace False _file _line _msg x = x
warnPprTrace True file line msg x
- = trace (show (doc defaultDumpStyle)) x
+ = trace (show (runSDoc doc (initSDocContext defaultDumpStyle))) x
where
doc = sep [hsep [text "WARNING: file", text file, text "line", int line],
msg]
projects / ghc-hetmet.git / commitdiff