never executed always true always false
1
2 {-# LANGUAGE TypeFamilies #-}
3
4 {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
5 {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
6
7 {-
8 (c) The University of Glasgow 2006
9 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
10
11
12 Desugaring expressions.
13 -}
14
15 module GHC.HsToCore.Expr
16 ( dsExpr, dsLExpr, dsLocalBinds
17 , dsValBinds, dsLit, dsSyntaxExpr
18 )
19 where
20
21 import GHC.Prelude
22
23 import GHC.HsToCore.Match
24 import GHC.HsToCore.Match.Literal
25 import GHC.HsToCore.Binds
26 import GHC.HsToCore.GuardedRHSs
27 import GHC.HsToCore.ListComp
28 import GHC.HsToCore.Utils
29 import GHC.HsToCore.Arrows
30 import GHC.HsToCore.Monad
31 import GHC.HsToCore.Pmc ( addTyCs, pmcGRHSs )
32 import GHC.HsToCore.Errors.Types
33 import GHC.Types.SourceText
34 import GHC.Types.Name
35 import GHC.Types.Name.Env
36 import GHC.Core.FamInstEnv( topNormaliseType )
37 import GHC.HsToCore.Quote
38 import GHC.Hs
39
40 -- NB: The desugarer, which straddles the source and Core worlds, sometimes
41 -- needs to see source types
42 import GHC.Tc.Utils.TcType
43 import GHC.Tc.Types.Evidence
44 import GHC.Tc.Utils.Monad
45 import GHC.Core.Type
46 import GHC.Core.TyCo.Rep
47 import GHC.Core.Multiplicity
48 import GHC.Core.Coercion( instNewTyCon_maybe, mkSymCo )
49 import GHC.Core
50 import GHC.Core.Utils
51 import GHC.Core.Make
52
53 import GHC.Driver.Session
54 import GHC.Types.CostCentre
55 import GHC.Types.Id
56 import GHC.Types.Id.Make
57 import GHC.Types.Var.Env
58 import GHC.Unit.Module
59 import GHC.Core.ConLike
60 import GHC.Core.DataCon
61 import GHC.Builtin.Types
62 import GHC.Builtin.Names
63 import GHC.Types.Basic
64 import GHC.Data.Maybe
65 import GHC.Types.SrcLoc
66 import GHC.Types.Tickish
67 import GHC.Utils.Misc
68 import GHC.Data.Bag
69 import GHC.Utils.Outputable as Outputable
70 import GHC.Utils.Panic
71 import GHC.Utils.Panic.Plain
72 import GHC.Core.PatSyn
73 import Control.Monad
74
75 {-
76 ************************************************************************
77 * *
78 dsLocalBinds, dsValBinds
79 * *
80 ************************************************************************
81 -}
82
83 dsLocalBinds :: HsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr
84 dsLocalBinds (EmptyLocalBinds _) body = return body
85 dsLocalBinds b@(HsValBinds _ binds) body = putSrcSpanDs (spanHsLocaLBinds b) $
86 dsValBinds binds body
87 dsLocalBinds (HsIPBinds _ binds) body = dsIPBinds binds body
88
89 -------------------------
90 -- caller sets location
91 dsValBinds :: HsValBinds GhcTc -> CoreExpr -> DsM CoreExpr
92 dsValBinds (XValBindsLR (NValBinds binds _)) body
93 = foldrM ds_val_bind body binds
94 dsValBinds (ValBinds {}) _ = panic "dsValBinds ValBindsIn"
95
96 -------------------------
97 dsIPBinds :: HsIPBinds GhcTc -> CoreExpr -> DsM CoreExpr
98 dsIPBinds (IPBinds ev_binds ip_binds) body
99 = do { ds_binds <- dsTcEvBinds ev_binds
100 ; let inner = mkCoreLets ds_binds body
101 -- The dict bindings may not be in
102 -- dependency order; hence Rec
103 ; foldrM ds_ip_bind inner ip_binds }
104 where
105 ds_ip_bind :: LIPBind GhcTc -> CoreExpr -> DsM CoreExpr
106 ds_ip_bind (L _ (IPBind _ ~(Right n) e)) body
107 = do e' <- dsLExpr e
108 return (Let (NonRec n e') body)
109
110 -------------------------
111 -- caller sets location
112 ds_val_bind :: (RecFlag, LHsBinds GhcTc) -> CoreExpr -> DsM CoreExpr
113 -- Special case for bindings which bind unlifted variables
114 -- We need to do a case right away, rather than building
115 -- a tuple and doing selections.
116 -- Silently ignore INLINE and SPECIALISE pragmas...
117 ds_val_bind (NonRecursive, hsbinds) body
118 | [L loc bind] <- bagToList hsbinds
119 -- Non-recursive, non-overloaded bindings only come in ones
120 -- ToDo: in some bizarre case it's conceivable that there
121 -- could be dict binds in the 'binds'. (See the notes
122 -- below. Then pattern-match would fail. Urk.)
123 , isUnliftedHsBind bind
124 = putSrcSpanDs (locA loc) $
125 -- see Note [Strict binds checks] in GHC.HsToCore.Binds
126 if is_polymorphic bind
127 then errDsCoreExpr (DsCannotMixPolyAndUnliftedBindings bind)
128 -- data Ptr a = Ptr Addr#
129 -- f x = let p@(Ptr y) = ... in ...
130 -- Here the binding for 'p' is polymorphic, but does
131 -- not mix with an unlifted binding for 'y'. You should
132 -- use a bang pattern. #6078.
133
134 else do { when (looksLazyPatBind bind) $
135 diagnosticDs (DsUnbangedStrictPatterns bind)
136 -- Complain about a binding that looks lazy
137 -- e.g. let I# y = x in ...
138 -- Remember, in checkStrictBinds we are going to do strict
139 -- matching, so (for software engineering reasons) we insist
140 -- that the strictness is manifest on each binding
141 -- However, lone (unboxed) variables are ok
142
143
144 ; dsUnliftedBind bind body }
145 where
146 is_polymorphic (AbsBinds { abs_tvs = tvs, abs_ev_vars = evs })
147 = not (null tvs && null evs)
148 is_polymorphic _ = False
149
150
151 ds_val_bind (is_rec, binds) _body
152 | anyBag (isUnliftedHsBind . unLoc) binds -- see Note [Strict binds checks] in GHC.HsToCore.Binds
153 = assert (isRec is_rec )
154 errDsCoreExpr $ DsRecBindsNotAllowedForUnliftedTys (bagToList binds)
155
156 -- Ordinary case for bindings; none should be unlifted
157 ds_val_bind (is_rec, binds) body
158 = do { massert (isRec is_rec || isSingletonBag binds)
159 -- we should never produce a non-recursive list of multiple binds
160
161 ; (force_vars,prs) <- dsLHsBinds binds
162 ; let body' = foldr seqVar body force_vars
163 ; assertPpr (not (any (isUnliftedType . idType . fst) prs)) (ppr is_rec $$ ppr binds) $
164 case prs of
165 [] -> return body
166 _ -> return (Let (Rec prs) body') }
167 -- Use a Rec regardless of is_rec.
168 -- Why? Because it allows the binds to be all
169 -- mixed up, which is what happens in one rare case
170 -- Namely, for an AbsBind with no tyvars and no dicts,
171 -- but which does have dictionary bindings.
172 -- See notes with GHC.Tc.Solver.inferLoop [NO TYVARS]
173 -- It turned out that wrapping a Rec here was the easiest solution
174 --
175 -- NB The previous case dealt with unlifted bindings, so we
176 -- only have to deal with lifted ones now; so Rec is ok
177
178 ------------------
179 dsUnliftedBind :: HsBind GhcTc -> CoreExpr -> DsM CoreExpr
180 dsUnliftedBind (AbsBinds { abs_tvs = [], abs_ev_vars = []
181 , abs_exports = exports
182 , abs_ev_binds = ev_binds
183 , abs_binds = lbinds }) body
184 = do { let body1 = foldr bind_export body exports
185 bind_export export b = bindNonRec (abe_poly export) (Var (abe_mono export)) b
186 ; body2 <- foldlM (\body lbind -> dsUnliftedBind (unLoc lbind) body)
187 body1 lbinds
188 ; ds_binds <- dsTcEvBinds_s ev_binds
189 ; return (mkCoreLets ds_binds body2) }
190
191 dsUnliftedBind (FunBind { fun_id = L l fun
192 , fun_matches = matches
193 , fun_ext = co_fn
194 , fun_tick = tick }) body
195 -- Can't be a bang pattern (that looks like a PatBind)
196 -- so must be simply unboxed
197 = do { (args, rhs) <- matchWrapper (mkPrefixFunRhs (L l $ idName fun))
198 Nothing matches
199 ; massert (null args) -- Functions aren't lifted
200 ; massert (isIdHsWrapper co_fn)
201 ; let rhs' = mkOptTickBox tick rhs
202 ; return (bindNonRec fun rhs' body) }
203
204 dsUnliftedBind (PatBind {pat_lhs = pat, pat_rhs = grhss
205 , pat_ext = ty }) body
206 = -- let C x# y# = rhs in body
207 -- ==> case rhs of C x# y# -> body
208 do { match_nablas <- pmcGRHSs PatBindGuards grhss
209 ; rhs <- dsGuarded grhss ty match_nablas
210 ; let upat = unLoc pat
211 eqn = EqnInfo { eqn_pats = [upat],
212 eqn_orig = FromSource,
213 eqn_rhs = cantFailMatchResult body }
214 ; var <- selectMatchVar Many upat
215 -- `var` will end up in a let binder, so the multiplicity
216 -- doesn't matter.
217 ; result <- matchEquations PatBindRhs [var] [eqn] (exprType body)
218 ; return (bindNonRec var rhs result) }
219
220 dsUnliftedBind bind body = pprPanic "dsLet: unlifted" (ppr bind $$ ppr body)
221
222 {-
223 ************************************************************************
224 * *
225 * Variables, constructors, literals *
226 * *
227 ************************************************************************
228 -}
229
230
231 -- | Replace the body of the function with this block to test the hsExprType
232 -- function in GHC.Tc.Utils.Zonk:
233 -- putSrcSpanDs loc $ do
234 -- { core_expr <- dsExpr e
235 -- ; massertPpr (exprType core_expr `eqType` hsExprType e)
236 -- (ppr e <+> dcolon <+> ppr (hsExprType e) $$
237 -- ppr core_expr <+> dcolon <+> ppr (exprType core_expr))
238 -- ; return core_expr }
239 dsLExpr :: LHsExpr GhcTc -> DsM CoreExpr
240 dsLExpr (L loc e) =
241 putSrcSpanDsA loc $ dsExpr e
242
243 dsExpr :: HsExpr GhcTc -> DsM CoreExpr
244 dsExpr (HsVar _ (L _ id)) = dsHsVar id
245 dsExpr (HsRecSel _ (FieldOcc id _)) = dsHsVar id
246 dsExpr (HsUnboundVar (HER ref _ _) _) = dsEvTerm =<< readMutVar ref
247 -- See Note [Holes] in GHC.Tc.Types.Constraint
248
249 dsExpr (HsPar _ _ e _) = dsLExpr e
250 dsExpr (ExprWithTySig _ e _) = dsLExpr e
251
252 dsExpr (HsIPVar x _) = dataConCantHappen x
253
254 dsExpr (HsGetField x _ _) = dataConCantHappen x
255 dsExpr (HsProjection x _) = dataConCantHappen x
256
257 dsExpr (HsLit _ lit)
258 = do { warnAboutOverflowedLit lit
259 ; dsLit (convertLit lit) }
260
261 dsExpr (HsOverLit _ lit)
262 = do { warnAboutOverflowedOverLit lit
263 ; dsOverLit lit }
264
265 dsExpr e@(XExpr ext_expr_tc)
266 = case ext_expr_tc of
267 ExpansionExpr (HsExpanded _ b) -> dsExpr b
268 WrapExpr {} -> dsHsWrapped e
269 ConLikeTc con tvs tys -> dsConLike con tvs tys
270 -- Hpc Support
271 HsTick tickish e -> do
272 e' <- dsLExpr e
273 return (Tick tickish e')
274
275 -- There is a problem here. The then and else branches
276 -- have no free variables, so they are open to lifting.
277 -- We need someway of stopping this.
278 -- This will make no difference to binary coverage
279 -- (did you go here: YES or NO), but will effect accurate
280 -- tick counting.
281
282 HsBinTick ixT ixF e -> do
283 e2 <- dsLExpr e
284 do { assert (exprType e2 `eqType` boolTy)
285 mkBinaryTickBox ixT ixF e2
286 }
287
288 dsExpr (NegApp _ (L loc
289 (HsOverLit _ lit@(OverLit { ol_val = HsIntegral i})))
290 neg_expr)
291 = do { expr' <- putSrcSpanDsA loc $ do
292 { warnAboutOverflowedOverLit
293 (lit { ol_val = HsIntegral (negateIntegralLit i) })
294 ; dsOverLit lit }
295 ; dsSyntaxExpr neg_expr [expr'] }
296
297 dsExpr (NegApp _ expr neg_expr)
298 = do { expr' <- dsLExpr expr
299 ; dsSyntaxExpr neg_expr [expr'] }
300
301 dsExpr (HsLam _ a_Match)
302 = uncurry mkLams <$> matchWrapper LambdaExpr Nothing a_Match
303
304 dsExpr (HsLamCase _ matches)
305 = do { ([discrim_var], matching_code) <- matchWrapper CaseAlt Nothing matches
306 ; return $ Lam discrim_var matching_code }
307
308 dsExpr e@(HsApp _ fun arg)
309 = do { fun' <- dsLExpr fun
310 ; arg' <- dsLExpr arg
311 ; return $ mkCoreAppDs (text "HsApp" <+> ppr e) fun' arg' }
312
313 dsExpr e@(HsAppType {}) = dsHsWrapped e
314
315 {-
316 Note [Desugaring vars]
317 ~~~~~~~~~~~~~~~~~~~~~~
318 In one situation we can get a *coercion* variable in a HsVar, namely
319 the support method for an equality superclass:
320 class (a~b) => C a b where ...
321 instance (blah) => C (T a) (T b) where ..
322 Then we get
323 $dfCT :: forall ab. blah => C (T a) (T b)
324 $dfCT ab blah = MkC ($c$p1C a blah) ($cop a blah)
325
326 $c$p1C :: forall ab. blah => (T a ~ T b)
327 $c$p1C ab blah = let ...; g :: T a ~ T b = ... } in g
328
329 That 'g' in the 'in' part is an evidence variable, and when
330 converting to core it must become a CO.
331 -}
332
333 dsExpr (ExplicitTuple _ tup_args boxity)
334 = do { let go (lam_vars, args) (Missing (Scaled mult ty))
335 -- For every missing expression, we need
336 -- another lambda in the desugaring.
337 = do { lam_var <- newSysLocalDs mult ty
338 ; return (lam_var : lam_vars, Var lam_var : args) }
339 go (lam_vars, args) (Present _ expr)
340 -- Expressions that are present don't generate
341 -- lambdas, just arguments.
342 = do { core_expr <- dsLExpr expr
343 ; return (lam_vars, core_expr : args) }
344
345 ; (lam_vars, args) <- foldM go ([], []) (reverse tup_args)
346 -- The reverse is because foldM goes left-to-right
347 ; return $ mkCoreLams lam_vars (mkCoreTupBoxity boxity args) }
348 -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make
349
350 dsExpr (ExplicitSum types alt arity expr)
351 = mkCoreUbxSum arity alt types <$> dsLExpr expr
352
353 dsExpr (HsPragE _ prag expr) =
354 ds_prag_expr prag expr
355
356 dsExpr (HsCase _ discrim matches)
357 = do { core_discrim <- dsLExpr discrim
358 ; ([discrim_var], matching_code) <- matchWrapper CaseAlt (Just discrim) matches
359 ; return (bindNonRec discrim_var core_discrim matching_code) }
360
361 -- Pepe: The binds are in scope in the body but NOT in the binding group
362 -- This is to avoid silliness in breakpoints
363 dsExpr (HsLet _ _ binds _ body) = do
364 body' <- dsLExpr body
365 dsLocalBinds binds body'
366
367 -- We need the `ListComp' form to use `deListComp' (rather than the "do" form)
368 -- because the interpretation of `stmts' depends on what sort of thing it is.
369 --
370 dsExpr (HsDo res_ty ListComp (L _ stmts)) = dsListComp stmts res_ty
371 dsExpr (HsDo _ ctx@DoExpr{} (L _ stmts)) = dsDo ctx stmts
372 dsExpr (HsDo _ ctx@GhciStmtCtxt (L _ stmts)) = dsDo ctx stmts
373 dsExpr (HsDo _ ctx@MDoExpr{} (L _ stmts)) = dsDo ctx stmts
374 dsExpr (HsDo _ MonadComp (L _ stmts)) = dsMonadComp stmts
375
376 dsExpr (HsIf _ guard_expr then_expr else_expr)
377 = do { pred <- dsLExpr guard_expr
378 ; b1 <- dsLExpr then_expr
379 ; b2 <- dsLExpr else_expr
380 ; return $ mkIfThenElse pred b1 b2 }
381
382 dsExpr (HsMultiIf res_ty alts)
383 | null alts
384 = mkErrorExpr
385
386 | otherwise
387 = do { let grhss = GRHSs emptyComments alts emptyLocalBinds
388 ; rhss_nablas <- pmcGRHSs IfAlt grhss
389 ; match_result <- dsGRHSs IfAlt grhss res_ty rhss_nablas
390 ; error_expr <- mkErrorExpr
391 ; extractMatchResult match_result error_expr }
392 where
393 mkErrorExpr = mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID res_ty
394 (text "multi-way if")
395
396 {-
397 \noindent
398 \underline{\bf Various data construction things}
399 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
400 -}
401
402 dsExpr (ExplicitList elt_ty xs) = dsExplicitList elt_ty xs
403
404 dsExpr (ArithSeq expr witness seq)
405 = case witness of
406 Nothing -> dsArithSeq expr seq
407 Just fl -> do { newArithSeq <- dsArithSeq expr seq
408 ; dsSyntaxExpr fl [newArithSeq] }
409
410 {-
411 Static Pointers
412 ~~~~~~~~~~~~~~~
413
414 See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable for an overview.
415
416 g = ... static f ...
417 ==>
418 g = ... makeStatic loc f ...
419 -}
420
421 dsExpr (HsStatic _ expr@(L loc _)) = do
422 expr_ds <- dsLExpr expr
423 let ty = exprType expr_ds
424 makeStaticId <- dsLookupGlobalId makeStaticName
425
426 dflags <- getDynFlags
427 let platform = targetPlatform dflags
428 let (line, col) = case locA loc of
429 RealSrcSpan r _ ->
430 ( srcLocLine $ realSrcSpanStart r
431 , srcLocCol $ realSrcSpanStart r
432 )
433 _ -> (0, 0)
434 srcLoc = mkCoreConApps (tupleDataCon Boxed 2)
435 [ Type intTy , Type intTy
436 , mkIntExprInt platform line, mkIntExprInt platform col
437 ]
438
439 putSrcSpanDsA loc $ return $
440 mkCoreApps (Var makeStaticId) [ Type ty, srcLoc, expr_ds ]
441
442 {-
443 \noindent
444 \underline{\bf Record construction and update}
445 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
446 For record construction we do this (assuming T has three arguments)
447 \begin{verbatim}
448 T { op2 = e }
449 ==>
450 let err = /\a -> recConErr a
451 T (recConErr t1 "M.hs/230/op1")
452 e
453 (recConErr t1 "M.hs/230/op3")
454 \end{verbatim}
455 @recConErr@ then converts its argument string into a proper message
456 before printing it as
457 \begin{verbatim}
458 M.hs, line 230: missing field op1 was evaluated
459 \end{verbatim}
460
461 We also handle @C{}@ as valid construction syntax for an unlabelled
462 constructor @C@, setting all of @C@'s fields to bottom.
463 -}
464
465 dsExpr (RecordCon { rcon_con = L _ con_like
466 , rcon_flds = rbinds
467 , rcon_ext = con_expr })
468 = do { con_expr' <- dsExpr con_expr
469 ; let
470 (arg_tys, _) = tcSplitFunTys (exprType con_expr')
471 -- A newtype in the corner should be opaque;
472 -- hence TcType.tcSplitFunTys
473
474 mk_arg (arg_ty, fl)
475 = case findField (rec_flds rbinds) (flSelector fl) of
476 (rhs:rhss) -> assert (null rhss)
477 dsLExpr rhs
478 [] -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (ppr (flLabel fl))
479 unlabelled_bottom arg_ty = mkErrorAppDs rEC_CON_ERROR_ID arg_ty Outputable.empty
480
481 labels = conLikeFieldLabels con_like
482
483 ; con_args <- if null labels
484 then mapM unlabelled_bottom (map scaledThing arg_tys)
485 else mapM mk_arg (zipEqual "dsExpr:RecordCon" (map scaledThing arg_tys) labels)
486
487 ; return (mkCoreApps con_expr' con_args) }
488
489 {-
490 Record update is a little harder. Suppose we have the decl:
491 \begin{verbatim}
492 data T = T1 {op1, op2, op3 :: Int}
493 | T2 {op4, op2 :: Int}
494 | T3
495 \end{verbatim}
496 Then we translate as follows:
497 \begin{verbatim}
498 r { op2 = e }
499 ===>
500 let op2 = e in
501 case r of
502 T1 op1 _ op3 -> T1 op1 op2 op3
503 T2 op4 _ -> T2 op4 op2
504 other -> recUpdError "M.hs/230"
505 \end{verbatim}
506 It's important that we use the constructor Ids for @T1@, @T2@ etc on the
507 RHSs, and do not generate a Core constructor application directly, because the constructor
508 might do some argument-evaluation first; and may have to throw away some
509 dictionaries.
510
511 Note [Update for GADTs]
512 ~~~~~~~~~~~~~~~~~~~~~~~
513 Consider
514 data T a b where
515 MkT :: { foo :: a } -> T a Int
516
517 upd :: T s t -> s -> T s t
518 upd z y = z { foo = y}
519
520 We need to get this:
521 $WMkT :: a -> T a Int
522 MkT :: (b ~# Int) => a -> T a b
523
524 upd = /\s t. \(z::T s t) (y::s) ->
525 case z of
526 MkT (co :: t ~# Int) _ -> $WMkT @s y |> T (Refl s) (Sym co)
527
528 Note the final cast
529 T (Refl s) (Sym co) :: T s Int ~ T s t
530 which uses co, bound by the GADT match. This is the wrap_co coercion
531 in wrapped_rhs. How do we produce it?
532
533 * Start with raw materials
534 tc, the tycon: T
535 univ_tvs, the universally quantified tyvars of MkT: a,b
536 NB: these are in 1-1 correspondence with the tyvars of tc
537
538 * Form univ_cos, a coercion for each of tc's args: (Refl s) (Sym co)
539 We replaced
540 a by (Refl s) since 's' instantiates 'a'
541 b by (Sym co) since 'b' is in the data-con's EqSpec
542
543 * Then form the coercion T (Refl s) (Sym co)
544
545 It gets more complicated when data families are involved (#18809).
546 Consider
547 data family F x
548 data instance F (a,b) where
549 MkF :: { foo :: Int } -> F (Int,b)
550
551 bar :: F (s,t) -> Int -> F (s,t)
552 bar z y = z { foo = y}
553
554 We have
555 data R:FPair a b where
556 MkF :: { foo :: Int } -> R:FPair Int b
557
558 $WMkF :: Int -> F (Int,b)
559 MkF :: forall a b. (a ~# Int) => Int -> R:FPair a b
560
561 bar :: F (s,t) -> Int -> F (s,t)
562 bar = /\s t. \(z::F (s,t)) \(y::Int) ->
563 case z |> co1 of
564 MkF (co2::s ~# Int) _ -> $WMkF @t y |> co3
565
566 (Side note: here (z |> co1) is built by typechecking the scrutinee, so
567 we ignore it here. In general the scrutinee is an arbitrary expression.)
568
569 The question is: what is co3, the cast for the RHS?
570 co3 :: F (Int,t) ~ F (s,t)
571 Again, we can construct it using co2, bound by the GADT match.
572 We do /exactly/ the same as the non-family case up to building
573 univ_cos. But that gives us
574 rep_tc: R:FPair
575 univ_cos: (Sym co2) (Refl t)
576 But then we use mkTcFamilyTyConAppCo to "lift" this to the coercion
577 we want, namely
578 F (Sym co2, Refl t) :: F (Int,t) ~ F (s,t)
579
580 -}
581
582 dsExpr RecordUpd { rupd_flds = Right _} =
583 -- Not possible due to elimination in the renamer. See Note
584 -- [Handling overloaded and rebindable constructs]
585 panic "The impossible happened"
586 dsExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = Left fields
587 , rupd_ext = RecordUpdTc
588 { rupd_cons = cons_to_upd
589 , rupd_in_tys = in_inst_tys
590 , rupd_out_tys = out_inst_tys
591 , rupd_wrap = dict_req_wrap }} )
592 | null fields
593 = dsLExpr record_expr
594 | otherwise
595 = assertPpr (notNull cons_to_upd) (ppr expr) $
596
597 do { record_expr' <- dsLExpr record_expr
598 ; field_binds' <- mapM ds_field fields
599 ; let upd_fld_env :: NameEnv Id -- Maps field name to the LocalId of the field binding
600 upd_fld_env = mkNameEnv [(f,l) | (f,l,_) <- field_binds']
601
602 -- It's important to generate the match with matchWrapper,
603 -- and the right hand sides with applications of the wrapper Id
604 -- so that everything works when we are doing fancy unboxing on the
605 -- constructor arguments.
606 ; alts <- mapM (mk_alt upd_fld_env) cons_to_upd
607 ; ([discrim_var], matching_code)
608 <- matchWrapper RecUpd (Just record_expr) -- See Note [Scrutinee in Record updates]
609 (MG { mg_alts = noLocA alts
610 , mg_ext = MatchGroupTc [unrestricted in_ty] out_ty
611 , mg_origin = FromSource
612 })
613 -- FromSource is not strictly right, but we
614 -- want incomplete pattern-match warnings
615
616 ; return (add_field_binds field_binds' $
617 bindNonRec discrim_var record_expr' matching_code) }
618 where
619 ds_field :: LHsRecUpdField GhcTc -> DsM (Name, Id, CoreExpr)
620 -- Clone the Id in the HsRecField, because its Name is that
621 -- of the record selector, and we must not make that a local binder
622 -- else we shadow other uses of the record selector
623 -- Hence 'lcl_id'. Cf #2735
624 ds_field (L _ rec_field)
625 = do { rhs <- dsLExpr (hfbRHS rec_field)
626 ; let fld_id = unLoc (hsRecUpdFieldId rec_field)
627 ; lcl_id <- newSysLocalDs (idMult fld_id) (idType fld_id)
628 ; return (idName fld_id, lcl_id, rhs) }
629
630 add_field_binds [] expr = expr
631 add_field_binds ((_,b,r):bs) expr = bindNonRec b r (add_field_binds bs expr)
632
633 -- Awkwardly, for families, the match goes
634 -- from instance type to family type
635 (in_ty, out_ty) =
636 case (head cons_to_upd) of
637 RealDataCon data_con ->
638 let tycon = dataConTyCon data_con in
639 (mkTyConApp tycon in_inst_tys, mkFamilyTyConApp tycon out_inst_tys)
640 PatSynCon pat_syn ->
641 ( patSynInstResTy pat_syn in_inst_tys
642 , patSynInstResTy pat_syn out_inst_tys)
643 mk_alt upd_fld_env con
644 = do { let (univ_tvs, ex_tvs, eq_spec,
645 prov_theta, _req_theta, arg_tys, _) = conLikeFullSig con
646 arg_tys' = map (scaleScaled Many) arg_tys
647 -- Record updates consume the source record with multiplicity
648 -- Many. Therefore all the fields need to be scaled thus.
649 user_tvs = binderVars $ conLikeUserTyVarBinders con
650
651 in_subst :: TCvSubst
652 in_subst = extendTCvInScopeList (zipTvSubst univ_tvs in_inst_tys) ex_tvs
653 -- The in_subst clones the universally quantified type
654 -- variables. It will be used to substitute into types that
655 -- contain existentials, however, so make sure to extend the
656 -- in-scope set with ex_tvs (#20278).
657
658 out_tv_env :: TvSubstEnv
659 out_tv_env = zipTyEnv univ_tvs out_inst_tys
660
661 -- I'm not bothering to clone the ex_tvs
662 ; eqs_vars <- mapM newPredVarDs (substTheta in_subst (eqSpecPreds eq_spec))
663 ; theta_vars <- mapM newPredVarDs (substTheta in_subst prov_theta)
664 ; arg_ids <- newSysLocalsDs (substScaledTysUnchecked in_subst arg_tys')
665 ; let field_labels = conLikeFieldLabels con
666 val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg
667 field_labels arg_ids
668 mk_val_arg fl pat_arg_id
669 = nlHsVar (lookupNameEnv upd_fld_env (flSelector fl) `orElse` pat_arg_id)
670
671 inst_con = noLocA $ mkHsWrap wrap (mkConLikeTc con)
672 -- Reconstruct with the WrapId so that unpacking happens
673 wrap = mkWpEvVarApps theta_vars <.>
674 dict_req_wrap <.>
675 mkWpTyApps [ lookupVarEnv out_tv_env tv
676 `orElse` mkTyVarTy tv
677 | tv <- user_tvs ]
678 -- Be sure to use user_tvs (which may be ordered
679 -- differently than `univ_tvs ++ ex_tvs) above.
680 -- See Note [DataCon user type variable binders]
681 -- in GHC.Core.DataCon.
682 rhs = foldl' (\a b -> nlHsApp a b) inst_con val_args
683
684 -- Tediously wrap the application in a cast
685 -- Note [Update for GADTs]
686 wrapped_rhs =
687 case con of
688 RealDataCon data_con
689 | null eq_spec -> rhs
690 | otherwise -> mkLHsWrap (mkWpCastN wrap_co) rhs
691 -- This wrap is the punchline: Note [Update for GADTs]
692 where
693 rep_tc = dataConTyCon data_con
694 wrap_co = mkTcFamilyTyConAppCo rep_tc univ_cos
695 univ_cos = zipWithEqual "dsExpr:upd" mk_univ_co univ_tvs out_inst_tys
696
697 mk_univ_co :: TyVar -- Universal tyvar from the DataCon
698 -> Type -- Corresponding instantiating type
699 -> Coercion
700 mk_univ_co univ_tv inst_ty
701 = case lookupVarEnv eq_spec_env univ_tv of
702 Just co -> co
703 Nothing -> mkTcNomReflCo inst_ty
704
705 eq_spec_env :: VarEnv Coercion
706 eq_spec_env = mkVarEnv [ (eqSpecTyVar spec, mkTcSymCo (mkTcCoVarCo eqs_var))
707 | (spec,eqs_var) <- zipEqual "dsExpr:upd2" eq_spec eqs_vars ]
708
709 -- eq_spec is always null for a PatSynCon
710 PatSynCon _ -> rhs
711
712
713 req_wrap = dict_req_wrap <.> mkWpTyApps in_inst_tys
714
715 pat = noLocA $ ConPat { pat_con = noLocA con
716 , pat_args = PrefixCon [] $ map nlVarPat arg_ids
717 , pat_con_ext = ConPatTc
718 { cpt_tvs = ex_tvs
719 , cpt_dicts = eqs_vars ++ theta_vars
720 , cpt_binds = emptyTcEvBinds
721 , cpt_arg_tys = in_inst_tys
722 , cpt_wrap = req_wrap
723 }
724 }
725 ; return (mkSimpleMatch RecUpd [pat] wrapped_rhs) }
726
727 {- Note [Scrutinee in Record updates]
728 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
729 Consider #17783:
730
731 data PartialRec = No
732 | Yes { a :: Int, b :: Bool }
733 update No = No
734 update r@(Yes {}) = r { b = False }
735
736 In the context of pattern-match checking, the occurrence of @r@ in
737 @r { b = False }@ is to be treated as if it was a scrutinee, as can be seen by
738 the following desugaring:
739
740 r { b = False } ==> case r of Yes a b -> Yes a False
741
742 Thus, we pass @r@ as the scrutinee expression to @matchWrapper@ above.
743 -}
744
745 -- Here is where we desugar the Template Haskell brackets and escapes
746
747 -- Template Haskell stuff
748
749 dsExpr (HsRnBracketOut x _ _) = dataConCantHappen x
750 dsExpr (HsTcBracketOut _ hs_wrapper x ps) = dsBracket hs_wrapper x ps
751 dsExpr (HsSpliceE _ s) = pprPanic "dsExpr:splice" (ppr s)
752
753 -- Arrow notation extension
754 dsExpr (HsProc _ pat cmd) = dsProcExpr pat cmd
755
756
757 -- HsSyn constructs that just shouldn't be here, because
758 -- the renamer removed them. See GHC.Rename.Expr.
759 -- Note [Handling overloaded and rebindable constructs]
760 dsExpr (HsOverLabel x _) = dataConCantHappen x
761 dsExpr (OpApp x _ _ _) = dataConCantHappen x
762 dsExpr (SectionL x _ _) = dataConCantHappen x
763 dsExpr (SectionR x _ _) = dataConCantHappen x
764 dsExpr (HsBracket x _) = dataConCantHappen x
765
766 ds_prag_expr :: HsPragE GhcTc -> LHsExpr GhcTc -> DsM CoreExpr
767 ds_prag_expr (HsPragSCC _ _ cc) expr = do
768 dflags <- getDynFlags
769 if sccProfilingEnabled dflags
770 then do
771 mod_name <- getModule
772 count <- goptM Opt_ProfCountEntries
773 let nm = sl_fs cc
774 flavour <- ExprCC <$> getCCIndexDsM nm
775 Tick (ProfNote (mkUserCC nm mod_name (getLocA expr) flavour) count True)
776 <$> dsLExpr expr
777 else dsLExpr expr
778
779 ------------------------------
780 dsSyntaxExpr :: SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr
781 dsSyntaxExpr (SyntaxExprTc { syn_expr = expr
782 , syn_arg_wraps = arg_wraps
783 , syn_res_wrap = res_wrap })
784 arg_exprs
785 = do { fun <- dsExpr expr
786 ; core_arg_wraps <- mapM dsHsWrapper arg_wraps
787 ; core_res_wrap <- dsHsWrapper res_wrap
788 ; let wrapped_args = zipWithEqual "dsSyntaxExpr" ($) core_arg_wraps arg_exprs
789 ; return $ core_res_wrap (mkCoreApps fun wrapped_args) }
790 dsSyntaxExpr NoSyntaxExprTc _ = panic "dsSyntaxExpr"
791
792 findField :: [LHsRecField GhcTc arg] -> Name -> [arg]
793 findField rbinds sel
794 = [hfbRHS fld | L _ fld <- rbinds
795 , sel == idName (hsRecFieldId fld) ]
796
797 {-
798 %--------------------------------------------------------------------
799
800 Note [Desugaring explicit lists]
801 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
802 Explicit lists are desugared in a cleverer way to prevent some
803 fruitless allocations. Essentially, whenever we see a list literal
804 [x_1, ..., x_n] we generate the corresponding expression in terms of
805 build:
806
807 Explicit lists (literals) are desugared to allow build/foldr fusion when
808 beneficial. This is a bit of a trade-off,
809
810 * build/foldr fusion can generate far larger code than the corresponding
811 cons-chain (e.g. see #11707)
812
813 * even when it doesn't produce more code, build can still fail to fuse,
814 requiring that the simplifier do more work to bring the expression
815 back into cons-chain form; this costs compile time
816
817 * when it works, fusion can be a significant win. Allocations are reduced
818 by up to 25% in some nofib programs. Specifically,
819
820 Program Size Allocs Runtime CompTime
821 rewrite +0.0% -26.3% 0.02 -1.8%
822 ansi -0.3% -13.8% 0.00 +0.0%
823 lift +0.0% -8.7% 0.00 -2.3%
824
825 At the moment we use a simple heuristic to determine whether build will be
826 fruitful: for small lists we assume the benefits of fusion will be worthwhile;
827 for long lists we assume that the benefits will be outweighted by the cost of
828 code duplication. This magic length threshold is @maxBuildLength@. Also, fusion
829 won't work at all if rewrite rules are disabled, so we don't use the build-based
830 desugaring in this case.
831
832 We used to have a more complex heuristic which would try to break the list into
833 "static" and "dynamic" parts and only build-desugar the dynamic part.
834 Unfortunately, determining "static-ness" reliably is a bit tricky and the
835 heuristic at times produced surprising behavior (see #11710) so it was dropped.
836 -}
837
838 {- | The longest list length which we will desugar using @build@.
839
840 This is essentially a magic number and its setting is unfortunate rather
841 arbitrary. The idea here, as mentioned in Note [Desugaring explicit lists],
842 is to avoid deforesting large static data into large(r) code. Ideally we'd
843 want a smaller threshold with larger consumers and vice-versa, but we have no
844 way of knowing what will be consuming our list in the desugaring impossible to
845 set generally correctly.
846
847 The effect of reducing this number will be that 'build' fusion is applied
848 less often. From a runtime performance perspective, applying 'build' more
849 liberally on "moderately" sized lists should rarely hurt and will often it can
850 only expose further optimization opportunities; if no fusion is possible it will
851 eventually get rule-rewritten back to a list). We do, however, pay in compile
852 time.
853 -}
854 maxBuildLength :: Int
855 maxBuildLength = 32
856
857 dsExplicitList :: Type -> [LHsExpr GhcTc]
858 -> DsM CoreExpr
859 -- See Note [Desugaring explicit lists]
860 dsExplicitList elt_ty xs
861 = do { dflags <- getDynFlags
862 ; xs' <- mapM dsLExpr xs
863 ; if xs' `lengthExceeds` maxBuildLength
864 -- Don't generate builds if the list is very long.
865 || null xs'
866 -- Don't generate builds when the [] constructor will do
867 || not (gopt Opt_EnableRewriteRules dflags) -- Rewrite rules off
868 -- Don't generate a build if there are no rules to eliminate it!
869 -- See Note [Desugaring RULE left hand sides] in GHC.HsToCore
870 then return $ mkListExpr elt_ty xs'
871 else mkBuildExpr elt_ty (mk_build_list xs') }
872 where
873 mk_build_list xs' (cons, _) (nil, _)
874 = return (foldr (App . App (Var cons)) (Var nil) xs')
875
876 dsArithSeq :: PostTcExpr -> (ArithSeqInfo GhcTc) -> DsM CoreExpr
877 dsArithSeq expr (From from)
878 = App <$> dsExpr expr <*> dsLExpr from
879 dsArithSeq expr (FromTo from to)
880 = do fam_envs <- dsGetFamInstEnvs
881 dflags <- getDynFlags
882 warnAboutEmptyEnumerations fam_envs dflags from Nothing to
883 expr' <- dsExpr expr
884 from' <- dsLExpr from
885 to' <- dsLExpr to
886 return $ mkApps expr' [from', to']
887 dsArithSeq expr (FromThen from thn)
888 = mkApps <$> dsExpr expr <*> mapM dsLExpr [from, thn]
889 dsArithSeq expr (FromThenTo from thn to)
890 = do fam_envs <- dsGetFamInstEnvs
891 dflags <- getDynFlags
892 warnAboutEmptyEnumerations fam_envs dflags from (Just thn) to
893 expr' <- dsExpr expr
894 from' <- dsLExpr from
895 thn' <- dsLExpr thn
896 to' <- dsLExpr to
897 return $ mkApps expr' [from', thn', to']
898
899 {-
900 Desugar 'do' and 'mdo' expressions (NOT list comprehensions, they're
901 handled in GHC.HsToCore.ListComp). Basically does the translation given in the
902 Haskell 98 report:
903 -}
904
905 dsDo :: HsDoFlavour -> [ExprLStmt GhcTc] -> DsM CoreExpr
906 dsDo ctx stmts
907 = goL stmts
908 where
909 goL [] = panic "dsDo"
910 goL ((L loc stmt):lstmts) = putSrcSpanDsA loc (go loc stmt lstmts)
911
912 go _ (LastStmt _ body _ _) stmts
913 = assert (null stmts ) dsLExpr body
914 -- The 'return' op isn't used for 'do' expressions
915
916 go _ (BodyStmt _ rhs then_expr _) stmts
917 = do { rhs2 <- dsLExpr rhs
918 ; warnDiscardedDoBindings rhs (exprType rhs2)
919 ; rest <- goL stmts
920 ; dsSyntaxExpr then_expr [rhs2, rest] }
921
922 go _ (LetStmt _ binds) stmts
923 = do { rest <- goL stmts
924 ; dsLocalBinds binds rest }
925
926 go _ (BindStmt xbs pat rhs) stmts
927 = do { body <- goL stmts
928 ; rhs' <- dsLExpr rhs
929 ; var <- selectSimpleMatchVarL (xbstc_boundResultMult xbs) pat
930 ; match <- matchSinglePatVar var Nothing (StmtCtxt (HsDoStmt ctx)) pat
931 (xbstc_boundResultType xbs) (cantFailMatchResult body)
932 ; match_code <- dsHandleMonadicFailure ctx pat match (xbstc_failOp xbs)
933 ; dsSyntaxExpr (xbstc_bindOp xbs) [rhs', Lam var match_code] }
934
935 go _ (ApplicativeStmt body_ty args mb_join) stmts
936 = do {
937 let
938 (pats, rhss) = unzip (map (do_arg . snd) args)
939
940 do_arg (ApplicativeArgOne fail_op pat expr _) =
941 ((pat, fail_op), dsLExpr expr)
942 do_arg (ApplicativeArgMany _ stmts ret pat _) =
943 ((pat, Nothing), dsDo ctx (stmts ++ [noLocA $ mkLastStmt (noLocA ret)]))
944
945 ; rhss' <- sequence rhss
946
947 ; body' <- dsLExpr $ noLocA $ HsDo body_ty ctx (noLocA stmts)
948
949 ; let match_args (pat, fail_op) (vs,body)
950 = do { var <- selectSimpleMatchVarL Many pat
951 ; match <- matchSinglePatVar var Nothing (StmtCtxt (HsDoStmt ctx)) pat
952 body_ty (cantFailMatchResult body)
953 ; match_code <- dsHandleMonadicFailure ctx pat match fail_op
954 ; return (var:vs, match_code)
955 }
956
957 ; (vars, body) <- foldrM match_args ([],body') pats
958 ; let fun' = mkLams vars body
959 ; let mk_ap_call l (op,r) = dsSyntaxExpr op [l,r]
960 ; expr <- foldlM mk_ap_call fun' (zip (map fst args) rhss')
961 ; case mb_join of
962 Nothing -> return expr
963 Just join_op -> dsSyntaxExpr join_op [expr] }
964
965 go loc (RecStmt { recS_stmts = L _ rec_stmts, recS_later_ids = later_ids
966 , recS_rec_ids = rec_ids, recS_ret_fn = return_op
967 , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op
968 , recS_ext = RecStmtTc
969 { recS_bind_ty = bind_ty
970 , recS_rec_rets = rec_rets
971 , recS_ret_ty = body_ty} }) stmts
972 = goL (new_bind_stmt : stmts) -- rec_ids can be empty; eg rec { print 'x' }
973 where
974 new_bind_stmt = L loc $ BindStmt
975 XBindStmtTc
976 { xbstc_bindOp = bind_op
977 , xbstc_boundResultType = bind_ty
978 , xbstc_boundResultMult = Many
979 , xbstc_failOp = Nothing -- Tuple cannot fail
980 }
981 (mkBigLHsPatTupId later_pats)
982 mfix_app
983
984 tup_ids = rec_ids ++ filterOut (`elem` rec_ids) later_ids
985 tup_ty = mkBigCoreTupTy (map idType tup_ids) -- Deals with singleton case
986 rec_tup_pats = map nlVarPat tup_ids
987 later_pats = rec_tup_pats
988 rets = map noLocA rec_rets
989 mfix_app = nlHsSyntaxApps mfix_op [mfix_arg]
990 mfix_arg = noLocA $ HsLam noExtField
991 (MG { mg_alts = noLocA [mkSimpleMatch
992 LambdaExpr
993 [mfix_pat] body]
994 , mg_ext = MatchGroupTc [unrestricted tup_ty] body_ty
995 , mg_origin = Generated })
996 mfix_pat = noLocA $ LazyPat noExtField $ mkBigLHsPatTupId rec_tup_pats
997 body = noLocA $ HsDo body_ty
998 ctx (noLocA (rec_stmts ++ [ret_stmt]))
999 ret_app = nlHsSyntaxApps return_op [mkBigLHsTupId rets]
1000 ret_stmt = noLocA $ mkLastStmt ret_app
1001 -- This LastStmt will be desugared with dsDo,
1002 -- which ignores the return_op in the LastStmt,
1003 -- so we must apply the return_op explicitly
1004
1005 go _ (ParStmt {}) _ = panic "dsDo ParStmt"
1006 go _ (TransStmt {}) _ = panic "dsDo TransStmt"
1007
1008 {-
1009 ************************************************************************
1010 * *
1011 Desugaring Variables
1012 * *
1013 ************************************************************************
1014 -}
1015
1016 dsHsVar :: Id -> DsM CoreExpr
1017 -- We could just call dsHsUnwrapped; but this is a short-cut
1018 -- for the very common case of a variable with no wrapper.
1019 -- NB: withDict is always instantiated by a wrapper, so we need
1020 -- only check for it in dsHsUnwrapped
1021 dsHsVar var
1022 = return (varToCoreExpr var) -- See Note [Desugaring vars]
1023
1024 dsHsConLike :: ConLike -> DsM CoreExpr
1025 dsHsConLike (RealDataCon dc)
1026 = return (varToCoreExpr (dataConWrapId dc))
1027 dsHsConLike (PatSynCon ps)
1028 | Just (builder_name, _, add_void) <- patSynBuilder ps
1029 = do { builder_id <- dsLookupGlobalId builder_name
1030 ; return (if add_void
1031 then mkCoreApp (text "dsConLike" <+> ppr ps)
1032 (Var builder_id) (Var voidPrimId)
1033 else Var builder_id) }
1034 | otherwise
1035 = pprPanic "dsConLike" (ppr ps)
1036
1037 dsConLike :: ConLike -> [TcInvisTVBinder] -> [Scaled Type] -> DsM CoreExpr
1038 -- This function desugars ConLikeTc
1039 -- See Note [Typechecking data constructors] in GHC.Tc.Gen.Head
1040 -- for what is going on here
1041 dsConLike con tvbs tys
1042 = do { ds_con <- dsHsConLike con
1043 ; ids <- newSysLocalsDs tys
1044 -- newSysLocalDs: /can/ be lev-poly; see
1045 -- Note [Checking representation-polymorphic data constructors]
1046 ; return (mkLams tvs $
1047 mkLams ids $
1048 ds_con `mkTyApps` mkTyVarTys tvs
1049 `mkVarApps` drop_stupid ids) }
1050 where
1051 tvs = binderVars tvbs
1052
1053 drop_stupid = dropList (conLikeStupidTheta con)
1054 -- drop_stupid: see Note [Instantiating stupid theta]
1055 -- in GHC.Tc.Gen.Head
1056
1057 {-
1058 ************************************************************************
1059 * *
1060 \subsection{Errors and contexts}
1061 * *
1062 ************************************************************************
1063 -}
1064
1065 -- Warn about certain types of values discarded in monadic bindings (#3263)
1066 warnDiscardedDoBindings :: LHsExpr GhcTc -> Type -> DsM ()
1067 warnDiscardedDoBindings rhs rhs_ty
1068 | Just (m_ty, elt_ty) <- tcSplitAppTy_maybe rhs_ty
1069 = do { warn_unused <- woptM Opt_WarnUnusedDoBind
1070 ; warn_wrong <- woptM Opt_WarnWrongDoBind
1071 ; when (warn_unused || warn_wrong) $
1072 do { fam_inst_envs <- dsGetFamInstEnvs
1073 ; let norm_elt_ty = topNormaliseType fam_inst_envs elt_ty
1074
1075 -- Warn about discarding non-() things in 'monadic' binding
1076 ; if warn_unused && not (isUnitTy norm_elt_ty)
1077 then diagnosticDs (DsUnusedDoBind rhs elt_ty)
1078 else
1079
1080 -- Warn about discarding m a things in 'monadic' binding of the same type,
1081 -- but only if we didn't already warn due to Opt_WarnUnusedDoBind
1082 when warn_wrong $
1083 case tcSplitAppTy_maybe norm_elt_ty of
1084 Just (elt_m_ty, _)
1085 | m_ty `eqType` topNormaliseType fam_inst_envs elt_m_ty
1086 -> diagnosticDs (DsWrongDoBind rhs elt_ty)
1087 _ -> return () } }
1088
1089 | otherwise -- RHS does have type of form (m ty), which is weird
1090 = return () -- but at least this warning is irrelevant
1091
1092 {-
1093 ************************************************************************
1094 * *
1095 dsHsWrapped and ds_withDict
1096 * *
1097 ************************************************************************
1098 -}
1099
1100 ------------------------------
1101 dsHsWrapped :: HsExpr GhcTc -> DsM CoreExpr
1102 dsHsWrapped orig_hs_expr
1103 = go idHsWrapper orig_hs_expr
1104 where
1105 go wrap (HsPar _ _ (L _ hs_e) _)
1106 = go wrap hs_e
1107 go wrap1 (XExpr (WrapExpr (HsWrap wrap2 hs_e)))
1108 = go (wrap1 <.> wrap2) hs_e
1109 go wrap (HsAppType ty (L _ hs_e) _)
1110 = go (wrap <.> WpTyApp ty) hs_e
1111
1112 go wrap (HsVar _ (L _ var))
1113 | var `hasKey` withDictKey
1114 = do { wrap' <- dsHsWrapper wrap
1115 ; ds_withDict (exprType (wrap' (varToCoreExpr var))) }
1116
1117 | otherwise
1118 = do { wrap' <- dsHsWrapper wrap
1119 ; let expr = wrap' (varToCoreExpr var)
1120 ty = exprType expr
1121 ; dflags <- getDynFlags
1122 ; warnAboutIdentities dflags var ty
1123 ; return expr }
1124
1125 go wrap hs_e
1126 = do { wrap' <- dsHsWrapper wrap
1127 ; addTyCs FromSource (hsWrapDictBinders wrap) $
1128 do { e <- dsExpr hs_e
1129 ; return (wrap' e) } }
1130
1131 -- See Note [withDict]
1132 ds_withDict :: Type -> DsM CoreExpr
1133 ds_withDict wrapped_ty
1134 -- Check that withDict is of the type `st -> (dt => r) -> r`.
1135 | Just (Anon VisArg (Scaled mult1 st), rest) <- splitPiTy_maybe wrapped_ty
1136 , Just (Anon VisArg (Scaled mult2 dt_to_r), _r1) <- splitPiTy_maybe rest
1137 , Just (Anon InvisArg (Scaled _ dt), _r2) <- splitPiTy_maybe dt_to_r
1138 -- Check that dt is a class constraint `C t_1 ... t_n`, where
1139 -- `dict_tc = C` and `dict_args = t_1 ... t_n`.
1140 , Just (dict_tc, dict_args) <- splitTyConApp_maybe dt
1141 -- Check that C is a class of the form
1142 -- `class C a_1 ... a_n where op :: meth_ty`, where
1143 -- `meth_tvs = a_1 ... a_n` and `co` is a newtype coercion between
1144 -- `C` and `meth_ty`.
1145 , Just (inst_meth_ty, co) <- instNewTyCon_maybe dict_tc dict_args
1146 -- Check that `st` is equal to `meth_ty[t_i/a_i]`.
1147 , st `eqType` inst_meth_ty
1148 = do { sv <- newSysLocalDs mult1 st
1149 ; k <- newSysLocalDs mult2 dt_to_r
1150 ; pure $ mkLams [sv, k] $ Var k `App` Cast (Var sv) (mkSymCo co) }
1151
1152 | otherwise
1153 = errDsCoreExpr (DsInvalidInstantiationDictAtType wrapped_ty)
1154
1155 {- Note [withDict]
1156 ~~~~~~~~~~~~~~~~~~
1157 The identifier `withDict` is just a place-holder, which is used to
1158 implement a primitive that we cannot define in Haskell but we can write
1159 in Core. It is declared with a place-holder type:
1160
1161 withDict :: forall {rr :: RuntimeRep} st dt (r :: TYPE rr). st -> (dt => r) -> r
1162
1163 The intention is that the identifier will be used in a very specific way,
1164 to create dictionaries for classes with a single method. Consider a class
1165 like this:
1166
1167 class C a where
1168 f :: T a
1169
1170 We can use `withDict`, in conjunction with a special case in the desugarer, to
1171 cast values of type `T a` into dictionaries for `C a`. To do this, we can
1172 define a function like this in the library:
1173
1174 withT :: T a -> (C a => b) -> b
1175 withT t k = withDict @(T a) @(C a) t k
1176
1177 Here:
1178
1179 * The `dt` in `withDict` (short for "dictionary type") is instantiated to
1180 `C a`.
1181
1182 * The `st` in `withDict` (short for "singleton type") is instantiated to
1183 `T a`. The definition of `T` itself is irrelevant, only that `C a` is a class
1184 with a single method of type `T a`.
1185
1186 * The `r` in `withDict` is instantiated to `b`.
1187
1188 There is a special case in dsHsWrapped.go_head which will replace the RHS
1189 of this definition with an appropriate definition in Core. The special case
1190 rewrites applications of `withDict` as follows:
1191
1192 withDict @{rr} @mtype @(C t_1 ... t_n) @r
1193 ---->
1194 \(sv :: mtype) (k :: C t_1 ... t_n => r) -> k (sv |> sym (co t_1 ... t_n))
1195
1196 Where:
1197
1198 * The `C t_1 ... t_n` argument to withDict is a class constraint.
1199
1200 * C must be defined as:
1201
1202 class C a_1 ... a_n where
1203 op :: meth_type
1204
1205 That is, C must be a class with exactly one method and no superclasses.
1206
1207 * The `mtype` argument to withDict must be equal to `meth_type[t_i/a_i]`,
1208 which is instantied type of C's method.
1209
1210 * `co` is a newtype coercion that, when applied to `t_1 ... t_n`, coerces from
1211 `C t_1 ... t_n` to `mtype`. This coercion is guaranteed to exist by virtue of
1212 the fact that C is a class with exactly one method and no superclasses, so it
1213 is treated like a newtype when compiled to Core.
1214
1215 These requirements are implemented in the guards in ds_withDict's definition.
1216
1217 Some further observations about `withDict`:
1218
1219 * Every use of `withDict` must be instantiated at a /particular/ class C.
1220 It's a bit like representation polymorphism: we don't allow class-polymorphic
1221 calls of `withDict`. We check this in the desugarer -- and then we
1222 can immediately replace this invocation of `withDict` with appropriate
1223 class-specific Core code.
1224
1225 * The `dt` in the type of withDict must be explicitly instantiated with
1226 visible type application, as invoking `withDict` would be ambiguous
1227 otherwise.
1228
1229 * For examples of how `withDict` is used in the `base` library, see `withSNat`
1230 in GHC.TypeNats, as well as `withSChar` and `withSSymbol` n GHC.TypeLits.
1231
1232 * The `r` is representation-polymorphic,
1233 to support things like `withTypeable` in `Data.Typeable.Internal`.
1234
1235 * As an alternative to `withDict`, one could define functions like `withT`
1236 above in terms of `unsafeCoerce`. This is more error-prone, however.
1237
1238 * In order to define things like `reifySymbol` below:
1239
1240 reifySymbol :: forall r. String -> (forall (n :: Symbol). KnownSymbol n => r) -> r
1241
1242 `withDict` needs to be instantiated with `Any`, like so:
1243
1244 reifySymbol n k = withDict @String @(KnownSymbol Any) @r n (k @Any)
1245
1246 The use of `Any` is explained in Note [NOINLINE someNatVal] in
1247 base:GHC.TypeNats.
1248
1249 * The only valid way to apply `withDict` is as described above. Applying
1250 `withDict` in any other way will result in a non-recoverable error during
1251 desugaring. In other words, GHC will never execute the `withDict` function
1252 in compiled code.
1253
1254 In theory, this means that we don't need to define a binding for `withDict`
1255 in GHC.Magic.Dict. In practice, we define a binding anyway, for two reasons:
1256
1257 - To give it Haddocks, and
1258 - To define the type of `withDict`, which GHC can find in
1259 GHC.Magic.Dict.hi.
1260
1261 Because we define a binding for `withDict`, we have to provide a right-hand
1262 side for its definition. We somewhat arbitrarily choose:
1263
1264 withDict = panicError "Non rewritten withDict"#
1265
1266 This should never be reachable anyway, but just in case ds_withDict fails
1267 to rewrite away `withDict`, this ensures that the program won't get very far.
1268
1269 * One could conceivably implement this special case for `withDict` as a
1270 constant-folding rule instead of during desugaring. We choose not to do so
1271 for the following reasons:
1272
1273 - Having a constant-folding rule would require that `withDict`'s definition
1274 be wired in to the compiler so as to prevent `withDict` from inlining too
1275 early. Implementing the special case in the desugarer, on the other hand,
1276 only requires that `withDict` be known-key.
1277
1278 - If the constant-folding rule were to fail, we want to throw a compile-time
1279 error, which is trickier to do with the way that GHC.Core.Opt.ConstantFold
1280 is set up.
1281 -}