X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FdeSugar%2FDsMonad.lhs;h=279416d8cc2bcffefc6205d24275fadc29d27d5e;hb=235edf36cc202bb21c00d0e5e05ebf076fb0542e;hp=9251a818ee794625147323db8bc65fde71841816;hpb=2bbec92eb827c0d70b25f4006a954d95ae3088bf;p=ghc-hetmet.git diff --git a/compiler/deSugar/DsMonad.lhs b/compiler/deSugar/DsMonad.lhs index 9251a81..279416d 100644 --- a/compiler/deSugar/DsMonad.lhs +++ b/compiler/deSugar/DsMonad.lhs @@ -6,10 +6,17 @@ @DsMonad@: monadery used in desugaring \begin{code} +{-# OPTIONS -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details + module DsMonad ( DsM, mappM, mapAndUnzipM, initDs, initDsTc, returnDs, thenDs, listDs, fixDs, mapAndUnzipDs, - foldlDs, foldrDs, + foldlDs, foldrDs, ifOptDs, newTyVarsDs, newLocalName, duplicateLocalDs, newSysLocalDs, newSysLocalsDs, newUniqueId, @@ -20,10 +27,10 @@ module DsMonad ( UniqSupply, newUniqueSupply, getDOptsDs, getGhcModeDs, doptDs, dsLookupGlobal, dsLookupGlobalId, dsLookupTyCon, dsLookupDataCon, + dsLookupClass, DsMetaEnv, DsMetaVal(..), dsLookupMetaEnv, dsExtendMetaEnv, - bindLocalsDs, getLocalBindsDs, getBkptSitesDs, getModNameRefDs, withModNameRefDs, -- Warnings DsWarning, warnDs, failWithDs, @@ -44,6 +51,7 @@ import HscTypes import Bag import DataCon import TyCon +import Class import Id import Module import Var @@ -56,9 +64,6 @@ import NameEnv import OccName import DynFlags import ErrUtils -import Bag -import Breakpoints -import OccName import Data.IORef @@ -125,7 +130,7 @@ listDs = sequenceM foldlDs = foldlM foldrDs = foldrM mapAndUnzipDs = mapAndUnzipM - +ifOptDs = ifOptM type DsWarning = (SrcSpan, SDoc) -- Not quite the same as a WarnMsg, we have an SDoc here @@ -136,17 +141,13 @@ data DsGblEnv = DsGblEnv { ds_mod :: Module, -- For SCC profiling ds_unqual :: PrintUnqualified, ds_msgs :: IORef Messages, -- Warning messages - ds_if_env :: (IfGblEnv, IfLclEnv), -- Used for looking up global, + ds_if_env :: (IfGblEnv, IfLclEnv) -- Used for looking up global, -- possibly-imported things - ds_bkptSites :: IORef SiteMap -- Inserted Breakpoints sites } data DsLclEnv = DsLclEnv { ds_meta :: DsMetaEnv, -- Template Haskell bindings - ds_loc :: SrcSpan, -- to put in pattern-matching error msgs - ds_locals :: OccEnv Id, -- For locals in breakpoints - ds_mod_name_ref :: Maybe Id -- The Id used to store the Module name - -- used by the breakpoint desugaring + ds_loc :: SrcSpan -- to put in pattern-matching error msgs } -- Inside [| |] brackets, the desugarer looks @@ -169,14 +170,14 @@ initDs :: HscEnv initDs hsc_env mod rdr_env type_env thing_inside = do { msg_var <- newIORef (emptyBag, emptyBag) - ; (ds_gbl_env, ds_lcl_env) <- mkDsEnvs mod rdr_env type_env msg_var + ; let dflags = hsc_dflags hsc_env + ; (ds_gbl_env, ds_lcl_env) <- mkDsEnvs dflags mod rdr_env type_env msg_var ; either_res <- initTcRnIf 'd' hsc_env ds_gbl_env ds_lcl_env $ tryM thing_inside -- Catch exceptions (= errors during desugaring) -- Display any errors and warnings -- Note: if -Werror is used, we don't signal an error here. - ; let dflags = hsc_dflags hsc_env ; msgs <- readIORef msg_var ; printErrorsAndWarnings dflags msgs @@ -195,26 +196,24 @@ initDsTc thing_inside = do { this_mod <- getModule ; tcg_env <- getGblEnv ; msg_var <- getErrsVar + ; dflags <- getDOpts ; let type_env = tcg_type_env tcg_env rdr_env = tcg_rdr_env tcg_env - ; ds_envs <- ioToIOEnv$ mkDsEnvs this_mod rdr_env type_env msg_var + ; ds_envs <- ioToIOEnv$ mkDsEnvs dflags this_mod rdr_env type_env msg_var ; setEnvs ds_envs thing_inside } -mkDsEnvs :: Module -> GlobalRdrEnv -> TypeEnv -> IORef Messages -> IO (DsGblEnv, DsLclEnv) -mkDsEnvs mod rdr_env type_env msg_var +mkDsEnvs :: DynFlags -> Module -> GlobalRdrEnv -> TypeEnv -> IORef Messages -> IO (DsGblEnv, DsLclEnv) +mkDsEnvs dflags mod rdr_env type_env msg_var = do sites_var <- newIORef [] let if_genv = IfGblEnv { if_rec_types = Just (mod, return type_env) } if_lenv = mkIfLclEnv mod (ptext SLIT("GHC error in desugarer lookup in") <+> ppr mod) gbl_env = DsGblEnv { ds_mod = mod, ds_if_env = (if_genv, if_lenv), - ds_unqual = mkPrintUnqualified rdr_env, - ds_msgs = msg_var, - ds_bkptSites = sites_var} + ds_unqual = mkPrintUnqualified dflags rdr_env, + ds_msgs = msg_var} lcl_env = DsLclEnv { ds_meta = emptyNameEnv, - ds_loc = noSrcSpan, - ds_locals = emptyOccEnv, - ds_mod_name_ref = Nothing } + ds_loc = noSrcSpan } return (gbl_env, lcl_env) @@ -325,6 +324,11 @@ dsLookupDataCon :: Name -> DsM DataCon dsLookupDataCon name = dsLookupGlobal name `thenDs` \ thing -> returnDs (tyThingDataCon thing) + +dsLookupClass :: Name -> DsM Class +dsLookupClass name + = dsLookupGlobal name `thenDs` \ thing -> + returnDs (tyThingClass thing) \end{code} \begin{code} @@ -335,26 +339,3 @@ dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a dsExtendMetaEnv menv thing_inside = updLclEnv (\env -> env { ds_meta = ds_meta env `plusNameEnv` menv }) thing_inside \end{code} - -\begin{code} -getLocalBindsDs :: DsM [Id] -getLocalBindsDs = do { env <- getLclEnv; return (occEnvElts$ ds_locals env) } - -getModNameRefDs :: DsM (Maybe Id) -getModNameRefDs = do { env <- getLclEnv; return (ds_mod_name_ref env) } - -withModNameRefDs :: Id -> DsM a -> DsM a -withModNameRefDs id thing_inside = - updLclEnv (\env -> env {ds_mod_name_ref = Just id}) thing_inside - -bindLocalsDs :: [Id] -> DsM a -> DsM a -bindLocalsDs new_ids enclosed_scope = - updLclEnv (\env-> env {ds_locals = ds_locals env `extendOccEnvList` occnamed_ids}) - enclosed_scope - where occnamed_ids = [ (nameOccName (idName id),id) | id <- new_ids ] - -getBkptSitesDs :: DsM (IORef SiteMap) -getBkptSitesDs = do { env <- getGblEnv; return (ds_bkptSites env) } - -\end{code} -