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