import RnMonad
import RnEnv
import RnIfaces ( lookupFixityRn )
-import CmdLineOpts ( opt_GlasgowExts, opt_IgnoreAsserts )
+import CmdLineOpts ( dopt_GlasgowExts, opt_IgnoreAsserts )
import Literal ( inIntRange )
import BasicTypes ( Fixity(..), FixityDirection(..), defaultFixity, negateFixity )
import PrelNames ( hasKey, assertIdKey,
returnRn (VarPatIn vname, emptyFVs)
rnPat (SigPatIn pat ty)
- | opt_GlasgowExts
- = rnPat pat `thenRn` \ (pat', fvs1) ->
- rnHsType doc ty `thenRn` \ (ty', fvs2) ->
- returnRn (SigPatIn pat' ty', fvs1 `plusFV` fvs2)
-
- | otherwise
- = addErrRn (patSigErr ty) `thenRn_`
- rnPat pat
+ = doptsRn dopt_GlasgowExts `thenRn` \ opt_GlasgowExts ->
+
+ if opt_GlasgowExts
+ then rnPat pat `thenRn` \ (pat', fvs1) ->
+ rnHsType doc ty `thenRn` \ (ty', fvs2) ->
+ returnRn (SigPatIn pat' ty', fvs1 `plusFV` fvs2)
+
+ else addErrRn (patSigErr ty) `thenRn_`
+ rnPat pat
where
doc = text "a pattern type-signature"
mapFvRn rnPat pats `thenRn` \ (pats', pat_fvs) ->
rnGRHSs grhss `thenRn` \ (grhss', grhss_fvs) ->
+ doptsRn dopt_GlasgowExts `thenRn` \ opt_GlasgowExts ->
(case maybe_rhs_sig of
Nothing -> returnRn (Nothing, emptyFVs)
Just ty | opt_GlasgowExts -> rnHsType doc_sig ty `thenRn` \ (ty', ty_fvs) ->
returnRn (GRHSs grhss' binds' Nothing, fvGRHSs)
rnGRHS (GRHS guarded locn)
- = pushSrcLocRn locn $
+ = doptsRn dopt_GlasgowExts `thenRn` \ opt_GlasgowExts ->
+ pushSrcLocRn locn $
(if not (opt_GlasgowExts || is_standard_guard guarded) then
addWarnRn (nonStdGuardErr guarded)
else
decode, mkLocalName, mkUnboundName, mkKnownKeyGlobal,
NameEnv, lookupNameEnv, emptyNameEnv, unitNameEnv, extendNameEnvList
)
-import Module ( Module, ModuleName, ModuleHiMap, SearchPath, WhereFrom,
- mkModuleHiMaps, moduleName, mkSearchPath
- )
+import Module ( Module, ModuleName, WhereFrom, moduleName )
import NameSet
-import CmdLineOpts ( opt_D_dump_rn_trace, opt_HiMap )
+import CmdLineOpts ( DynFlags, dopt_D_dump_rn_trace )
import PrelInfo ( wiredInNames, knownKeyRdrNames )
import SrcLoc ( SrcLoc, mkGeneratedSrcLoc )
import Unique ( Unique )
import Bag ( Bag, mapBag, emptyBag, isEmptyBag, snocBag )
import UniqSupply
import Outputable
+import CmFind ( Finder )
infixr 9 `thenRn`, `thenRn_`
\end{code}
(\ err -> return (Left err))
traceRn :: SDoc -> RnM d ()
-traceRn msg | opt_D_dump_rn_trace = putDocRn msg
- | otherwise = returnRn ()
+traceRn msg
+ = doptsRn dopt_D_dump_rn_trace `thenRn` \b ->
+ if b then putDocRn msg else returnRn ()
putDocRn :: SDoc -> RnM d ()
putDocRn msg = ioToRnM (printErrs msg) `thenRn_`
rn_loc :: SrcLoc, -- Current locn
rn_finder :: Finder,
- rn_flags :: DynFlags,
+ rn_dflags :: DynFlags,
rn_gst :: GlobalSymbolTable, -- Both home modules and packages,
-- at the moment we started compiling
-- this module
rn_errs :: IORef (Bag WarnMsg, Bag ErrMsg),
rn_ns :: IORef NameSupply,
- rn_ifaces :: IORef Ifaces,
+ rn_ifaces :: IORef Ifaces
}
-- For renaming source code
[(name,Version)] -- List guaranteed non-empty
deriving( Eq )
-- 'Specifically' doesn't let you say "I imported f but none of the fixities in
- -- the module. If you use anything in the module you get its fixity and rule version
+ -- the module". If you use anything in the module you get its fixity and rule version
-- So if the fixities or rules change, you'll recompile, even if you don't use either.
-- This is easy to implement, and it's safer: you might not have used the rules last
-- time round, but if someone has added a new rule you might need it this time
type RdrNamePragma = () -- Fudge for now
-------------------
+\end{code}
+
%************************************************************************
%* *
\subsection{The renamer state}
-- See comments with RnIfaces.lookupFixity
iDeprecs :: DeprecationEnv,
-
-- EPHEMERAL FIELDS
-- These fields persist during the compilation of a single module only
-- All the names (whether "big" or "small", whether wired-in or not,
-- whether locally defined or not) that have been slurped in so far.
- iVSlurp :: [(Name,Version)],
+ iVSlurp :: [(Name,Version)]
-- All the (a) non-wired-in (b) "big" (c) non-locally-defined
-- names that have been slurped in so far, with their versions.
-- This is used to generate the "usage" information for this module.
initRn :: DynFlags -> Finder -> GlobalSymbolTable
-> PersistentRenamerState
-> Module -> SrcLoc
- -> RnMG r
- -> IO (r, Bag ErrMsg, Bag WarnMsg)
-initRn flags finder gst prs mod loc do_rn = do
+initRn dflags finder gst prs mod loc do_rn = do
himaps <- mkModuleHiMaps dirs
names_var <- newIORef (prsNS pcs)
errs_var <- newIORef (emptyBag,emptyBag)
rn_loc = loc,
rn_finder = finder,
- rn_flags = flags,
+ rn_dflags = dflags,
rn_gst = gst,
rn_ns = names_var,
once you must either split it, or install a fresh unique supply.
\begin{code}
-renameSourceCode :: Module
- -> NameSupply
+renameSourceCode :: DynFlags
+ -> Module
+ -> RnNameSupply
-> RnMS r
-> r
-renameSourceCode mod name_supply m
+renameSourceCode dflags mod name_supply m
= unsafePerformIO (
-- It's not really unsafe! When renaming source code we
-- only do any I/O if we need to read in a fixity declaration;
-- and that doesn't happen in pragmas etc
- mkModuleHiMaps (mkSearchPath opt_HiMap) >>= \ himaps ->
newIORef name_supply >>= \ names_var ->
newIORef (emptyBag,emptyBag) >>= \ errs_var ->
let
- rn_down = RnDown { rn_loc = mkGeneratedSrcLoc, rn_ns = names_var,
- rn_errs = errs_var, rn_hi_maps = himaps,
+ rn_down = RnDown { rn_dflags = dflags,
+ rn_loc = mkGeneratedSrcLoc, rn_ns = names_var,
+ rn_errs = errs_var,
rn_mod = mod,
rn_ifaces = panic "rnameSourceCode: rn_ifaces" -- Not required
}
checkErrsRn (RnDown {rn_errs = errs_var}) l_down
= 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)
\end{code}
setIfacesRn :: Ifaces -> RnM d ()
setIfacesRn ifaces (RnDown {rn_ifaces = iface_var}) _
= writeIORef iface_var ifaces
-
-getHiMaps :: RnM d (SearchPath, ModuleHiMap, ModuleHiMap)
-getHiMaps (RnDown {rn_hi_maps = himaps}) _
- = return himaps
-\end{code}
\end{code}
import List ( partition, nub )
import Outputable
import SrcLoc ( SrcLoc )
-import CmdLineOpts ( opt_GlasgowExts, opt_WarnUnusedMatches ) -- Warn of unused for-all'd tyvars
+import CmdLineOpts ( opt_WarnUnusedMatches, dopt_GlasgowExts ) -- Warn of unused for-all'd tyvars
import Unique ( Uniquable(..) )
import ErrUtils ( Message )
import CStrings ( isCLabelString )
rnDecl (TyClD (TySynonym name tyvars ty src_loc))
= pushSrcLocRn src_loc $
+ doptsRn dopt_GlasgowExts `thenRn` \ glaExts ->
lookupTopBndrRn name `thenRn` \ name' ->
bindTyVarsFVRn syn_doc tyvars $ \ tyvars' ->
- rnHsType syn_doc (unquantify ty) `thenRn` \ (ty', ty_fvs) ->
+ rnHsType syn_doc (unquantify glaExts ty) `thenRn` \ (ty', ty_fvs) ->
returnRn (TyClD (TySynonym name' tyvars' ty' src_loc), ty_fvs)
where
syn_doc = text "the declaration for type synonym" <+> quotes (ppr name)
-- For H98 we do *not* universally quantify on the RHS of a synonym
-- Silently discard context... but the tyvars in the rest won't be in scope
- unquantify (HsForAllTy Nothing ctxt ty) | not opt_GlasgowExts = ty
- unquantify ty = ty
+ unquantify glaExts (HsForAllTy Nothing ctxt ty) | glaExts = ty
+ unquantify glaExys ty = ty
rnDecl (TyClD (ClassDecl context cname tyvars fds sigs mbinds pragmas
names src_loc))
projects / ghc-hetmet.git / commitdiff