Refactor RdrName.Provenance, to fix #7672
[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, fixDs,
15 foldlM, foldrM, whenGOptM, unsetGOptM, unsetWOptM,
16 Applicative(..),(<$>),
17
18 newLocalName,
19 duplicateLocalDs, newSysLocalDs, newSysLocalsDs, newUniqueId,
20 newFailLocalDs, newPredVarDs,
21 getSrcSpanDs, putSrcSpanDs,
22 mkPrintUnqualifiedDs,
23 newUnique,
24 UniqSupply, newUniqueSupply,
25 getGhcModeDs, dsGetFamInstEnvs, dsGetStaticBindsVar,
26 dsLookupGlobal, dsLookupGlobalId, dsDPHBuiltin, dsLookupTyCon, dsLookupDataCon,
27
28 PArrBuiltin(..),
29 dsLookupDPHRdrEnv, dsLookupDPHRdrEnv_maybe,
30 dsInitPArrBuiltin,
31
32 DsMetaEnv, DsMetaVal(..), dsGetMetaEnv, dsLookupMetaEnv, dsExtendMetaEnv,
33
34 -- Warnings
35 DsWarning, warnDs, failWithDs, discardWarningsDs,
36
37 -- Data types
38 DsMatchContext(..),
39 EquationInfo(..), MatchResult(..), DsWrapper, idDsWrapper,
40 CanItFail(..), orFail
41 ) where
42
43 import TcRnMonad
44 import FamInstEnv
45 import CoreSyn
46 import HsSyn
47 import TcIface
48 import LoadIface
49 import Finder
50 import PrelNames
51 import RdrName
52 import HscTypes
53 import Bag
54 import DataCon
55 import TyCon
56 import Id
57 import Module
58 import Outputable
59 import SrcLoc
60 import Type
61 import UniqSupply
62 import Name
63 import NameEnv
64 import DynFlags
65 import ErrUtils
66 import FastString
67 import Maybes
68 import GHC.Fingerprint
69
70 import Data.IORef
71 import Control.Monad
72
73 {-
74 ************************************************************************
75 * *
76 Data types for the desugarer
77 * *
78 ************************************************************************
79 -}
80
81 data DsMatchContext
82 = DsMatchContext (HsMatchContext Name) SrcSpan
83 deriving ()
84
85 data EquationInfo
86 = EqnInfo { eqn_pats :: [Pat Id], -- The patterns for an eqn
87 eqn_rhs :: MatchResult } -- What to do after match
88
89 instance Outputable EquationInfo where
90 ppr (EqnInfo pats _) = ppr pats
91
92 type DsWrapper = CoreExpr -> CoreExpr
93 idDsWrapper :: DsWrapper
94 idDsWrapper e = e
95
96 -- The semantics of (match vs (EqnInfo wrap pats rhs)) is the MatchResult
97 -- \fail. wrap (case vs of { pats -> rhs fail })
98 -- where vs are not bound by wrap
99
100
101 -- A MatchResult is an expression with a hole in it
102 data MatchResult
103 = MatchResult
104 CanItFail -- Tells whether the failure expression is used
105 (CoreExpr -> DsM CoreExpr)
106 -- Takes a expression to plug in at the
107 -- failure point(s). The expression should
108 -- be duplicatable!
109
110 data CanItFail = CanFail | CantFail
111
112 orFail :: CanItFail -> CanItFail -> CanItFail
113 orFail CantFail CantFail = CantFail
114 orFail _ _ = CanFail
115
116 {-
117 ************************************************************************
118 * *
119 Monad functions
120 * *
121 ************************************************************************
122 -}
123
124 -- Compatibility functions
125 fixDs :: (a -> DsM a) -> DsM a
126 fixDs = fixM
127
128 type DsWarning = (SrcSpan, SDoc)
129 -- Not quite the same as a WarnMsg, we have an SDoc here
130 -- and we'll do the print_unqual stuff later on to turn it
131 -- into a Doc.
132
133 initDs :: HscEnv
134 -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
135 -> DsM a
136 -> IO (Messages, Maybe a)
137 -- Print errors and warnings, if any arise
138
139 initDs hsc_env mod rdr_env type_env fam_inst_env thing_inside
140 = do { msg_var <- newIORef (emptyBag, emptyBag)
141 ; static_binds_var <- newIORef []
142 ; let dflags = hsc_dflags hsc_env
143 (ds_gbl_env, ds_lcl_env) = mkDsEnvs dflags mod rdr_env type_env
144 fam_inst_env msg_var
145 static_binds_var
146
147 ; either_res <- initTcRnIf 'd' hsc_env ds_gbl_env ds_lcl_env $
148 loadDAP $
149 initDPHBuiltins $
150 tryM thing_inside -- Catch exceptions (= errors during desugaring)
151
152 -- Display any errors and warnings
153 -- Note: if -Werror is used, we don't signal an error here.
154 ; msgs <- readIORef msg_var
155
156 ; let final_res | errorsFound dflags msgs = Nothing
157 | otherwise = case either_res of
158 Right res -> Just res
159 Left exn -> pprPanic "initDs" (text (show exn))
160 -- The (Left exn) case happens when the thing_inside throws
161 -- a UserError exception. Then it should have put an error
162 -- message in msg_var, so we just discard the exception
163
164 ; return (msgs, final_res)
165 }
166 where
167 -- Extend the global environment with a 'GlobalRdrEnv' containing the exported entities of
168 -- * 'Data.Array.Parallel' iff '-XParallelArrays' specified (see also 'checkLoadDAP').
169 -- * 'Data.Array.Parallel.Prim' iff '-fvectorise' specified.
170 loadDAP thing_inside
171 = do { dapEnv <- loadOneModule dATA_ARRAY_PARALLEL_NAME checkLoadDAP paErr
172 ; dappEnv <- loadOneModule dATA_ARRAY_PARALLEL_PRIM_NAME (goptM Opt_Vectorise) veErr
173 ; updGblEnv (\env -> env {ds_dph_env = dapEnv `plusOccEnv` dappEnv }) thing_inside
174 }
175 where
176 loadOneModule :: ModuleName -- the module to load
177 -> DsM Bool -- under which condition
178 -> MsgDoc -- error message if module not found
179 -> DsM GlobalRdrEnv -- empty if condition 'False'
180 loadOneModule modname check err
181 = do { doLoad <- check
182 ; if not doLoad
183 then return emptyGlobalRdrEnv
184 else do {
185 ; result <- liftIO $ findImportedModule hsc_env modname Nothing
186 ; case result of
187 FoundModule h -> loadModule err (fr_mod h)
188 _ -> pprPgmError "Unable to use Data Parallel Haskell (DPH):" err
189 } }
190
191 paErr = ptext (sLit "To use ParallelArrays,") <+> specBackend $$ hint1 $$ hint2
192 veErr = ptext (sLit "To use -fvectorise,") <+> specBackend $$ hint1 $$ hint2
193 specBackend = ptext (sLit "you must specify a DPH backend package")
194 hint1 = ptext (sLit "Look for packages named 'dph-lifted-*' with 'ghc-pkg'")
195 hint2 = ptext (sLit "You may need to install them with 'cabal install dph-examples'")
196
197 initDPHBuiltins thing_inside
198 = do { -- If '-XParallelArrays' given, we populate the builtin table for desugaring those
199 ; doInitBuiltins <- checkLoadDAP
200 ; if doInitBuiltins
201 then dsInitPArrBuiltin thing_inside
202 else thing_inside
203 }
204
205 checkLoadDAP = do { paEnabled <- xoptM Opt_ParallelArrays
206 ; return $ paEnabled &&
207 mod /= gHC_PARR' &&
208 moduleName mod /= dATA_ARRAY_PARALLEL_NAME
209 }
210 -- do not load 'Data.Array.Parallel' iff compiling 'base:GHC.PArr' or a
211 -- module called 'dATA_ARRAY_PARALLEL_NAME'; see also the comments at the top
212 -- of 'base:GHC.PArr' and 'Data.Array.Parallel' in the DPH libraries
213
214 initDsTc :: DsM a -> TcM a
215 initDsTc thing_inside
216 = do { this_mod <- getModule
217 ; tcg_env <- getGblEnv
218 ; msg_var <- getErrsVar
219 ; dflags <- getDynFlags
220 ; static_binds_var <- liftIO $ newIORef []
221 ; let type_env = tcg_type_env tcg_env
222 rdr_env = tcg_rdr_env tcg_env
223 fam_inst_env = tcg_fam_inst_env tcg_env
224 ds_envs = mkDsEnvs dflags this_mod rdr_env type_env fam_inst_env
225 msg_var static_binds_var
226 ; setEnvs ds_envs thing_inside
227 }
228
229 mkDsEnvs :: DynFlags -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
230 -> IORef Messages -> IORef [(Fingerprint, (Id, CoreExpr))]
231 -> (DsGblEnv, DsLclEnv)
232 mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var static_binds_var
233 = let if_genv = IfGblEnv { if_rec_types = Just (mod, return type_env) }
234 if_lenv = mkIfLclEnv mod (ptext (sLit "GHC error in desugarer lookup in") <+> ppr mod)
235 gbl_env = DsGblEnv { ds_mod = mod
236 , ds_fam_inst_env = fam_inst_env
237 , ds_if_env = (if_genv, if_lenv)
238 , ds_unqual = mkPrintUnqualified dflags rdr_env
239 , ds_msgs = msg_var
240 , ds_dph_env = emptyGlobalRdrEnv
241 , ds_parr_bi = panic "DsMonad: uninitialised ds_parr_bi"
242 , ds_static_binds = static_binds_var
243 }
244 lcl_env = DsLclEnv { dsl_meta = emptyNameEnv
245 , dsl_loc = noSrcSpan
246 }
247 in (gbl_env, lcl_env)
248
249 -- Attempt to load the given module and return its exported entities if successful.
250 --
251 loadModule :: SDoc -> Module -> DsM GlobalRdrEnv
252 loadModule doc mod
253 = do { env <- getGblEnv
254 ; setEnvs (ds_if_env env) $ do
255 { iface <- loadInterface doc mod ImportBySystem
256 ; case iface of
257 Failed err -> pprPanic "DsMonad.loadModule: failed to load" (err $$ doc)
258 Succeeded iface -> return $ mkGlobalRdrEnv . gresFromAvails prov . mi_exports $ iface
259 } }
260 where
261 prov = Just (ImpSpec { is_decl = imp_spec, is_item = ImpAll })
262 imp_spec = ImpDeclSpec { is_mod = name, is_qual = True,
263 is_dloc = wiredInSrcSpan, is_as = name }
264 name = moduleName mod
265
266 {-
267 ************************************************************************
268 * *
269 Operations in the monad
270 * *
271 ************************************************************************
272
273 And all this mysterious stuff is so we can occasionally reach out and
274 grab one or more names. @newLocalDs@ isn't exported---exported
275 functions are defined with it. The difference in name-strings makes
276 it easier to read debugging output.
277 -}
278
279 -- Make a new Id with the same print name, but different type, and new unique
280 newUniqueId :: Id -> Type -> DsM Id
281 newUniqueId id = mkSysLocalM (occNameFS (nameOccName (idName id)))
282
283 duplicateLocalDs :: Id -> DsM Id
284 duplicateLocalDs old_local
285 = do { uniq <- newUnique
286 ; return (setIdUnique old_local uniq) }
287
288 newPredVarDs :: PredType -> DsM Var
289 newPredVarDs pred
290 = newSysLocalDs pred
291
292 newSysLocalDs, newFailLocalDs :: Type -> DsM Id
293 newSysLocalDs = mkSysLocalM (fsLit "ds")
294 newFailLocalDs = mkSysLocalM (fsLit "fail")
295
296 newSysLocalsDs :: [Type] -> DsM [Id]
297 newSysLocalsDs tys = mapM newSysLocalDs tys
298
299 {-
300 We can also reach out and either set/grab location information from
301 the @SrcSpan@ being carried around.
302 -}
303
304 getGhcModeDs :: DsM GhcMode
305 getGhcModeDs = getDynFlags >>= return . ghcMode
306
307 getSrcSpanDs :: DsM SrcSpan
308 getSrcSpanDs = do { env <- getLclEnv; return (dsl_loc env) }
309
310 putSrcSpanDs :: SrcSpan -> DsM a -> DsM a
311 putSrcSpanDs new_loc thing_inside = updLclEnv (\ env -> env {dsl_loc = new_loc}) thing_inside
312 warnDs :: SDoc -> DsM ()
313 warnDs warn = do { env <- getGblEnv
314 ; loc <- getSrcSpanDs
315 ; dflags <- getDynFlags
316 ; let msg = mkWarnMsg dflags loc (ds_unqual env) warn
317 ; updMutVar (ds_msgs env) (\ (w,e) -> (w `snocBag` msg, e)) }
318
319 failWithDs :: SDoc -> DsM a
320 failWithDs err
321 = do { env <- getGblEnv
322 ; loc <- getSrcSpanDs
323 ; dflags <- getDynFlags
324 ; let msg = mkErrMsg dflags loc (ds_unqual env) err
325 ; updMutVar (ds_msgs env) (\ (w,e) -> (w, e `snocBag` msg))
326 ; failM }
327
328 mkPrintUnqualifiedDs :: DsM PrintUnqualified
329 mkPrintUnqualifiedDs = ds_unqual <$> getGblEnv
330
331 instance MonadThings (IOEnv (Env DsGblEnv DsLclEnv)) where
332 lookupThing = dsLookupGlobal
333
334 dsLookupGlobal :: Name -> DsM TyThing
335 -- Very like TcEnv.tcLookupGlobal
336 dsLookupGlobal name
337 = do { env <- getGblEnv
338 ; setEnvs (ds_if_env env)
339 (tcIfaceGlobal name) }
340
341 dsLookupGlobalId :: Name -> DsM Id
342 dsLookupGlobalId name
343 = tyThingId <$> dsLookupGlobal name
344
345 -- |Get a name from "Data.Array.Parallel" for the desugarer, from the 'ds_parr_bi' component of the
346 -- global desugerar environment.
347 --
348 dsDPHBuiltin :: (PArrBuiltin -> a) -> DsM a
349 dsDPHBuiltin sel = (sel . ds_parr_bi) <$> getGblEnv
350
351 dsLookupTyCon :: Name -> DsM TyCon
352 dsLookupTyCon name
353 = tyThingTyCon <$> dsLookupGlobal name
354
355 dsLookupDataCon :: Name -> DsM DataCon
356 dsLookupDataCon name
357 = tyThingDataCon <$> dsLookupGlobal name
358
359 -- |Lookup a name exported by 'Data.Array.Parallel.Prim' or 'Data.Array.Parallel.Prim'.
360 -- Panic if there isn't one, or if it is defined multiple times.
361 dsLookupDPHRdrEnv :: OccName -> DsM Name
362 dsLookupDPHRdrEnv occ
363 = liftM (fromMaybe (pprPanic nameNotFound (ppr occ)))
364 $ dsLookupDPHRdrEnv_maybe occ
365 where nameNotFound = "Name not found in 'Data.Array.Parallel' or 'Data.Array.Parallel.Prim':"
366
367 -- |Lookup a name exported by 'Data.Array.Parallel.Prim' or 'Data.Array.Parallel.Prim',
368 -- returning `Nothing` if it's not defined. Panic if it's defined multiple times.
369 dsLookupDPHRdrEnv_maybe :: OccName -> DsM (Maybe Name)
370 dsLookupDPHRdrEnv_maybe occ
371 = do { env <- ds_dph_env <$> getGblEnv
372 ; let gres = lookupGlobalRdrEnv env occ
373 ; case gres of
374 [] -> return $ Nothing
375 [gre] -> return $ Just $ gre_name gre
376 _ -> pprPanic multipleNames (ppr occ)
377 }
378 where multipleNames = "Multiple definitions in 'Data.Array.Parallel' and 'Data.Array.Parallel.Prim':"
379
380
381 -- Populate 'ds_parr_bi' from 'ds_dph_env'.
382 --
383 dsInitPArrBuiltin :: DsM a -> DsM a
384 dsInitPArrBuiltin thing_inside
385 = do { lengthPVar <- externalVar (fsLit "lengthP")
386 ; replicatePVar <- externalVar (fsLit "replicateP")
387 ; singletonPVar <- externalVar (fsLit "singletonP")
388 ; mapPVar <- externalVar (fsLit "mapP")
389 ; filterPVar <- externalVar (fsLit "filterP")
390 ; zipPVar <- externalVar (fsLit "zipP")
391 ; crossMapPVar <- externalVar (fsLit "crossMapP")
392 ; indexPVar <- externalVar (fsLit "!:")
393 ; emptyPVar <- externalVar (fsLit "emptyP")
394 ; appPVar <- externalVar (fsLit "+:+")
395 -- ; enumFromToPVar <- externalVar (fsLit "enumFromToP")
396 -- ; enumFromThenToPVar <- externalVar (fsLit "enumFromThenToP")
397 ; enumFromToPVar <- return arithErr
398 ; enumFromThenToPVar <- return arithErr
399
400 ; updGblEnv (\env -> env {ds_parr_bi = PArrBuiltin
401 { lengthPVar = lengthPVar
402 , replicatePVar = replicatePVar
403 , singletonPVar = singletonPVar
404 , mapPVar = mapPVar
405 , filterPVar = filterPVar
406 , zipPVar = zipPVar
407 , crossMapPVar = crossMapPVar
408 , indexPVar = indexPVar
409 , emptyPVar = emptyPVar
410 , appPVar = appPVar
411 , enumFromToPVar = enumFromToPVar
412 , enumFromThenToPVar = enumFromThenToPVar
413 } })
414 thing_inside
415 }
416 where
417 externalVar :: FastString -> DsM Var
418 externalVar fs = dsLookupDPHRdrEnv (mkVarOccFS fs) >>= dsLookupGlobalId
419
420 arithErr = panic "Arithmetic sequences have to wait until we support type classes"
421
422 dsGetFamInstEnvs :: DsM FamInstEnvs
423 -- Gets both the external-package inst-env
424 -- and the home-pkg inst env (includes module being compiled)
425 dsGetFamInstEnvs
426 = do { eps <- getEps; env <- getGblEnv
427 ; return (eps_fam_inst_env eps, ds_fam_inst_env env) }
428
429 dsGetMetaEnv :: DsM (NameEnv DsMetaVal)
430 dsGetMetaEnv = do { env <- getLclEnv; return (dsl_meta env) }
431
432 dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal)
433 dsLookupMetaEnv name = do { env <- getLclEnv; return (lookupNameEnv (dsl_meta env) name) }
434
435 dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a
436 dsExtendMetaEnv menv thing_inside
437 = updLclEnv (\env -> env { dsl_meta = dsl_meta env `plusNameEnv` menv }) thing_inside
438
439 -- | Gets a reference to the SPT entries created so far.
440 dsGetStaticBindsVar :: DsM (IORef [(Fingerprint, (Id,CoreExpr))])
441 dsGetStaticBindsVar = fmap ds_static_binds getGblEnv
442
443 discardWarningsDs :: DsM a -> DsM a
444 -- Ignore warnings inside the thing inside;
445 -- used to ignore inaccessable cases etc. inside generated code
446 discardWarningsDs thing_inside
447 = do { env <- getGblEnv
448 ; old_msgs <- readTcRef (ds_msgs env)
449
450 ; result <- thing_inside
451
452 -- Revert messages to old_msgs
453 ; writeTcRef (ds_msgs env) old_msgs
454
455 ; return result }