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