DsMonad.hs 20 KB
Newer Older
Austin Seipp's avatar
Austin Seipp committed
1
2
3
4
{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998

Simon Marlow's avatar
Simon Marlow committed
5
6

@DsMonad@: monadery used in desugaring
Austin Seipp's avatar
Austin Seipp committed
7
-}
8

9
{-# LANGUAGE FlexibleInstances #-}
10
{-# OPTIONS_GHC -fno-warn-orphans #-}  -- instance MonadThings is necessarily an orphan
11

12
module DsMonad (
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
13
        DsM, mapM, mapAndUnzipM,
14
        initDs, initDsTc, initTcDsForSolver, fixDs,
ian@well-typed.com's avatar
ian@well-typed.com committed
15
        foldlM, foldrM, whenGOptM, unsetGOptM, unsetWOptM,
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
16
        Applicative(..),(<$>),
17

18
19
20
21
22
        newLocalName,
        duplicateLocalDs, newSysLocalDs, newSysLocalsDs, newUniqueId,
        newFailLocalDs, newPredVarDs,
        getSrcSpanDs, putSrcSpanDs,
        mkPrintUnqualifiedDs,
Austin Seipp's avatar
Austin Seipp committed
23
        newUnique,
24
        UniqSupply, newUniqueSupply,
25
        getGhcModeDs, dsGetFamInstEnvs,
26
        dsLookupGlobal, dsLookupGlobalId, dsDPHBuiltin, dsLookupTyCon, dsLookupDataCon,
Austin Seipp's avatar
Austin Seipp committed
27
28

        PArrBuiltin(..),
29
30
        dsLookupDPHRdrEnv, dsLookupDPHRdrEnv_maybe,
        dsInitPArrBuiltin,
31

32
        DsMetaEnv, DsMetaVal(..), dsGetMetaEnv, dsLookupMetaEnv, dsExtendMetaEnv,
33

34
35
36
        -- Getting and setting EvVars and term constraints in local environment
        getDictsDs, addDictsDs, getTmCsDs, addTmCsDs,

37
38
39
        -- Iterations for pm checking
        incrCheckPmIterDs, resetPmIterDs,

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
40
        -- Warnings
Gergő Érdi's avatar
Gergő Érdi committed
41
        DsWarning, warnDs, failWithDs, discardWarningsDs,
42

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
43
44
45
46
        -- Data types
        DsMatchContext(..),
        EquationInfo(..), MatchResult(..), DsWrapper, idDsWrapper,
        CanItFail(..), orFail
47
48
    ) where

49
import TcRnMonad
50
import FamInstEnv
Simon Marlow's avatar
Simon Marlow committed
51
52
53
import CoreSyn
import HsSyn
import TcIface
54
import LoadIface
55
import Finder
56
import PrelNames
Adam Gundry's avatar
Adam Gundry committed
57
import RnNames
Simon Marlow's avatar
Simon Marlow committed
58
59
60
61
62
import RdrName
import HscTypes
import Bag
import DataCon
import TyCon
63
import PmExpr
Simon Marlow's avatar
Simon Marlow committed
64
65
import Id
import Module
66
import Outputable
Simon Marlow's avatar
Simon Marlow committed
67
68
69
70
import SrcLoc
import Type
import UniqSupply
import Name
71
import NameEnv
Simon Marlow's avatar
Simon Marlow committed
72
73
import DynFlags
import ErrUtils
74
import FastString
75
import Maybes
76
import Var (EvVar)
77
import qualified GHC.LanguageExtensions as LangExt
Simon Marlow's avatar
Simon Marlow committed
78
79

import Data.IORef
80
import Control.Monad
81

Austin Seipp's avatar
Austin Seipp committed
82
83
84
{-
************************************************************************
*                                                                      *
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
85
                Data types for the desugarer
Austin Seipp's avatar
Austin Seipp committed
86
87
88
*                                                                      *
************************************************************************
-}
89
90

data DsMatchContext
91
  = DsMatchContext (HsMatchContext Name) SrcSpan
92
93
94
  deriving ()

data EquationInfo
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
95
96
  = EqnInfo { eqn_pats :: [Pat Id],     -- The patterns for an eqn
              eqn_rhs  :: MatchResult } -- What to do after match
97

98
99
100
instance Outputable EquationInfo where
    ppr (EqnInfo pats _) = ppr pats

101
type DsWrapper = CoreExpr -> CoreExpr
twanvl's avatar
twanvl committed
102
idDsWrapper :: DsWrapper
103
idDsWrapper e = e
104

105
-- The semantics of (match vs (EqnInfo wrap pats rhs)) is the MatchResult
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
106
--      \fail. wrap (case vs of { pats -> rhs fail })
simonpj@microsoft.com's avatar
simonpj@microsoft.com committed
107
-- where vs are not bound by wrap
108
109
110
111
112


-- A MatchResult is an expression with a hole in it
data MatchResult
  = MatchResult
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
113
114
115
116
117
        CanItFail       -- Tells whether the failure expression is used
        (CoreExpr -> DsM CoreExpr)
                        -- Takes a expression to plug in at the
                        -- failure point(s). The expression should
                        -- be duplicatable!
118
119
120

data CanItFail = CanFail | CantFail

twanvl's avatar
twanvl committed
121
orFail :: CanItFail -> CanItFail -> CanItFail
122
orFail CantFail CantFail = CantFail
twanvl's avatar
twanvl committed
123
orFail _        _        = CanFail
124

Austin Seipp's avatar
Austin Seipp committed
125
126
127
{-
************************************************************************
*                                                                      *
128
                Monad functions
Austin Seipp's avatar
Austin Seipp committed
129
130
131
*                                                                      *
************************************************************************
-}
132

133
-- Compatibility functions
twanvl's avatar
twanvl committed
134
fixDs :: (a -> DsM a) -> DsM a
135
136
fixDs    = fixM

137
type DsWarning = (SrcSpan, SDoc)
Austin Seipp's avatar
Austin Seipp committed
138
        -- Not quite the same as a WarnMsg, we have an SDoc here
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
139
140
        -- and we'll do the print_unqual stuff later on to turn it
        -- into a Doc.
141

142
initDs :: HscEnv
143
       -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
144
145
       -> DsM a
       -> IO (Messages, Maybe a)
146
-- Print errors and warnings, if any arise
147

148
initDs hsc_env mod rdr_env type_env fam_inst_env thing_inside
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
149
  = do  { msg_var <- newIORef (emptyBag, emptyBag)
150
        ; pm_iter_var      <- newIORef 0
151
        ; let dflags                   = hsc_dflags hsc_env
Facundo Domínguez's avatar
Facundo Domínguez committed
152
153
              (ds_gbl_env, ds_lcl_env) = mkDsEnvs dflags mod rdr_env type_env
                                                  fam_inst_env msg_var
154
                                                  pm_iter_var
155

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
156
        ; either_res <- initTcRnIf 'd' hsc_env ds_gbl_env ds_lcl_env $
157
                          loadDAP $
158
159
                            initDPHBuiltins $
                              tryM thing_inside     -- Catch exceptions (= errors during desugaring)
160

Austin Seipp's avatar
Austin Seipp committed
161
        -- Display any errors and warnings
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
162
163
        -- Note: if -Werror is used, we don't signal an error here.
        ; msgs <- readIORef msg_var
164

chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
165
166
167
        ; let final_res | errorsFound dflags msgs = Nothing
                        | otherwise = case either_res of
                                        Right res -> Just res
168
                                        Left exn  -> pprPanic "initDs" (text (show exn))
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
169
170
171
                -- The (Left exn) case happens when the thing_inside throws
                -- a UserError exception.  Then it should have put an error
                -- message in msg_var, so we just discard the exception
172

Austin Seipp's avatar
Austin Seipp committed
173
        ; return (msgs, final_res)
174
175
176
        }
  where
    -- Extend the global environment with a 'GlobalRdrEnv' containing the exported entities of
Edward Z. Yang's avatar
Edward Z. Yang committed
177
    --   * 'Data.Array.Parallel'      iff '-XParallelArrays' specified (see also 'checkLoadDAP').
178
    --   * 'Data.Array.Parallel.Prim' iff '-fvectorise' specified.
179
    loadDAP thing_inside
180
      = do { dapEnv  <- loadOneModule dATA_ARRAY_PARALLEL_NAME      checkLoadDAP          paErr
ian@well-typed.com's avatar
ian@well-typed.com committed
181
           ; dappEnv <- loadOneModule dATA_ARRAY_PARALLEL_PRIM_NAME (goptM Opt_Vectorise) veErr
182
           ; updGblEnv (\env -> env {ds_dph_env = dapEnv `plusOccEnv` dappEnv }) thing_inside
183
           }
184
185
186
      where
        loadOneModule :: ModuleName           -- the module to load
                      -> DsM Bool             -- under which condition
187
                      -> MsgDoc              -- error message if module not found
188
189
190
                      -> DsM GlobalRdrEnv     -- empty if condition 'False'
        loadOneModule modname check err
          = do { doLoad <- check
Austin Seipp's avatar
Austin Seipp committed
191
               ; if not doLoad
192
193
194
195
                 then return emptyGlobalRdrEnv
                 else do {
               ; result <- liftIO $ findImportedModule hsc_env modname Nothing
               ; case result of
196
                   Found _ mod -> loadModule err mod
197
                   _           -> pprPgmError "Unable to use Data Parallel Haskell (DPH):" err
198
199
               } }

200
201
202
203
204
        paErr       = text "To use ParallelArrays," <+> specBackend $$ hint1 $$ hint2
        veErr       = text "To use -fvectorise," <+> specBackend $$ hint1 $$ hint2
        specBackend = text "you must specify a DPH backend package"
        hint1       = text "Look for packages named 'dph-lifted-*' with 'ghc-pkg'"
        hint2       = text "You may need to install them with 'cabal install dph-examples'"
205
206
207
208
209
210
211

    initDPHBuiltins thing_inside
      = do {   -- If '-XParallelArrays' given, we populate the builtin table for desugaring those
           ; doInitBuiltins <- checkLoadDAP
           ; if doInitBuiltins
             then dsInitPArrBuiltin thing_inside
             else thing_inside
212
213
           }

214
    checkLoadDAP = do { paEnabled <- xoptM LangExt.ParallelArrays
215
                      ; return $ paEnabled &&
Austin Seipp's avatar
Austin Seipp committed
216
                                 mod /= gHC_PARR' &&
217
218
219
220
221
                                 moduleName mod /= dATA_ARRAY_PARALLEL_NAME
                      }
                      -- do not load 'Data.Array.Parallel' iff compiling 'base:GHC.PArr' or a
                      -- module called 'dATA_ARRAY_PARALLEL_NAME'; see also the comments at the top
                      -- of 'base:GHC.PArr' and 'Data.Array.Parallel' in the DPH libraries
222
223
224

initDsTc :: DsM a -> TcM a
initDsTc thing_inside
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
225
226
227
  = do  { this_mod <- getModule
        ; tcg_env  <- getGblEnv
        ; msg_var  <- getErrsVar
228
        ; dflags   <- getDynFlags
229
        ; pm_iter_var      <- liftIO $ newIORef 0
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
230
231
        ; let type_env = tcg_type_env tcg_env
              rdr_env  = tcg_rdr_env tcg_env
232
              fam_inst_env = tcg_fam_inst_env tcg_env
Facundo Domínguez's avatar
Facundo Domínguez committed
233
              ds_envs  = mkDsEnvs dflags this_mod rdr_env type_env fam_inst_env
234
                                  msg_var pm_iter_var
235
236
        ; setEnvs ds_envs thing_inside
        }
237

238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
initTcDsForSolver :: TcM a -> DsM (Messages, Maybe a)
-- Spin up a TcM context so that we can run the constraint solver
-- Returns any error messages generated by the constraint solver
-- and (Just res) if no error happened; Nothing if an errror happened
--
-- Simon says: I'm not very happy about this.  We spin up a complete TcM monad
--             only to immediately refine it to a TcS monad.
-- Better perhaps to make TcS into its own monad, rather than building on TcS
-- But that may in turn interact with plugins

initTcDsForSolver thing_inside
  = do { (gbl, lcl) <- getEnvs
       ; hsc_env    <- getTopEnv

       ; let DsGblEnv { ds_mod = mod
                      , ds_fam_inst_env = fam_inst_env } = gbl

             DsLclEnv { dsl_loc = loc }                  = lcl

       ; liftIO $ initTc hsc_env HsSrcFile False mod loc $
         updGblEnv (\tc_gbl -> tc_gbl { tcg_fam_inst_env = fam_inst_env }) $
         thing_inside }

Facundo Domínguez's avatar
Facundo Domínguez committed
261
mkDsEnvs :: DynFlags -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
262
263
         -> IORef Messages -> IORef Int -> (DsGblEnv, DsLclEnv)
mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var pmvar
264
  = let if_genv = IfGblEnv { if_rec_types = Just (mod, return type_env) }
265
        if_lenv = mkIfLclEnv mod (text "GHC error in desugarer lookup in" <+> ppr mod)
266
        real_span = realSrcLocSpan (mkRealSrcLoc (moduleNameFS (moduleName mod)) 1 1)
267
        gbl_env = DsGblEnv { ds_mod     = mod
268
                           , ds_fam_inst_env = fam_inst_env
269
270
271
272
                           , ds_if_env  = (if_genv, if_lenv)
                           , ds_unqual  = mkPrintUnqualified dflags rdr_env
                           , ds_msgs    = msg_var
                           , ds_dph_env = emptyGlobalRdrEnv
273
                           , ds_parr_bi = panic "DsMonad: uninitialised ds_parr_bi"
274
                           }
275
276
277
278
279
        lcl_env = DsLclEnv { dsl_meta    = emptyNameEnv
                           , dsl_loc     = real_span
                           , dsl_dicts   = emptyBag
                           , dsl_tm_cs   = emptyBag
                           , dsl_pm_iter = pmvar
280
281
282
                           }
    in (gbl_env, lcl_env)

283
-- Attempt to load the given module and return its exported entities if successful.
284
285
286
--
loadModule :: SDoc -> Module -> DsM GlobalRdrEnv
loadModule doc mod
287
  = do { env    <- getGblEnv
288
289
       ; setEnvs (ds_if_env env) $ do
       { iface <- loadInterface doc mod ImportBySystem
290
       ; case iface of
291
           Failed err      -> pprPanic "DsMonad.loadModule: failed to load" (err $$ doc)
292
           Succeeded iface -> return $ mkGlobalRdrEnv . gresFromAvails prov . mi_exports $ iface
293
294
       } }
  where
295
    prov     = Just (ImpSpec { is_decl = imp_spec, is_item = ImpAll })
296
297
298
299
    imp_spec = ImpDeclSpec { is_mod = name, is_qual = True,
                             is_dloc = wiredInSrcSpan, is_as = name }
    name = moduleName mod

Austin Seipp's avatar
Austin Seipp committed
300
301
302
{-
************************************************************************
*                                                                      *
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
303
                Operations in the monad
Austin Seipp's avatar
Austin Seipp committed
304
305
*                                                                      *
************************************************************************
306

307
308
309
310
And all this mysterious stuff is so we can occasionally reach out and
grab one or more names.  @newLocalDs@ isn't exported---exported
functions are defined with it.  The difference in name-strings makes
it easier to read debugging output.
Austin Seipp's avatar
Austin Seipp committed
311
-}
sof's avatar
sof committed
312

313
-- Make a new Id with the same print name, but different type, and new unique
314
newUniqueId :: Id -> Type -> DsM Id
315
newUniqueId id = mkSysLocalOrCoVarM (occNameFS (nameOccName (idName id)))
316

317
duplicateLocalDs :: Id -> DsM Id
Austin Seipp's avatar
Austin Seipp committed
318
duplicateLocalDs old_local
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
319
320
  = do  { uniq <- newUnique
        ; return (setIdUnique old_local uniq) }
321
322
323

newPredVarDs :: PredType -> DsM Var
newPredVarDs pred
batterseapower's avatar
batterseapower committed
324
 = newSysLocalDs pred
Austin Seipp's avatar
Austin Seipp committed
325

326
newSysLocalDs, newFailLocalDs :: Type -> DsM Id
327
328
newSysLocalDs  = mkSysLocalOrCoVarM (fsLit "ds")
newFailLocalDs = mkSysLocalOrCoVarM (fsLit "fail")
329

twanvl's avatar
twanvl committed
330
newSysLocalsDs :: [Type] -> DsM [Id]
331
newSysLocalsDs tys = mapM newSysLocalDs tys
332

Austin Seipp's avatar
Austin Seipp committed
333
{-
334
We can also reach out and either set/grab location information from
335
the @SrcSpan@ being carried around.
Austin Seipp's avatar
Austin Seipp committed
336
-}
337

mnislaih's avatar
mnislaih committed
338
getGhcModeDs :: DsM GhcMode
339
getGhcModeDs =  getDynFlags >>= return . ghcMode
mnislaih's avatar
mnislaih committed
340

341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
-- | Get in-scope type constraints (pm check)
getDictsDs :: DsM (Bag EvVar)
getDictsDs = do { env <- getLclEnv; return (dsl_dicts env) }

-- | Add in-scope type constraints (pm check)
addDictsDs :: Bag EvVar -> DsM a -> DsM a
addDictsDs ev_vars
  = updLclEnv (\env -> env { dsl_dicts = unionBags ev_vars (dsl_dicts env) })

-- | Get in-scope term constraints (pm check)
getTmCsDs :: DsM (Bag SimpleEq)
getTmCsDs = do { env <- getLclEnv; return (dsl_tm_cs env) }

-- | Add in-scope term constraints (pm check)
addTmCsDs :: Bag SimpleEq -> DsM a -> DsM a
addTmCsDs tm_cs
  = updLclEnv (\env -> env { dsl_tm_cs = unionBags tm_cs (dsl_tm_cs env) })

359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
-- | Increase the counter for elapsed pattern match check iterations.
-- If the current counter is already over the limit, fail
incrCheckPmIterDs :: DsM ()
incrCheckPmIterDs = do
  env <- getLclEnv
  cnt <- readTcRef (dsl_pm_iter env)
  max_iters <- maxPmCheckIterations <$> getDynFlags
  if cnt >= max_iters
    then failM
    else updTcRef (dsl_pm_iter env) (+1)

-- | Reset the counter for pattern match check iterations to zero
resetPmIterDs :: DsM ()
resetPmIterDs = do { env <- getLclEnv; writeTcRef (dsl_pm_iter env) 0 }

374
getSrcSpanDs :: DsM SrcSpan
375
376
getSrcSpanDs = do { env <- getLclEnv
                  ; return (RealSrcSpan (dsl_loc env)) }
377

378
putSrcSpanDs :: SrcSpan -> DsM a -> DsM a
379
380
381
382
383
putSrcSpanDs (UnhelpfulSpan {}) thing_inside
  = thing_inside
putSrcSpanDs (RealSrcSpan real_span) thing_inside
  = updLclEnv (\ env -> env {dsl_loc = real_span}) thing_inside

384
385
386
387
388
389
390
391
392
-- | Emit a warning for the current source location
warnDs :: WarnReason -> SDoc -> DsM ()
warnDs reason warn
  = do { env <- getGblEnv
       ; loc <- getSrcSpanDs
       ; dflags <- getDynFlags
       ; let msg = makeIntoWarning reason $
                   mkWarnMsg dflags loc (ds_unqual env) warn
       ; updMutVar (ds_msgs env) (\ (w,e) -> (w `snocBag` msg, e)) }
393
394

failWithDs :: SDoc -> DsM a
Austin Seipp's avatar
Austin Seipp committed
395
396
failWithDs err
  = do  { env <- getGblEnv
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
397
        ; loc <- getSrcSpanDs
Ian Lynagh's avatar
Ian Lynagh committed
398
399
        ; dflags <- getDynFlags
        ; let msg = mkErrMsg dflags loc (ds_unqual env) err
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
400
401
        ; updMutVar (ds_msgs env) (\ (w,e) -> (w, e `snocBag` msg))
        ; failM }
402
403
404

mkPrintUnqualifiedDs :: DsM PrintUnqualified
mkPrintUnqualifiedDs = ds_unqual <$> getGblEnv
405

406
407
408
instance MonadThings (IOEnv (Env DsGblEnv DsLclEnv)) where
    lookupThing = dsLookupGlobal

409
dsLookupGlobal :: Name -> DsM TyThing
410
-- Very like TcEnv.tcLookupGlobal
Austin Seipp's avatar
Austin Seipp committed
411
dsLookupGlobal name
chak@cse.unsw.edu.au.'s avatar
chak@cse.unsw.edu.au. committed
412
413
414
  = do  { env <- getGblEnv
        ; setEnvs (ds_if_env env)
                  (tcIfaceGlobal name) }
415

416
dsLookupGlobalId :: Name -> DsM Id
Austin Seipp's avatar
Austin Seipp committed
417
dsLookupGlobalId name
418
  = tyThingId <$> dsLookupGlobal name
419

420
421
-- |Get a name from "Data.Array.Parallel" for the desugarer, from the 'ds_parr_bi' component of the
-- global desugerar environment.
422
--
423
424
dsDPHBuiltin :: (PArrBuiltin -> a) -> DsM a
dsDPHBuiltin sel = (sel . ds_parr_bi) <$> getGblEnv
425

426
dsLookupTyCon :: Name -> DsM TyCon
427
dsLookupTyCon name
428
  = tyThingTyCon <$> dsLookupGlobal name
429

430
431
dsLookupDataCon :: Name -> DsM DataCon
dsLookupDataCon name
432
  = tyThingDataCon <$> dsLookupGlobal name
433
434
435

-- |Lookup a name exported by 'Data.Array.Parallel.Prim' or 'Data.Array.Parallel.Prim'.
--  Panic if there isn't one, or if it is defined multiple times.
436
437
dsLookupDPHRdrEnv :: OccName -> DsM Name
dsLookupDPHRdrEnv occ
438
439
440
441
442
443
444
445
  = liftM (fromMaybe (pprPanic nameNotFound (ppr occ)))
  $ dsLookupDPHRdrEnv_maybe occ
  where nameNotFound  = "Name not found in 'Data.Array.Parallel' or 'Data.Array.Parallel.Prim':"

-- |Lookup a name exported by 'Data.Array.Parallel.Prim' or 'Data.Array.Parallel.Prim',
--  returning `Nothing` if it's not defined. Panic if it's defined multiple times.
dsLookupDPHRdrEnv_maybe :: OccName -> DsM (Maybe Name)
dsLookupDPHRdrEnv_maybe occ
446
447
448
  = do { env <- ds_dph_env <$> getGblEnv
       ; let gres = lookupGlobalRdrEnv env occ
       ; case gres of
449
450
           []    -> return $ Nothing
           [gre] -> return $ Just $ gre_name gre
451
           _     -> pprPanic multipleNames (ppr occ)
452
       }
453
454
  where multipleNames = "Multiple definitions in 'Data.Array.Parallel' and 'Data.Array.Parallel.Prim':"

455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493

-- Populate 'ds_parr_bi' from 'ds_dph_env'.
--
dsInitPArrBuiltin :: DsM a -> DsM a
dsInitPArrBuiltin thing_inside
  = do { lengthPVar         <- externalVar (fsLit "lengthP")
       ; replicatePVar      <- externalVar (fsLit "replicateP")
       ; singletonPVar      <- externalVar (fsLit "singletonP")
       ; mapPVar            <- externalVar (fsLit "mapP")
       ; filterPVar         <- externalVar (fsLit "filterP")
       ; zipPVar            <- externalVar (fsLit "zipP")
       ; crossMapPVar       <- externalVar (fsLit "crossMapP")
       ; indexPVar          <- externalVar (fsLit "!:")
       ; emptyPVar          <- externalVar (fsLit "emptyP")
       ; appPVar            <- externalVar (fsLit "+:+")
       -- ; enumFromToPVar     <- externalVar (fsLit "enumFromToP")
       -- ; enumFromThenToPVar <- externalVar (fsLit "enumFromThenToP")
       ; enumFromToPVar     <- return arithErr
       ; enumFromThenToPVar <- return arithErr

       ; updGblEnv (\env -> env {ds_parr_bi = PArrBuiltin
                                              { lengthPVar         = lengthPVar
                                              , replicatePVar      = replicatePVar
                                              , singletonPVar      = singletonPVar
                                              , mapPVar            = mapPVar
                                              , filterPVar         = filterPVar
                                              , zipPVar            = zipPVar
                                              , crossMapPVar       = crossMapPVar
                                              , indexPVar          = indexPVar
                                              , emptyPVar          = emptyPVar
                                              , appPVar            = appPVar
                                              , enumFromToPVar     = enumFromToPVar
                                              , enumFromThenToPVar = enumFromThenToPVar
                                              } })
                   thing_inside
       }
  where
    externalVar :: FastString -> DsM Var
    externalVar fs = dsLookupDPHRdrEnv (mkVarOccFS fs) >>= dsLookupGlobalId
494

495
    arithErr = panic "Arithmetic sequences have to wait until we support type classes"
496

497
498
499
500
501
502
503
dsGetFamInstEnvs :: DsM FamInstEnvs
-- Gets both the external-package inst-env
-- and the home-pkg inst env (includes module being compiled)
dsGetFamInstEnvs
  = do { eps <- getEps; env <- getGblEnv
       ; return (eps_fam_inst_env eps, ds_fam_inst_env env) }

504
dsGetMetaEnv :: DsM (NameEnv DsMetaVal)
505
dsGetMetaEnv = do { env <- getLclEnv; return (dsl_meta env) }
506

507
dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal)
508
dsLookupMetaEnv name = do { env <- getLclEnv; return (lookupNameEnv (dsl_meta env) name) }
509
510

dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a
511
dsExtendMetaEnv menv thing_inside
512
  = updLclEnv (\env -> env { dsl_meta = dsl_meta env `plusNameEnv` menv }) thing_inside
Gergő Érdi's avatar
Gergő Érdi committed
513
514
515
516
517
518
519
520
521
522
523
524
525
526

discardWarningsDs :: DsM a -> DsM a
-- Ignore warnings inside the thing inside;
-- used to ignore inaccessable cases etc. inside generated code
discardWarningsDs thing_inside
  = do  { env <- getGblEnv
        ; old_msgs <- readTcRef (ds_msgs env)

        ; result <- thing_inside

        -- Revert messages to old_msgs
        ; writeTcRef (ds_msgs env) old_msgs

        ; return result }