87f3343f94d19062ece133039090e02f49aac5f9
[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, ifDOptM, unsetDOptM, unsetWOptM,
13         Applicative(..),(<$>),
14
15         newLocalName,
16         duplicateLocalDs, newSysLocalDs, newSysLocalsDs, newUniqueId,
17         newFailLocalDs, newPredVarDs,
18         getSrcSpanDs, putSrcSpanDs,
19         getModuleDs,
20         mkPrintUnqualifiedDs,
21         newUnique, 
22         UniqSupply, newUniqueSupply,
23         getDOptsDs, getGhcModeDs, doptDs, woptDs,
24         dsLookupGlobal, dsLookupGlobalId, dsLookupDPHId, dsLookupTyCon, dsLookupDataCon,
25         
26         assertDAPPLoaded, lookupDAPPRdrEnv, dsImportDecl, dsImportId, dsImportTyCon,
27
28         DsMetaEnv, DsMetaVal(..), dsLookupMetaEnv, dsExtendMetaEnv,
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 PrelNames
45 import Avail
46 import RdrName
47 import HscTypes
48 import Bag
49 import DataCon
50 import TyCon
51 import Id
52 import Module
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 import Maybes
63 import Control.Monad
64
65 import Data.IORef
66 \end{code}
67
68 %************************************************************************
69 %*                                                                      *
70                 Data types for the desugarer
71 %*                                                                      *
72 %************************************************************************
73
74 \begin{code}
75 data DsMatchContext
76   = DsMatchContext (HsMatchContext Name) SrcSpan
77   deriving ()
78
79 data EquationInfo
80   = EqnInfo { eqn_pats :: [Pat Id],     -- The patterns for an eqn
81               eqn_rhs  :: MatchResult } -- What to do after match
82
83 instance Outputable EquationInfo where
84     ppr (EqnInfo pats _) = ppr pats
85
86 type DsWrapper = CoreExpr -> CoreExpr
87 idDsWrapper :: DsWrapper
88 idDsWrapper e = e
89
90 -- The semantics of (match vs (EqnInfo wrap pats rhs)) is the MatchResult
91 --      \fail. wrap (case vs of { pats -> rhs fail })
92 -- where vs are not bound by wrap
93
94
95 -- A MatchResult is an expression with a hole in it
96 data MatchResult
97   = MatchResult
98         CanItFail       -- Tells whether the failure expression is used
99         (CoreExpr -> DsM CoreExpr)
100                         -- Takes a expression to plug in at the
101                         -- failure point(s). The expression should
102                         -- be duplicatable!
103
104 data CanItFail = CanFail | CantFail
105
106 orFail :: CanItFail -> CanItFail -> CanItFail
107 orFail CantFail CantFail = CantFail
108 orFail _        _        = CanFail
109 \end{code}
110
111
112 %************************************************************************
113 %*                                                                      *
114                 Monad stuff
115 %*                                                                      *
116 %************************************************************************
117
118 Now the mondo monad magic (yes, @DsM@ is a silly name)---carry around
119 a @UniqueSupply@ and some annotations, which
120 presumably include source-file location information:
121
122 \begin{code}
123 type DsM result = TcRnIf DsGblEnv DsLclEnv result
124
125 -- Compatibility functions
126 fixDs :: (a -> DsM a) -> DsM a
127 fixDs    = fixM
128
129 type DsWarning = (SrcSpan, SDoc)
130         -- Not quite the same as a WarnMsg, we have an SDoc here 
131         -- and we'll do the print_unqual stuff later on to turn it
132         -- into a Doc.
133
134 data DsGblEnv = DsGblEnv {
135         ds_mod     :: Module,                   -- For SCC profiling
136         ds_unqual  :: PrintUnqualified,
137         ds_msgs    :: IORef Messages,           -- Warning messages
138         ds_if_env  :: (IfGblEnv, IfLclEnv),     -- Used for looking up global, 
139                                                 -- possibly-imported things
140         ds_dph_env :: GlobalRdrEnv              -- exported entities of 'Data.Array.Parallel.Prim' iff
141                                                 -- '-fdph-*' flag was given (i.e., 'DynFlags.DPHBackend /=
142                                                 -- DPHNone'); otherwise, empty
143     }
144
145 data DsLclEnv = DsLclEnv {
146         ds_meta    :: DsMetaEnv,        -- Template Haskell bindings
147         ds_loc     :: SrcSpan           -- to put in pattern-matching error msgs
148      }
149
150 -- Inside [| |] brackets, the desugarer looks 
151 -- up variables in the DsMetaEnv
152 type DsMetaEnv = NameEnv DsMetaVal
153
154 data DsMetaVal
155    = Bound Id           -- Bound by a pattern inside the [| |]. 
156                         -- Will be dynamically alpha renamed.
157                         -- The Id has type THSyntax.Var
158
159    | Splice (HsExpr Id) -- These bindings are introduced by
160                         -- the PendingSplices on a HsBracketOut
161
162 initDs :: HscEnv
163        -> Module -> GlobalRdrEnv -> TypeEnv
164        -> DsM a
165        -> IO (Messages, Maybe a)
166 -- Print errors and warnings, if any arise
167
168 initDs hsc_env mod rdr_env type_env thing_inside
169   = do  { msg_var <- newIORef (emptyBag, emptyBag)
170         ; let dflags                   = hsc_dflags hsc_env
171               (ds_gbl_env, ds_lcl_env) = mkDsEnvs dflags mod rdr_env type_env msg_var
172
173         ; either_res <- initTcRnIf 'd' hsc_env ds_gbl_env ds_lcl_env $
174                           loadDAPP dflags $
175                             tryM thing_inside       -- Catch exceptions (= errors during desugaring)
176
177         -- Display any errors and warnings 
178         -- Note: if -Werror is used, we don't signal an error here.
179         ; msgs <- readIORef msg_var
180
181         ; let final_res | errorsFound dflags msgs = Nothing
182                         | otherwise = case either_res of
183                                         Right res -> Just res
184                                         Left exn  -> pprPanic "initDs" (text (show exn))
185                 -- The (Left exn) case happens when the thing_inside throws
186                 -- a UserError exception.  Then it should have put an error
187                 -- message in msg_var, so we just discard the exception
188
189         ; return (msgs, final_res) 
190         }
191   where
192     -- Extend the global environment with a 'GlobalRdrEnv' containing the exported entities of
193     -- 'Data.Array.Parallel.Prim' if '-fdph-*' specified.
194     loadDAPP dflags thing_inside
195       | Just pkg <- dphPackageMaybe dflags
196       = do { rdr_env <- loadModule sdoc (dATA_ARRAY_PARALLEL_PRIM pkg)
197            ; updGblEnv (\env -> env {ds_dph_env = rdr_env}) thing_inside
198            }
199       | otherwise
200       = do { ifXOptM Opt_ParallelArrays (liftIO $ fatalErrorMsg dflags $ ptext selectBackendErrPA)
201            ; ifDOptM Opt_Vectorise      (liftIO $ fatalErrorMsg dflags $ ptext selectBackendErrVect)
202            ; thing_inside
203            }
204
205     sdoc = ptext (sLit "Internal Data Parallel Haskell interface 'Data.Array.Parallel.Prim'")
206
207     selectBackendErrVect = sLit "To use -fvectorise select a DPH backend with -fdph-par or -fdph-seq"
208     selectBackendErrPA   = sLit "To use -XParallelArrays select a DPH backend with -fdph-par or -fdph-seq"
209
210 initDsTc :: DsM a -> TcM a
211 initDsTc thing_inside
212   = do  { this_mod <- getModule
213         ; tcg_env  <- getGblEnv
214         ; msg_var  <- getErrsVar
215         ; dflags   <- getDOpts
216         ; let type_env = tcg_type_env tcg_env
217               rdr_env  = tcg_rdr_env tcg_env
218               ds_envs  = mkDsEnvs dflags this_mod rdr_env type_env msg_var
219         ; setEnvs ds_envs thing_inside
220         }
221
222 mkDsEnvs :: DynFlags -> Module -> GlobalRdrEnv -> TypeEnv -> IORef Messages -> (DsGblEnv, DsLclEnv)
223 mkDsEnvs dflags mod rdr_env type_env msg_var
224   = let if_genv = IfGblEnv { if_rec_types = Just (mod, return type_env) }
225         if_lenv = mkIfLclEnv mod (ptext (sLit "GHC error in desugarer lookup in") <+> ppr mod)
226         gbl_env = DsGblEnv { ds_mod     = mod
227                            , ds_if_env  = (if_genv, if_lenv)
228                            , ds_unqual  = mkPrintUnqualified dflags rdr_env
229                            , ds_msgs    = msg_var
230                            , ds_dph_env = emptyGlobalRdrEnv
231                            }
232         lcl_env = DsLclEnv { ds_meta = emptyNameEnv
233                            , ds_loc  = noSrcSpan
234                            }
235     in (gbl_env, lcl_env)
236
237 -- Attempt to load the given module and return its exported entities if successful; otherwise, return an
238 -- empty environment.  See "Note [Loading Data.Array.Parallel.Prim]".
239 --
240 loadModule :: SDoc -> Module -> DsM GlobalRdrEnv
241 loadModule doc mod
242   = do { env <- getGblEnv
243        ; setEnvs (ds_if_env env) $ do
244        { iface <- loadInterface doc mod ImportBySystem
245        ;   case iface of
246              Failed _err     -> return $ mkGlobalRdrEnv []
247              Succeeded iface -> return $ mkGlobalRdrEnv . gresFromAvails prov . mi_exports $ iface
248        } }
249   where
250     prov     = Imported [ImpSpec { is_decl = imp_spec, is_item = ImpAll }]
251     imp_spec = ImpDeclSpec { is_mod = name, is_qual = True,
252                              is_dloc = wiredInSrcSpan, is_as = name }
253     name = moduleName mod
254 \end{code}
255
256 Note [Loading Data.Array.Parallel.Prim]
257 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
258 We generally attempt to load the interface of 'Data.Array.Parallel.Prim' when a DPH backend is selected.
259 However, while compiling packages containing a DPH backend, we will start out compiling the modules
260 'Data.Array.Parallel.Prim' depends on — i.e., when compiling these modules, the interface won't exist yet.
261 This is fine, as these modules do not use the vectoriser, but we need to ensure that GHC doesn't barf when
262 the interface is missing.  Instead of an error message, we just put an empty 'GlobalRdrEnv' into the
263 'DsM' state.
264
265
266 %************************************************************************
267 %*                                                                      *
268                 Operations in the monad
269 %*                                                                      *
270 %************************************************************************
271
272 And all this mysterious stuff is so we can occasionally reach out and
273 grab one or more names.  @newLocalDs@ isn't exported---exported
274 functions are defined with it.  The difference in name-strings makes
275 it easier to read debugging output.
276
277 \begin{code}
278 -- Make a new Id with the same print name, but different type, and new unique
279 newUniqueId :: Id -> Type -> DsM Id
280 newUniqueId id = mkSysLocalM (occNameFS (nameOccName (idName id)))
281
282 duplicateLocalDs :: Id -> DsM Id
283 duplicateLocalDs old_local 
284   = do  { uniq <- newUnique
285         ; return (setIdUnique old_local uniq) }
286
287 newPredVarDs :: PredType -> DsM Var
288 newPredVarDs pred
289  = newSysLocalDs pred
290  
291 newSysLocalDs, newFailLocalDs :: Type -> DsM Id
292 newSysLocalDs  = mkSysLocalM (fsLit "ds")
293 newFailLocalDs = mkSysLocalM (fsLit "fail")
294
295 newSysLocalsDs :: [Type] -> DsM [Id]
296 newSysLocalsDs tys = mapM newSysLocalDs tys
297 \end{code}
298
299 We can also reach out and either set/grab location information from
300 the @SrcSpan@ being carried around.
301
302 \begin{code}
303 getDOptsDs :: DsM DynFlags
304 getDOptsDs = getDOpts
305
306 doptDs :: DynFlag -> TcRnIf gbl lcl Bool
307 doptDs = doptM
308
309 woptDs :: WarningFlag -> TcRnIf gbl lcl Bool
310 woptDs = woptM
311
312 getGhcModeDs :: DsM GhcMode
313 getGhcModeDs =  getDOptsDs >>= return . ghcMode
314
315 getModuleDs :: DsM Module
316 getModuleDs = do { env <- getGblEnv; return (ds_mod env) }
317
318 getSrcSpanDs :: DsM SrcSpan
319 getSrcSpanDs = do { env <- getLclEnv; return (ds_loc env) }
320
321 putSrcSpanDs :: SrcSpan -> DsM a -> DsM a
322 putSrcSpanDs new_loc thing_inside = updLclEnv (\ env -> env {ds_loc = new_loc}) thing_inside
323
324 warnDs :: SDoc -> DsM ()
325 warnDs warn = do { env <- getGblEnv 
326                  ; loc <- getSrcSpanDs
327                  ; let msg = mkWarnMsg loc (ds_unqual env) 
328                                       (ptext (sLit "Warning:") <+> warn)
329                  ; updMutVar (ds_msgs env) (\ (w,e) -> (w `snocBag` msg, e)) }
330
331 failWithDs :: SDoc -> DsM a
332 failWithDs err 
333   = do  { env <- getGblEnv 
334         ; loc <- getSrcSpanDs
335         ; let msg = mkErrMsg loc (ds_unqual env) err
336         ; updMutVar (ds_msgs env) (\ (w,e) -> (w, e `snocBag` msg))
337         ; failM }
338
339 mkPrintUnqualifiedDs :: DsM PrintUnqualified
340 mkPrintUnqualifiedDs = ds_unqual <$> getGblEnv
341 \end{code}
342
343 \begin{code}
344 instance MonadThings (IOEnv (Env DsGblEnv DsLclEnv)) where
345     lookupThing = dsLookupGlobal
346
347 dsLookupGlobal :: Name -> DsM TyThing
348 -- Very like TcEnv.tcLookupGlobal
349 dsLookupGlobal name 
350   = do  { env <- getGblEnv
351         ; setEnvs (ds_if_env env)
352                   (tcIfaceGlobal name) }
353
354 dsLookupGlobalId :: Name -> DsM Id
355 dsLookupGlobalId name 
356   = tyThingId <$> dsLookupGlobal name
357
358 -- Looking up a global DPH 'Id' is like 'dsLookupGlobalId', but the package, in which the looked
359 -- up name is located, varies with the active DPH backend.
360 --
361 dsLookupDPHId :: (PackageId -> Name) -> DsM Id
362 dsLookupDPHId nameInPkg
363   = do { dflags <- getDOpts
364        ; case dphPackageMaybe dflags of
365            Just pkg -> tyThingId <$> dsLookupGlobal (nameInPkg pkg)
366            Nothing  -> failWithDs $ ptext err
367        }
368   where
369     err = sLit "To use -XParallelArrays select a DPH backend with -fdph-par or -fdph-seq"
370
371 dsLookupTyCon :: Name -> DsM TyCon
372 dsLookupTyCon name
373   = tyThingTyCon <$> dsLookupGlobal name
374
375 dsLookupDataCon :: Name -> DsM DataCon
376 dsLookupDataCon name
377   = tyThingDataCon <$> dsLookupGlobal name
378 \end{code}
379
380 \begin{code}
381 -- Complain if 'Data.Array.Parallel.Prim' wasn't loaded (and we are about to use it).
382 --
383 -- See "Note [Loading Data.Array.Parallel.Prim]".
384 --
385 assertDAPPLoaded :: DsM ()
386 assertDAPPLoaded 
387   = do { env <- ds_dph_env <$> getGblEnv
388        ; when (null $ occEnvElts env) $
389            panic "'Data.Array.Parallel.Prim' not available; probably missing dependencies in DPH package"
390        }
391
392 -- Look up a name exported by 'Data.Array.Parallel.Prim'.
393 --
394 lookupDAPPRdrEnv :: OccName -> DsM Name
395 lookupDAPPRdrEnv occ
396   = do { env <- ds_dph_env <$> getGblEnv
397        ; let gres = lookupGlobalRdrEnv env occ
398        ; case gres of
399            []    -> pprPanic "Name not found in 'Data.Array.Parallel.Prim':" (ppr occ)
400            [gre] -> return $ gre_name gre
401            _     -> pprPanic "Multiple definitions in 'Data.Array.Parallel.Prim':" (ppr occ)
402        }
403
404 -- Find the thing repferred to by an imported name.
405 --
406 dsImportDecl :: Name -> DsM TyThing
407 dsImportDecl name
408   = do { env <- getGblEnv
409        ; setEnvs (ds_if_env env) $ do
410        { mb_thing <- importDecl name
411        ; case mb_thing of
412            Failed err      -> failIfM err
413            Succeeded thing -> return thing
414        } }
415
416 dsImportId :: Name -> DsM Id
417 dsImportId name
418   = tyThingId <$> dsImportDecl name
419
420 dsImportTyCon :: Name -> DsM TyCon
421 dsImportTyCon name
422   = tyThingTyCon <$> dsImportDecl name
423 \end{code}
424
425 \begin{code}
426 dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal)
427 dsLookupMetaEnv name = do { env <- getLclEnv; return (lookupNameEnv (ds_meta env) name) }
428
429 dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a
430 dsExtendMetaEnv menv thing_inside
431   = updLclEnv (\env -> env { ds_meta = ds_meta env `plusNameEnv` menv }) thing_inside
432 \end{code}