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 -}