69aa0f9648766debdc611c65f4b5eae5998cb8ec
[ghc.git] / compiler / deSugar / DsMonad.hs
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
9 {-# LANGUAGE FlexibleInstances #-}
10 {-# OPTIONS_GHC -fno-warn-orphans #-} -- instance MonadThings is necessarily an orphan
11
12 module DsMonad (
13 DsM, mapM, mapAndUnzipM,
14 initDs, initDsTc, initTcDsForSolver, fixDs,
15 foldlM, foldrM, whenGOptM, unsetGOptM, unsetWOptM,
16 Applicative(..),(<$>),
17
18 newLocalName,
19 duplicateLocalDs, newSysLocalDs, newSysLocalsDs, newUniqueId,
20 newFailLocalDs, newPredVarDs,
21 getSrcSpanDs, putSrcSpanDs,
22 mkPrintUnqualifiedDs,
23 newUnique,
24 UniqSupply, newUniqueSupply,
25 getGhcModeDs, dsGetFamInstEnvs,
26 dsLookupGlobal, dsLookupGlobalId, dsDPHBuiltin, dsLookupTyCon, dsLookupDataCon,
27
28 PArrBuiltin(..),
29 dsLookupDPHRdrEnv, dsLookupDPHRdrEnv_maybe,
30 dsInitPArrBuiltin,
31
32 DsMetaEnv, DsMetaVal(..), dsGetMetaEnv, dsLookupMetaEnv, dsExtendMetaEnv,
33
34 -- Getting and setting EvVars and term constraints in local environment
35 getDictsDs, addDictsDs, getTmCsDs, addTmCsDs,
36
37 -- Iterations for pm checking
38 incrCheckPmIterDs, resetPmIterDs,
39
40 -- Warnings
41 DsWarning, warnDs, failWithDs, discardWarningsDs,
42
43 -- Data types
44 DsMatchContext(..),
45 EquationInfo(..), MatchResult(..), DsWrapper, idDsWrapper,
46 CanItFail(..), orFail
47 ) where
48
49 import TcRnMonad
50 import FamInstEnv
51 import CoreSyn
52 import HsSyn
53 import TcIface
54 import LoadIface
55 import Finder
56 import PrelNames
57 import RnNames
58 import RdrName
59 import HscTypes
60 import Bag
61 import DataCon
62 import TyCon
63 import PmExpr
64 import Id
65 import Module
66 import Outputable
67 import SrcLoc
68 import Type
69 import UniqSupply
70 import Name
71 import NameEnv
72 import DynFlags
73 import ErrUtils
74 import FastString
75 import Maybes
76 import Var (EvVar)
77 import qualified GHC.LanguageExtensions as LangExt
78
79 import Data.IORef
80 import Control.Monad
81
82 {-
83 ************************************************************************
84 * *
85 Data types for the desugarer
86 * *
87 ************************************************************************
88 -}
89
90 data DsMatchContext
91 = DsMatchContext (HsMatchContext Name) SrcSpan
92 deriving ()
93
94 data EquationInfo
95 = EqnInfo { eqn_pats :: [Pat Id], -- The patterns for an eqn
96 eqn_rhs :: MatchResult } -- What to do after match
97
98 instance Outputable EquationInfo where
99 ppr (EqnInfo pats _) = ppr pats
100
101 type DsWrapper = CoreExpr -> CoreExpr
102 idDsWrapper :: DsWrapper
103 idDsWrapper e = e
104
105 -- The semantics of (match vs (EqnInfo wrap pats rhs)) is the MatchResult
106 -- \fail. wrap (case vs of { pats -> rhs fail })
107 -- where vs are not bound by wrap
108
109
110 -- A MatchResult is an expression with a hole in it
111 data MatchResult
112 = MatchResult
113 CanItFail -- Tells whether the failure expression is used
114 (CoreExpr -> DsM CoreExpr)
115 -- Takes a expression to plug in at the
116 -- failure point(s). The expression should
117 -- be duplicatable!
118
119 data CanItFail = CanFail | CantFail
120
121 orFail :: CanItFail -> CanItFail -> CanItFail
122 orFail CantFail CantFail = CantFail
123 orFail _ _ = CanFail
124
125 {-
126 ************************************************************************
127 * *
128 Monad functions
129 * *
130 ************************************************************************
131 -}
132
133 -- Compatibility functions
134 fixDs :: (a -> DsM a) -> DsM a
135 fixDs = fixM
136
137 type DsWarning = (SrcSpan, SDoc)
138 -- Not quite the same as a WarnMsg, we have an SDoc here
139 -- and we'll do the print_unqual stuff later on to turn it
140 -- into a Doc.
141
142 initDs :: HscEnv
143 -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
144 -> DsM a
145 -> IO (Messages, Maybe a)
146 -- Print errors and warnings, if any arise
147
148 initDs hsc_env mod rdr_env type_env fam_inst_env thing_inside
149 = do { msg_var <- newIORef (emptyBag, emptyBag)
150 ; pm_iter_var <- newIORef 0
151 ; let dflags = hsc_dflags hsc_env
152 (ds_gbl_env, ds_lcl_env) = mkDsEnvs dflags mod rdr_env type_env
153 fam_inst_env msg_var
154 pm_iter_var
155
156 ; either_res <- initTcRnIf 'd' hsc_env ds_gbl_env ds_lcl_env $
157 loadDAP $
158 initDPHBuiltins $
159 tryM thing_inside -- Catch exceptions (= errors during desugaring)
160
161 -- Display any errors and warnings
162 -- Note: if -Werror is used, we don't signal an error here.
163 ; msgs <- readIORef msg_var
164
165 ; let final_res | errorsFound dflags msgs = Nothing
166 | otherwise = case either_res of
167 Right res -> Just res
168 Left exn -> pprPanic "initDs" (text (show exn))
169 -- The (Left exn) case happens when the thing_inside throws
170 -- a UserError exception. Then it should have put an error
171 -- message in msg_var, so we just discard the exception
172
173 ; return (msgs, final_res)
174 }
175 where
176 -- Extend the global environment with a 'GlobalRdrEnv' containing the exported entities of
177 -- * 'Data.Array.Parallel' iff '-XParallelArrays' specified (see also 'checkLoadDAP').
178 -- * 'Data.Array.Parallel.Prim' iff '-fvectorise' specified.
179 loadDAP thing_inside
180 = do { dapEnv <- loadOneModule dATA_ARRAY_PARALLEL_NAME checkLoadDAP paErr
181 ; dappEnv <- loadOneModule dATA_ARRAY_PARALLEL_PRIM_NAME (goptM Opt_Vectorise) veErr
182 ; updGblEnv (\env -> env {ds_dph_env = dapEnv `plusOccEnv` dappEnv }) thing_inside
183 }
184 where
185 loadOneModule :: ModuleName -- the module to load
186 -> DsM Bool -- under which condition
187 -> MsgDoc -- error message if module not found
188 -> DsM GlobalRdrEnv -- empty if condition 'False'
189 loadOneModule modname check err
190 = do { doLoad <- check
191 ; if not doLoad
192 then return emptyGlobalRdrEnv
193 else do {
194 ; result <- liftIO $ findImportedModule hsc_env modname Nothing
195 ; case result of
196 Found _ mod -> loadModule err mod
197 _ -> pprPgmError "Unable to use Data Parallel Haskell (DPH):" err
198 } }
199
200 paErr = text "To use ParallelArrays," <+> specBackend $$ hint1 $$ hint2
201 veErr = text "To use -fvectorise," <+> specBackend $$ hint1 $$ hint2
202 specBackend = text "you must specify a DPH backend package"
203 hint1 = text "Look for packages named 'dph-lifted-*' with 'ghc-pkg'"
204 hint2 = text "You may need to install them with 'cabal install dph-examples'"
205
206 initDPHBuiltins thing_inside
207 = do { -- If '-XParallelArrays' given, we populate the builtin table for desugaring those
208 ; doInitBuiltins <- checkLoadDAP
209 ; if doInitBuiltins
210 then dsInitPArrBuiltin thing_inside
211 else thing_inside
212 }
213
214 checkLoadDAP = do { paEnabled <- xoptM LangExt.ParallelArrays
215 ; return $ paEnabled &&
216 mod /= gHC_PARR' &&
217 moduleName mod /= dATA_ARRAY_PARALLEL_NAME
218 }
219 -- do not load 'Data.Array.Parallel' iff compiling 'base:GHC.PArr' or a
220 -- module called 'dATA_ARRAY_PARALLEL_NAME'; see also the comments at the top
221 -- of 'base:GHC.PArr' and 'Data.Array.Parallel' in the DPH libraries
222
223 initDsTc :: DsM a -> TcM a
224 initDsTc thing_inside
225 = do { this_mod <- getModule
226 ; tcg_env <- getGblEnv
227 ; msg_var <- getErrsVar
228 ; dflags <- getDynFlags
229 ; pm_iter_var <- liftIO $ newIORef 0
230 ; let type_env = tcg_type_env tcg_env
231 rdr_env = tcg_rdr_env tcg_env
232 fam_inst_env = tcg_fam_inst_env tcg_env
233 ds_envs = mkDsEnvs dflags this_mod rdr_env type_env fam_inst_env
234 msg_var pm_iter_var
235 ; setEnvs ds_envs thing_inside
236 }
237
238 initTcDsForSolver :: TcM a -> DsM (Messages, Maybe a)
239 -- Spin up a TcM context so that we can run the constraint solver
240 -- Returns any error messages generated by the constraint solver
241 -- and (Just res) if no error happened; Nothing if an errror happened
242 --
243 -- Simon says: I'm not very happy about this. We spin up a complete TcM monad
244 -- only to immediately refine it to a TcS monad.
245 -- Better perhaps to make TcS into its own monad, rather than building on TcS
246 -- But that may in turn interact with plugins
247
248 initTcDsForSolver thing_inside
249 = do { (gbl, lcl) <- getEnvs
250 ; hsc_env <- getTopEnv
251
252 ; let DsGblEnv { ds_mod = mod
253 , ds_fam_inst_env = fam_inst_env } = gbl
254
255 DsLclEnv { dsl_loc = loc } = lcl
256
257 ; liftIO $ initTc hsc_env HsSrcFile False mod loc $
258 updGblEnv (\tc_gbl -> tc_gbl { tcg_fam_inst_env = fam_inst_env }) $
259 thing_inside }
260
261 mkDsEnvs :: DynFlags -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
262 -> IORef Messages -> IORef Int -> (DsGblEnv, DsLclEnv)
263 mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var pmvar
264 = let if_genv = IfGblEnv { if_doc = text "mkDsEnvs",
265 if_rec_types = Just (mod, return type_env) }
266 if_lenv = mkIfLclEnv mod (text "GHC error in desugarer lookup in" <+> ppr mod)
267 real_span = realSrcLocSpan (mkRealSrcLoc (moduleNameFS (moduleName mod)) 1 1)
268 gbl_env = DsGblEnv { ds_mod = mod
269 , ds_fam_inst_env = fam_inst_env
270 , ds_if_env = (if_genv, if_lenv)
271 , ds_unqual = mkPrintUnqualified dflags rdr_env
272 , ds_msgs = msg_var
273 , ds_dph_env = emptyGlobalRdrEnv
274 , ds_parr_bi = panic "DsMonad: uninitialised ds_parr_bi"
275 }
276 lcl_env = DsLclEnv { dsl_meta = emptyNameEnv
277 , dsl_loc = real_span
278 , dsl_dicts = emptyBag
279 , dsl_tm_cs = emptyBag
280 , dsl_pm_iter = pmvar
281 }
282 in (gbl_env, lcl_env)
283
284 -- Attempt to load the given module and return its exported entities if successful.
285 --
286 loadModule :: SDoc -> Module -> DsM GlobalRdrEnv
287 loadModule doc mod
288 = do { env <- getGblEnv
289 ; setEnvs (ds_if_env env) $ do
290 { iface <- loadInterface doc mod ImportBySystem
291 ; case iface of
292 Failed err -> pprPanic "DsMonad.loadModule: failed to load" (err $$ doc)
293 Succeeded iface -> return $ mkGlobalRdrEnv . gresFromAvails prov . mi_exports $ iface
294 } }
295 where
296 prov = Just (ImpSpec { is_decl = imp_spec, is_item = ImpAll })
297 imp_spec = ImpDeclSpec { is_mod = name, is_qual = True,
298 is_dloc = wiredInSrcSpan, is_as = name }
299 name = moduleName mod
300
301 {-
302 ************************************************************************
303 * *
304 Operations in the monad
305 * *
306 ************************************************************************
307
308 And all this mysterious stuff is so we can occasionally reach out and
309 grab one or more names. @newLocalDs@ isn't exported---exported
310 functions are defined with it. The difference in name-strings makes
311 it easier to read debugging output.
312 -}
313
314 -- Make a new Id with the same print name, but different type, and new unique
315 newUniqueId :: Id -> Type -> DsM Id
316 newUniqueId id = mkSysLocalOrCoVarM (occNameFS (nameOccName (idName id)))
317
318 duplicateLocalDs :: Id -> DsM Id
319 duplicateLocalDs old_local
320 = do { uniq <- newUnique
321 ; return (setIdUnique old_local uniq) }
322
323 newPredVarDs :: PredType -> DsM Var
324 newPredVarDs pred
325 = newSysLocalDs pred
326
327 newSysLocalDs, newFailLocalDs :: Type -> DsM Id
328 newSysLocalDs = mkSysLocalOrCoVarM (fsLit "ds")
329 newFailLocalDs = mkSysLocalOrCoVarM (fsLit "fail")
330
331 newSysLocalsDs :: [Type] -> DsM [Id]
332 newSysLocalsDs tys = mapM newSysLocalDs tys
333
334 {-
335 We can also reach out and either set/grab location information from
336 the @SrcSpan@ being carried around.
337 -}
338
339 getGhcModeDs :: DsM GhcMode
340 getGhcModeDs = getDynFlags >>= return . ghcMode
341
342 -- | Get in-scope type constraints (pm check)
343 getDictsDs :: DsM (Bag EvVar)
344 getDictsDs = do { env <- getLclEnv; return (dsl_dicts env) }
345
346 -- | Add in-scope type constraints (pm check)
347 addDictsDs :: Bag EvVar -> DsM a -> DsM a
348 addDictsDs ev_vars
349 = updLclEnv (\env -> env { dsl_dicts = unionBags ev_vars (dsl_dicts env) })
350
351 -- | Get in-scope term constraints (pm check)
352 getTmCsDs :: DsM (Bag SimpleEq)
353 getTmCsDs = do { env <- getLclEnv; return (dsl_tm_cs env) }
354
355 -- | Add in-scope term constraints (pm check)
356 addTmCsDs :: Bag SimpleEq -> DsM a -> DsM a
357 addTmCsDs tm_cs
358 = updLclEnv (\env -> env { dsl_tm_cs = unionBags tm_cs (dsl_tm_cs env) })
359
360 -- | Increase the counter for elapsed pattern match check iterations.
361 -- If the current counter is already over the limit, fail
362 incrCheckPmIterDs :: DsM ()
363 incrCheckPmIterDs = do
364 env <- getLclEnv
365 cnt <- readTcRef (dsl_pm_iter env)
366 max_iters <- maxPmCheckIterations <$> getDynFlags
367 if cnt >= max_iters
368 then failM
369 else updTcRef (dsl_pm_iter env) (+1)
370
371 -- | Reset the counter for pattern match check iterations to zero
372 resetPmIterDs :: DsM ()
373 resetPmIterDs = do { env <- getLclEnv; writeTcRef (dsl_pm_iter env) 0 }
374
375 getSrcSpanDs :: DsM SrcSpan
376 getSrcSpanDs = do { env <- getLclEnv
377 ; return (RealSrcSpan (dsl_loc env)) }
378
379 putSrcSpanDs :: SrcSpan -> DsM a -> DsM a
380 putSrcSpanDs (UnhelpfulSpan {}) thing_inside
381 = thing_inside
382 putSrcSpanDs (RealSrcSpan real_span) thing_inside
383 = updLclEnv (\ env -> env {dsl_loc = real_span}) thing_inside
384
385 -- | Emit a warning for the current source location
386 warnDs :: WarnReason -> SDoc -> DsM ()
387 warnDs reason warn
388 = do { env <- getGblEnv
389 ; loc <- getSrcSpanDs
390 ; dflags <- getDynFlags
391 ; let msg = makeIntoWarning reason $
392 mkWarnMsg dflags loc (ds_unqual env) warn
393 ; updMutVar (ds_msgs env) (\ (w,e) -> (w `snocBag` msg, e)) }
394
395 failWithDs :: SDoc -> DsM a
396 failWithDs err
397 = do { env <- getGblEnv
398 ; loc <- getSrcSpanDs
399 ; dflags <- getDynFlags
400 ; let msg = mkErrMsg dflags loc (ds_unqual env) err
401 ; updMutVar (ds_msgs env) (\ (w,e) -> (w, e `snocBag` msg))
402 ; failM }
403
404 mkPrintUnqualifiedDs :: DsM PrintUnqualified
405 mkPrintUnqualifiedDs = ds_unqual <$> getGblEnv
406
407 instance MonadThings (IOEnv (Env DsGblEnv DsLclEnv)) where
408 lookupThing = dsLookupGlobal
409
410 dsLookupGlobal :: Name -> DsM TyThing
411 -- Very like TcEnv.tcLookupGlobal
412 dsLookupGlobal name
413 = do { env <- getGblEnv
414 ; setEnvs (ds_if_env env)
415 (tcIfaceGlobal name) }
416
417 dsLookupGlobalId :: Name -> DsM Id
418 dsLookupGlobalId name
419 = tyThingId <$> dsLookupGlobal name
420
421 -- |Get a name from "Data.Array.Parallel" for the desugarer, from the 'ds_parr_bi' component of the
422 -- global desugerar environment.
423 --
424 dsDPHBuiltin :: (PArrBuiltin -> a) -> DsM a
425 dsDPHBuiltin sel = (sel . ds_parr_bi) <$> getGblEnv
426
427 dsLookupTyCon :: Name -> DsM TyCon
428 dsLookupTyCon name
429 = tyThingTyCon <$> dsLookupGlobal name
430
431 dsLookupDataCon :: Name -> DsM DataCon
432 dsLookupDataCon name
433 = tyThingDataCon <$> dsLookupGlobal name
434
435 -- |Lookup a name exported by 'Data.Array.Parallel.Prim' or 'Data.Array.Parallel.Prim'.
436 -- Panic if there isn't one, or if it is defined multiple times.
437 dsLookupDPHRdrEnv :: OccName -> DsM Name
438 dsLookupDPHRdrEnv occ
439 = liftM (fromMaybe (pprPanic nameNotFound (ppr occ)))
440 $ dsLookupDPHRdrEnv_maybe occ
441 where nameNotFound = "Name not found in 'Data.Array.Parallel' or 'Data.Array.Parallel.Prim':"
442
443 -- |Lookup a name exported by 'Data.Array.Parallel.Prim' or 'Data.Array.Parallel.Prim',
444 -- returning `Nothing` if it's not defined. Panic if it's defined multiple times.
445 dsLookupDPHRdrEnv_maybe :: OccName -> DsM (Maybe Name)
446 dsLookupDPHRdrEnv_maybe occ
447 = do { env <- ds_dph_env <$> getGblEnv
448 ; let gres = lookupGlobalRdrEnv env occ
449 ; case gres of
450 [] -> return $ Nothing
451 [gre] -> return $ Just $ gre_name gre
452 _ -> pprPanic multipleNames (ppr occ)
453 }
454 where multipleNames = "Multiple definitions in 'Data.Array.Parallel' and 'Data.Array.Parallel.Prim':"
455
456
457 -- Populate 'ds_parr_bi' from 'ds_dph_env'.
458 --
459 dsInitPArrBuiltin :: DsM a -> DsM a
460 dsInitPArrBuiltin thing_inside
461 = do { lengthPVar <- externalVar (fsLit "lengthP")
462 ; replicatePVar <- externalVar (fsLit "replicateP")
463 ; singletonPVar <- externalVar (fsLit "singletonP")
464 ; mapPVar <- externalVar (fsLit "mapP")
465 ; filterPVar <- externalVar (fsLit "filterP")
466 ; zipPVar <- externalVar (fsLit "zipP")
467 ; crossMapPVar <- externalVar (fsLit "crossMapP")
468 ; indexPVar <- externalVar (fsLit "!:")
469 ; emptyPVar <- externalVar (fsLit "emptyP")
470 ; appPVar <- externalVar (fsLit "+:+")
471 -- ; enumFromToPVar <- externalVar (fsLit "enumFromToP")
472 -- ; enumFromThenToPVar <- externalVar (fsLit "enumFromThenToP")
473 ; enumFromToPVar <- return arithErr
474 ; enumFromThenToPVar <- return arithErr
475
476 ; updGblEnv (\env -> env {ds_parr_bi = PArrBuiltin
477 { lengthPVar = lengthPVar
478 , replicatePVar = replicatePVar
479 , singletonPVar = singletonPVar
480 , mapPVar = mapPVar
481 , filterPVar = filterPVar
482 , zipPVar = zipPVar
483 , crossMapPVar = crossMapPVar
484 , indexPVar = indexPVar
485 , emptyPVar = emptyPVar
486 , appPVar = appPVar
487 , enumFromToPVar = enumFromToPVar
488 , enumFromThenToPVar = enumFromThenToPVar
489 } })
490 thing_inside
491 }
492 where
493 externalVar :: FastString -> DsM Var
494 externalVar fs = dsLookupDPHRdrEnv (mkVarOccFS fs) >>= dsLookupGlobalId
495
496 arithErr = panic "Arithmetic sequences have to wait until we support type classes"
497
498 dsGetFamInstEnvs :: DsM FamInstEnvs
499 -- Gets both the external-package inst-env
500 -- and the home-pkg inst env (includes module being compiled)
501 dsGetFamInstEnvs
502 = do { eps <- getEps; env <- getGblEnv
503 ; return (eps_fam_inst_env eps, ds_fam_inst_env env) }
504
505 dsGetMetaEnv :: DsM (NameEnv DsMetaVal)
506 dsGetMetaEnv = do { env <- getLclEnv; return (dsl_meta env) }
507
508 dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal)
509 dsLookupMetaEnv name = do { env <- getLclEnv; return (lookupNameEnv (dsl_meta env) name) }
510
511 dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a
512 dsExtendMetaEnv menv thing_inside
513 = updLclEnv (\env -> env { dsl_meta = dsl_meta env `plusNameEnv` menv }) thing_inside
514
515 discardWarningsDs :: DsM a -> DsM a
516 -- Ignore warnings inside the thing inside;
517 -- used to ignore inaccessable cases etc. inside generated code
518 discardWarningsDs thing_inside
519 = do { env <- getGblEnv
520 ; old_msgs <- readTcRef (ds_msgs env)
521
522 ; result <- thing_inside
523
524 -- Revert messages to old_msgs
525 ; writeTcRef (ds_msgs env) old_msgs
526
527 ; return result }