← Back to branch summary

~ubuntu-branches/ubuntu/precise/ghc/precise

« back to all changes in this revision

Viewing changes to compiler/deSugar/DsMonad.lhs

  • Committer: Bazaar Package Importer
  • Author(s): Joachim Breitner
  • Date: 2011-01-17 12:49:24 UTC
  • Revision ID: james.westby@ubuntu.com-20110117124924-do1pym1jlf5o636m
Tags: upstream-7.0.1
Import upstream version 7.0.1

Show diffs side-by-side

added added

removed removed

Lines of Context:
compiler/deSugar/DsMonad.lhs
 
1
%
 
2
% (c) The University of Glasgow 2006
 
3
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 
4
%
 
5
 
 
6
@DsMonad@: monadery used in desugaring
 
7
 
 
8
\begin{code}
 
9
module DsMonad (
 
10
        DsM, mapM, mapAndUnzipM,
 
11
        initDs, initDsTc, fixDs,
 
12
        foldlM, foldrM, ifDOptM, unsetOptM,
 
13
        Applicative(..),(<$>),
 
14
 
 
15
        newLocalName,
 
16
        duplicateLocalDs, newSysLocalDs, newSysLocalsDs, newUniqueId,
 
17
        newFailLocalDs, newPredVarDs,
 
18
        getSrcSpanDs, putSrcSpanDs,
 
19
        getModuleDs,
 
20
        newUnique, 
 
21
        UniqSupply, newUniqueSupply,
 
22
        getDOptsDs, getGhcModeDs, doptDs,
 
23
        dsLookupGlobal, dsLookupGlobalId, dsLookupTyCon, dsLookupDataCon,
 
24
        dsLookupClass,
 
25
 
 
26
        DsMetaEnv, DsMetaVal(..), dsLookupMetaEnv, dsExtendMetaEnv,
 
27
 
 
28
        dsLoadModule,
 
29
 
 
30
        -- Warnings
 
31
        DsWarning, warnDs, failWithDs,
 
32
 
 
33
        -- Data types
 
34
        DsMatchContext(..),
 
35
        EquationInfo(..), MatchResult(..), DsWrapper, idDsWrapper,
 
36
        CanItFail(..), orFail
 
37
    ) where
 
38
 
 
39
import TcRnMonad
 
40
import CoreSyn
 
41
import HsSyn
 
42
import TcIface
 
43
import LoadIface
 
44
import RdrName
 
45
import HscTypes
 
46
import Bag
 
47
import DataCon
 
48
import TyCon
 
49
import Class
 
50
import Id
 
51
import Module
 
52
import Var
 
53
import Outputable
 
54
import SrcLoc
 
55
import Type
 
56
import UniqSupply
 
57
import Name
 
58
import NameEnv
 
59
import DynFlags
 
60
import ErrUtils
 
61
import FastString
 
62
 
 
63
import Data.IORef
 
64
\end{code}
 
65
 
 
66
%************************************************************************
 
67
%*                                                                      *
 
68
                Data types for the desugarer
 
69
%*                                                                      *
 
70
%************************************************************************
 
71
 
 
72
\begin{code}
 
73
data DsMatchContext
 
74
  = DsMatchContext (HsMatchContext Name) SrcSpan
 
75
  deriving ()
 
76
 
 
77
data EquationInfo
 
78
  = EqnInfo { eqn_pats :: [Pat Id],     -- The patterns for an eqn
 
79
              eqn_rhs  :: MatchResult } -- What to do after match
 
80
 
 
81
instance Outputable EquationInfo where
 
82
    ppr (EqnInfo pats _) = ppr pats
 
83
 
 
84
type DsWrapper = CoreExpr -> CoreExpr
 
85
idDsWrapper :: DsWrapper
 
86
idDsWrapper e = e
 
87
 
 
88
-- The semantics of (match vs (EqnInfo wrap pats rhs)) is the MatchResult
 
89
--      \fail. wrap (case vs of { pats -> rhs fail })
 
90
-- where vs are not bound by wrap
 
91
 
 
92
 
 
93
-- A MatchResult is an expression with a hole in it
 
94
data MatchResult
 
95
  = MatchResult
 
96
        CanItFail       -- Tells whether the failure expression is used
 
97
        (CoreExpr -> DsM CoreExpr)
 
98
                        -- Takes a expression to plug in at the
 
99
                        -- failure point(s). The expression should
 
100
                        -- be duplicatable!
 
101
 
 
102
data CanItFail = CanFail | CantFail
 
103
 
 
104
orFail :: CanItFail -> CanItFail -> CanItFail
 
105
orFail CantFail CantFail = CantFail
 
106
orFail _        _        = CanFail
 
107
\end{code}
 
108
 
 
109
 
 
110
%************************************************************************
 
111
%*                                                                      *
 
112
                Monad stuff
 
113
%*                                                                      *
 
114
%************************************************************************
 
115
 
 
116
Now the mondo monad magic (yes, @DsM@ is a silly name)---carry around
 
117
a @UniqueSupply@ and some annotations, which
 
118
presumably include source-file location information:
 
119
\begin{code}
 
120
type DsM result = TcRnIf DsGblEnv DsLclEnv result
 
121
 
 
122
-- Compatibility functions
 
123
fixDs :: (a -> DsM a) -> DsM a
 
124
fixDs    = fixM
 
125
 
 
126
type DsWarning = (SrcSpan, SDoc)
 
127
        -- Not quite the same as a WarnMsg, we have an SDoc here 
 
128
        -- and we'll do the print_unqual stuff later on to turn it
 
129
        -- into a Doc.
 
130
 
 
131
data DsGblEnv = DsGblEnv {
 
132
        ds_mod     :: Module,                   -- For SCC profiling
 
133
        ds_unqual  :: PrintUnqualified,
 
134
        ds_msgs    :: IORef Messages,           -- Warning messages
 
135
        ds_if_env  :: (IfGblEnv, IfLclEnv)      -- Used for looking up global, 
 
136
                                                -- possibly-imported things
 
137
    }
 
138
 
 
139
data DsLclEnv = DsLclEnv {
 
140
        ds_meta    :: DsMetaEnv,        -- Template Haskell bindings
 
141
        ds_loc     :: SrcSpan           -- to put in pattern-matching error msgs
 
142
     }
 
143
 
 
144
-- Inside [| |] brackets, the desugarer looks 
 
145
-- up variables in the DsMetaEnv
 
146
type DsMetaEnv = NameEnv DsMetaVal
 
147
 
 
148
data DsMetaVal
 
149
   = Bound Id           -- Bound by a pattern inside the [| |]. 
 
150
                        -- Will be dynamically alpha renamed.
 
151
                        -- The Id has type THSyntax.Var
 
152
 
 
153
   | Splice (HsExpr Id) -- These bindings are introduced by
 
154
                        -- the PendingSplices on a HsBracketOut
 
155
 
 
156
initDs  :: HscEnv
 
157
        -> Module -> GlobalRdrEnv -> TypeEnv
 
158
        -> DsM a
 
159
        -> IO (Messages, Maybe a)
 
160
-- Print errors and warnings, if any arise
 
161
 
 
162
initDs hsc_env mod rdr_env type_env thing_inside
 
163
  = do  { msg_var <- newIORef (emptyBag, emptyBag)
 
164
        ; let dflags = hsc_dflags hsc_env
 
165
        ; (ds_gbl_env, ds_lcl_env) <- mkDsEnvs dflags mod rdr_env type_env msg_var
 
166
 
 
167
        ; either_res <- initTcRnIf 'd' hsc_env ds_gbl_env ds_lcl_env $
 
168
                        tryM thing_inside       -- Catch exceptions (= errors during desugaring)
 
169
 
 
170
        -- Display any errors and warnings 
 
171
        -- Note: if -Werror is used, we don't signal an error here.
 
172
        ; msgs <- readIORef msg_var
 
173
 
 
174
        ; let final_res | errorsFound dflags msgs = Nothing
 
175
                        | otherwise = case either_res of
 
176
                                        Right res -> Just res
 
177
                                        Left exn -> pprPanic "initDs" (text (show exn))
 
178
                -- The (Left exn) case happens when the thing_inside throws
 
179
                -- a UserError exception.  Then it should have put an error
 
180
                -- message in msg_var, so we just discard the exception
 
181
 
 
182
        ; return (msgs, final_res) }
 
183
 
 
184
initDsTc :: DsM a -> TcM a
 
185
initDsTc thing_inside
 
186
  = do  { this_mod <- getModule
 
187
        ; tcg_env  <- getGblEnv
 
188
        ; msg_var  <- getErrsVar
 
189
        ; dflags   <- getDOpts
 
190
        ; let type_env = tcg_type_env tcg_env
 
191
              rdr_env  = tcg_rdr_env tcg_env
 
192
        ; ds_envs <- liftIO $ mkDsEnvs dflags this_mod rdr_env type_env msg_var
 
193
        ; setEnvs ds_envs thing_inside }
 
194
 
 
195
mkDsEnvs :: DynFlags -> Module -> GlobalRdrEnv -> TypeEnv -> IORef Messages -> IO (DsGblEnv, DsLclEnv)
 
196
mkDsEnvs dflags mod rdr_env type_env msg_var
 
197
  = do -- TODO: unnecessarily monadic
 
198
       let     if_genv = IfGblEnv { if_rec_types = Just (mod, return type_env) }
 
199
               if_lenv = mkIfLclEnv mod (ptext (sLit "GHC error in desugarer lookup in") <+> ppr mod)
 
200
               gbl_env = DsGblEnv { ds_mod = mod, 
 
201
                                    ds_if_env = (if_genv, if_lenv),
 
202
                                    ds_unqual = mkPrintUnqualified dflags rdr_env,
 
203
                                    ds_msgs = msg_var}
 
204
               lcl_env = DsLclEnv { ds_meta = emptyNameEnv, 
 
205
                                    ds_loc = noSrcSpan }
 
206
 
 
207
       return (gbl_env, lcl_env)
 
208
\end{code}
 
209
 
 
210
%************************************************************************
 
211
%*                                                                      *
 
212
                Operations in the monad
 
213
%*                                                                      *
 
214
%************************************************************************
 
215
 
 
216
And all this mysterious stuff is so we can occasionally reach out and
 
217
grab one or more names.  @newLocalDs@ isn't exported---exported
 
218
functions are defined with it.  The difference in name-strings makes
 
219
it easier to read debugging output.
 
220
 
 
221
\begin{code}
 
222
-- Make a new Id with the same print name, but different type, and new unique
 
223
newUniqueId :: Id -> Type -> DsM Id
 
224
newUniqueId id = mkSysLocalM (occNameFS (nameOccName (idName id)))
 
225
 
 
226
duplicateLocalDs :: Id -> DsM Id
 
227
duplicateLocalDs old_local 
 
228
  = do  { uniq <- newUnique
 
229
        ; return (setIdUnique old_local uniq) }
 
230
 
 
231
newPredVarDs :: PredType -> DsM Var
 
232
newPredVarDs pred
 
233
 | isEqPred pred
 
234
 = do { uniq <- newUnique; 
 
235
      ; let name = mkSystemName uniq (mkOccNameFS tcName (fsLit "co_pv"))
 
236
            kind = mkPredTy pred
 
237
      ; return (mkCoVar name kind) }
 
238
 | otherwise
 
239
 = newSysLocalDs (mkPredTy pred)
 
240
 
 
241
newSysLocalDs, newFailLocalDs :: Type -> DsM Id
 
242
newSysLocalDs  = mkSysLocalM (fsLit "ds")
 
243
newFailLocalDs = mkSysLocalM (fsLit "fail")
 
244
 
 
245
newSysLocalsDs :: [Type] -> DsM [Id]
 
246
newSysLocalsDs tys = mapM newSysLocalDs tys
 
247
\end{code}
 
248
 
 
249
We can also reach out and either set/grab location information from
 
250
the @SrcSpan@ being carried around.
 
251
 
 
252
\begin{code}
 
253
getDOptsDs :: DsM DynFlags
 
254
getDOptsDs = getDOpts
 
255
 
 
256
doptDs :: DynFlag -> TcRnIf gbl lcl Bool
 
257
doptDs = doptM
 
258
 
 
259
getGhcModeDs :: DsM GhcMode
 
260
getGhcModeDs =  getDOptsDs >>= return . ghcMode
 
261
 
 
262
getModuleDs :: DsM Module
 
263
getModuleDs = do { env <- getGblEnv; return (ds_mod env) }
 
264
 
 
265
getSrcSpanDs :: DsM SrcSpan
 
266
getSrcSpanDs = do { env <- getLclEnv; return (ds_loc env) }
 
267
 
 
268
putSrcSpanDs :: SrcSpan -> DsM a -> DsM a
 
269
putSrcSpanDs new_loc thing_inside = updLclEnv (\ env -> env {ds_loc = new_loc}) thing_inside
 
270
 
 
271
warnDs :: SDoc -> DsM ()
 
272
warnDs warn = do { env <- getGblEnv 
 
273
                 ; loc <- getSrcSpanDs
 
274
                 ; let msg = mkWarnMsg loc (ds_unqual env) 
 
275
                                      (ptext (sLit "Warning:") <+> warn)
 
276
                 ; updMutVar (ds_msgs env) (\ (w,e) -> (w `snocBag` msg, e)) }
 
277
 
 
278
failWithDs :: SDoc -> DsM a
 
279
failWithDs err 
 
280
  = do  { env <- getGblEnv 
 
281
        ; loc <- getSrcSpanDs
 
282
        ; let msg = mkErrMsg loc (ds_unqual env) err
 
283
        ; updMutVar (ds_msgs env) (\ (w,e) -> (w, e `snocBag` msg))
 
284
        ; failM }
 
285
\end{code}
 
286
 
 
287
\begin{code}
 
288
instance MonadThings (IOEnv (Env DsGblEnv DsLclEnv)) where
 
289
    lookupThing = dsLookupGlobal
 
290
 
 
291
dsLookupGlobal :: Name -> DsM TyThing
 
292
-- Very like TcEnv.tcLookupGlobal
 
293
dsLookupGlobal name 
 
294
  = do  { env <- getGblEnv
 
295
        ; setEnvs (ds_if_env env)
 
296
                  (tcIfaceGlobal name) }
 
297
 
 
298
dsLookupGlobalId :: Name -> DsM Id
 
299
dsLookupGlobalId name 
 
300
  = tyThingId <$> dsLookupGlobal name
 
301
 
 
302
dsLookupTyCon :: Name -> DsM TyCon
 
303
dsLookupTyCon name
 
304
  = tyThingTyCon <$> dsLookupGlobal name
 
305
 
 
306
dsLookupDataCon :: Name -> DsM DataCon
 
307
dsLookupDataCon name
 
308
  = tyThingDataCon <$> dsLookupGlobal name
 
309
 
 
310
dsLookupClass :: Name -> DsM Class
 
311
dsLookupClass name
 
312
  = tyThingClass <$> dsLookupGlobal name
 
313
\end{code}
 
314
 
 
315
\begin{code}
 
316
dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal)
 
317
dsLookupMetaEnv name = do { env <- getLclEnv; return (lookupNameEnv (ds_meta env) name) }
 
318
 
 
319
dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a
 
320
dsExtendMetaEnv menv thing_inside
 
321
  = updLclEnv (\env -> env { ds_meta = ds_meta env `plusNameEnv` menv }) thing_inside
 
322
\end{code}
 
323
 
 
324
\begin{code}
 
325
dsLoadModule :: SDoc -> Module -> DsM ()
 
326
dsLoadModule doc mod
 
327
  = do { env <- getGblEnv
 
328
       ; setEnvs (ds_if_env env)
 
329
                 (loadSysInterface doc mod >> return ())
 
330
       }
 
331
\end{code}
 
332