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