DsMonad.lhs 8.89 KB
Newer Older
1
%
Simon Marlow's avatar
Simon Marlow committed
2
% (c) The University of Glasgow 2006
3
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4
%
Simon Marlow's avatar
Simon Marlow committed
5
6

@DsMonad@: monadery used in desugaring
7
8
9

\begin{code}
module DsMonad (
10
	DsM, mapM, mapAndUnzipM,
twanvl's avatar
twanvl committed
11
	initDs, initDsTc, fixDs,
12
13
	foldlM, foldrM, ifOptM,
	Applicative(..),(<$>),
14

15
	newLocalName,
16
	duplicateLocalDs, newSysLocalDs, newSysLocalsDs, newUniqueId,
17
	newFailLocalDs,
18
	getSrcSpanDs, putSrcSpanDs,
19
	getModuleDs,
20
21
	newUnique, 
	UniqSupply, newUniqueSupply,
mnislaih's avatar
mnislaih committed
22
	getDOptsDs, getGhcModeDs, doptDs,
23
	dsLookupGlobal, dsLookupGlobalId, dsLookupTyCon, dsLookupDataCon,
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
24
        dsLookupClass,
25
26

	DsMetaEnv, DsMetaVal(..), dsLookupMetaEnv, dsExtendMetaEnv,
27

28
	-- Warnings
29
	DsWarning, warnDs, failWithDs,
30
31
32

	-- Data types
	DsMatchContext(..),
33
	EquationInfo(..), MatchResult(..), DsWrapper, idDsWrapper,
34
	CanItFail(..), orFail
35
36
    ) where

37
import TcRnMonad
Simon Marlow's avatar
Simon Marlow committed
38
39
40
41
42
43
44
45
import CoreSyn
import HsSyn
import TcIface
import RdrName
import HscTypes
import Bag
import DataCon
import TyCon
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
46
import Class
Simon Marlow's avatar
Simon Marlow committed
47
48
49
import Id
import Module
import Var
50
import Outputable
Simon Marlow's avatar
Simon Marlow committed
51
52
53
54
import SrcLoc
import Type
import UniqSupply
import Name
55
import NameEnv
Simon Marlow's avatar
Simon Marlow committed
56
57
58
import OccName
import DynFlags
import ErrUtils
59
import MonadUtils
60
import FastString
Simon Marlow's avatar
Simon Marlow committed
61
62

import Data.IORef
63
64
\end{code}

65
66
67
68
69
70
71
72
%************************************************************************
%*									*
		Data types for the desugarer
%*									*
%************************************************************************

\begin{code}
data DsMatchContext
73
  = DsMatchContext (HsMatchContext Name) SrcSpan
74
75
76
77
  | NoMatchContext
  deriving ()

data EquationInfo
78
  = EqnInfo { eqn_pats :: [Pat Id],    	-- The patterns for an eqn
79
80
	      eqn_rhs  :: MatchResult }	-- What to do after match

81
82
83
instance Outputable EquationInfo where
    ppr (EqnInfo pats _) = ppr pats

84
type DsWrapper = CoreExpr -> CoreExpr
twanvl's avatar
twanvl committed
85
idDsWrapper :: DsWrapper
86
idDsWrapper e = e
87

88
89
-- The semantics of (match vs (EqnInfo wrap pats rhs)) is the MatchResult
--	\fail. wrap (case vs of { pats -> rhs fail })
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
90
-- where vs are not bound by wrap
91
92
93
94
95
96
97
98
99
100
101
102
103


-- A MatchResult is an expression with a hole in it
data MatchResult
  = MatchResult
	CanItFail	-- Tells whether the failure expression is used
	(CoreExpr -> DsM CoreExpr)
			-- Takes a expression to plug in at the
			-- failure point(s). The expression should
			-- be duplicatable!

data CanItFail = CanFail | CantFail

twanvl's avatar
twanvl committed
104
orFail :: CanItFail -> CanItFail -> CanItFail
105
orFail CantFail CantFail = CantFail
twanvl's avatar
twanvl committed
106
orFail _        _        = CanFail
107
108
109
110
111
112
113
114
115
\end{code}


%************************************************************************
%*									*
		Monad stuff
%*									*
%************************************************************************

116
117
118
119
Now the mondo monad magic (yes, @DsM@ is a silly name)---carry around
a @UniqueSupply@ and some annotations, which
presumably include source-file location information:
\begin{code}
120
type DsM result = TcRnIf DsGblEnv DsLclEnv result
121

122
-- Compatibility functions
twanvl's avatar
twanvl committed
123
fixDs :: (a -> DsM a) -> DsM a
124
125
fixDs    = fixM

126
127
128
129
type DsWarning = (SrcSpan, SDoc)
	-- Not quite the same as a WarnMsg, we have an SDoc here 
	-- and we'll do the print_unqual stuff later on to turn it
	-- into a Doc.
130
131
132

data DsGblEnv = DsGblEnv {
	ds_mod	   :: Module,       		-- For SCC profiling
133
134
	ds_unqual  :: PrintUnqualified,
	ds_msgs    :: IORef Messages,		-- Warning messages
135
	ds_if_env  :: (IfGblEnv, IfLclEnv)	-- Used for looking up global, 
136
137
138
139
						-- possibly-imported things
    }

data DsLclEnv = DsLclEnv {
140
	ds_meta	   :: DsMetaEnv,	-- Template Haskell bindings
141
	ds_loc	   :: SrcSpan		-- to put in pattern-matching error msgs
142
143
144
145
146
     }

-- Inside [| |] brackets, the desugarer looks 
-- up variables in the DsMetaEnv
type DsMetaEnv = NameEnv DsMetaVal
147

148
149
150
data DsMetaVal
   = Bound Id		-- Bound by a pattern inside the [| |]. 
			-- Will be dynamically alpha renamed.
151
			-- The Id has type THSyntax.Var
152

153
154
   | Splice (HsExpr Id)	-- These bindings are introduced by
			-- the PendingSplices on a HsBracketOut
155

156
initDs  :: HscEnv
157
	-> Module -> GlobalRdrEnv -> TypeEnv
158
	-> DsM a
159
160
	-> IO (Maybe a)
-- 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
165
	; let dflags = hsc_dflags hsc_env
        ; (ds_gbl_env, ds_lcl_env) <- mkDsEnvs dflags mod rdr_env type_env msg_var
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189

	; 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.
	; msgs <- readIORef msg_var
        ; printErrorsAndWarnings dflags msgs 

	; let final_res | errorsFound dflags msgs = Nothing
		        | otherwise = case either_res of
				        Right res -> Just res
				        Left exn -> pprPanic "initDs" (text (show exn))
		-- The (Left exn) case happens when the thing_inside throws
		-- a UserError exception.  Then it should have put an error
		-- message in msg_var, so we just discard the exception

	; return final_res }

initDsTc :: DsM a -> TcM a
initDsTc thing_inside
  = do	{ this_mod <- getModule
	; tcg_env  <- getGblEnv
	; msg_var  <- getErrsVar
190
        ; dflags   <- getDOpts
191
192
	; let type_env = tcg_type_env tcg_env
	      rdr_env  = tcg_rdr_env tcg_env
193
        ; ds_envs <- liftIO $ mkDsEnvs dflags this_mod rdr_env type_env msg_var
194
	; setEnvs ds_envs thing_inside }
195

196
197
mkDsEnvs :: DynFlags -> Module -> GlobalRdrEnv -> TypeEnv -> IORef Messages -> IO (DsGblEnv, DsLclEnv)
mkDsEnvs dflags mod rdr_env type_env msg_var
twanvl's avatar
twanvl committed
198
  = do -- TODO: unnecessarily monadic
199
       let     if_genv = IfGblEnv { if_rec_types = Just (mod, return type_env) }
Ian Lynagh's avatar
Ian Lynagh committed
200
               if_lenv = mkIfLclEnv mod (ptext (sLit "GHC error in desugarer lookup in") <+> ppr mod)
201
202
               gbl_env = DsGblEnv { ds_mod = mod, 
    			            ds_if_env = (if_genv, if_lenv),
203
    			            ds_unqual = mkPrintUnqualified dflags rdr_env,
204
    			            ds_msgs = msg_var}
205
               lcl_env = DsLclEnv { ds_meta = emptyNameEnv, 
206
			            ds_loc = noSrcSpan }
207
208

       return (gbl_env, lcl_env)
209
210
\end{code}

211
212
213
214
215
216
%************************************************************************
%*									*
		Operations in the monad
%*									*
%************************************************************************

217
218
219
220
And all this mysterious stuff is so we can occasionally reach out and
grab one or more names.  @newLocalDs@ isn't exported---exported
functions are defined with it.  The difference in name-strings makes
it easier to read debugging output.
sof's avatar
sof committed
221

222
\begin{code}
223
224
-- Make a new Id with the same print name, but different type, and new unique
newUniqueId :: Name -> Type -> DsM Id
225
newUniqueId id = mkSysLocalM (occNameFS (nameOccName id))
226

227
duplicateLocalDs :: Id -> DsM Id
228
229
230
duplicateLocalDs old_local = do
    uniq <- newUnique
    return (setIdUnique old_local uniq)
231

232
newSysLocalDs, newFailLocalDs :: Type -> DsM Id
233
234
newSysLocalDs = mkSysLocalM (fsLit "ds")
newFailLocalDs = mkSysLocalM (fsLit "fail")
235

twanvl's avatar
twanvl committed
236
newSysLocalsDs :: [Type] -> DsM [Id]
237
newSysLocalsDs tys = mapM newSysLocalDs tys
238
239
240
\end{code}

We can also reach out and either set/grab location information from
241
the @SrcSpan@ being carried around.
242

243
\begin{code}
244
getDOptsDs :: DsM DynFlags
245
getDOptsDs = getDOpts
246

mnislaih's avatar
mnislaih committed
247
248
249
250
251
252
doptDs :: DynFlag -> TcRnIf gbl lcl Bool
doptDs = doptM

getGhcModeDs :: DsM GhcMode
getGhcModeDs =  getDOptsDs >>= return . ghcMode

253
getModuleDs :: DsM Module
254
getModuleDs = do { env <- getGblEnv; return (ds_mod env) }
255

256
257
getSrcSpanDs :: DsM SrcSpan
getSrcSpanDs = do { env <- getLclEnv; return (ds_loc env) }
258

259
260
putSrcSpanDs :: SrcSpan -> DsM a -> DsM a
putSrcSpanDs new_loc thing_inside = updLclEnv (\ env -> env {ds_loc = new_loc}) thing_inside
261

262
263
warnDs :: SDoc -> DsM ()
warnDs warn = do { env <- getGblEnv 
264
		 ; loc <- getSrcSpanDs
265
		 ; let msg = mkWarnMsg loc (ds_unqual env) 
Ian Lynagh's avatar
Ian Lynagh committed
266
				      (ptext (sLit "Warning:") <+> warn)
267
268
269
270
271
272
273
274
275
		 ; updMutVar (ds_msgs env) (\ (w,e) -> (w `snocBag` msg, e)) }

failWithDs :: SDoc -> DsM a
failWithDs err 
  = do	{ env <- getGblEnv 
	; loc <- getSrcSpanDs
	; let msg = mkErrMsg loc (ds_unqual env) err
	; updMutVar (ds_msgs env) (\ (w,e) -> (w, e `snocBag` msg))
	; failM }
276
277
278
\end{code}

\begin{code}
279
280
281
instance MonadThings (IOEnv (Env DsGblEnv DsLclEnv)) where
    lookupThing = dsLookupGlobal

282
dsLookupGlobal :: Name -> DsM TyThing
283
-- Very like TcEnv.tcLookupGlobal
284
dsLookupGlobal name 
285
  = do	{ env <- getGblEnv
286
	; setEnvs (ds_if_env env)
287
		  (tcIfaceGlobal name) }
288

289
dsLookupGlobalId :: Name -> DsM Id
290
dsLookupGlobalId name 
291
  = tyThingId <$> dsLookupGlobal name
292
293

dsLookupTyCon :: Name -> DsM TyCon
294
dsLookupTyCon name
295
  = tyThingTyCon <$> dsLookupGlobal name
296

297
298
dsLookupDataCon :: Name -> DsM DataCon
dsLookupDataCon name
299
  = tyThingDataCon <$> dsLookupGlobal name
rl@cse.unsw.edu.au's avatar
rl@cse.unsw.edu.au committed
300
301
302

dsLookupClass :: Name -> DsM Class
dsLookupClass name
303
  = tyThingClass <$> dsLookupGlobal name
304
305
306
\end{code}

\begin{code}
307
dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal)
308
dsLookupMetaEnv name = do { env <- getLclEnv; return (lookupNameEnv (ds_meta env) name) }
309
310

dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a
311
312
dsExtendMetaEnv menv thing_inside
  = updLclEnv (\env -> env { ds_meta = ds_meta env `plusNameEnv` menv }) thing_inside
313
\end{code}