import IO ( hPutStr, hPutStrLn, stdout )
-import CmdLineOpts ( DynFlags, dopt_D_show_passes, dopt_DoCoreLinting,
- opt_PprStyle_Debug )
import CoreSyn
import Rules ( RuleBase, pprRuleBase )
import CoreFVs ( idFreeVars, mustHaveLocalBinding )
)
import TyCon ( TyCon, isPrimTyCon, tyConDataCons )
import BasicTypes ( RecFlag(..), isNonRec )
+import CmdLineOpts
import Maybe
import Outputable
\begin{code}
beginPass :: DynFlags -> String -> IO ()
beginPass dflags pass_name
- | dopt_D_show_passes dflags
+ | dopt Opt_D_show_passes dflags
= hPutStrLn stdout ("*** " ++ pass_name)
| otherwise
= return ()
-- Report result size if required
-- This has the side effect of forcing the intermediate to be evaluated
- if dopt_D_show_passes dflags then
+ if dopt Opt_D_show_passes dflags then
hPutStrLn stdout (" Result size = " ++ show (coreBindsSize binds))
else
return ()
lintCoreBindings :: DynFlags -> String -> [CoreBind] -> IO ()
lintCoreBindings dflags whoDunnit binds
- | not (dopt_DoCoreLinting dflags)
+ | not (dopt Opt_DoCoreLinting dflags)
= return ()
lintCoreBindings dflags whoDunnit binds
returnL ()
lint_bind (NonRec bndr rhs) = lintSingleBinding NonRecursive (bndr,rhs)
- done_lint = doIfSet_dyn dflags dopt_D_show_passes
+ done_lint = doIfSet_dyn dflags (dopt Opt_D_show_passes)
(hPutStr stdout ("*** Core Linted result of " ++ whoDunnit ++ "\n"))
warn warnings
= vcat [
-> (Maybe Message, Maybe Message) -- (Nothing,_) => OK
lintUnfolding dflags locn vars expr
- | not (dopt_DoCoreLinting dflags)
+ | not (dopt Opt_DoCoreLinting dflags)
= (Nothing, Nothing)
| otherwise
opt_UF_FunAppDiscount,
opt_UF_KeenessFactor,
opt_UF_DearOp, opt_UnfoldCasms,
- DynFlags, dopt_D_dump_inlinings
+ DynFlags, DynFlag(..), dopt
)
import CoreSyn
import PprCore ( pprCoreExpr )
in
#ifdef DEBUG
- if dopt_D_dump_inlinings dflags then
+ if dopt Opt_D_dump_inlinings dflags then
pprTrace "Considering inlining"
(ppr id <+> vcat [text "black listed:" <+> ppr black_listed,
text "occ info:" <+> ppr occ,
switchIsOn,
isStaticHscFlag,
- -- debugging opts
- dopt_D_dump_absC,
- dopt_D_dump_asm,
- dopt_D_dump_cpranal,
- dopt_D_dump_cse,
- dopt_D_dump_deriv,
- dopt_D_dump_ds,
- dopt_D_dump_flatC,
- dopt_D_dump_foreign,
- dopt_D_dump_hi_diffs,
- dopt_D_dump_inlinings,
- dopt_D_dump_occur_anal,
- dopt_D_dump_parsed,
- dopt_D_dump_realC,
- dopt_D_dump_rn,
- dopt_D_dump_rules,
- dopt_D_dump_simpl,
- dopt_D_dump_simpl_iterations,
- dopt_D_dump_simpl_stats,
- dopt_D_dump_spec,
- dopt_D_dump_stg,
- dopt_D_dump_stranal,
- dopt_D_dump_tc,
- dopt_D_dump_types,
- dopt_D_dump_usagesp,
- dopt_D_dump_worker_wrapper,
- dopt_D_show_passes,
- dopt_D_dump_rn_trace,
- dopt_D_dump_rn_stats,
- dopt_D_dump_stix,
- dopt_D_dump_minimal_imports,
- dopt_D_source_stats,
- dopt_D_verbose_core2core,
- dopt_D_verbose_stg2stg,
- dopt_DoCoreLinting,
- dopt_DoStgLinting,
- dopt_DoUSPLinting,
-
opt_PprStyle_NoPrags,
opt_PprUserLength,
opt_PprStyle_Debug,
+ dopt,
+
-- other dynamic flags
dopt_CoreToDo,
dopt_StgToDo,
- -- warning opts
- opt_WarnDuplicateExports,
- opt_WarnHiShadows,
- opt_WarnIncompletePatterns,
- opt_WarnMissingFields,
- opt_WarnMissingMethods,
- opt_WarnMissingSigs,
- opt_WarnNameShadowing,
- opt_WarnOverlappingPatterns,
- opt_WarnSimplePatterns,
- opt_WarnTypeDefaults,
- opt_WarnUnusedBinds,
- opt_WarnUnusedImports,
- opt_WarnUnusedMatches,
- opt_WarnDeprecations,
-
-- profiling opts
opt_AutoSccsOnAllToplevs,
opt_AutoSccsOnExportedToplevs,
opt_AllStrict,
opt_DictsStrict,
opt_MaxContextReductionDepth,
- dopt_AllowOverlappingInstances,
- dopt_AllowUndecidableInstances,
- dopt_GlasgowExts,
opt_Generics,
opt_IrrefutableTuples,
opt_NumbersStrict,
| CoreDoWorkerWrapper
| CoreDoSpecialising
| CoreDoUSPInf
- | CoreDoCPResult
+ | CoreDoCPResult
| CoreDoGlomBinds
| CoreCSE
| Opt_DoStgLinting
| Opt_DoUSPLinting
+ | Opt_WarnDuplicateExports
+ | Opt_WarnHiShadows
+ | Opt_WarnIncompletePatterns
+ | Opt_WarnMissingFields
+ | Opt_WarnMissingMethods
+ | Opt_WarnMissingSigs
+ | Opt_WarnNameShadowing
+ | Opt_WarnOverlappingPatterns
+ | Opt_WarnSimplePatterns
+ | Opt_WarnTypeDefaults
+ | Opt_WarnUnusedBinds
+ | Opt_WarnUnusedImports
+ | Opt_WarnUnusedMatches
+ | Opt_WarnDeprecations
+
-- language opts
| Opt_AllowOverlappingInstances
| Opt_AllowUndecidableInstances
flags :: [DynFlag]
}
-boolOpt :: DynFlag -> DynFlags -> Bool
-boolOpt f dflags = f `elem` (flags dflags)
-
-dopt_D_dump_all = boolOpt Opt_D_dump_all
-dopt_D_dump_most = boolOpt Opt_D_dump_most
-dopt_D_dump_absC = boolOpt Opt_D_dump_absC
-dopt_D_dump_asm = boolOpt Opt_D_dump_asm
-dopt_D_dump_cpranal = boolOpt Opt_D_dump_cpranal
-dopt_D_dump_deriv = boolOpt Opt_D_dump_deriv
-dopt_D_dump_ds = boolOpt Opt_D_dump_ds
-dopt_D_dump_flatC = boolOpt Opt_D_dump_flatC
-dopt_D_dump_foreign = boolOpt Opt_D_dump_foreign
-dopt_D_dump_inlinings = boolOpt Opt_D_dump_inlinings
-dopt_D_dump_occur_anal = boolOpt Opt_D_dump_occur_anal
-dopt_D_dump_parsed = boolOpt Opt_D_dump_parsed
-dopt_D_dump_realC = boolOpt Opt_D_dump_realC
-dopt_D_dump_rn = boolOpt Opt_D_dump_rn
-dopt_D_dump_simpl = boolOpt Opt_D_dump_simpl
-dopt_D_dump_simpl_iterations = boolOpt Opt_D_dump_simpl_iterations
-dopt_D_dump_spec = boolOpt Opt_D_dump_spec
-dopt_D_dump_stg = boolOpt Opt_D_dump_stg
-dopt_D_dump_stranal = boolOpt Opt_D_dump_stranal
-dopt_D_dump_tc = boolOpt Opt_D_dump_tc
-dopt_D_dump_types = boolOpt Opt_D_dump_types
-dopt_D_dump_rules = boolOpt Opt_D_dump_rules
-dopt_D_dump_usagesp = boolOpt Opt_D_dump_usagesp
-dopt_D_dump_cse = boolOpt Opt_D_dump_cse
-dopt_D_dump_worker_wrapper = boolOpt Opt_D_dump_worker_wrapper
-dopt_D_show_passes = boolOpt Opt_D_show_passes
-dopt_D_dump_rn_trace = boolOpt Opt_D_dump_rn_trace
-dopt_D_dump_rn_stats = boolOpt Opt_D_dump_rn_stats
-dopt_D_dump_stix = boolOpt Opt_D_dump_stix
-dopt_D_dump_simpl_stats = boolOpt Opt_D_dump_simpl_stats
-dopt_D_source_stats = boolOpt Opt_D_source_stats
-dopt_D_verbose_core2core = boolOpt Opt_D_verbose_core2core
-dopt_D_verbose_stg2stg = boolOpt Opt_D_verbose_stg2stg
-dopt_D_dump_hi_diffs = boolOpt Opt_D_dump_hi_diffs
-dopt_D_dump_minimal_imports = boolOpt Opt_D_dump_minimal_imports
-dopt_DoCoreLinting = boolOpt Opt_DoCoreLinting
-dopt_DoStgLinting = boolOpt Opt_DoStgLinting
-dopt_DoUSPLinting = boolOpt Opt_DoUSPLinting
-
-dopt_AllowOverlappingInstances = boolOpt Opt_AllowOverlappingInstances
-dopt_AllowUndecidableInstances = boolOpt Opt_AllowUndecidableInstances
-dopt_GlasgowExts = boolOpt Opt_GlasgowExts
+dopt :: DynFlag -> DynFlags -> Bool
+dopt f dflags = f `elem` (flags dflags)
dopt_CoreToDo :: DynFlags -> CoreToDo
dopt_CoreToDo = coreToDo
= HscC
| HscAsm
| HscJava
+ | HscInterpreter
deriving Eq
dopt_HscLang :: DynFlags -> HscLang
opt_PprStyle_Debug = lookUp SLIT("-dppr-debug")
opt_PprUserLength = lookup_def_int "-dppr-user-length" 5 --ToDo: give this a name
--- warning opts
-opt_WarnDuplicateExports = lookUp SLIT("-fwarn-duplicate-exports")
-opt_WarnHiShadows = lookUp SLIT("-fwarn-hi-shadowing")
-opt_WarnIncompletePatterns = lookUp SLIT("-fwarn-incomplete-patterns")
-opt_WarnMissingFields = lookUp SLIT("-fwarn-missing-fields")
-opt_WarnMissingMethods = lookUp SLIT("-fwarn-missing-methods")
-opt_WarnMissingSigs = lookUp SLIT("-fwarn-missing-signatures")
-opt_WarnNameShadowing = lookUp SLIT("-fwarn-name-shadowing")
-opt_WarnOverlappingPatterns = lookUp SLIT("-fwarn-overlapping-patterns")
-opt_WarnSimplePatterns = lookUp SLIT("-fwarn-simple-patterns")
-opt_WarnTypeDefaults = lookUp SLIT("-fwarn-type-defaults")
-opt_WarnUnusedBinds = lookUp SLIT("-fwarn-unused-binds")
-opt_WarnUnusedImports = lookUp SLIT("-fwarn-unused-imports")
-opt_WarnUnusedMatches = lookUp SLIT("-fwarn-unused-matches")
-opt_WarnDeprecations = lookUp SLIT("-fwarn-deprecations")
-
-- profiling opts
opt_AutoSccsOnAllToplevs = lookUp SLIT("-fauto-sccs-on-all-toplevs")
opt_AutoSccsOnExportedToplevs = lookUp SLIT("-fauto-sccs-on-exported-toplevs")
opt_UnboxStrictFields = lookUp SLIT("-funbox-strict-fields")
{-
- The optional '-inpackage=P' flag tells what package
+ The optional '-inpackage=P' flag tells what package
we are compiling this module for.
The Prelude, for example is compiled with '-package prelude'
-}
%************************************************************************
\begin{code}
-isStaticHscFlag f =
+isStaticHscFlag f =
f `elem` [
- "-fwarn-duplicate-exports",
- "-fwarn-hi-shadowing",
- "-fwarn-incomplete-patterns",
- "-fwarn-missing-fields",
- "-fwarn-missing-methods",
- "-fwarn-missing-signatures",
- "-fwarn-name-shadowing",
- "-fwarn-overlapping-patterns",
- "-fwarn-simple-patterns",
- "-fwarn-type-defaults",
- "-fwarn-unused-binds",
- "-fwarn-unused-imports",
- "-fwarn-unused-matches",
- "-fwarn-deprecations",
"-fauto-sccs-on-all-toplevs",
"-fauto-sccs-on-exported-toplevs",
"-fauto-sccs-on-individual-cafs",
#endif
}
where
- mk_assoc_elem k@(MaxSimplifierIterations lvl)
+ mk_assoc_elem k@(MaxSimplifierIterations lvl)
= (iBox (tagOf_SimplSwitch k), SwInt lvl)
mk_assoc_elem k@(SimplInlinePhase n)
= (iBox (tagOf_SimplSwitch k), SwInt n)
-----------------------------------------------------------------------------
--- $Id: DriverFlags.hs,v 1.4 2000/10/16 14:26:26 simonmar Exp $
+-- $Id: DriverFlags.hs,v 1.5 2000/10/17 13:22:10 simonmar Exp $
--
-- Driver flags
--
-----------------------------------------------------------------------------
-- parse the dynamic arguments
-GLOBAL_VAR(v_DynFlags, error "no dynFlags", DynFlags)
+GLOBAL_VAR(v_InitDynFlags, error "no InitDynFlags", DynFlags)
+GLOBAL_VAR(v_DynFlags, error "no DynFlags", DynFlags)
setDynFlag f = do
dfs <- readIORef v_DynFlags
, ( "DoStgLinting", NoArg (setDynFlag Opt_DoStgLinting) )
, ( "DoUSPLinting", NoArg (setDynFlag Opt_DoUSPLinting) )
+ ------ Warnings ----------------------------------------------------
+
+ , ( "-fwarn-duplicate-exports", NoArg (setDynFlag Opt_WarnDuplicateExports) )
+ , ( "-fwarn-hi-shadowing", NoArg (setDynFlag Opt_WarnHiShadows) )
+ , ( "-fwarn-incomplete-patterns", NoArg (setDynFlag Opt_WarnIncompletePatterns) )
+ , ( "-fwarn-missing-fields", NoArg (setDynFlag Opt_WarnMissingFields) )
+ , ( "-fwarn-missing-methods", NoArg (setDynFlag Opt_WarnMissingMethods))
+ , ( "-fwarn-missing-signatures", NoArg (setDynFlag Opt_WarnMissingSigs) )
+ , ( "-fwarn-name-shadowing", NoArg (setDynFlag Opt_WarnNameShadowin) )
+ , ( "-fwarn-overlapping-patterns", NoArg (setDynFlag Opt_WarnOverlappingPatterns )) )
+ , ( "-fwarn-simple-patterns", NoArg (setDynFlag Opt_WarnSimplePatterns))
+ , ( "-fwarn-type-defaults", NoArg (setDynFlag Opt_WarnTypeDefaults) )
+ , ( "-fwarn-unused-binds", NoArg (setDynFlag Opt_WarnUnusedBinds) )
+ , ( "-fwarn-unused-imports", NoArg (setDynFlag Opt_WarnUnusedImports) )
+ , ( "-fwarn-unused-matches", NoArg (setDynFlag Opt_WarnUnusedMatches) )
+ , ( "-fwarn-deprecations", NoArg (setDynFlag Opt_WarnDeprecations) )
+
------ Machine dependant (-m<blah>) stuff ---------------------------
, ( "monly-2-regs", NoArg (updateState (\s -> s{stolen_x86_regs = 2}) ))
static <- (do s <- readIORef static; if s then return "-static" else return "")
- l <- readIORef hsc_lang
- let lang = case l of
- HscC -> "-olang=C"
- HscAsm -> "-olang=asm"
- HscJava -> "-olang=java"
-
-- get hi-file suffix
hisuf <- readIORef hi_suf
import_dirs <- readIORef import_paths
package_import_dirs <- getPackageImportPath
- let hi_map = "-himap=" ++
- makeHiMap import_dirs hisuf
- package_import_dirs package_hisuf
- split_marker
-
- hi_map_sep = "-himap-sep=" ++ [split_marker]
-
return
(
filtered_opts
- ++ [ hi_vers, static, verb, lang, hi_map, hi_map_sep ]
+ ++ [ hi_vers, static, verb ]
)
-
-makeHiMap
- (import_dirs :: [String])
- (hi_suffix :: String)
- (package_import_dirs :: [String])
- (package_hi_suffix :: String)
- (split_marker :: Char)
- = foldr (add_dir hi_suffix)
- (foldr (add_dir package_hi_suffix) "" package_import_dirs)
- import_dirs
- where
- add_dir hisuf dir str = dir ++ "%." ++ hisuf ++ split_marker : str
-----------------------------------------------------------------------------
--- $Id: DriverMkDepend.hs,v 1.1 2000/10/11 15:31:43 simonmar Exp $
+-- $Id: DriverMkDepend.hs,v 1.2 2000/10/17 13:22:10 simonmar Exp $
--
-- GHC Driver
--
import DriverUtil
import DriverFlags
import TmpFiles
+import Module
import Config
import Util
-import CmdLineOpts
import IOExts
import Exception
let
(imp_mod, is_source) =
case imp of
- MINormal str -> (str, False)
- MISource str -> (str, True )
+ MINormal str -> (moduleNameString str, False)
+ MISource str -> (moduleNameString str, True )
imp_hi = imp_mod ++ '.':hisuf
imp_hiboot = imp_mod ++ ".hi-boot"
module Finder (
Finder, -- = ModuleName -> IO (Maybe (Module, ModuleLocation))
newFinder, -- :: PackageConfigInfo -> IO Finder,
- ModuleLocation(..)
+ ModuleLocation(..),
+ mkHomeModuleLocn
) where
#include "HsVersions.h"
lhs = basename ++ ".lhs"
case lookupFM home_cache hs of {
- Just path -> mkHomeModuleLocn mod_name basename path hs;
+ Just path -> mkHomeModuleLocn mod_name (path ++ '/':basename) hs;
Nothing ->
case lookupFM home_cache lhs of {
- Just path -> mkHomeModuleLocn mod_name basename path lhs;
+ Just path -> mkHomeModuleLocn mod_name (path ++ '/':basename) lhs;
Nothing -> return Nothing
}}
-mkHomeModuleLocn mod_name basename path source_fn = do
+mkHomeModuleLocn mod_name basename source_fn = do
-- figure out the .hi file name: it lives in the same dir as the
-- source, unless there's a -ohi flag on the command line.
ohi <- readIORef output_hi
hisuf <- readIORef hi_suf
let hifile = case ohi of
- Nothing -> path ++ '/':basename ++ hisuf
+ Nothing -> basename ++ hisuf
Just fn -> fn
-- figure out the .o file name. It also lives in the same dir
-- as the source, but can be overriden by a -odir flag.
- o_file <- odir_ify (path ++ '/':basename ++ '.':phaseInputExt Ln)
+ o_file <- odir_ify (basename ++ '.':phaseInputExt Ln)
return (Just (mkHomeModule mod_name,
ModuleLocation{
{-# OPTIONS -W -fno-warn-incomplete-patterns #-}
-----------------------------------------------------------------------------
--- $Id: Main.hs,v 1.5 2000/10/11 16:26:04 simonmar Exp $
+-- $Id: Main.hs,v 1.6 2000/10/17 13:22:11 simonmar Exp $
--
-- GHC Driver program
--
-- the rest of the arguments are "dynamic"
srcs <- processArgs dynamic_flags non_static []
+ -- save the "initial DynFlags" away
+ dyn_flags <- readIORef v_DynFlags
+ writeIORef v_InitDynFlags dyn_flags
-- complain about any unknown flags
let unknown_flags = [ f | ('-':f) <- srcs ]
TauType, ClassContext )
import Unique ( incrUnique, mkTupleTyConUnique, mkTupleDataConUnique )
import PrelNames
-import CmdLineOpts ( DynFlags, dopt_GlasgowExts )
+import CmdLineOpts
import Array
alpha_tyvar = [alphaTyVar]
= marshalableTyCon dflags tc
marshalableTyCon dflags tc
- = (dopt_GlasgowExts dflags && isUnLiftedTyCon tc)
+ = (dopt Opt_GlasgowExts dflags && isUnLiftedTyCon tc)
|| boxedMarshalableTyCon tc
boxedMarshalableTyCon tc
#include "HsVersions.h"
-import CmdLineOpts ( opt_WarnNameShadowing, opt_WarnUnusedMatches,
- opt_WarnUnusedBinds, opt_WarnUnusedImports )
import HsSyn
import RdrHsSyn ( RdrNameIE )
import RdrName ( RdrName, rdrNameModule, rdrNameOcc, isQual, isUnqual,
import Util ( thenCmp, sortLt )
import List ( nub )
import PrelNames ( mkUnboundName )
+import CmdLineOpts
\end{code}
-- Check for duplicate names
checkDupOrQualNames doc_str rdr_names_w_loc `thenRn_`
+ doptRn Opt_WarnNameShadowing `thenRn` \ warn_shadow ->
+
-- Warn about shadowing, but only in source modules
(case mode of
- SourceMode | opt_WarnNameShadowing -> mapRn_ (check_shadow name_env) rdr_names_w_loc
+ SourceMode | warn_shadow -> mapRn_ (check_shadow name_env) rdr_names_w_loc
other -> returnRn ()
) `thenRn_`
\begin{code}
warnUnusedModules :: [Module] -> RnM d ()
warnUnusedModules mods
- | not opt_WarnUnusedImports = returnRn ()
- | otherwise = mapRn_ (addWarnRn . unused_mod . moduleName) mods
+ = doptRn Opt_WarnUnusedImports `thenRn` \ warn ->
+ if warn then mapRn_ (addWarnRn . unused_mod . moduleName) mods
+ else returnRn ()
where
unused_mod m = vcat [ptext SLIT("Module") <+> quotes (ppr m) <+>
text "is imported, but nothing from it is used",
warnUnusedImports :: [(Name,Provenance)] -> RnM d ()
warnUnusedImports names
- | not opt_WarnUnusedImports
- = returnRn () -- Don't force names unless necessary
- | otherwise
- = warnUnusedBinds names
+ = doptRn Opt_WarnUnusedImports `thenRn` \ warn ->
+ if warn then warnUnusedBinds names else return ()
warnUnusedLocalBinds, warnUnusedMatches :: [Name] -> RnM d ()
warnUnusedLocalBinds names
- | not opt_WarnUnusedBinds = returnRn ()
- | otherwise = warnUnusedBinds [(n,LocalDef) | n<-names]
+ = doptRn Opt_WarnUnusedBinds `thenRn` \ warn ->
+ if warn then warnUnusedBinds [(n,LocalDef) | n<-names]
+ else returnRn ()
warnUnusedMatches names
- | opt_WarnUnusedMatches = warnUnusedGroup [(n,LocalDef) | n<-names]
- | otherwise = returnRn ()
+ = doptRn Opt_WarnUnusedMatches `thenRn` \ warn ->
+ if warn then warnUnusedGroup [(n,LocalDef) | n<-names]
+ else returnRn ()
-------------------------
)
import Module ( Module, ModuleName, WhereFrom, moduleName )
import NameSet
-import CmdLineOpts ( DynFlags, dopt_D_dump_rn_trace )
+import CmdLineOpts ( DynFlags, DynFlag(..), dopt )
import SrcLoc ( SrcLoc, generatedSrcLoc )
import Unique ( Unique )
import FiniteMap ( FiniteMap, emptyFM, listToFM, plusFM )
traceRn :: SDoc -> RnM d ()
traceRn msg
- = doptsRn dopt_D_dump_rn_trace `thenRn` \b ->
+ = doptRn Opt_D_dump_rn_trace `thenRn` \b ->
if b then putDocRn msg else returnRn ()
putDocRn :: SDoc -> RnM d ()
= readIORef errs_var >>= \ (warns,errs) ->
return (isEmptyBag errs)
-doptsRn :: (DynFlags -> Bool) -> RnM d Bool
-doptsRn dopt (RnDown { rn_dflags = dflags}) l_down
- = return (dopt dflags)
+doptRn :: DynFlag -> RnM d Bool
+doptRn dflag (RnDown { rn_dflags = dflags}) l_down
+ = return (dopt dflag dflags)
\end{code}
import CoreSyn
import CoreUnfold ( Unfolding, certainlyWillInline )
-import CmdLineOpts ( DynFlags,
- dopt_D_verbose_core2core, dopt_D_dump_worker_wrapper )
import CoreLint ( beginPass, endPass )
import CoreUtils ( exprType, exprEtaExpandArity )
import MkId ( mkWorkerId )
)
import Demand ( Demand, wwLazy )
import UniqSupply ( UniqSupply, initUs_, returnUs, thenUs, mapUs, getUniqueUs, UniqSM )
+import CmdLineOpts
import WwLib
import Outputable
\end{code}
let { binds' = workersAndWrappers us binds };
endPass dflags "Worker Wrapper binds"
- (dopt_D_dump_worker_wrapper dflags ||
- dopt_D_verbose_core2core dflags)
+ (dopt Opt_D_dump_worker_wrapper dflags ||
+ dopt Opt_D_verbose_core2core dflags)
binds'
}
\end{code}
import Class ( classTyVars, classBigSig, classSelIds, classTyCon, Class, ClassOpItem,
DefMeth (..) )
import Bag ( bagToList )
-import CmdLineOpts ( dopt_GlasgowExts, opt_WarnMissingMethods, opt_PprStyle_Debug )
import MkId ( mkDictSelId, mkDataConId, mkDataConWrapId, mkDefaultMethodId )
import DataCon ( mkDataCon, notMarkedStrict )
import Id ( Id, idType, idName )
)
import Var ( TyVar )
import VarSet ( mkVarSet, emptyVarSet )
+import CmdLineOpts
import ErrUtils ( dumpIfSet )
import Util ( count )
import Maybes ( seqMaybe, maybeToBool, orElse )
tyvar_names fundeps class_sigs def_methods pragmas
sys_names src_loc)
= -- CHECK ARITY 1 FOR HASKELL 1.4
- doptsTc dopt_GlasgowExts `thenTc` \ glaExts ->
+ doptsTc Opt_GlasgowExts `thenTc` \ glaExts ->
checkTc (glaExts || length tyvar_names == 1)
(classArityErr class_name) `thenTc_`
-- only the type variable of the class decl.
-- For std Haskell check that the context constrains only tyvars
- doptsTc dopt_GlasgowExts `thenTc` \ glaExts ->
+ doptsTc Opt_GlasgowExts `thenTc` \ glaExts ->
(if glaExts then
returnTc ()
else
mkDefMethRhs is_inst_decl clas inst_tys sel_id loc NoDefMeth
= -- No default method
-- Warn only if -fwarn-missing-methods
- warnTc (is_inst_decl && opt_WarnMissingMethods)
+ doptsTc Opt_WarnMissingMethods `thenNF_Tc` \ warn ->
+ warnTc (is_inst_decl && warn)
(omittedMethodWarn sel_id clas) `thenNF_Tc_`
returnTc error_rhs
where
idType, lazySetIdInfo, idInfo, tyVarKind, UVar,
)
import VarSet
-import VarEnv ( TyVarSubstEnv )
import Type ( Kind, Type, superKind,
tyVarsOfType, tyVarsOfTypes,
splitForAllTys, splitRhoTy, splitFunTys,
)
import OccName ( mkDFunOcc, mkDefaultMethodOcc, occNameString )
import Module ( Module )
-import Unify ( unifyTyListsX, matchTys )
import HscTypes ( ModDetails(..), InstEnv, lookupTypeEnv, TyThing(..),
GlobalSymbolTable, Provenance(..) )
import Unique ( pprUnique10, Unique, Uniquable(..) )
import Util ( zipEqual, zipWith3Equal, mapAccumL )
import SrcLoc ( SrcLoc )
import FastString ( FastString )
-import Maybes
import Outputable
import TcInstUtil ( emptyInstEnv )
)
import TyCon ( TyCon, tyConTyVars )
import Subst ( mkTopTyVarSubst, substClasses, substTy )
-import UsageSPUtils ( unannotTy )
import VarSet ( elemVarSet, mkVarSet )
import TysWiredIn ( boolTy )
import TcUnify ( unifyTauTy, unifyFunTy, unifyListTy, unifyTupleTy )
import Maybes ( maybeToBool, mapMaybe )
import ListSetOps ( minusList )
import Util
-import CmdLineOpts ( opt_WarnMissingFields )
+import CmdLineOpts
import HscTypes ( TyThing(..) )
\end{code}
let
missing_fields = missingFields rbinds data_con
in
- checkTcM (not (opt_WarnMissingFields && not (null missing_fields)))
+ doptsTc Opt_WarnMissingFields `thenNF_Tc` \ warn ->
+ checkTcM (not (warn && not (null missing_fields)))
(mapNF_Tc ((warnTc True) . missingFieldCon con_name) missing_fields `thenNF_Tc_`
returnNF_Tc ()) `thenNF_Tc_`
#include "HsVersions.h"
import RnHsSyn ( RenamedMonoBinds, RenamedSig )
-import HsTypes ( toHsType )
-import CmdLineOpts ( DynFlags, dopt_AllowOverlappingInstances )
-import TcMonad
-import Bag ( bagToList, Bag )
+import HscTypes ( InstEnv, ClsInstEnv, DFunId )
import Class ( Class )
-import Var ( TyVar, Id, idName )
+import Var ( TyVar, Id )
import VarSet ( unionVarSet, mkVarSet )
import VarEnv ( TyVarSubstEnv )
import Maybes ( MaybeErr(..), returnMaB, failMaB, thenMaB, maybeToBool )
-import Name ( getSrcLoc, nameModule, isLocallyDefined, toRdrName )
+import Name ( getSrcLoc )
import SrcLoc ( SrcLoc )
import Type ( Type, ThetaType, splitTyConApp_maybe,
- mkSigmaTy, splitSigmaTy, mkDictTy, splitDictTy,
+ splitSigmaTy, splitDictTy,
tyVarsOfTypes )
-import PprType ( pprConstraint )
+import PprType ( )
import Class ( classTyCon )
import DataCon ( DataCon )
import TyCon ( TyCon, tyConDataCons )
import Outputable
-import HscTypes ( InstEnv, ClsInstEnv, DFunId )
import Unify ( matchTys, unifyTyListsX )
import UniqFM ( lookupWithDefaultUFM, addToUFM, emptyUFM )
import Id ( idType )
import ErrUtils ( Message )
+import CmdLineOpts
\end{code}
-- (b) they unify, and any sort of overlap is prohibited,
-- (c) they unify but neither is more specific than t'other
| identical
- || (unifiable && not (dopt_AllowOverlappingInstances dflags))
+ || (unifiable && not (dopt Opt_AllowOverlappingInstances dflags))
|| (unifiable && not (ins_item_more_specific || cur_item_more_specific))
= failMaB val
import Type ( Type, Kind, PredType, ThetaType, RhoType, TauType,
)
import ErrUtils ( addShortErrLocLine, addShortWarnLocLine, ErrMsg, Message, WarnMsg )
-import CmdLineOpts ( DynFlags, opt_PprStyle_Debug )
import Bag ( Bag, emptyBag, isEmptyBag,
foldBag, unitBag, unionBags, snocBag )
import UniqSupply ( UniqSupply, uniqFromSupply, uniqsFromSupply,
splitUniqSupply, mkSplitUniqSupply,
UniqSM, initUs_ )
-import SrcLoc ( SrcLoc, noSrcLoc )
+import SrcLoc ( SrcLoc )
import FiniteMap ( FiniteMap, lookupFM, addToFM, emptyFM )
-import UniqFM ( UniqFM, emptyUFM )
+import UniqFM ( emptyUFM )
import Unique ( Unique )
-import BasicTypes ( Unused )
+import CmdLineOpts
import Outputable
-import FastString ( FastString )
import IOExts ( IORef, newIORef, readIORef, writeIORef,
unsafeInterleaveIO, fixIO
setErrCtxt down msg = down{tc_ctxt=[msg]}
addErrCtxt down msg = down{tc_ctxt = msg : tc_ctxt down}
-doptsTc :: (DynFlags -> Bool) -> TcM Bool
-doptsTc dopt (TcDown{tc_dflags=dflags}) env_down
- = return (dopt dflags)
+doptsTc :: DynFlag -> TcM Bool
+doptsTc dflag (TcDown{tc_dflags=dflags}) env_down
+ = return (dopt dflag dflags)
getDOptsTc :: TcM DynFlags
getDOptsTc (TcDown{tc_dflags=dflags}) env_down
import DataCon ( dataConSig, dataConFieldLabels,
dataConSourceArity
)
-import Id ( isDataConWrapId_maybe )
import Type ( isTauTy, mkTyConApp, mkClassPred, boxedTypeKind )
import Subst ( substTy, substClasses )
import TysPrim ( charPrimTy, intPrimTy, floatPrimTy,
#include "HsVersions.h"
-import CmdLineOpts ( opt_MaxContextReductionDepth, dopt_GlasgowExts, opt_WarnTypeDefaults )
import HsSyn ( MonoBinds(..), HsExpr(..), andMonoBinds, andMonoBindList )
import TcHsSyn ( TcExpr, TcId,
TcMonoBinds, TcDictBinds
import List ( partition )
import Maybe ( fromJust )
import Maybes ( maybeToBool )
+import CmdLineOpts
\end{code}
-> TcM ClassContext -- Needed
tcSimplifyThetas wanteds
- = doptsTc dopt_GlasgowExts `thenNF_Tc` \ glaExts ->
+ = doptsTc Opt_GlasgowExts `thenNF_Tc` \ glaExts ->
reduceSimple [] wanteds `thenNF_Tc` \ irreds ->
let
-- For multi-param Haskell, check that the returned dictionaries
(tidy_env, tidy_dict) = tidyInst emptyTidyEnv dict
warnDefault dicts default_ty
- | not opt_WarnTypeDefaults
- = returnNF_Tc ()
+ = doptsTc Opt_WarnTypeDefaults `thenTc` \ warn ->
+ if warn then warnTc True msg else returnNF_Tc ()
- | otherwise
- = warnTc True msg
where
msg | length dicts > 1
= (ptext SLIT("Defaulting the following constraint(s) to type") <+> quotes (ppr default_ty))
-- friends:
import TcMonad
import TypeRep ( Type(..), PredType(..) ) -- friend
-import Type ( funTyCon, Kind, unboxedTypeKind, boxedTypeKind, openTypeKind,
- superBoxity, typeCon, openKindCon, hasMoreBoxityInfo,
+import Type ( unboxedTypeKind, boxedTypeKind, openTypeKind,
+ typeCon, openKindCon, hasMoreBoxityInfo,
tyVarsOfType, typeKind,
- mkTyVarTy, mkFunTy, splitFunTy_maybe, splitTyConApp_maybe,
+ mkFunTy, splitFunTy_maybe, splitTyConApp_maybe,
isNotUsgTy, splitAppTy_maybe, mkTyConApp,
tidyOpenType, tidyOpenTypes, tidyTyVar
)
import TyCon ( TyCon, isTupleTyCon, tupleTyConBoxity, tyConArity )
-import Var ( TyVar, tyVarKind, varName, isSigTyVar )
+import Var ( tyVarKind, varName, isSigTyVar )
import VarSet ( varSetElems )
import TcType ( TcType, TcTauType, TcTyVar, TcKind, newBoxityVar,
newTyVarTy, newTyVarTys, tcGetTyVar, tcPutTyVar, zonkTcType
projects / ghc-hetmet.git / commitdiff