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