never executed always true always false
1 {-# LANGUAGE DeriveFunctor #-}
2 {-# LANGUAGE FlexibleContexts #-}
3 {-# LANGUAGE FlexibleInstances #-}
4 {-# LANGUAGE LambdaCase #-}
5
6 {-# OPTIONS_GHC -fno-warn-orphans #-} -- instance MonadThings is necessarily an orphan
7
8 {-
9 (c) The University of Glasgow 2006
10 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
11
12
13 Monadery used in desugaring
14 -}
15
16 module GHC.HsToCore.Monad (
17 DsM, mapM, mapAndUnzipM,
18 initDs, initDsTc, initTcDsForSolver, initDsWithModGuts, fixDs,
19 foldlM, foldrM, whenGOptM, unsetGOptM, unsetWOptM, xoptM,
20 Applicative(..),(<$>),
21
22 duplicateLocalDs, newSysLocalDs,
23 newSysLocalsDs, newUniqueId,
24 newFailLocalDs, newPredVarDs,
25 getSrcSpanDs, putSrcSpanDs, putSrcSpanDsA,
26 mkPrintUnqualifiedDs,
27 newUnique,
28 UniqSupply, newUniqueSupply,
29 getGhcModeDs, dsGetFamInstEnvs,
30 dsLookupGlobal, dsLookupGlobalId, dsLookupTyCon,
31 dsLookupDataCon, dsLookupConLike,
32 getCCIndexDsM,
33
34 DsMetaEnv, DsMetaVal(..), dsGetMetaEnv, dsLookupMetaEnv, dsExtendMetaEnv,
35
36 -- Getting and setting pattern match oracle states
37 getPmNablas, updPmNablas,
38
39 -- Get COMPLETE sets of a TyCon
40 dsGetCompleteMatches,
41
42 -- Warnings and errors
43 DsWarning, diagnosticDs, errDsCoreExpr,
44 failWithDs, failDs, discardWarningsDs,
45
46 -- Data types
47 DsMatchContext(..),
48 EquationInfo(..), MatchResult (..), runMatchResult, DsWrapper, idDsWrapper,
49
50 -- Trace injection
51 pprRuntimeTrace
52 ) where
53
54 import GHC.Prelude
55
56 import GHC.Driver.Env
57 import GHC.Driver.Session
58 import GHC.Driver.Ppr
59 import GHC.Driver.Config.Diagnostic
60
61 import GHC.Hs
62
63 import GHC.HsToCore.Types
64 import GHC.HsToCore.Errors.Types
65 import GHC.HsToCore.Pmc.Solver.Types (Nablas, initNablas)
66
67 import GHC.Core.FamInstEnv
68 import GHC.Core
69 import GHC.Core.Make ( unitExpr )
70 import GHC.Core.Utils ( exprType )
71 import GHC.Core.DataCon
72 import GHC.Core.ConLike
73 import GHC.Core.TyCon
74 import GHC.Core.Type
75 import GHC.Core.Multiplicity
76
77 import GHC.IfaceToCore
78
79 import GHC.Tc.Utils.Monad
80
81 import GHC.Builtin.Names
82
83 import GHC.Data.FastString
84
85 import GHC.Unit.Env
86 import GHC.Unit.External
87 import GHC.Unit.Module
88 import GHC.Unit.Module.ModGuts
89
90 import GHC.Types.Name.Reader
91 import GHC.Types.Basic ( Origin )
92 import GHC.Types.SourceFile
93 import GHC.Types.Id
94 import GHC.Types.SrcLoc
95 import GHC.Types.TypeEnv
96 import GHC.Types.Unique.Supply
97 import GHC.Types.Name
98 import GHC.Types.Name.Env
99 import GHC.Types.Name.Ppr
100 import GHC.Types.Literal ( mkLitString )
101 import GHC.Types.CostCentre.State
102 import GHC.Types.TyThing
103 import GHC.Types.Error
104
105 import GHC.Utils.Error
106 import GHC.Utils.Outputable
107 import GHC.Utils.Panic
108 import qualified GHC.Data.Strict as Strict
109
110 import Data.IORef
111 import GHC.Driver.Env.KnotVars
112
113 {-
114 ************************************************************************
115 * *
116 Data types for the desugarer
117 * *
118 ************************************************************************
119 -}
120
121 data DsMatchContext
122 = DsMatchContext (HsMatchContext GhcRn) SrcSpan
123 deriving ()
124
125 instance Outputable DsMatchContext where
126 ppr (DsMatchContext hs_match ss) = ppr ss <+> pprMatchContext hs_match
127
128 data EquationInfo
129 = EqnInfo { eqn_pats :: [Pat GhcTc]
130 -- ^ The patterns for an equation
131 --
132 -- NB: We have /already/ applied 'decideBangHood' to
133 -- these patterns. See Note [decideBangHood] in "GHC.HsToCore.Utils"
134
135 , eqn_orig :: Origin
136 -- ^ Was this equation present in the user source?
137 --
138 -- This helps us avoid warnings on patterns that GHC elaborated.
139 --
140 -- For instance, the pattern @-1 :: Word@ gets desugared into
141 -- @W# -1## :: Word@, but we shouldn't warn about an overflowed
142 -- literal for /both/ of these cases.
143
144 , eqn_rhs :: MatchResult CoreExpr
145 -- ^ What to do after match
146 }
147
148 instance Outputable EquationInfo where
149 ppr (EqnInfo pats _ _) = ppr pats
150
151 type DsWrapper = CoreExpr -> CoreExpr
152 idDsWrapper :: DsWrapper
153 idDsWrapper e = e
154
155 -- The semantics of (match vs (EqnInfo wrap pats rhs)) is the MatchResult CoreExpr
156 -- \fail. wrap (case vs of { pats -> rhs fail })
157 -- where vs are not bound by wrap
158
159 -- | This is a value of type a with potentially a CoreExpr-shaped hole in it.
160 -- This is used to deal with cases where we are potentially handling pattern
161 -- match failure, and want to later specify how failure is handled.
162 data MatchResult a
163 -- | We represent the case where there is no hole without a function from
164 -- 'CoreExpr', like this, because sometimes we have nothing to put in the
165 -- hole and so want to be sure there is in fact no hole.
166 = MR_Infallible (DsM a)
167 | MR_Fallible (CoreExpr -> DsM a)
168 deriving (Functor)
169
170 -- | Product is an "or" on falliblity---the combined match result is infallible
171 -- only if the left and right argument match results both were.
172 --
173 -- This is useful for combining a bunch of alternatives together and then
174 -- getting the overall falliblity of the entire group. See 'mkDataConCase' for
175 -- an example.
176 instance Applicative MatchResult where
177 pure v = MR_Infallible (pure v)
178 MR_Infallible f <*> MR_Infallible x = MR_Infallible (f <*> x)
179 f <*> x = MR_Fallible $ \fail -> runMatchResult fail f <*> runMatchResult fail x
180
181 -- Given a fail expression to use, and a MatchResult CoreExpr, compute the filled CoreExpr whether
182 -- the MatchResult CoreExpr was failable or not.
183 runMatchResult :: CoreExpr -> MatchResult a -> DsM a
184 runMatchResult fail = \case
185 MR_Infallible body -> body
186 MR_Fallible body_fn -> body_fn fail
187
188 {-
189 ************************************************************************
190 * *
191 Monad functions
192 * *
193 ************************************************************************
194 -}
195
196 -- Compatibility functions
197 fixDs :: (a -> DsM a) -> DsM a
198 fixDs = fixM
199
200 type DsWarning = (SrcSpan, SDoc)
201 -- Not quite the same as a WarnMsg, we have an SDoc here
202 -- and we'll do the print_unqual stuff later on to turn it
203 -- into a Doc.
204
205 -- | Run a 'DsM' action inside the 'TcM' monad.
206 initDsTc :: DsM a -> TcM (Messages DsMessage, Maybe a)
207 initDsTc thing_inside
208 = do { tcg_env <- getGblEnv
209 ; msg_var <- liftIO $ newIORef emptyMessages
210 ; hsc_env <- getTopEnv
211 ; envs <- mkDsEnvsFromTcGbl hsc_env msg_var tcg_env
212 ; e_result <- tryM $ -- need to tryM so that we don't discard
213 -- DsMessages
214 setEnvs envs thing_inside
215 ; msgs <- liftIO $ readIORef msg_var
216 ; return (msgs, case e_result of Left _ -> Nothing
217 Right x -> Just x)
218 }
219
220 -- | Run a 'DsM' action inside the 'IO' monad.
221 initDs :: HscEnv -> TcGblEnv -> DsM a -> IO (Messages DsMessage, Maybe a)
222 initDs hsc_env tcg_env thing_inside
223 = do { msg_var <- newIORef emptyMessages
224 ; envs <- mkDsEnvsFromTcGbl hsc_env msg_var tcg_env
225 ; runDs hsc_env envs thing_inside
226 }
227
228 -- | Build a set of desugarer environments derived from a 'TcGblEnv'.
229 mkDsEnvsFromTcGbl :: MonadIO m
230 => HscEnv -> IORef (Messages DsMessage) -> TcGblEnv
231 -> m (DsGblEnv, DsLclEnv)
232 mkDsEnvsFromTcGbl hsc_env msg_var tcg_env
233 = do { cc_st_var <- liftIO $ newIORef newCostCentreState
234 ; eps <- liftIO $ hscEPS hsc_env
235 ; let unit_env = hsc_unit_env hsc_env
236 this_mod = tcg_mod tcg_env
237 type_env = tcg_type_env tcg_env
238 rdr_env = tcg_rdr_env tcg_env
239 fam_inst_env = tcg_fam_inst_env tcg_env
240 complete_matches = hptCompleteSigs hsc_env -- from the home package
241 ++ tcg_complete_matches tcg_env -- from the current module
242 ++ eps_complete_matches eps -- from imports
243 -- re-use existing next_wrapper_num to ensure uniqueness
244 next_wrapper_num_var = tcg_next_wrapper_num tcg_env
245 ; return $ mkDsEnvs unit_env this_mod rdr_env type_env fam_inst_env
246 msg_var cc_st_var next_wrapper_num_var complete_matches
247 }
248
249 runDs :: HscEnv -> (DsGblEnv, DsLclEnv) -> DsM a -> IO (Messages DsMessage, Maybe a)
250 runDs hsc_env (ds_gbl, ds_lcl) thing_inside
251 = do { res <- initTcRnIf 'd' hsc_env ds_gbl ds_lcl
252 (tryM thing_inside)
253 ; msgs <- readIORef (ds_msgs ds_gbl)
254 ; let final_res
255 | errorsFound msgs = Nothing
256 | Right r <- res = Just r
257 | otherwise = panic "initDs"
258 ; return (msgs, final_res)
259 }
260
261 -- | Run a 'DsM' action in the context of an existing 'ModGuts'
262 initDsWithModGuts :: HscEnv -> ModGuts -> DsM a -> IO (Messages DsMessage, Maybe a)
263 initDsWithModGuts hsc_env (ModGuts { mg_module = this_mod, mg_binds = binds
264 , mg_tcs = tycons, mg_fam_insts = fam_insts
265 , mg_patsyns = patsyns, mg_rdr_env = rdr_env
266 , mg_fam_inst_env = fam_inst_env
267 , mg_complete_matches = local_complete_matches
268 }) thing_inside
269 = do { cc_st_var <- newIORef newCostCentreState
270 ; next_wrapper_num <- newIORef emptyModuleEnv
271 ; msg_var <- newIORef emptyMessages
272 ; eps <- liftIO $ hscEPS hsc_env
273 ; let unit_env = hsc_unit_env hsc_env
274 type_env = typeEnvFromEntities ids tycons patsyns fam_insts
275 complete_matches = hptCompleteSigs hsc_env -- from the home package
276 ++ local_complete_matches -- from the current module
277 ++ eps_complete_matches eps -- from imports
278
279 bindsToIds (NonRec v _) = [v]
280 bindsToIds (Rec binds) = map fst binds
281 ids = concatMap bindsToIds binds
282
283 envs = mkDsEnvs unit_env this_mod rdr_env type_env
284 fam_inst_env msg_var cc_st_var
285 next_wrapper_num complete_matches
286 ; runDs hsc_env envs thing_inside
287 }
288
289 initTcDsForSolver :: TcM a -> DsM a
290 -- Spin up a TcM context so that we can run the constraint solver
291 -- Returns any error messages generated by the constraint solver
292 -- and (Just res) if no error happened; Nothing if an error happened
293 --
294 -- Simon says: I'm not very happy about this. We spin up a complete TcM monad
295 -- only to immediately refine it to a TcS monad.
296 -- Better perhaps to make TcS into its own monad, rather than building on TcS
297 -- But that may in turn interact with plugins
298
299 initTcDsForSolver thing_inside
300 = do { (gbl, lcl) <- getEnvs
301 ; hsc_env <- getTopEnv
302
303 ; let DsGblEnv { ds_mod = mod
304 , ds_fam_inst_env = fam_inst_env
305 , ds_gbl_rdr_env = rdr_env } = gbl
306 -- This is *the* use of ds_gbl_rdr_env:
307 -- Make sure the solver (used by the pattern-match overlap checker) has
308 -- access to the GlobalRdrEnv and FamInstEnv for the module, so that it
309 -- knows how to reduce type families, and which newtypes it can unwrap.
310
311
312 DsLclEnv { dsl_loc = loc } = lcl
313
314 ; (msgs, mb_ret) <- liftIO $ initTc hsc_env HsSrcFile False mod loc $
315 updGblEnv (\tc_gbl -> tc_gbl { tcg_fam_inst_env = fam_inst_env
316 , tcg_rdr_env = rdr_env }) $
317 thing_inside
318 ; case mb_ret of
319 Just ret -> pure ret
320 Nothing -> pprPanic "initTcDsForSolver" (vcat $ pprMsgEnvelopeBagWithLoc (getErrorMessages msgs)) }
321
322 mkDsEnvs :: UnitEnv -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
323 -> IORef (Messages DsMessage) -> IORef CostCentreState
324 -> IORef (ModuleEnv Int) -> CompleteMatches
325 -> (DsGblEnv, DsLclEnv)
326 mkDsEnvs unit_env mod rdr_env type_env fam_inst_env msg_var cc_st_var
327 next_wrapper_num complete_matches
328 = let if_genv = IfGblEnv { if_doc = text "mkDsEnvs"
329 -- Failing tests here are `ghci` and `T11985` if you get this wrong.
330 -- this is very very "at a distance" because the reason for this check is that the type_env in interactive
331 -- mode is the smushed together of all the interactive modules.
332 -- See Note [Why is KnotVars not a ModuleEnv]
333 , if_rec_types = KnotVars [mod] (\that_mod -> if that_mod == mod || isInteractiveModule mod
334 then Just (return type_env)
335 else Nothing) }
336 if_lenv = mkIfLclEnv mod (text "GHC error in desugarer lookup in" <+> ppr mod)
337 NotBoot
338 real_span = realSrcLocSpan (mkRealSrcLoc (moduleNameFS (moduleName mod)) 1 1)
339 gbl_env = DsGblEnv { ds_mod = mod
340 , ds_fam_inst_env = fam_inst_env
341 , ds_gbl_rdr_env = rdr_env
342 , ds_if_env = (if_genv, if_lenv)
343 , ds_unqual = mkPrintUnqualified unit_env rdr_env
344 , ds_msgs = msg_var
345 , ds_complete_matches = complete_matches
346 , ds_cc_st = cc_st_var
347 , ds_next_wrapper_num = next_wrapper_num
348 }
349 lcl_env = DsLclEnv { dsl_meta = emptyNameEnv
350 , dsl_loc = real_span
351 , dsl_nablas = initNablas
352 }
353 in (gbl_env, lcl_env)
354
355
356 {-
357 ************************************************************************
358 * *
359 Operations in the monad
360 * *
361 ************************************************************************
362
363 And all this mysterious stuff is so we can occasionally reach out and
364 grab one or more names. @newLocalDs@ isn't exported---exported
365 functions are defined with it. The difference in name-strings makes
366 it easier to read debugging output.
367
368 -}
369
370 -- Make a new Id with the same print name, but different type, and new unique
371 newUniqueId :: Id -> Mult -> Type -> DsM Id
372 newUniqueId id = mkSysLocalOrCoVarM (occNameFS (nameOccName (idName id)))
373
374 duplicateLocalDs :: Id -> DsM Id
375 duplicateLocalDs old_local
376 = do { uniq <- newUnique
377 ; return (setIdUnique old_local uniq) }
378
379 newPredVarDs :: PredType -> DsM Var
380 newPredVarDs
381 = mkSysLocalOrCoVarM (fsLit "ds") Many -- like newSysLocalDs, but we allow covars
382
383 newSysLocalDs, newFailLocalDs :: Mult -> Type -> DsM Id
384 newSysLocalDs = mkSysLocalM (fsLit "ds")
385 newFailLocalDs = mkSysLocalM (fsLit "fail")
386
387 newSysLocalsDs :: [Scaled Type] -> DsM [Id]
388 newSysLocalsDs = mapM (\(Scaled w t) -> newSysLocalDs w t)
389
390 {-
391 We can also reach out and either set/grab location information from
392 the @SrcSpan@ being carried around.
393 -}
394
395 getGhcModeDs :: DsM GhcMode
396 getGhcModeDs = getDynFlags >>= return . ghcMode
397
398 -- | Get the current pattern match oracle state. See 'dsl_nablas'.
399 getPmNablas :: DsM Nablas
400 getPmNablas = do { env <- getLclEnv; return (dsl_nablas env) }
401
402 -- | Set the pattern match oracle state within the scope of the given action.
403 -- See 'dsl_nablas'.
404 updPmNablas :: Nablas -> DsM a -> DsM a
405 updPmNablas nablas = updLclEnv (\env -> env { dsl_nablas = nablas })
406
407 getSrcSpanDs :: DsM SrcSpan
408 getSrcSpanDs = do { env <- getLclEnv
409 ; return (RealSrcSpan (dsl_loc env) Strict.Nothing) }
410
411 putSrcSpanDs :: SrcSpan -> DsM a -> DsM a
412 putSrcSpanDs (UnhelpfulSpan {}) thing_inside
413 = thing_inside
414 putSrcSpanDs (RealSrcSpan real_span _) thing_inside
415 = updLclEnv (\ env -> env {dsl_loc = real_span}) thing_inside
416
417 putSrcSpanDsA :: SrcSpanAnn' ann -> DsM a -> DsM a
418 putSrcSpanDsA loc = putSrcSpanDs (locA loc)
419
420 -- | Emit a diagnostic for the current source location. In case the diagnostic is a warning,
421 -- the latter will be ignored and discarded if the relevant 'WarningFlag' is not set in the DynFlags.
422 -- See Note [Discarding Messages] in 'GHC.Types.Error'.
423 diagnosticDs :: DsMessage -> DsM ()
424 diagnosticDs dsMessage
425 = do { env <- getGblEnv
426 ; loc <- getSrcSpanDs
427 ; !diag_opts <- initDiagOpts <$> getDynFlags
428 ; let msg = mkMsgEnvelope diag_opts loc (ds_unqual env) dsMessage
429 ; updMutVar (ds_msgs env) (\ msgs -> msg `addMessage` msgs) }
430
431 -- | Issue an error, but return the expression for (), so that we can continue
432 -- reporting errors.
433 errDsCoreExpr :: DsMessage -> DsM CoreExpr
434 errDsCoreExpr msg
435 = do { diagnosticDs msg
436 ; return unitExpr }
437
438 failWithDs :: DsMessage -> DsM a
439 failWithDs msg
440 = do { diagnosticDs msg
441 ; failM }
442
443 failDs :: DsM a
444 failDs = failM
445
446 mkPrintUnqualifiedDs :: DsM PrintUnqualified
447 mkPrintUnqualifiedDs = ds_unqual <$> getGblEnv
448
449 instance MonadThings (IOEnv (Env DsGblEnv DsLclEnv)) where
450 lookupThing = dsLookupGlobal
451
452 dsLookupGlobal :: Name -> DsM TyThing
453 -- Very like GHC.Tc.Utils.Env.tcLookupGlobal
454 dsLookupGlobal name
455 = do { env <- getGblEnv
456 ; setEnvs (ds_if_env env)
457 (tcIfaceGlobal name) }
458
459 dsLookupGlobalId :: Name -> DsM Id
460 dsLookupGlobalId name
461 = tyThingId <$> dsLookupGlobal name
462
463 dsLookupTyCon :: Name -> DsM TyCon
464 dsLookupTyCon name
465 = tyThingTyCon <$> dsLookupGlobal name
466
467 dsLookupDataCon :: Name -> DsM DataCon
468 dsLookupDataCon name
469 = tyThingDataCon <$> dsLookupGlobal name
470
471 dsLookupConLike :: Name -> DsM ConLike
472 dsLookupConLike name
473 = tyThingConLike <$> dsLookupGlobal name
474
475
476 dsGetFamInstEnvs :: DsM FamInstEnvs
477 -- Gets both the external-package inst-env
478 -- and the home-pkg inst env (includes module being compiled)
479 dsGetFamInstEnvs
480 = do { eps <- getEps; env <- getGblEnv
481 ; return (eps_fam_inst_env eps, ds_fam_inst_env env) }
482
483 dsGetMetaEnv :: DsM (NameEnv DsMetaVal)
484 dsGetMetaEnv = do { env <- getLclEnv; return (dsl_meta env) }
485
486 -- | The @COMPLETE@ pragmas that are in scope.
487 dsGetCompleteMatches :: DsM CompleteMatches
488 dsGetCompleteMatches = ds_complete_matches <$> getGblEnv
489
490 dsLookupMetaEnv :: Name -> DsM (Maybe DsMetaVal)
491 dsLookupMetaEnv name = do { env <- getLclEnv; return (lookupNameEnv (dsl_meta env) name) }
492
493 dsExtendMetaEnv :: DsMetaEnv -> DsM a -> DsM a
494 dsExtendMetaEnv menv thing_inside
495 = updLclEnv (\env -> env { dsl_meta = dsl_meta env `plusNameEnv` menv }) thing_inside
496
497 discardWarningsDs :: DsM a -> DsM a
498 -- Ignore warnings inside the thing inside;
499 -- used to ignore inaccessible cases etc. inside generated code
500 discardWarningsDs thing_inside
501 = do { env <- getGblEnv
502 ; old_msgs <- readTcRef (ds_msgs env)
503
504 ; result <- thing_inside
505
506 -- Revert messages to old_msgs
507 ; writeTcRef (ds_msgs env) old_msgs
508
509 ; return result }
510
511 -- | Inject a trace message into the compiled program. Whereas
512 -- pprTrace prints out information *while compiling*, pprRuntimeTrace
513 -- captures that information and causes it to be printed *at runtime*
514 -- using Debug.Trace.trace.
515 --
516 -- pprRuntimeTrace hdr doc expr
517 --
518 -- will produce an expression that looks like
519 --
520 -- trace (hdr + doc) expr
521 --
522 -- When using this to debug a module that Debug.Trace depends on,
523 -- it is necessary to import {-# SOURCE #-} Debug.Trace () in that
524 -- module. We could avoid this inconvenience by wiring in Debug.Trace.trace,
525 -- but that doesn't seem worth the effort and maintenance cost.
526 pprRuntimeTrace :: String -- ^ header
527 -> SDoc -- ^ information to output
528 -> CoreExpr -- ^ expression
529 -> DsM CoreExpr
530 pprRuntimeTrace str doc expr = do
531 traceId <- dsLookupGlobalId traceName
532 unpackCStringId <- dsLookupGlobalId unpackCStringName
533 dflags <- getDynFlags
534 let message :: CoreExpr
535 message = App (Var unpackCStringId) $
536 Lit $ mkLitString $ showSDoc dflags (hang (text str) 4 doc)
537 return $ mkApps (Var traceId) [Type (exprType expr), message, expr]
538
539 -- | See 'getCCIndexM'.
540 getCCIndexDsM :: FastString -> DsM CostCentreIndex
541 getCCIndexDsM = getCCIndexM ds_cc_st