Deal with exceptions in dsWhenNoErrs
[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, FlexibleContexts #-}
10 {-# OPTIONS_GHC -fno-warn-orphans #-} -- instance MonadThings is necessarily an orphan
11
12 module DsMonad (
13 DsM, mapM, mapAndUnzipM,
14 initDs, initDsTc, initTcDsForSolver, initDsWithModGuts, fixDs,
15 foldlM, foldrM, whenGOptM, unsetGOptM, unsetWOptM, xoptM,
16 Applicative(..),(<$>),
17
18 duplicateLocalDs, newSysLocalDsNoLP, newSysLocalDs,
19 newSysLocalsDsNoLP, newSysLocalsDs, newUniqueId,
20 newFailLocalDs, newPredVarDs,
21 getSrcSpanDs, putSrcSpanDs,
22 mkPrintUnqualifiedDs,
23 newUnique,
24 UniqSupply, newUniqueSupply,
25 getGhcModeDs, dsGetFamInstEnvs,
26 dsLookupGlobal, dsLookupGlobalId, dsDPHBuiltin, dsLookupTyCon,
27 dsLookupDataCon, dsLookupConLike,
28
29 PArrBuiltin(..),
30 dsLookupDPHRdrEnv, dsLookupDPHRdrEnv_maybe,
31 dsInitPArrBuiltin,
32
33 DsMetaEnv, DsMetaVal(..), dsGetMetaEnv, dsLookupMetaEnv, dsExtendMetaEnv,
34
35 -- Getting and setting EvVars and term constraints in local environment
36 getDictsDs, addDictsDs, getTmCsDs, addTmCsDs,
37
38 -- Iterations for pm checking
39 incrCheckPmIterDs, resetPmIterDs, dsGetCompleteMatches,
40
41 -- Warnings and errors
42 DsWarning, warnDs, warnIfSetDs, errDs, errDsCoreExpr,
43 failWithDs, failDs, discardWarningsDs,
44 askNoErrsDs,
45
46 -- Data types
47 DsMatchContext(..),
48 EquationInfo(..), MatchResult(..), DsWrapper, idDsWrapper,
49 CanItFail(..), orFail,
50
51 -- Levity polymorphism
52 dsNoLevPoly, dsNoLevPolyExpr, dsWhenNoErrs
53 ) where
54
55 import TcRnMonad
56 import FamInstEnv
57 import CoreSyn
58 import MkCore ( unitExpr )
59 import CoreUtils ( exprType, isExprLevPoly )
60 import HsSyn
61 import TcIface
62 import TcMType ( checkForLevPolyX, formatLevPolyErr )
63 import LoadIface
64 import Finder
65 import PrelNames
66 import RdrName
67 import HscTypes
68 import Bag
69 import DataCon
70 import ConLike
71 import TyCon
72 import PmExpr
73 import Id
74 import Module
75 import Outputable
76 import SrcLoc
77 import Type
78 import UniqSupply
79 import Name
80 import NameEnv
81 import DynFlags
82 import ErrUtils
83 import FastString
84 import Maybes
85 import Var (EvVar)
86 import qualified GHC.LanguageExtensions as LangExt
87 import UniqFM ( lookupWithDefaultUFM )
88
89 import Data.IORef
90 import Control.Monad
91
92 {-
93 ************************************************************************
94 * *
95 Data types for the desugarer
96 * *
97 ************************************************************************
98 -}
99
100 data DsMatchContext
101 = DsMatchContext (HsMatchContext Name) SrcSpan
102 deriving ()
103
104 instance Outputable DsMatchContext where
105 ppr (DsMatchContext hs_match ss) = ppr ss <+> pprMatchContext hs_match
106
107 data EquationInfo
108 = EqnInfo { eqn_pats :: [Pat Id], -- The patterns for an eqn
109 eqn_rhs :: MatchResult } -- What to do after match
110
111 instance Outputable EquationInfo where
112 ppr (EqnInfo pats _) = ppr pats
113
114 type DsWrapper = CoreExpr -> CoreExpr
115 idDsWrapper :: DsWrapper
116 idDsWrapper e = e
117
118 -- The semantics of (match vs (EqnInfo wrap pats rhs)) is the MatchResult
119 -- \fail. wrap (case vs of { pats -> rhs fail })
120 -- where vs are not bound by wrap
121
122
123 -- A MatchResult is an expression with a hole in it
124 data MatchResult
125 = MatchResult
126 CanItFail -- Tells whether the failure expression is used
127 (CoreExpr -> DsM CoreExpr)
128 -- Takes a expression to plug in at the
129 -- failure point(s). The expression should
130 -- be duplicatable!
131
132 data CanItFail = CanFail | CantFail
133
134 orFail :: CanItFail -> CanItFail -> CanItFail
135 orFail CantFail CantFail = CantFail
136 orFail _ _ = CanFail
137
138 {-
139 ************************************************************************
140 * *
141 Monad functions
142 * *
143 ************************************************************************
144 -}
145
146 -- Compatibility functions
147 fixDs :: (a -> DsM a) -> DsM a
148 fixDs = fixM
149
150 type DsWarning = (SrcSpan, SDoc)
151 -- Not quite the same as a WarnMsg, we have an SDoc here
152 -- and we'll do the print_unqual stuff later on to turn it
153 -- into a Doc.
154
155 -- | Run a 'DsM' action inside the 'TcM' monad.
156 initDsTc :: DsM a -> TcM a
157 initDsTc thing_inside
158 = do { tcg_env <- getGblEnv
159 ; msg_var <- getErrsVar
160 ; hsc_env <- getTopEnv
161 ; envs <- mkDsEnvsFromTcGbl hsc_env msg_var tcg_env
162 ; setEnvs envs $ initDPH thing_inside
163 }
164
165 -- | Run a 'DsM' action inside the 'IO' monad.
166 initDs :: HscEnv -> TcGblEnv -> DsM a -> IO (Messages, Maybe a)
167 initDs hsc_env tcg_env thing_inside
168 = do { msg_var <- newIORef emptyMessages
169 ; envs <- mkDsEnvsFromTcGbl hsc_env msg_var tcg_env
170 ; runDs hsc_env envs thing_inside
171 }
172
173 -- | Build a set of desugarer environments derived from a 'TcGblEnv'.
174 mkDsEnvsFromTcGbl :: MonadIO m
175 => HscEnv -> IORef Messages -> TcGblEnv
176 -> m (DsGblEnv, DsLclEnv)
177 mkDsEnvsFromTcGbl hsc_env msg_var tcg_env
178 = do { pm_iter_var <- liftIO $ newIORef 0
179 ; let dflags = hsc_dflags hsc_env
180 this_mod = tcg_mod tcg_env
181 type_env = tcg_type_env tcg_env
182 rdr_env = tcg_rdr_env tcg_env
183 fam_inst_env = tcg_fam_inst_env tcg_env
184 complete_matches = hptCompleteSigs hsc_env
185 ++ tcg_complete_matches tcg_env
186 ; return $ mkDsEnvs dflags this_mod rdr_env type_env fam_inst_env
187 msg_var pm_iter_var complete_matches
188 }
189
190 runDs :: HscEnv -> (DsGblEnv, DsLclEnv) -> DsM a -> IO (Messages, Maybe a)
191 runDs hsc_env (ds_gbl, ds_lcl) thing_inside
192 = do { res <- initTcRnIf 'd' hsc_env ds_gbl ds_lcl
193 (initDPH $ tryM thing_inside)
194 ; msgs <- readIORef (ds_msgs ds_gbl)
195 ; let final_res
196 | errorsFound dflags msgs = Nothing
197 | Right r <- res = Just r
198 | otherwise = panic "initDs"
199 ; return (msgs, final_res)
200 }
201 where dflags = hsc_dflags hsc_env
202
203 -- | Run a 'DsM' action in the context of an existing 'ModGuts'
204 initDsWithModGuts :: HscEnv -> ModGuts -> DsM a -> IO (Messages, Maybe a)
205 initDsWithModGuts hsc_env guts thing_inside
206 = do { pm_iter_var <- newIORef 0
207 ; msg_var <- newIORef emptyMessages
208 ; let dflags = hsc_dflags hsc_env
209 type_env = typeEnvFromEntities ids (mg_tcs guts) (mg_fam_insts guts)
210 rdr_env = mg_rdr_env guts
211 fam_inst_env = mg_fam_inst_env guts
212 this_mod = mg_module guts
213 complete_matches = hptCompleteSigs hsc_env
214 ++ mg_complete_sigs guts
215
216 bindsToIds (NonRec v _) = [v]
217 bindsToIds (Rec binds) = map fst binds
218 ids = concatMap bindsToIds (mg_binds guts)
219
220 envs = mkDsEnvs dflags this_mod rdr_env type_env
221 fam_inst_env msg_var pm_iter_var
222 complete_matches
223 ; runDs hsc_env envs thing_inside
224 }
225
226 initTcDsForSolver :: TcM a -> DsM (Messages, Maybe a)
227 -- Spin up a TcM context so that we can run the constraint solver
228 -- Returns any error messages generated by the constraint solver
229 -- and (Just res) if no error happened; Nothing if an error happened
230 --
231 -- Simon says: I'm not very happy about this. We spin up a complete TcM monad
232 -- only to immediately refine it to a TcS monad.
233 -- Better perhaps to make TcS into its own monad, rather than building on TcS
234 -- But that may in turn interact with plugins
235
236 initTcDsForSolver thing_inside
237 = do { (gbl, lcl) <- getEnvs
238 ; hsc_env <- getTopEnv
239
240 ; let DsGblEnv { ds_mod = mod
241 , ds_fam_inst_env = fam_inst_env } = gbl
242
243 DsLclEnv { dsl_loc = loc } = lcl
244
245 ; liftIO $ initTc hsc_env HsSrcFile False mod loc $
246 updGblEnv (\tc_gbl -> tc_gbl { tcg_fam_inst_env = fam_inst_env }) $
247 thing_inside }
248
249 mkDsEnvs :: DynFlags -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
250 -> IORef Messages -> IORef Int -> [CompleteMatch]
251 -> (DsGblEnv, DsLclEnv)
252 mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var pmvar
253 complete_matches
254 = let if_genv = IfGblEnv { if_doc = text "mkDsEnvs",
255 if_rec_types = Just (mod, return type_env) }
256 if_lenv = mkIfLclEnv mod (text "GHC error in desugarer lookup in" <+> ppr mod)
257 False -- not boot!
258 real_span = realSrcLocSpan (mkRealSrcLoc (moduleNameFS (moduleName mod)) 1 1)
259 completeMatchMap = mkCompleteMatchMap complete_matches
260 gbl_env = DsGblEnv { ds_mod = mod
261 , ds_fam_inst_env = fam_inst_env
262 , ds_if_env = (if_genv, if_lenv)
263 , ds_unqual = mkPrintUnqualified dflags rdr_env
264 , ds_msgs = msg_var
265 , ds_dph_env = emptyGlobalRdrEnv
266 , ds_parr_bi = panic "DsMonad: uninitialised ds_parr_bi"
267 , ds_complete_matches = completeMatchMap
268 }
269 lcl_env = DsLclEnv { dsl_meta = emptyNameEnv
270 , dsl_loc = real_span
271 , dsl_dicts = emptyBag
272 , dsl_tm_cs = emptyBag
273 , dsl_pm_iter = pmvar
274 }
275 in (gbl_env, lcl_env)
276
277
278 {-
279 ************************************************************************
280 * *
281 Operations in the monad
282 * *
283 ************************************************************************
284
285 And all this mysterious stuff is so we can occasionally reach out and
286 grab one or more names. @newLocalDs@ isn't exported---exported
287 functions are defined with it. The difference in name-strings makes
288 it easier to read debugging output.
289
290 Note [Levity polymorphism checking]
291 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
292 According to the "Levity Polymorphism" paper (PLDI '17), levity
293 polymorphism is forbidden in precisely two places: in the type of a bound
294 term-level argument and in the type of an argument to a function. The paper
295 explains it more fully, but briefly: expressions in these contexts need to be
296 stored in registers, and it's hard (read, impossible) to store something
297 that's levity polymorphic.
298
299 We cannot check for bad levity polymorphism conveniently in the type checker,
300 because we can't tell, a priori, which levity metavariables will be solved.
301 At one point, I (Richard) thought we could check in the zonker, but it's hard
302 to know where precisely are the abstracted variables and the arguments. So
303 we check in the desugarer, the only place where we can see the Core code and
304 still report respectable syntax to the user. This covers the vast majority
305 of cases; see calls to DsMonad.dsNoLevPoly and friends.
306
307 Levity polymorphism is also prohibited in the types of binders, and the
308 desugarer checks for this in GHC-generated Ids. (The zonker handles
309 the user-writted ids in zonkIdBndr.) This is done in newSysLocalDsNoLP.
310 The newSysLocalDs variant is used in the vast majority of cases where
311 the binder is obviously not levity polymorphic, omitting the check.
312 It would be nice to ASSERT that there is no levity polymorphism here,
313 but we can't, because of the fixM in DsArrows. It's all OK, though:
314 Core Lint will catch an error here.
315
316 However, the desugarer is the wrong place for certain checks. In particular,
317 the desugarer can't report a sensible error message if an HsWrapper is malformed.
318 After all, GHC itself produced the HsWrapper. So we store some message text
319 in the appropriate HsWrappers (e.g. WpFun) that we can print out in the
320 desugarer.
321
322 There are a few more checks in places where Core is generated outside the
323 desugarer. For example, in datatype and class declarations, where levity
324 polymorphism is checked for during validity checking. It would be nice to
325 have one central place for all this, but that doesn't seem possible while
326 still reporting nice error messages.
327
328 -}
329
330 -- Make a new Id with the same print name, but different type, and new unique
331 newUniqueId :: Id -> Type -> DsM Id
332 newUniqueId id = mk_local (occNameFS (nameOccName (idName id)))
333
334 duplicateLocalDs :: Id -> DsM Id
335 duplicateLocalDs old_local
336 = do { uniq <- newUnique
337 ; return (setIdUnique old_local uniq) }
338
339 newPredVarDs :: PredType -> DsM Var
340 newPredVarDs pred
341 = newSysLocalDs pred
342
343 newSysLocalDsNoLP, newSysLocalDs, newFailLocalDs :: Type -> DsM Id
344 newSysLocalDsNoLP = mk_local (fsLit "ds")
345
346 -- this variant should be used when the caller can be sure that the variable type
347 -- is not levity-polymorphic. It is necessary when the type is knot-tied because
348 -- of the fixM used in DsArrows. See Note [Levity polymorphism checking]
349 newSysLocalDs = mkSysLocalOrCoVarM (fsLit "ds")
350 newFailLocalDs = mkSysLocalOrCoVarM (fsLit "fail")
351 -- the fail variable is used only in a situation where we can tell that
352 -- levity-polymorphism is impossible.
353
354 newSysLocalsDsNoLP, newSysLocalsDs :: [Type] -> DsM [Id]
355 newSysLocalsDsNoLP = mapM newSysLocalDsNoLP
356 newSysLocalsDs = mapM newSysLocalDs
357
358 mk_local :: FastString -> Type -> DsM Id
359 mk_local fs ty = do { dsNoLevPoly ty (text "When trying to create a variable of type:" <+>
360 ppr ty) -- could improve the msg with another
361 -- parameter indicating context
362 ; mkSysLocalOrCoVarM fs ty }
363
364 {-
365 We can also reach out and either set/grab location information from
366 the @SrcSpan@ being carried around.
367 -}
368
369 getGhcModeDs :: DsM GhcMode
370 getGhcModeDs = getDynFlags >>= return . ghcMode
371
372 -- | Get in-scope type constraints (pm check)
373 getDictsDs :: DsM (Bag EvVar)
374 getDictsDs = do { env <- getLclEnv; return (dsl_dicts env) }
375
376 -- | Add in-scope type constraints (pm check)
377 addDictsDs :: Bag EvVar -> DsM a -> DsM a
378 addDictsDs ev_vars
379 = updLclEnv (\env -> env { dsl_dicts = unionBags ev_vars (dsl_dicts env) })
380
381 -- | Get in-scope term constraints (pm check)
382 getTmCsDs :: DsM (Bag SimpleEq)
383 getTmCsDs = do { env <- getLclEnv; return (dsl_tm_cs env) }
384
385 -- | Add in-scope term constraints (pm check)
386 addTmCsDs :: Bag SimpleEq -> DsM a -> DsM a
387 addTmCsDs tm_cs
388 = updLclEnv (\env -> env { dsl_tm_cs = unionBags tm_cs (dsl_tm_cs env) })
389
390 -- | Increase the counter for elapsed pattern match check iterations.
391 -- If the current counter is already over the limit, fail
392 incrCheckPmIterDs :: DsM Int
393 incrCheckPmIterDs = do
394 env <- getLclEnv
395 cnt <- readTcRef (dsl_pm_iter env)
396 max_iters <- maxPmCheckIterations <$> getDynFlags
397 if cnt >= max_iters
398 then failM
399 else updTcRef (dsl_pm_iter env) (+1)
400 return cnt
401
402 -- | Reset the counter for pattern match check iterations to zero
403 resetPmIterDs :: DsM ()
404 resetPmIterDs = do { env <- getLclEnv; writeTcRef (dsl_pm_iter env) 0 }
405
406 getSrcSpanDs :: DsM SrcSpan
407 getSrcSpanDs = do { env <- getLclEnv
408 ; return (RealSrcSpan (dsl_loc env)) }
409
410 putSrcSpanDs :: SrcSpan -> DsM a -> DsM a
411 putSrcSpanDs (UnhelpfulSpan {}) thing_inside
412 = thing_inside
413 putSrcSpanDs (RealSrcSpan real_span) thing_inside
414 = updLclEnv (\ env -> env {dsl_loc = real_span}) thing_inside
415
416 -- | Emit a warning for the current source location
417 -- NB: Warns whether or not -Wxyz is set
418 warnDs :: WarnReason -> SDoc -> DsM ()
419 warnDs reason warn
420 = do { env <- getGblEnv
421 ; loc <- getSrcSpanDs
422 ; dflags <- getDynFlags
423 ; let msg = makeIntoWarning reason $
424 mkWarnMsg dflags loc (ds_unqual env) warn
425 ; updMutVar (ds_msgs env) (\ (w,e) -> (w `snocBag` msg, e)) }
426
427 -- | Emit a warning only if the correct WarnReason is set in the DynFlags
428 warnIfSetDs :: WarningFlag -> SDoc -> DsM ()
429 warnIfSetDs flag warn
430 = whenWOptM flag $
431 warnDs (Reason flag) warn
432
433 errDs :: SDoc -> DsM ()
434 errDs err
435 = do { env <- getGblEnv
436 ; loc <- getSrcSpanDs
437 ; dflags <- getDynFlags
438 ; let msg = mkErrMsg dflags loc (ds_unqual env) err
439 ; updMutVar (ds_msgs env) (\ (w,e) -> (w, e `snocBag` msg)) }
440
441 -- | Issue an error, but return the expression for (), so that we can continue
442 -- reporting errors.
443 errDsCoreExpr :: SDoc -> DsM CoreExpr
444 errDsCoreExpr err
445 = do { errDs err
446 ; return unitExpr }
447
448 failWithDs :: SDoc -> DsM a
449 failWithDs err
450 = do { errDs err
451 ; failM }
452
453 failDs :: DsM a
454 failDs = failM
455
456 -- (askNoErrsDs m) runs m
457 -- If m fails,
458 -- then (askNoErrsDs m) fails
459 -- If m succeeds with result r,
460 -- then (askNoErrsDs m) succeeds with result (r, b),
461 -- where b is True iff m generated no errors
462 -- Regardless of success or failure,
463 -- propagate any errors/warnings generated by m
464 --
465 -- c.f. TcRnMonad.askNoErrs
466 askNoErrsDs :: DsM a -> DsM (a, Bool)
467 askNoErrsDs thing_inside
468 = do { errs_var <- newMutVar emptyMessages
469 ; env <- getGblEnv
470 ; mb_res <- tryM $ -- Be careful to catch exceptions
471 -- so that we propagate errors correctly
472 -- (Trac #13642)
473 setGblEnv (env { ds_msgs = errs_var }) $
474 thing_inside
475
476 -- Propagate errors
477 ; msgs@(warns, errs) <- readMutVar errs_var
478 ; updMutVar (ds_msgs env) (\ (w,e) -> (w `unionBags` warns, e `unionBags` errs))
479
480 -- And return
481 ; case mb_res of
482 Left _ -> failM
483 Right res -> do { dflags <- getDynFlags
484 ; let errs_found = errorsFound dflags msgs
485 ; return (res, not errs_found) } }
486
487 mkPrintUnqualifiedDs :: DsM PrintUnqualified
488 mkPrintUnqualifiedDs = ds_unqual <$> getGblEnv
489
490 instance MonadThings (IOEnv (Env DsGblEnv DsLclEnv)) where
491 lookupThing = dsLookupGlobal
492
493 -- | Attempt to load the given module and return its exported entities if
494 -- successful.
495 dsLoadModule :: SDoc -> Module -> DsM GlobalRdrEnv
496 dsLoadModule doc mod
497 = do { env <- getGblEnv
498 ; setEnvs (ds_if_env env) $ do
499 { iface <- loadInterface doc mod ImportBySystem
500 ; case iface of
501 Failed err -> pprPanic "DsMonad.dsLoadModule: failed to load" (err $$ doc)
502 Succeeded iface -> return $ mkGlobalRdrEnv . gresFromAvails prov . mi_exports $ iface
503 } }
504 where
505 prov = Just (ImpSpec { is_decl = imp_spec, is_item = ImpAll })
506 imp_spec = ImpDeclSpec { is_mod = name, is_qual = True,
507 is_dloc = wiredInSrcSpan, is_as = name }
508 name = moduleName mod
509
510 dsLookupGlobal :: Name -> DsM TyThing
511 -- Very like TcEnv.tcLookupGlobal
512 dsLookupGlobal name
513 = do { env <- getGblEnv
514 ; setEnvs (ds_if_env env)
515 (tcIfaceGlobal name) }
516
517 dsLookupGlobalId :: Name -> DsM Id
518 dsLookupGlobalId name
519 = tyThingId <$> dsLookupGlobal name
520
521 dsLookupTyCon :: Name -> DsM TyCon
522 dsLookupTyCon name
523 = tyThingTyCon <$> dsLookupGlobal name
524
525 dsLookupDataCon :: Name -> DsM DataCon
526 dsLookupDataCon name
527 = tyThingDataCon <$> dsLookupGlobal name
528
529 dsLookupConLike :: Name -> DsM ConLike
530 dsLookupConLike name
531 = tyThingConLike <$> dsLookupGlobal name
532
533
534 dsGetFamInstEnvs :: DsM FamInstEnvs
535 -- Gets both the external-package inst-env
536 -- and the home-pkg inst env (includes module being compiled)
537 dsGetFamInstEnvs
538 = do { eps <- getEps; env <- getGblEnv
539 ; return (eps_fam_inst_env eps, ds_fam_inst_env env) }
540
541 dsGetMetaEnv :: DsM (NameEnv DsMetaVal)
542 dsGetMetaEnv = do { env <- getLclEnv; return (dsl_meta env) }
543
544 -- | The @COMPLETE@ pragams provided by the user for a given `TyCon`.
545 dsGetCompleteMatches :: TyCon -> DsM [CompleteMatch]
546 dsGetCompleteMatches tc = do
547 eps <- getEps
548 env <- getGblEnv
549 let lookup_completes ufm = lookupWithDefaultUFM ufm [] tc
550 eps_matches_list = lookup_completes $ eps_complete_matches eps
551 env_matches_list = lookup_completes $ ds_complete_matches env
552 return $ eps_matches_list ++ env_matches_list
553
554 dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal)
555 dsLookupMetaEnv name = do { env <- getLclEnv; return (lookupNameEnv (dsl_meta env) name) }
556
557 dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a
558 dsExtendMetaEnv menv thing_inside
559 = updLclEnv (\env -> env { dsl_meta = dsl_meta env `plusNameEnv` menv }) thing_inside
560
561 discardWarningsDs :: DsM a -> DsM a
562 -- Ignore warnings inside the thing inside;
563 -- used to ignore inaccessable cases etc. inside generated code
564 discardWarningsDs thing_inside
565 = do { env <- getGblEnv
566 ; old_msgs <- readTcRef (ds_msgs env)
567
568 ; result <- thing_inside
569
570 -- Revert messages to old_msgs
571 ; writeTcRef (ds_msgs env) old_msgs
572
573 ; return result }
574
575 -- | Fail with an error message if the type is levity polymorphic.
576 dsNoLevPoly :: Type -> SDoc -> DsM ()
577 -- See Note [Levity polymorphism checking]
578 dsNoLevPoly ty doc = checkForLevPolyX errDs doc ty
579
580 -- | Check an expression for levity polymorphism, failing if it is
581 -- levity polymorphic.
582 dsNoLevPolyExpr :: CoreExpr -> SDoc -> DsM ()
583 -- See Note [Levity polymorphism checking]
584 dsNoLevPolyExpr e doc
585 | isExprLevPoly e = errDs (formatLevPolyErr (exprType e) $$ doc)
586 | otherwise = return ()
587
588 -- | Runs the thing_inside. If there are no errors, then returns the expr
589 -- given. Otherwise, returns unitExpr. This is useful for doing a bunch
590 -- of levity polymorphism checks and then avoiding making a core App.
591 -- (If we make a core App on a levity polymorphic argument, detecting how
592 -- to handle the let/app invariant might call isUnliftedType, which panics
593 -- on a levity polymorphic type.)
594 -- See #12709 for an example of why this machinery is necessary.
595 dsWhenNoErrs :: DsM a -> (a -> CoreExpr) -> DsM CoreExpr
596 dsWhenNoErrs thing_inside mk_expr
597 = do { (result, no_errs) <- askNoErrsDs thing_inside
598 ; return $ if no_errs
599 then mk_expr result
600 else unitExpr }
601
602 --------------------------------------------------------------------------
603 -- Data Parallel Haskell
604 --------------------------------------------------------------------------
605
606 -- | Run a 'DsM' with DPH things in scope if necessary.
607 initDPH :: DsM a -> DsM a
608 initDPH = loadDAP . initDPHBuiltins
609
610 -- | Extend the global environment with a 'GlobalRdrEnv' containing the exported
611 -- entities of,
612 --
613 -- * 'Data.Array.Parallel' iff '-XParallelArrays' specified (see also 'checkLoadDAP').
614 -- * 'Data.Array.Parallel.Prim' iff '-fvectorise' specified.
615 loadDAP :: DsM a -> DsM a
616 loadDAP thing_inside
617 = do { dapEnv <- loadOneModule dATA_ARRAY_PARALLEL_NAME checkLoadDAP paErr
618 ; dappEnv <- loadOneModule dATA_ARRAY_PARALLEL_PRIM_NAME (goptM Opt_Vectorise) veErr
619 ; updGblEnv (\env -> env {ds_dph_env = dapEnv `plusOccEnv` dappEnv }) thing_inside
620 }
621 where
622 loadOneModule :: ModuleName -- the module to load
623 -> DsM Bool -- under which condition
624 -> MsgDoc -- error message if module not found
625 -> DsM GlobalRdrEnv -- empty if condition 'False'
626 loadOneModule modname check err
627 = do { doLoad <- check
628 ; if not doLoad
629 then return emptyGlobalRdrEnv
630 else do {
631 ; hsc_env <- getTopEnv
632 ; result <- liftIO $ findImportedModule hsc_env modname Nothing
633 ; case result of
634 Found _ mod -> dsLoadModule err mod
635 _ -> pprPgmError "Unable to use Data Parallel Haskell (DPH):" err
636 } }
637
638 paErr = text "To use ParallelArrays," <+> specBackend $$ hint1 $$ hint2
639 veErr = text "To use -fvectorise," <+> specBackend $$ hint1 $$ hint2
640 specBackend = text "you must specify a DPH backend package"
641 hint1 = text "Look for packages named 'dph-lifted-*' with 'ghc-pkg'"
642 hint2 = text "You may need to install them with 'cabal install dph-examples'"
643
644 -- | If '-XParallelArrays' given, we populate the builtin table for desugaring
645 -- those.
646 initDPHBuiltins :: DsM a -> DsM a
647 initDPHBuiltins thing_inside
648 = do { doInitBuiltins <- checkLoadDAP
649 ; if doInitBuiltins
650 then dsInitPArrBuiltin thing_inside
651 else thing_inside
652 }
653
654 checkLoadDAP :: DsM Bool
655 checkLoadDAP
656 = do { paEnabled <- xoptM LangExt.ParallelArrays
657 ; mod <- getModule
658 -- do not load 'Data.Array.Parallel' iff compiling 'base:GHC.PArr' or a
659 -- module called 'dATA_ARRAY_PARALLEL_NAME'; see also the comments at the top
660 -- of 'base:GHC.PArr' and 'Data.Array.Parallel' in the DPH libraries
661 ; return $ paEnabled &&
662 mod /= gHC_PARR' &&
663 moduleName mod /= dATA_ARRAY_PARALLEL_NAME
664 }
665
666 -- | Populate 'ds_parr_bi' from 'ds_dph_env'.
667 --
668 dsInitPArrBuiltin :: DsM a -> DsM a
669 dsInitPArrBuiltin thing_inside
670 = do { lengthPVar <- externalVar (fsLit "lengthP")
671 ; replicatePVar <- externalVar (fsLit "replicateP")
672 ; singletonPVar <- externalVar (fsLit "singletonP")
673 ; mapPVar <- externalVar (fsLit "mapP")
674 ; filterPVar <- externalVar (fsLit "filterP")
675 ; zipPVar <- externalVar (fsLit "zipP")
676 ; crossMapPVar <- externalVar (fsLit "crossMapP")
677 ; indexPVar <- externalVar (fsLit "!:")
678 ; emptyPVar <- externalVar (fsLit "emptyP")
679 ; appPVar <- externalVar (fsLit "+:+")
680 -- ; enumFromToPVar <- externalVar (fsLit "enumFromToP")
681 -- ; enumFromThenToPVar <- externalVar (fsLit "enumFromThenToP")
682 ; enumFromToPVar <- return arithErr
683 ; enumFromThenToPVar <- return arithErr
684
685 ; updGblEnv (\env -> env {ds_parr_bi = PArrBuiltin
686 { lengthPVar = lengthPVar
687 , replicatePVar = replicatePVar
688 , singletonPVar = singletonPVar
689 , mapPVar = mapPVar
690 , filterPVar = filterPVar
691 , zipPVar = zipPVar
692 , crossMapPVar = crossMapPVar
693 , indexPVar = indexPVar
694 , emptyPVar = emptyPVar
695 , appPVar = appPVar
696 , enumFromToPVar = enumFromToPVar
697 , enumFromThenToPVar = enumFromThenToPVar
698 } })
699 thing_inside
700 }
701 where
702 externalVar :: FastString -> DsM Var
703 externalVar fs = dsLookupDPHRdrEnv (mkVarOccFS fs) >>= dsLookupGlobalId
704
705 arithErr = panic "Arithmetic sequences have to wait until we support type classes"
706
707 -- |Get a name from "Data.Array.Parallel" for the desugarer, from the
708 -- 'ds_parr_bi' component of the global desugerar environment.
709 --
710 dsDPHBuiltin :: (PArrBuiltin -> a) -> DsM a
711 dsDPHBuiltin sel = (sel . ds_parr_bi) <$> getGblEnv
712
713 -- |Lookup a name exported by 'Data.Array.Parallel.Prim' or 'Data.Array.Parallel.Prim'.
714 -- Panic if there isn't one, or if it is defined multiple times.
715 dsLookupDPHRdrEnv :: OccName -> DsM Name
716 dsLookupDPHRdrEnv occ
717 = liftM (fromMaybe (pprPanic nameNotFound (ppr occ)))
718 $ dsLookupDPHRdrEnv_maybe occ
719 where nameNotFound = "Name not found in 'Data.Array.Parallel' or 'Data.Array.Parallel.Prim':"
720
721 -- |Lookup a name exported by 'Data.Array.Parallel.Prim' or 'Data.Array.Parallel.Prim',
722 -- returning `Nothing` if it's not defined. Panic if it's defined multiple times.
723 dsLookupDPHRdrEnv_maybe :: OccName -> DsM (Maybe Name)
724 dsLookupDPHRdrEnv_maybe occ
725 = do { env <- ds_dph_env <$> getGblEnv
726 ; let gres = lookupGlobalRdrEnv env occ
727 ; case gres of
728 [] -> return $ Nothing
729 [gre] -> return $ Just $ gre_name gre
730 _ -> pprPanic multipleNames (ppr occ)
731 }
732 where multipleNames = "Multiple definitions in 'Data.Array.Parallel' and 'Data.Array.Parallel.Prim':"