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