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