never executed always true always false
    1 
    2 {-# LANGUAGE DataKinds           #-}
    3 {-# LANGUAGE FlexibleContexts    #-}
    4 {-# LANGUAGE ScopedTypeVariables #-}
    5 {-# LANGUAGE TupleSections       #-}
    6 {-# LANGUAGE TypeFamilies        #-}
    7 {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]
    8                                       -- in module Language.Haskell.Syntax.Extension
    9 {-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}
   10 
   11 {-
   12 %
   13 (c) The University of Glasgow 2006
   14 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   15 
   16 -}
   17 
   18 module GHC.Tc.Gen.Expr
   19        ( tcCheckPolyExpr, tcCheckPolyExprNC,
   20          tcCheckMonoExpr, tcCheckMonoExprNC,
   21          tcMonoExpr, tcMonoExprNC,
   22          tcInferRho, tcInferRhoNC,
   23          tcPolyExpr, tcExpr,
   24          tcSyntaxOp, tcSyntaxOpGen, SyntaxOpType(..), synKnownType,
   25          tcCheckId,
   26          getFixedTyVars ) where
   27 
   28 import GHC.Prelude
   29 
   30 import {-# SOURCE #-}   GHC.Tc.Gen.Splice( tcSpliceExpr, tcTypedBracket, tcUntypedBracket )
   31 
   32 import GHC.Hs
   33 import GHC.Hs.Syn.Type
   34 import GHC.Rename.Utils
   35 import GHC.Tc.Utils.Zonk
   36 import GHC.Tc.Utils.Monad
   37 import GHC.Tc.Utils.Unify
   38 import GHC.Types.Basic
   39 import GHC.Types.Error
   40 import GHC.Core.Multiplicity
   41 import GHC.Core.UsageEnv
   42 import GHC.Tc.Errors.Types
   43 import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep, mkWpFun )
   44 import GHC.Tc.Utils.Instantiate
   45 import GHC.Tc.Gen.App
   46 import GHC.Tc.Gen.Head
   47 import GHC.Tc.Gen.Bind        ( tcLocalBinds )
   48 import GHC.Tc.Instance.Family ( tcGetFamInstEnvs )
   49 import GHC.Core.FamInstEnv    ( FamInstEnvs )
   50 import GHC.Rename.Env         ( addUsedGRE )
   51 import GHC.Tc.Utils.Env
   52 import GHC.Tc.Gen.Arrow
   53 import GHC.Tc.Gen.Match
   54 import GHC.Tc.Gen.HsType
   55 import GHC.Tc.Gen.Pat
   56 import GHC.Tc.Utils.TcMType
   57 import GHC.Tc.Types.Origin
   58 import GHC.Tc.Utils.TcType as TcType
   59 import GHC.Types.Id
   60 import GHC.Types.Id.Info
   61 import GHC.Core.ConLike
   62 import GHC.Core.DataCon
   63 import GHC.Core.PatSyn
   64 import GHC.Types.Name
   65 import GHC.Types.Name.Env
   66 import GHC.Types.Name.Set
   67 import GHC.Types.Name.Reader
   68 import GHC.Core.TyCon
   69 import GHC.Core.Type
   70 import GHC.Tc.Types.Evidence
   71 import GHC.Types.Var.Set
   72 import GHC.Builtin.Types
   73 import GHC.Builtin.Names
   74 import GHC.Driver.Session
   75 import GHC.Types.SrcLoc
   76 import GHC.Utils.Misc
   77 import GHC.Data.List.SetOps
   78 import GHC.Data.Maybe
   79 import GHC.Utils.Outputable as Outputable
   80 import GHC.Utils.Panic
   81 import GHC.Utils.Panic.Plain
   82 import Control.Monad
   83 import GHC.Core.Class(classTyCon)
   84 import GHC.Types.Unique.Set ( UniqSet, mkUniqSet, elementOfUniqSet, nonDetEltsUniqSet )
   85 
   86 import Data.Function
   87 import Data.List (partition, sortBy, groupBy, intersect)
   88 
   89 {-
   90 ************************************************************************
   91 *                                                                      *
   92 \subsection{Main wrappers}
   93 *                                                                      *
   94 ************************************************************************
   95 -}
   96 
   97 
   98 tcCheckPolyExpr, tcCheckPolyExprNC
   99   :: LHsExpr GhcRn         -- Expression to type check
  100   -> TcSigmaType           -- Expected type (could be a polytype)
  101   -> TcM (LHsExpr GhcTc) -- Generalised expr with expected type
  102 
  103 -- tcCheckPolyExpr is a convenient place (frequent but not too frequent)
  104 -- place to add context information.
  105 -- The NC version does not do so, usually because the caller wants
  106 -- to do so themselves.
  107 
  108 tcCheckPolyExpr   expr res_ty = tcPolyLExpr   expr (mkCheckExpType res_ty)
  109 tcCheckPolyExprNC expr res_ty = tcPolyLExprNC expr (mkCheckExpType res_ty)
  110 
  111 -- These versions take an ExpType
  112 tcPolyLExpr, tcPolyLExprNC :: LHsExpr GhcRn -> ExpSigmaType
  113                            -> TcM (LHsExpr GhcTc)
  114 
  115 tcPolyLExpr (L loc expr) res_ty
  116   = setSrcSpanA loc   $  -- Set location /first/; see GHC.Tc.Utils.Monad
  117     addExprCtxt expr $  -- Note [Error contexts in generated code]
  118     do { expr' <- tcPolyExpr expr res_ty
  119        ; return (L loc expr') }
  120 
  121 tcPolyLExprNC (L loc expr) res_ty
  122   = setSrcSpanA loc    $
  123     do { expr' <- tcPolyExpr expr res_ty
  124        ; return (L loc expr') }
  125 
  126 ---------------
  127 tcCheckMonoExpr, tcCheckMonoExprNC
  128     :: LHsExpr GhcRn     -- Expression to type check
  129     -> TcRhoType         -- Expected type
  130                          -- Definitely no foralls at the top
  131     -> TcM (LHsExpr GhcTc)
  132 tcCheckMonoExpr   expr res_ty = tcMonoExpr   expr (mkCheckExpType res_ty)
  133 tcCheckMonoExprNC expr res_ty = tcMonoExprNC expr (mkCheckExpType res_ty)
  134 
  135 tcMonoExpr, tcMonoExprNC
  136     :: LHsExpr GhcRn     -- Expression to type check
  137     -> ExpRhoType        -- Expected type
  138                          -- Definitely no foralls at the top
  139     -> TcM (LHsExpr GhcTc)
  140 
  141 tcMonoExpr (L loc expr) res_ty
  142   = setSrcSpanA loc   $  -- Set location /first/; see GHC.Tc.Utils.Monad
  143     addExprCtxt expr $  -- Note [Error contexts in generated code]
  144     do  { expr' <- tcExpr expr res_ty
  145         ; return (L loc expr') }
  146 
  147 tcMonoExprNC (L loc expr) res_ty
  148   = setSrcSpanA loc $
  149     do  { expr' <- tcExpr expr res_ty
  150         ; return (L loc expr') }
  151 
  152 ---------------
  153 tcInferRho, tcInferRhoNC :: LHsExpr GhcRn -> TcM (LHsExpr GhcTc, TcRhoType)
  154 -- Infer a *rho*-type. The return type is always instantiated.
  155 tcInferRho (L loc expr)
  156   = setSrcSpanA loc   $  -- Set location /first/; see GHC.Tc.Utils.Monad
  157     addExprCtxt expr $  -- Note [Error contexts in generated code]
  158     do { (expr', rho) <- tcInfer (tcExpr expr)
  159        ; return (L loc expr', rho) }
  160 
  161 tcInferRhoNC (L loc expr)
  162   = setSrcSpanA loc $
  163     do { (expr', rho) <- tcInfer (tcExpr expr)
  164        ; return (L loc expr', rho) }
  165 
  166 
  167 {- *********************************************************************
  168 *                                                                      *
  169         tcExpr: the main expression typechecker
  170 *                                                                      *
  171 ********************************************************************* -}
  172 
  173 tcPolyExpr :: HsExpr GhcRn -> ExpSigmaType -> TcM (HsExpr GhcTc)
  174 tcPolyExpr expr res_ty
  175   = do { traceTc "tcPolyExpr" (ppr res_ty)
  176        ; (wrap, expr') <- tcSkolemiseET GenSigCtxt res_ty $ \ res_ty ->
  177                           tcExpr expr res_ty
  178        ; return $ mkHsWrap wrap expr' }
  179 
  180 tcExpr :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
  181 
  182 -- Use tcApp to typecheck appplications, which are treated specially
  183 -- by Quick Look.  Specifically:
  184 --   - HsVar         lone variables, to ensure that they can get an
  185 --                     impredicative instantiation (via Quick Look
  186 --                     driven by res_ty (in checking mode)).
  187 --   - HsApp         value applications
  188 --   - HsAppType     type applications
  189 --   - ExprWithTySig (e :: type)
  190 --   - HsRecSel      overloaded record fields
  191 --   - HsExpanded    renamer expansions
  192 --   - HsOpApp       operator applications
  193 --   - HsOverLit     overloaded literals
  194 -- These constructors are the union of
  195 --   - ones taken apart by GHC.Tc.Gen.Head.splitHsApps
  196 --   - ones understood by GHC.Tc.Gen.Head.tcInferAppHead_maybe
  197 -- See Note [Application chains and heads] in GHC.Tc.Gen.App
  198 tcExpr e@(HsVar {})              res_ty = tcApp e res_ty
  199 tcExpr e@(HsApp {})              res_ty = tcApp e res_ty
  200 tcExpr e@(OpApp {})              res_ty = tcApp e res_ty
  201 tcExpr e@(HsAppType {})          res_ty = tcApp e res_ty
  202 tcExpr e@(ExprWithTySig {})      res_ty = tcApp e res_ty
  203 tcExpr e@(HsRecSel {})           res_ty = tcApp e res_ty
  204 tcExpr e@(XExpr (HsExpanded {})) res_ty = tcApp e res_ty
  205 
  206 tcExpr e@(HsOverLit _ lit) res_ty
  207   = do { mb_res <- tcShortCutLit lit res_ty
  208          -- See Note [Short cut for overloaded literals] in GHC.Tc.Utils.Zonk
  209        ; case mb_res of
  210            Just lit' -> return (HsOverLit noAnn lit')
  211            Nothing   -> tcApp e res_ty }
  212 
  213 -- Typecheck an occurrence of an unbound Id
  214 --
  215 -- Some of these started life as a true expression hole "_".
  216 -- Others might simply be variables that accidentally have no binding site
  217 tcExpr (HsUnboundVar _ occ) res_ty
  218   = do { ty <- expTypeToType res_ty    -- Allow Int# etc (#12531)
  219        ; her <- emitNewExprHole occ ty
  220        ; tcEmitBindingUsage bottomUE   -- Holes fit any usage environment
  221                                        -- (#18491)
  222        ; return (HsUnboundVar her occ) }
  223 
  224 tcExpr e@(HsLit x lit) res_ty
  225   = do { let lit_ty = hsLitType lit
  226        ; tcWrapResult e (HsLit x (convertLit lit)) lit_ty res_ty }
  227 
  228 tcExpr (HsPar x lpar expr rpar) res_ty
  229   = do { expr' <- tcMonoExprNC expr res_ty
  230        ; return (HsPar x lpar expr' rpar) }
  231 
  232 tcExpr (HsPragE x prag expr) res_ty
  233   = do { expr' <- tcMonoExpr expr res_ty
  234        ; return (HsPragE x (tcExprPrag prag) expr') }
  235 
  236 tcExpr (NegApp x expr neg_expr) res_ty
  237   = do  { (expr', neg_expr')
  238             <- tcSyntaxOp NegateOrigin neg_expr [SynAny] res_ty $
  239                \[arg_ty] [arg_mult] ->
  240                tcScalingUsage arg_mult $ tcCheckMonoExpr expr arg_ty
  241         ; return (NegApp x expr' neg_expr') }
  242 
  243 tcExpr e@(HsIPVar _ x) res_ty
  244   = do {   {- Implicit parameters must have a *tau-type* not a
  245               type scheme.  We enforce this by creating a fresh
  246               type variable as its type.  (Because res_ty may not
  247               be a tau-type.) -}
  248          ip_ty <- newOpenFlexiTyVarTy
  249        ; let ip_name = mkStrLitTy (hsIPNameFS x)
  250        ; ipClass <- tcLookupClass ipClassName
  251        ; ip_var <- emitWantedEvVar origin (mkClassPred ipClass [ip_name, ip_ty])
  252        ; tcWrapResult e
  253                    (fromDict ipClass ip_name ip_ty (HsVar noExtField (noLocA ip_var)))
  254                    ip_ty res_ty }
  255   where
  256   -- Coerces a dictionary for `IP "x" t` into `t`.
  257   fromDict ipClass x ty = mkHsWrap $ mkWpCastR $
  258                           unwrapIP $ mkClassPred ipClass [x,ty]
  259   origin = IPOccOrigin x
  260 
  261 tcExpr (HsLam _ match) res_ty
  262   = do  { (wrap, match') <- tcMatchLambda herald match_ctxt match res_ty
  263         ; return (mkHsWrap wrap (HsLam noExtField match')) }
  264   where
  265     match_ctxt = MC { mc_what = LambdaExpr, mc_body = tcBody }
  266     herald = sep [ text "The lambda expression" <+>
  267                    quotes (pprSetDepth (PartWay 1) $
  268                            pprMatches match),
  269                         -- The pprSetDepth makes the abstraction print briefly
  270                    text "has"]
  271 
  272 tcExpr e@(HsLamCase x matches) res_ty
  273   = do { (wrap, matches')
  274            <- tcMatchLambda msg match_ctxt matches res_ty
  275            -- The laziness annotation is because we don't want to fail here
  276            -- if there are multiple arguments
  277        ; return (mkHsWrap wrap $ HsLamCase x matches') }
  278   where
  279     msg = sep [ text "The function" <+> quotes (ppr e)
  280               , text "requires"]
  281     match_ctxt = MC { mc_what = CaseAlt, mc_body = tcBody }
  282 
  283 
  284 
  285 {-
  286 ************************************************************************
  287 *                                                                      *
  288                 Explicit lists
  289 *                                                                      *
  290 ************************************************************************
  291 -}
  292 
  293 -- Explict lists [e1,e2,e3] have been expanded already in the renamer
  294 -- The expansion includes an ExplicitList, but it is always the built-in
  295 -- list type, so that's all we need concern ourselves with here.  See
  296 -- GHC.Rename.Expr. Note [Handling overloaded and rebindable constructs]
  297 tcExpr (ExplicitList _ exprs) res_ty
  298   = do  { res_ty <- expTypeToType res_ty
  299         ; (coi, elt_ty) <- matchExpectedListTy res_ty
  300         ; let tc_elt expr = tcCheckPolyExpr expr elt_ty
  301         ; exprs' <- mapM tc_elt exprs
  302         ; return $ mkHsWrapCo coi $ ExplicitList elt_ty exprs' }
  303 
  304 tcExpr expr@(ExplicitTuple x tup_args boxity) res_ty
  305   | all tupArgPresent tup_args
  306   = do { let arity  = length tup_args
  307              tup_tc = tupleTyCon boxity arity
  308                -- NB: tupleTyCon doesn't flatten 1-tuples
  309                -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make
  310        ; res_ty <- expTypeToType res_ty
  311        ; (coi, arg_tys) <- matchExpectedTyConApp tup_tc res_ty
  312                            -- Unboxed tuples have RuntimeRep vars, which we
  313                            -- don't care about here
  314                            -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon
  315        ; let arg_tys' = case boxity of Unboxed -> drop arity arg_tys
  316                                        Boxed   -> arg_tys
  317        ; tup_args1 <- tcTupArgs tup_args arg_tys'
  318        ; return $ mkHsWrapCo coi (ExplicitTuple x tup_args1 boxity) }
  319 
  320   | otherwise
  321   = -- The tup_args are a mixture of Present and Missing (for tuple sections)
  322     do { let arity = length tup_args
  323 
  324        ; arg_tys <- case boxity of
  325            { Boxed   -> newFlexiTyVarTys arity liftedTypeKind
  326            ; Unboxed -> replicateM arity newOpenFlexiTyVarTy }
  327 
  328        -- Handle tuple sections where
  329        ; tup_args1 <- tcTupArgs tup_args arg_tys
  330 
  331        ; let expr'       = ExplicitTuple x tup_args1 boxity
  332              missing_tys = [Scaled mult ty | (Missing (Scaled mult _), ty) <- zip tup_args1 arg_tys]
  333 
  334              -- See Note [Typechecking data constructors] in GHC.Tc.Gen.Head
  335              -- See Note [Don't flatten tuples from HsSyn] in GHC.Core.Make
  336              act_res_ty = mkVisFunTys missing_tys (mkTupleTy1 boxity arg_tys)
  337 
  338        ; traceTc "ExplicitTuple" (ppr act_res_ty $$ ppr res_ty)
  339 
  340        ; tcWrapResultMono expr expr' act_res_ty res_ty }
  341 
  342 tcExpr (ExplicitSum _ alt arity expr) res_ty
  343   = do { let sum_tc = sumTyCon arity
  344        ; res_ty <- expTypeToType res_ty
  345        ; (coi, arg_tys) <- matchExpectedTyConApp sum_tc res_ty
  346        ; -- Drop levity vars, we don't care about them here
  347          let arg_tys' = drop arity arg_tys
  348              arg_ty   = arg_tys' `getNth` (alt - 1)
  349        ; expr' <- tcCheckPolyExpr expr arg_ty
  350        -- Check the whole res_ty, not just the arg_ty, to avoid #20277.
  351        -- Example:
  352        --   a :: TYPE rep (representation-polymorphic)
  353        --   (# 17# | #) :: (# Int# | a #)
  354        -- This should cause an error, even though (17# :: Int#)
  355        -- is not representation-polymorphic: we don't know how
  356        -- wide the concrete representation of the sum type will be.
  357        ; _concrete_ev <- hasFixedRuntimeRep FRRUnboxedSum res_ty
  358        ; return $ mkHsWrapCo coi (ExplicitSum arg_tys' alt arity expr' ) }
  359 
  360 
  361 {-
  362 ************************************************************************
  363 *                                                                      *
  364                 Let, case, if, do
  365 *                                                                      *
  366 ************************************************************************
  367 -}
  368 
  369 tcExpr (HsLet x tkLet binds tkIn expr) res_ty
  370   = do  { (binds', expr') <- tcLocalBinds binds $
  371                              tcMonoExpr expr res_ty
  372         ; return (HsLet x tkLet binds' tkIn expr') }
  373 
  374 tcExpr (HsCase x scrut matches) res_ty
  375   = do  {  -- We used to typecheck the case alternatives first.
  376            -- The case patterns tend to give good type info to use
  377            -- when typechecking the scrutinee.  For example
  378            --   case (map f) of
  379            --     (x:xs) -> ...
  380            -- will report that map is applied to too few arguments
  381            --
  382            -- But now, in the GADT world, we need to typecheck the scrutinee
  383            -- first, to get type info that may be refined in the case alternatives
  384           mult <- newFlexiTyVarTy multiplicityTy
  385 
  386           -- Typecheck the scrutinee.  We use tcInferRho but tcInferSigma
  387           -- would also be possible (tcMatchesCase accepts sigma-types)
  388           -- Interesting litmus test: do these two behave the same?
  389           --     case id        of {..}
  390           --     case (\v -> v) of {..}
  391           -- This design choice is discussed in #17790
  392         ; (scrut', scrut_ty) <- tcScalingUsage mult $ tcInferRho scrut
  393 
  394         ; traceTc "HsCase" (ppr scrut_ty)
  395         ; matches' <- tcMatchesCase match_ctxt (Scaled mult scrut_ty) matches res_ty
  396         ; return (HsCase x scrut' matches') }
  397  where
  398     match_ctxt = MC { mc_what = CaseAlt,
  399                       mc_body = tcBody }
  400 
  401 tcExpr (HsIf x pred b1 b2) res_ty
  402   = do { pred'    <- tcCheckMonoExpr pred boolTy
  403        ; (u1,b1') <- tcCollectingUsage $ tcMonoExpr b1 res_ty
  404        ; (u2,b2') <- tcCollectingUsage $ tcMonoExpr b2 res_ty
  405        ; tcEmitBindingUsage (supUE u1 u2)
  406        ; return (HsIf x pred' b1' b2') }
  407 
  408 tcExpr (HsMultiIf _ alts) res_ty
  409   = do { alts' <- mapM (wrapLocMA $ tcGRHS match_ctxt res_ty) alts
  410        ; res_ty <- readExpType res_ty
  411        ; return (HsMultiIf res_ty alts') }
  412   where match_ctxt = MC { mc_what = IfAlt, mc_body = tcBody }
  413 
  414 tcExpr (HsDo _ do_or_lc stmts) res_ty
  415   = tcDoStmts do_or_lc stmts res_ty
  416 
  417 tcExpr (HsProc x pat cmd) res_ty
  418   = do  { (pat', cmd', coi) <- tcProc pat cmd res_ty
  419         ; return $ mkHsWrapCo coi (HsProc x pat' cmd') }
  420 
  421 -- Typechecks the static form and wraps it with a call to 'fromStaticPtr'.
  422 -- See Note [Grand plan for static forms] in GHC.Iface.Tidy.StaticPtrTable for an overview.
  423 -- To type check
  424 --      (static e) :: p a
  425 -- we want to check (e :: a),
  426 -- and wrap (static e) in a call to
  427 --    fromStaticPtr :: IsStatic p => StaticPtr a -> p a
  428 
  429 tcExpr (HsStatic fvs expr) res_ty
  430   = do  { res_ty          <- expTypeToType res_ty
  431         ; (co, (p_ty, expr_ty)) <- matchExpectedAppTy res_ty
  432         ; (expr', lie)    <- captureConstraints $
  433             addErrCtxt (hang (text "In the body of a static form:")
  434                              2 (ppr expr)
  435                        ) $
  436             tcCheckPolyExprNC expr expr_ty
  437 
  438         -- Check that the free variables of the static form are closed.
  439         -- It's OK to use nonDetEltsUniqSet here as the only side effects of
  440         -- checkClosedInStaticForm are error messages.
  441         ; mapM_ checkClosedInStaticForm $ nonDetEltsUniqSet fvs
  442 
  443         -- Require the type of the argument to be Typeable.
  444         ; typeableClass <- tcLookupClass typeableClassName
  445         ; typeable_ev <- emitWantedEvVar StaticOrigin $
  446                   mkTyConApp (classTyCon typeableClass)
  447                              [liftedTypeKind, expr_ty]
  448 
  449         -- Insert the constraints of the static form in a global list for later
  450         -- validation.
  451         ; emitStaticConstraints lie
  452 
  453         -- Wrap the static form with the 'fromStaticPtr' call.
  454         ; fromStaticPtr <- newMethodFromName StaticOrigin fromStaticPtrName
  455                                              [p_ty]
  456         ; let wrap = mkWpEvVarApps [typeable_ev] <.> mkWpTyApps [expr_ty]
  457         ; loc <- getSrcSpanM
  458         ; return $ mkHsWrapCo co $ HsApp noComments
  459                             (L (noAnnSrcSpan loc) $ mkHsWrap wrap fromStaticPtr)
  460                             (L (noAnnSrcSpan loc) (HsStatic fvs expr'))
  461         }
  462 
  463 {-
  464 ************************************************************************
  465 *                                                                      *
  466                 Record construction and update
  467 *                                                                      *
  468 ************************************************************************
  469 -}
  470 
  471 tcExpr expr@(RecordCon { rcon_con = L loc con_name
  472                        , rcon_flds = rbinds }) res_ty
  473   = do  { con_like <- tcLookupConLike con_name
  474 
  475         ; (con_expr, con_sigma) <- tcInferId con_name
  476         ; (con_wrap, con_tau)   <- topInstantiate orig con_sigma
  477               -- a shallow instantiation should really be enough for
  478               -- a data constructor.
  479         ; let arity = conLikeArity con_like
  480               Right (arg_tys, actual_res_ty) = tcSplitFunTysN arity con_tau
  481 
  482         ; checkTc (conLikeHasBuilder con_like) $
  483           nonBidirectionalErr (conLikeName con_like)
  484 
  485         ; rbinds' <- tcRecordBinds con_like (map scaledThing arg_tys) rbinds
  486                    -- It is currently not possible for a record to have
  487                    -- multiplicities. When they do, `tcRecordBinds` will take
  488                    -- scaled types instead. Meanwhile, it's safe to take
  489                    -- `scaledThing` above, as we know all the multiplicities are
  490                    -- Many.
  491 
  492         ; let rcon_tc = mkHsWrap con_wrap con_expr
  493               expr' = RecordCon { rcon_ext = rcon_tc
  494                                 , rcon_con = L loc con_like
  495                                 , rcon_flds = rbinds' }
  496 
  497         ; ret <- tcWrapResultMono expr expr' actual_res_ty res_ty
  498 
  499         -- Check for missing fields.  We do this after type-checking to get
  500         -- better types in error messages (cf #18869).  For example:
  501         --     data T a = MkT { x :: a, y :: a }
  502         --     r = MkT { y = True }
  503         -- Then we'd like to warn about a missing field `x :: True`, rather than `x :: a0`.
  504         --
  505         -- NB: to do this really properly we should delay reporting until typechecking is complete,
  506         -- via a new `HoleSort`.  But that seems too much work.
  507         ; checkMissingFields con_like rbinds arg_tys
  508 
  509         ; return ret }
  510   where
  511     orig = OccurrenceOf con_name
  512 
  513 {-
  514 Note [Type of a record update]
  515 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  516 The main complication with RecordUpd is that we need to explicitly
  517 handle the *non-updated* fields.  Consider:
  518 
  519         data T a b c = MkT1 { fa :: a, fb :: (b,c) }
  520                      | MkT2 { fa :: a, fb :: (b,c), fc :: c -> c }
  521                      | MkT3 { fd :: a }
  522 
  523         upd :: T a b c -> (b',c) -> T a b' c
  524         upd t x = t { fb = x}
  525 
  526 The result type should be (T a b' c)
  527 not (T a b c),   because 'b' *is not* mentioned in a non-updated field
  528 not (T a b' c'), because 'c' *is*     mentioned in a non-updated field
  529 NB that it's not good enough to look at just one constructor; we must
  530 look at them all; cf #3219
  531 
  532 After all, upd should be equivalent to:
  533         upd t x = case t of
  534                         MkT1 p q -> MkT1 p x
  535                         MkT2 a b -> MkT2 p b
  536                         MkT3 d   -> error ...
  537 
  538 So we need to give a completely fresh type to the result record,
  539 and then constrain it by the fields that are *not* updated ("p" above).
  540 We call these the "fixed" type variables, and compute them in getFixedTyVars.
  541 
  542 Note that because MkT3 doesn't contain all the fields being updated,
  543 its RHS is simply an error, so it doesn't impose any type constraints.
  544 Hence the use of 'relevant_cont'.
  545 
  546 Note [Implicit type sharing]
  547 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
  548 We also take into account any "implicit" non-update fields.  For example
  549         data T a b where { MkT { f::a } :: T a a; ... }
  550 So the "real" type of MkT is: forall ab. (a~b) => a -> T a b
  551 
  552 Then consider
  553         upd t x = t { f=x }
  554 We infer the type
  555         upd :: T a b -> a -> T a b
  556         upd (t::T a b) (x::a)
  557            = case t of { MkT (co:a~b) (_:a) -> MkT co x }
  558 We can't give it the more general type
  559         upd :: T a b -> c -> T c b
  560 
  561 Note [Criteria for update]
  562 ~~~~~~~~~~~~~~~~~~~~~~~~~~
  563 We want to allow update for existentials etc, provided the updated
  564 field isn't part of the existential. For example, this should be ok.
  565   data T a where { MkT { f1::a, f2::b->b } :: T a }
  566   f :: T a -> b -> T b
  567   f t b = t { f1=b }
  568 
  569 The criterion we use is this:
  570 
  571   The types of the updated fields
  572   mention only the universally-quantified type variables
  573   of the data constructor
  574 
  575 NB: this is not (quite) the same as being a "naughty" record selector
  576 (See Note [Naughty record selectors]) in GHC.Tc.TyCl), at least
  577 in the case of GADTs. Consider
  578    data T a where { MkT :: { f :: a } :: T [a] }
  579 Then f is not "naughty" because it has a well-typed record selector.
  580 But we don't allow updates for 'f'.  (One could consider trying to
  581 allow this, but it makes my head hurt.  Badly.  And no one has asked
  582 for it.)
  583 
  584 In principle one could go further, and allow
  585   g :: T a -> T a
  586   g t = t { f2 = \x -> x }
  587 because the expression is polymorphic...but that seems a bridge too far.
  588 
  589 Note [Data family example]
  590 ~~~~~~~~~~~~~~~~~~~~~~~~~~
  591     data instance T (a,b) = MkT { x::a, y::b }
  592   --->
  593     data :TP a b = MkT { a::a, y::b }
  594     coTP a b :: T (a,b) ~ :TP a b
  595 
  596 Suppose r :: T (t1,t2), e :: t3
  597 Then  r { x=e } :: T (t3,t1)
  598   --->
  599       case r |> co1 of
  600         MkT x y -> MkT e y |> co2
  601       where co1 :: T (t1,t2) ~ :TP t1 t2
  602             co2 :: :TP t3 t2 ~ T (t3,t2)
  603 The wrapping with co2 is done by the constructor wrapper for MkT
  604 
  605 Outgoing invariants
  606 ~~~~~~~~~~~~~~~~~~~
  607 In the outgoing (HsRecordUpd scrut binds cons in_inst_tys out_inst_tys):
  608 
  609   * cons are the data constructors to be updated
  610 
  611   * in_inst_tys, out_inst_tys have same length, and instantiate the
  612         *representation* tycon of the data cons.  In Note [Data
  613         family example], in_inst_tys = [t1,t2], out_inst_tys = [t3,t2]
  614 
  615 Note [Mixed Record Field Updates]
  616 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  617 Consider the following pattern synonym.
  618 
  619   data MyRec = MyRec { foo :: Int, qux :: String }
  620 
  621   pattern HisRec{f1, f2} = MyRec{foo = f1, qux=f2}
  622 
  623 This allows updates such as the following
  624 
  625   updater :: MyRec -> MyRec
  626   updater a = a {f1 = 1 }
  627 
  628 It would also make sense to allow the following update (which we reject).
  629 
  630   updater a = a {f1 = 1, qux = "two" } ==? MyRec 1 "two"
  631 
  632 This leads to confusing behaviour when the selectors in fact refer the same
  633 field.
  634 
  635   updater a = a {f1 = 1, foo = 2} ==? ???
  636 
  637 For this reason, we reject a mixture of pattern synonym and normal record
  638 selectors in the same update block. Although of course we still allow the
  639 following.
  640 
  641   updater a = (a {f1 = 1}) {foo = 2}
  642 
  643   > updater (MyRec 0 "str")
  644   MyRec 2 "str"
  645 
  646 -}
  647 
  648 -- Record updates via dot syntax are replaced by desugared expressions
  649 -- in the renamer. See Note [Overview of record dot syntax] in
  650 -- GHC.Hs.Expr. This is why we match on 'rupd_flds = Left rbnds' here
  651 -- and panic otherwise.
  652 tcExpr expr@(RecordUpd { rupd_expr = record_expr, rupd_flds = Left rbnds }) res_ty
  653   = assert (notNull rbnds) $
  654     do  { -- STEP -2: typecheck the record_expr, the record to be updated
  655           (record_expr', record_rho) <- tcScalingUsage Many $ tcInferRho record_expr
  656             -- Record update drops some of the content of the record (namely the
  657             -- content of the field being updated). As a consequence, unless the
  658             -- field being updated is unrestricted in the record, or we need an
  659             -- unrestricted record. Currently, we simply always require an
  660             -- unrestricted record.
  661             --
  662             -- Consider the following example:
  663             --
  664             -- data R a = R { self :: a }
  665             -- bad :: a ⊸ ()
  666             -- bad x = let r = R x in case r { self = () } of { R x' -> x' }
  667             --
  668             -- This should definitely *not* typecheck.
  669 
  670         -- STEP -1  See Note [Disambiguating record fields] in GHC.Tc.Gen.Head
  671         -- After this we know that rbinds is unambiguous
  672         ; rbinds <- disambiguateRecordBinds record_expr record_rho rbnds res_ty
  673         ; let upd_flds = map (unLoc . hfbLHS . unLoc) rbinds
  674               upd_fld_occs = map (occNameFS . rdrNameOcc . rdrNameAmbiguousFieldOcc) upd_flds
  675               sel_ids      = map selectorAmbiguousFieldOcc upd_flds
  676         -- STEP 0
  677         -- Check that the field names are really field names
  678         -- and they are all field names for proper records or
  679         -- all field names for pattern synonyms.
  680         ; let bad_guys = [ setSrcSpan loc $ addErrTc (notSelector fld_name)
  681                          | fld <- rbinds,
  682                            -- Excludes class ops
  683                            let L loc sel_id = hsRecUpdFieldId (unLoc fld),
  684                            not (isRecordSelector sel_id),
  685                            let fld_name = idName sel_id ]
  686         ; unless (null bad_guys) (sequence bad_guys >> failM)
  687         -- See note [Mixed Record Selectors]
  688         ; let (data_sels, pat_syn_sels) =
  689                 partition isDataConRecordSelector sel_ids
  690         ; massert (all isPatSynRecordSelector pat_syn_sels)
  691         ; checkTc ( null data_sels || null pat_syn_sels )
  692                   ( mixedSelectors data_sels pat_syn_sels )
  693 
  694         -- STEP 1
  695         -- Figure out the tycon and data cons from the first field name
  696         ; let   -- It's OK to use the non-tc splitters here (for a selector)
  697               sel_id : _  = sel_ids
  698 
  699               mtycon :: Maybe TyCon
  700               mtycon = case idDetails sel_id of
  701                           RecSelId (RecSelData tycon) _ -> Just tycon
  702                           _ -> Nothing
  703 
  704               con_likes :: [ConLike]
  705               con_likes = case idDetails sel_id of
  706                              RecSelId (RecSelData tc) _
  707                                 -> map RealDataCon (tyConDataCons tc)
  708                              RecSelId (RecSelPatSyn ps) _
  709                                 -> [PatSynCon ps]
  710                              _  -> panic "tcRecordUpd"
  711                 -- NB: for a data type family, the tycon is the instance tycon
  712 
  713               relevant_cons = conLikesWithFields con_likes upd_fld_occs
  714                 -- A constructor is only relevant to this process if
  715                 -- it contains *all* the fields that are being updated
  716                 -- Other ones will cause a runtime error if they occur
  717 
  718         -- Step 2
  719         -- Check that at least one constructor has all the named fields
  720         -- i.e. has an empty set of bad fields returned by badFields
  721         ; checkTc (not (null relevant_cons)) (badFieldsUpd rbinds con_likes)
  722 
  723         -- Take apart a representative constructor
  724         ; let con1 = assert (not (null relevant_cons) ) head relevant_cons
  725               (con1_tvs, _, _, _prov_theta, req_theta, scaled_con1_arg_tys, _)
  726                  = conLikeFullSig con1
  727               con1_arg_tys = map scaledThing scaled_con1_arg_tys
  728                 -- We can safely drop the fields' multiplicities because
  729                 -- they are currently always 1: there is no syntax for record
  730                 -- fields with other multiplicities yet. This way we don't need
  731                 -- to handle it in the rest of the function
  732               con1_flds   = map flLabel $ conLikeFieldLabels con1
  733               con1_tv_tys = mkTyVarTys con1_tvs
  734               con1_res_ty = case mtycon of
  735                               Just tc -> mkFamilyTyConApp tc con1_tv_tys
  736                               Nothing -> conLikeResTy con1 con1_tv_tys
  737 
  738         -- Check that we're not dealing with a unidirectional pattern
  739         -- synonym
  740         ; checkTc (conLikeHasBuilder con1) $
  741           nonBidirectionalErr (conLikeName con1)
  742 
  743         -- STEP 3    Note [Criteria for update]
  744         -- Check that each updated field is polymorphic; that is, its type
  745         -- mentions only the universally-quantified variables of the data con
  746         ; let flds1_w_tys  = zipEqual "tcExpr:RecConUpd" con1_flds con1_arg_tys
  747               bad_upd_flds = filter bad_fld flds1_w_tys
  748               con1_tv_set  = mkVarSet con1_tvs
  749               bad_fld (fld, ty) = fld `elem` upd_fld_occs &&
  750                                       not (tyCoVarsOfType ty `subVarSet` con1_tv_set)
  751         ; checkTc (null bad_upd_flds) (TcRnFieldUpdateInvalidType bad_upd_flds)
  752 
  753         -- STEP 4  Note [Type of a record update]
  754         -- Figure out types for the scrutinee and result
  755         -- Both are of form (T a b c), with fresh type variables, but with
  756         -- common variables where the scrutinee and result must have the same type
  757         -- These are variables that appear in *any* arg of *any* of the
  758         -- relevant constructors *except* in the updated fields
  759         --
  760         ; let fixed_tvs = getFixedTyVars upd_fld_occs con1_tvs relevant_cons
  761               is_fixed_tv tv = tv `elemVarSet` fixed_tvs
  762 
  763               mk_inst_ty :: TCvSubst -> (TyVar, TcType) -> TcM (TCvSubst, TcType)
  764               -- Deals with instantiation of kind variables
  765               --   c.f. GHC.Tc.Utils.TcMType.newMetaTyVars
  766               mk_inst_ty subst (tv, result_inst_ty)
  767                 | is_fixed_tv tv   -- Same as result type
  768                 = return (extendTvSubst subst tv result_inst_ty, result_inst_ty)
  769                 | otherwise        -- Fresh type, of correct kind
  770                 = do { (subst', new_tv) <- newMetaTyVarX subst tv
  771                      ; return (subst', mkTyVarTy new_tv) }
  772 
  773         ; (result_subst, con1_tvs') <- newMetaTyVars con1_tvs
  774         ; let result_inst_tys = mkTyVarTys con1_tvs'
  775               init_subst = mkEmptyTCvSubst (getTCvInScope result_subst)
  776 
  777         ; (scrut_subst, scrut_inst_tys) <- mapAccumLM mk_inst_ty init_subst
  778                                                       (con1_tvs `zip` result_inst_tys)
  779 
  780         ; let rec_res_ty    = TcType.substTy result_subst con1_res_ty
  781               scrut_ty      = TcType.substTy scrut_subst  con1_res_ty
  782               con1_arg_tys' = map (TcType.substTy result_subst) con1_arg_tys
  783 
  784         ; co_scrut <- unifyType (Just (ppr record_expr)) record_rho scrut_ty
  785                 -- NB: normal unification is OK here (as opposed to subsumption),
  786                 -- because for this to work out, both record_rho and scrut_ty have
  787                 -- to be normal datatypes -- no contravariant stuff can go on
  788 
  789         -- STEP 5
  790         -- Typecheck the bindings
  791         ; rbinds'      <- tcRecordUpd con1 con1_arg_tys' rbinds
  792 
  793         -- STEP 6: Deal with the stupid theta
  794         ; let theta' = substThetaUnchecked scrut_subst (conLikeStupidTheta con1)
  795         ; instStupidTheta RecordUpdOrigin theta'
  796 
  797         -- Step 7: make a cast for the scrutinee, in the
  798         --         case that it's from a data family
  799         ; let fam_co :: HsWrapper   -- RepT t1 .. tn ~R scrut_ty
  800               fam_co | Just tycon <- mtycon
  801                      , Just co_con <- tyConFamilyCoercion_maybe tycon
  802                      = mkWpCastR (mkTcUnbranchedAxInstCo co_con scrut_inst_tys [])
  803                      | otherwise
  804                      = idHsWrapper
  805 
  806         -- Step 8: Check that the req constraints are satisfied
  807         -- For normal data constructors req_theta is empty but we must do
  808         -- this check for pattern synonyms.
  809         ; let req_theta' = substThetaUnchecked scrut_subst req_theta
  810         ; req_wrap <- instCallConstraints RecordUpdOrigin req_theta'
  811 
  812         -- Phew!
  813         ; let upd_tc = RecordUpdTc { rupd_cons = relevant_cons
  814                                    , rupd_in_tys = scrut_inst_tys
  815                                    , rupd_out_tys = result_inst_tys
  816                                    , rupd_wrap = req_wrap }
  817               expr' = RecordUpd { rupd_expr = mkLHsWrap fam_co $
  818                                                 mkLHsWrapCo co_scrut record_expr'
  819                                 , rupd_flds = Left rbinds'
  820                                 , rupd_ext = upd_tc }
  821 
  822         ; tcWrapResult expr expr' rec_res_ty res_ty }
  823 tcExpr (RecordUpd {}) _ = panic "GHC.Tc.Gen.Expr: tcExpr: The impossible happened!"
  824 
  825 
  826 {-
  827 ************************************************************************
  828 *                                                                      *
  829         Arithmetic sequences                    e.g. [a,b..]
  830         and their parallel-array counterparts   e.g. [: a,b.. :]
  831 
  832 *                                                                      *
  833 ************************************************************************
  834 -}
  835 
  836 tcExpr (ArithSeq _ witness seq) res_ty
  837   = tcArithSeq witness seq res_ty
  838 
  839 {-
  840 ************************************************************************
  841 *                                                                      *
  842                 Record dot syntax
  843 *                                                                      *
  844 ************************************************************************
  845 -}
  846 
  847 -- These terms have been replaced by desugaring in the renamer. See
  848 -- Note [Overview of record dot syntax].
  849 tcExpr (HsGetField _ _ _) _ = panic "GHC.Tc.Gen.Expr: tcExpr: HsGetField: Not implemented"
  850 tcExpr (HsProjection _ _) _ = panic "GHC.Tc.Gen.Expr: tcExpr: HsProjection: Not implemented"
  851 
  852 {-
  853 ************************************************************************
  854 *                                                                      *
  855                 Template Haskell
  856 *                                                                      *
  857 ************************************************************************
  858 -}
  859 
  860 -- HsSpliced is an annotation produced by 'GHC.Rename.Splice.rnSpliceExpr'.
  861 -- Here we get rid of it and add the finalizers to the global environment.
  862 --
  863 -- See Note [Delaying modFinalizers in untyped splices] in GHC.Rename.Splice.
  864 tcExpr (HsSpliceE _ (HsSpliced _ mod_finalizers (HsSplicedExpr expr)))
  865        res_ty
  866   = do addModFinalizersWithLclEnv mod_finalizers
  867        tcExpr expr res_ty
  868 tcExpr (HsSpliceE _ splice)          res_ty = tcSpliceExpr splice res_ty
  869 tcExpr e@(HsBracket _ brack)         res_ty = tcTypedBracket e brack res_ty
  870 tcExpr e@(HsRnBracketOut _ brack ps) res_ty = tcUntypedBracket e brack ps res_ty
  871 
  872 {-
  873 ************************************************************************
  874 *                                                                      *
  875                 Catch-all
  876 *                                                                      *
  877 ************************************************************************
  878 -}
  879 
  880 tcExpr (HsOverLabel {})    ty = pprPanic "tcExpr:HsOverLabel"  (ppr ty)
  881 tcExpr (SectionL {})       ty = pprPanic "tcExpr:SectionL"    (ppr ty)
  882 tcExpr (SectionR {})       ty = pprPanic "tcExpr:SectionR"    (ppr ty)
  883 tcExpr (HsTcBracketOut {}) ty = pprPanic "tcExpr:HsTcBracketOut"    (ppr ty)
  884 
  885 
  886 {-
  887 ************************************************************************
  888 *                                                                      *
  889                 Arithmetic sequences [a..b] etc
  890 *                                                                      *
  891 ************************************************************************
  892 -}
  893 
  894 tcArithSeq :: Maybe (SyntaxExpr GhcRn) -> ArithSeqInfo GhcRn -> ExpRhoType
  895            -> TcM (HsExpr GhcTc)
  896 
  897 tcArithSeq witness seq@(From expr) res_ty
  898   = do { (wrap, elt_mult, elt_ty, wit') <- arithSeqEltType witness res_ty
  899        ; expr' <-tcScalingUsage elt_mult $ tcCheckPolyExpr expr elt_ty
  900        ; enum_from <- newMethodFromName (ArithSeqOrigin seq)
  901                               enumFromName [elt_ty]
  902        ; return $ mkHsWrap wrap $
  903          ArithSeq enum_from wit' (From expr') }
  904 
  905 tcArithSeq witness seq@(FromThen expr1 expr2) res_ty
  906   = do { (wrap, elt_mult, elt_ty, wit') <- arithSeqEltType witness res_ty
  907        ; expr1' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr1 elt_ty
  908        ; expr2' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr2 elt_ty
  909        ; enum_from_then <- newMethodFromName (ArithSeqOrigin seq)
  910                               enumFromThenName [elt_ty]
  911        ; return $ mkHsWrap wrap $
  912          ArithSeq enum_from_then wit' (FromThen expr1' expr2') }
  913 
  914 tcArithSeq witness seq@(FromTo expr1 expr2) res_ty
  915   = do { (wrap, elt_mult, elt_ty, wit') <- arithSeqEltType witness res_ty
  916        ; expr1' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr1 elt_ty
  917        ; expr2' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr2 elt_ty
  918        ; enum_from_to <- newMethodFromName (ArithSeqOrigin seq)
  919                               enumFromToName [elt_ty]
  920        ; return $ mkHsWrap wrap $
  921          ArithSeq enum_from_to wit' (FromTo expr1' expr2') }
  922 
  923 tcArithSeq witness seq@(FromThenTo expr1 expr2 expr3) res_ty
  924   = do { (wrap, elt_mult, elt_ty, wit') <- arithSeqEltType witness res_ty
  925         ; expr1' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr1 elt_ty
  926         ; expr2' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr2 elt_ty
  927         ; expr3' <- tcScalingUsage elt_mult $ tcCheckPolyExpr expr3 elt_ty
  928         ; eft <- newMethodFromName (ArithSeqOrigin seq)
  929                               enumFromThenToName [elt_ty]
  930         ; return $ mkHsWrap wrap $
  931           ArithSeq eft wit' (FromThenTo expr1' expr2' expr3') }
  932 
  933 -----------------
  934 arithSeqEltType :: Maybe (SyntaxExpr GhcRn) -> ExpRhoType
  935                 -> TcM (HsWrapper, Mult, TcType, Maybe (SyntaxExpr GhcTc))
  936 arithSeqEltType Nothing res_ty
  937   = do { res_ty <- expTypeToType res_ty
  938        ; (coi, elt_ty) <- matchExpectedListTy res_ty
  939        ; return (mkWpCastN coi, One, elt_ty, Nothing) }
  940 arithSeqEltType (Just fl) res_ty
  941   = do { ((elt_mult, elt_ty), fl')
  942            <- tcSyntaxOp ListOrigin fl [SynList] res_ty $
  943               \ [elt_ty] [elt_mult] -> return (elt_mult, elt_ty)
  944        ; return (idHsWrapper, elt_mult, elt_ty, Just fl') }
  945 
  946 ----------------
  947 tcTupArgs :: [HsTupArg GhcRn] -> [TcSigmaType] -> TcM [HsTupArg GhcTc]
  948 tcTupArgs args tys
  949   = do massert (equalLength args tys)
  950        checkTupSize (length args)
  951        zipWith3M go [1,2..] args tys
  952   where
  953     go :: Int -> HsTupArg GhcRn -> TcType -> TcM (HsTupArg GhcTc)
  954     go i (Missing {})     arg_ty
  955       = do { mult <- newFlexiTyVarTy multiplicityTy
  956            ; _concrete_ev <- hasFixedRuntimeRep (FRRTupleSection i) arg_ty
  957            ; return (Missing (Scaled mult arg_ty)) }
  958     go i (Present x expr) arg_ty
  959       = do { expr' <- tcCheckPolyExpr expr arg_ty
  960            ; _concrete_ev <- hasFixedRuntimeRep (FRRTupleArg i) arg_ty
  961            ; return (Present x expr') }
  962 
  963 ---------------------------
  964 -- See TcType.SyntaxOpType also for commentary
  965 tcSyntaxOp :: CtOrigin
  966            -> SyntaxExprRn
  967            -> [SyntaxOpType]           -- ^ shape of syntax operator arguments
  968            -> ExpRhoType               -- ^ overall result type
  969            -> ([TcSigmaType] -> [Mult] -> TcM a) -- ^ Type check any arguments,
  970                                                  -- takes a type per hole and a
  971                                                  -- multiplicity per arrow in
  972                                                  -- the shape.
  973            -> TcM (a, SyntaxExprTc)
  974 -- ^ Typecheck a syntax operator
  975 -- The operator is a variable or a lambda at this stage (i.e. renamer
  976 -- output)t
  977 tcSyntaxOp orig expr arg_tys res_ty
  978   = tcSyntaxOpGen orig expr arg_tys (SynType res_ty)
  979 
  980 -- | Slightly more general version of 'tcSyntaxOp' that allows the caller
  981 -- to specify the shape of the result of the syntax operator
  982 tcSyntaxOpGen :: CtOrigin
  983               -> SyntaxExprRn
  984               -> [SyntaxOpType]
  985               -> SyntaxOpType
  986               -> ([TcSigmaType] -> [Mult] -> TcM a)
  987               -> TcM (a, SyntaxExprTc)
  988 tcSyntaxOpGen orig (SyntaxExprRn op) arg_tys res_ty thing_inside
  989   = do { (expr, sigma) <- tcInferAppHead (op, VACall op 0 noSrcSpan) []
  990              -- Ugh!! But all this code is scheduled for demolition anyway
  991        ; traceTc "tcSyntaxOpGen" (ppr op $$ ppr expr $$ ppr sigma)
  992        ; (result, expr_wrap, arg_wraps, res_wrap)
  993            <- tcSynArgA orig sigma arg_tys res_ty $
  994               thing_inside
  995        ; traceTc "tcSyntaxOpGen" (ppr op $$ ppr expr $$ ppr sigma )
  996        ; return (result, SyntaxExprTc { syn_expr = mkHsWrap expr_wrap expr
  997                                       , syn_arg_wraps = arg_wraps
  998                                       , syn_res_wrap  = res_wrap }) }
  999 tcSyntaxOpGen _ NoSyntaxExprRn _ _ _ = panic "tcSyntaxOpGen"
 1000 
 1001 {-
 1002 Note [tcSynArg]
 1003 ~~~~~~~~~~~~~~~
 1004 Because of the rich structure of SyntaxOpType, we must do the
 1005 contra-/covariant thing when working down arrows, to get the
 1006 instantiation vs. skolemisation decisions correct (and, more
 1007 obviously, the orientation of the HsWrappers). We thus have
 1008 two tcSynArgs.
 1009 -}
 1010 
 1011 -- works on "expected" types, skolemising where necessary
 1012 -- See Note [tcSynArg]
 1013 tcSynArgE :: CtOrigin
 1014           -> TcSigmaType
 1015           -> SyntaxOpType                -- ^ shape it is expected to have
 1016           -> ([TcSigmaType] -> [Mult] -> TcM a) -- ^ check the arguments
 1017           -> TcM (a, HsWrapper)
 1018            -- ^ returns a wrapper :: (type of right shape) "->" (type passed in)
 1019 tcSynArgE orig sigma_ty syn_ty thing_inside
 1020   = do { (skol_wrap, (result, ty_wrapper))
 1021            <- tcSkolemise GenSigCtxt sigma_ty
 1022                 (\ rho_ty -> go rho_ty syn_ty)
 1023        ; return (result, skol_wrap <.> ty_wrapper) }
 1024     where
 1025     go rho_ty SynAny
 1026       = do { result <- thing_inside [rho_ty] []
 1027            ; return (result, idHsWrapper) }
 1028 
 1029     go rho_ty SynRho   -- same as SynAny, because we skolemise eagerly
 1030       = do { result <- thing_inside [rho_ty] []
 1031            ; return (result, idHsWrapper) }
 1032 
 1033     go rho_ty SynList
 1034       = do { (list_co, elt_ty) <- matchExpectedListTy rho_ty
 1035            ; result <- thing_inside [elt_ty] []
 1036            ; return (result, mkWpCastN list_co) }
 1037 
 1038     go rho_ty (SynFun arg_shape res_shape)
 1039       = do { ( match_wrapper                         -- :: (arg_ty -> res_ty) "->" rho_ty
 1040              , ( ( (result, arg_ty, res_ty, op_mult)
 1041                  , res_wrapper )                     -- :: res_ty_out "->" res_ty
 1042                , arg_wrapper1, [], arg_wrapper2 ) )  -- :: arg_ty "->" arg_ty_out
 1043                <- matchExpectedFunTys herald GenSigCtxt 1 (mkCheckExpType rho_ty) $
 1044                   \ [arg_ty] res_ty ->
 1045                   do { arg_tc_ty <- expTypeToType (scaledThing arg_ty)
 1046                      ; res_tc_ty <- expTypeToType res_ty
 1047 
 1048                          -- another nested arrow is too much for now,
 1049                          -- but I bet we'll never need this
 1050                      ; massertPpr (case arg_shape of
 1051                                    SynFun {} -> False;
 1052                                    _         -> True)
 1053                                   (text "Too many nested arrows in SyntaxOpType" $$
 1054                                    pprCtOrigin orig)
 1055 
 1056                      ; let arg_mult = scaledMult arg_ty
 1057                      ; tcSynArgA orig arg_tc_ty [] arg_shape $
 1058                        \ arg_results arg_res_mults ->
 1059                        tcSynArgE orig res_tc_ty res_shape $
 1060                        \ res_results res_res_mults ->
 1061                        do { result <- thing_inside (arg_results ++ res_results) ([arg_mult] ++ arg_res_mults ++ res_res_mults)
 1062                           ; return (result, arg_tc_ty, res_tc_ty, arg_mult) }}
 1063 
 1064            ; fun_wrap <- mkWpFun (arg_wrapper2 <.> arg_wrapper1) res_wrapper
 1065                               (Scaled op_mult arg_ty) res_ty (WpFunSyntaxOp orig)
 1066            ; return (result, match_wrapper <.> fun_wrap) }
 1067       where
 1068         herald = text "This rebindable syntax expects a function with"
 1069 
 1070     go rho_ty (SynType the_ty)
 1071       = do { wrap   <- tcSubTypePat orig GenSigCtxt the_ty rho_ty
 1072            ; result <- thing_inside [] []
 1073            ; return (result, wrap) }
 1074 
 1075 -- works on "actual" types, instantiating where necessary
 1076 -- See Note [tcSynArg]
 1077 tcSynArgA :: CtOrigin
 1078           -> TcSigmaType
 1079           -> [SyntaxOpType]              -- ^ argument shapes
 1080           -> SyntaxOpType                -- ^ result shape
 1081           -> ([TcSigmaType] -> [Mult] -> TcM a) -- ^ check the arguments
 1082           -> TcM (a, HsWrapper, [HsWrapper], HsWrapper)
 1083             -- ^ returns a wrapper to be applied to the original function,
 1084             -- wrappers to be applied to arguments
 1085             -- and a wrapper to be applied to the overall expression
 1086 tcSynArgA orig sigma_ty arg_shapes res_shape thing_inside
 1087   = do { (match_wrapper, arg_tys, res_ty)
 1088            <- matchActualFunTysRho herald orig Nothing
 1089                                    (length arg_shapes) sigma_ty
 1090               -- match_wrapper :: sigma_ty "->" (arg_tys -> res_ty)
 1091        ; ((result, res_wrapper), arg_wrappers)
 1092            <- tc_syn_args_e (map scaledThing arg_tys) arg_shapes $ \ arg_results arg_res_mults ->
 1093               tc_syn_arg    res_ty  res_shape  $ \ res_results ->
 1094               thing_inside (arg_results ++ res_results) (map scaledMult arg_tys ++ arg_res_mults)
 1095        ; return (result, match_wrapper, arg_wrappers, res_wrapper) }
 1096   where
 1097     herald = text "This rebindable syntax expects a function with"
 1098 
 1099     tc_syn_args_e :: [TcSigmaType] -> [SyntaxOpType]
 1100                   -> ([TcSigmaType] -> [Mult] -> TcM a)
 1101                   -> TcM (a, [HsWrapper])
 1102                     -- the wrappers are for arguments
 1103     tc_syn_args_e (arg_ty : arg_tys) (arg_shape : arg_shapes) thing_inside
 1104       = do { ((result, arg_wraps), arg_wrap)
 1105                <- tcSynArgE     orig arg_ty  arg_shape  $ \ arg1_results arg1_mults ->
 1106                   tc_syn_args_e      arg_tys arg_shapes $ \ args_results args_mults ->
 1107                   thing_inside (arg1_results ++ args_results) (arg1_mults ++ args_mults)
 1108            ; return (result, arg_wrap : arg_wraps) }
 1109     tc_syn_args_e _ _ thing_inside = (, []) <$> thing_inside [] []
 1110 
 1111     tc_syn_arg :: TcSigmaType -> SyntaxOpType
 1112                -> ([TcSigmaType] -> TcM a)
 1113                -> TcM (a, HsWrapper)
 1114                   -- the wrapper applies to the overall result
 1115     tc_syn_arg res_ty SynAny thing_inside
 1116       = do { result <- thing_inside [res_ty]
 1117            ; return (result, idHsWrapper) }
 1118     tc_syn_arg res_ty SynRho thing_inside
 1119       = do { (inst_wrap, rho_ty) <- topInstantiate orig res_ty
 1120                -- inst_wrap :: res_ty "->" rho_ty
 1121            ; result <- thing_inside [rho_ty]
 1122            ; return (result, inst_wrap) }
 1123     tc_syn_arg res_ty SynList thing_inside
 1124       = do { (inst_wrap, rho_ty) <- topInstantiate orig res_ty
 1125                -- inst_wrap :: res_ty "->" rho_ty
 1126            ; (list_co, elt_ty)   <- matchExpectedListTy rho_ty
 1127                -- list_co :: [elt_ty] ~N rho_ty
 1128            ; result <- thing_inside [elt_ty]
 1129            ; return (result, mkWpCastN (mkTcSymCo list_co) <.> inst_wrap) }
 1130     tc_syn_arg _ (SynFun {}) _
 1131       = pprPanic "tcSynArgA hits a SynFun" (ppr orig)
 1132     tc_syn_arg res_ty (SynType the_ty) thing_inside
 1133       = do { wrap   <- tcSubType orig GenSigCtxt res_ty the_ty
 1134            ; result <- thing_inside []
 1135            ; return (result, wrap) }
 1136 
 1137 {-
 1138 Note [Push result type in]
 1139 ~~~~~~~~~~~~~~~~~~~~~~~~~~
 1140 Unify with expected result before type-checking the args so that the
 1141 info from res_ty percolates to args.  This is when we might detect a
 1142 too-few args situation.  (One can think of cases when the opposite
 1143 order would give a better error message.)
 1144 experimenting with putting this first.
 1145 
 1146 Here's an example where it actually makes a real difference
 1147 
 1148    class C t a b | t a -> b
 1149    instance C Char a Bool
 1150 
 1151    data P t a = forall b. (C t a b) => MkP b
 1152    data Q t   = MkQ (forall a. P t a)
 1153 
 1154    f1, f2 :: Q Char;
 1155    f1 = MkQ (MkP True)
 1156    f2 = MkQ (MkP True :: forall a. P Char a)
 1157 
 1158 With the change, f1 will type-check, because the 'Char' info from
 1159 the signature is propagated into MkQ's argument. With the check
 1160 in the other order, the extra signature in f2 is reqd.
 1161 -}
 1162 
 1163 {- *********************************************************************
 1164 *                                                                      *
 1165                  Record bindings
 1166 *                                                                      *
 1167 ********************************************************************* -}
 1168 
 1169 getFixedTyVars :: [FieldLabelString] -> [TyVar] -> [ConLike] -> TyVarSet
 1170 -- These tyvars must not change across the updates
 1171 getFixedTyVars upd_fld_occs univ_tvs cons
 1172       = mkVarSet [tv1 | con <- cons
 1173                       , let (u_tvs, _, eqspec, prov_theta
 1174                              , req_theta, arg_tys, _)
 1175                               = conLikeFullSig con
 1176                             theta = eqSpecPreds eqspec
 1177                                      ++ prov_theta
 1178                                      ++ req_theta
 1179                             flds = conLikeFieldLabels con
 1180                             fixed_tvs = exactTyCoVarsOfTypes (map scaledThing fixed_tys)
 1181                                     -- fixed_tys: See Note [Type of a record update]
 1182                                         `unionVarSet` tyCoVarsOfTypes theta
 1183                                     -- Universally-quantified tyvars that
 1184                                     -- appear in any of the *implicit*
 1185                                     -- arguments to the constructor are fixed
 1186                                     -- See Note [Implicit type sharing]
 1187 
 1188                             fixed_tys = [ty | (fl, ty) <- zip flds arg_tys
 1189                                             , not (flLabel fl `elem` upd_fld_occs)]
 1190                       , (tv1,tv) <- univ_tvs `zip` u_tvs
 1191                       , tv `elemVarSet` fixed_tvs ]
 1192 
 1193 -- Disambiguate the fields in a record update.
 1194 -- See Note [Disambiguating record fields] in GHC.Tc.Gen.Head
 1195 disambiguateRecordBinds :: LHsExpr GhcRn -> TcRhoType
 1196                  -> [LHsRecUpdField GhcRn] -> ExpRhoType
 1197                  -> TcM [LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
 1198 disambiguateRecordBinds record_expr record_rho rbnds res_ty
 1199     -- Are all the fields unambiguous?
 1200   = case mapM isUnambiguous rbnds of
 1201                      -- If so, just skip to looking up the Ids
 1202                      -- Always the case if DuplicateRecordFields is off
 1203       Just rbnds' -> mapM lookupSelector rbnds'
 1204       Nothing     -> -- If not, try to identify a single parent
 1205         do { fam_inst_envs <- tcGetFamInstEnvs
 1206              -- Look up the possible parents for each field
 1207            ; rbnds_with_parents <- getUpdFieldsParents
 1208            ; let possible_parents = map (map fst . snd) rbnds_with_parents
 1209              -- Identify a single parent
 1210            ; p <- identifyParent fam_inst_envs possible_parents
 1211              -- Pick the right selector with that parent for each field
 1212            ; checkNoErrs $ mapM (pickParent p) rbnds_with_parents }
 1213   where
 1214     -- Extract the selector name of a field update if it is unambiguous
 1215     isUnambiguous :: LHsRecUpdField GhcRn -> Maybe (LHsRecUpdField GhcRn,Name)
 1216     isUnambiguous x = case unLoc (hfbLHS (unLoc x)) of
 1217                         Unambiguous sel_name _ -> Just (x, sel_name)
 1218                         Ambiguous{}            -> Nothing
 1219 
 1220     -- Look up the possible parents and selector GREs for each field
 1221     getUpdFieldsParents :: TcM [(LHsRecUpdField GhcRn
 1222                                 , [(RecSelParent, GlobalRdrElt)])]
 1223     getUpdFieldsParents
 1224       = fmap (zip rbnds) $ mapM
 1225           (lookupParents False . unLoc . hsRecUpdFieldRdr . unLoc)
 1226           rbnds
 1227 
 1228     -- Given a the lists of possible parents for each field,
 1229     -- identify a single parent
 1230     identifyParent :: FamInstEnvs -> [[RecSelParent]] -> TcM RecSelParent
 1231     identifyParent fam_inst_envs possible_parents
 1232       = case foldr1 intersect possible_parents of
 1233         -- No parents for all fields: record update is ill-typed
 1234         []  -> failWithTc (TcRnNoPossibleParentForFields rbnds)
 1235 
 1236         -- Exactly one datatype with all the fields: use that
 1237         [p] -> return p
 1238 
 1239         -- Multiple possible parents: try harder to disambiguate
 1240         -- Can we get a parent TyCon from the pushed-in type?
 1241         _:_ | Just p <- tyConOfET fam_inst_envs res_ty ->
 1242               do { reportAmbiguousField p
 1243                  ; return (RecSelData p) }
 1244 
 1245         -- Does the expression being updated have a type signature?
 1246         -- If so, try to extract a parent TyCon from it
 1247             | Just {} <- obviousSig (unLoc record_expr)
 1248             , Just tc <- tyConOf fam_inst_envs record_rho
 1249             -> do { reportAmbiguousField tc
 1250                   ; return (RecSelData tc) }
 1251 
 1252         -- Nothing else we can try...
 1253         _ -> failWithTc (TcRnBadOverloadedRecordUpdate rbnds)
 1254 
 1255     -- Make a field unambiguous by choosing the given parent.
 1256     -- Emits an error if the field cannot have that parent,
 1257     -- e.g. if the user writes
 1258     --     r { x = e } :: T
 1259     -- where T does not have field x.
 1260     pickParent :: RecSelParent
 1261                -> (LHsRecUpdField GhcRn, [(RecSelParent, GlobalRdrElt)])
 1262                -> TcM (LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn))
 1263     pickParent p (upd, xs)
 1264       = case lookup p xs of
 1265                       -- Phew! The parent is valid for this field.
 1266                       -- Previously ambiguous fields must be marked as
 1267                       -- used now that we know which one is meant, but
 1268                       -- unambiguous ones shouldn't be recorded again
 1269                       -- (giving duplicate deprecation warnings).
 1270           Just gre -> do { unless (null (tail xs)) $ do
 1271                              let L loc _ = hfbLHS (unLoc upd)
 1272                              setSrcSpanA loc $ addUsedGRE True gre
 1273                          ; lookupSelector (upd, greMangledName gre) }
 1274                       -- The field doesn't belong to this parent, so report
 1275                       -- an error but keep going through all the fields
 1276           Nothing  -> do { addErrTc (fieldNotInType p
 1277                                       (unLoc (hsRecUpdFieldRdr (unLoc upd))))
 1278                          ; lookupSelector (upd, greMangledName (snd (head xs))) }
 1279 
 1280     -- Given a (field update, selector name) pair, look up the
 1281     -- selector to give a field update with an unambiguous Id
 1282     lookupSelector :: (LHsRecUpdField GhcRn, Name)
 1283                  -> TcM (LHsFieldBind GhcRn (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn))
 1284     lookupSelector (L l upd, n)
 1285       = do { i <- tcLookupId n
 1286            ; let L loc af = hfbLHS upd
 1287                  lbl      = rdrNameAmbiguousFieldOcc af
 1288            ; return $ L l HsFieldBind
 1289                { hfbAnn = hfbAnn upd
 1290                , hfbLHS
 1291                        = L (l2l loc) (Unambiguous i (L (l2l loc) lbl))
 1292                , hfbRHS = hfbRHS upd
 1293                , hfbPun = hfbPun upd
 1294                }
 1295            }
 1296 
 1297     -- See Note [Deprecating ambiguous fields] in GHC.Tc.Gen.Head
 1298     reportAmbiguousField :: TyCon -> TcM ()
 1299     reportAmbiguousField parent_type =
 1300         setSrcSpan loc $ addDiagnostic $ TcRnAmbiguousField rupd parent_type
 1301       where
 1302         rupd = RecordUpd { rupd_expr = record_expr, rupd_flds = Left rbnds, rupd_ext = noExtField }
 1303         loc  = getLocA (head rbnds)
 1304 
 1305 {-
 1306 Game plan for record bindings
 1307 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 1308 1. Find the TyCon for the bindings, from the first field label.
 1309 
 1310 2. Instantiate its tyvars and unify (T a1 .. an) with expected_ty.
 1311 
 1312 For each binding field = value
 1313 
 1314 3. Instantiate the field type (from the field label) using the type
 1315    envt from step 2.
 1316 
 1317 4  Type check the value using tcCheckPolyExprNC (in tcRecordField),
 1318    passing the field type as the expected argument type.
 1319 
 1320 This extends OK when the field types are universally quantified.
 1321 -}
 1322 
 1323 tcRecordBinds
 1324         :: ConLike
 1325         -> [TcType]     -- Expected type for each field
 1326         -> HsRecordBinds GhcRn
 1327         -> TcM (HsRecordBinds GhcTc)
 1328 
 1329 tcRecordBinds con_like arg_tys (HsRecFields rbinds dd)
 1330   = do  { mb_binds <- mapM do_bind rbinds
 1331         ; return (HsRecFields (catMaybes mb_binds) dd) }
 1332   where
 1333     fields = map flSelector $ conLikeFieldLabels con_like
 1334     flds_w_tys = zipEqual "tcRecordBinds" fields arg_tys
 1335 
 1336     do_bind :: LHsRecField GhcRn (LHsExpr GhcRn)
 1337             -> TcM (Maybe (LHsRecField GhcTc (LHsExpr GhcTc)))
 1338     do_bind (L l fld@(HsFieldBind { hfbLHS = f
 1339                                  , hfbRHS = rhs }))
 1340 
 1341       = do { mb <- tcRecordField con_like flds_w_tys f rhs
 1342            ; case mb of
 1343                Nothing         -> return Nothing
 1344                -- Just (f', rhs') -> return (Just (L l (fld { hfbLHS = f'
 1345                --                                            , hfbRHS = rhs' }))) }
 1346                Just (f', rhs') -> return (Just (L l (HsFieldBind
 1347                                                      { hfbAnn = hfbAnn fld
 1348                                                      , hfbLHS = f'
 1349                                                      , hfbRHS = rhs'
 1350                                                      , hfbPun = hfbPun fld}))) }
 1351 
 1352 tcRecordUpd
 1353         :: ConLike
 1354         -> [TcType]     -- Expected type for each field
 1355         -> [LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
 1356         -> TcM [LHsRecUpdField GhcTc]
 1357 
 1358 tcRecordUpd con_like arg_tys rbinds = fmap catMaybes $ mapM do_bind rbinds
 1359   where
 1360     fields = map flSelector $ conLikeFieldLabels con_like
 1361     flds_w_tys = zipEqual "tcRecordUpd" fields arg_tys
 1362 
 1363     do_bind :: LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)
 1364             -> TcM (Maybe (LHsRecUpdField GhcTc))
 1365     do_bind (L l fld@(HsFieldBind { hfbLHS = L loc af
 1366                                  , hfbRHS = rhs }))
 1367       = do { let lbl = rdrNameAmbiguousFieldOcc af
 1368                  sel_id = selectorAmbiguousFieldOcc af
 1369                  f = L loc (FieldOcc (idName sel_id) (L (l2l loc) lbl))
 1370            ; mb <- tcRecordField con_like flds_w_tys f rhs
 1371            ; case mb of
 1372                Nothing         -> return Nothing
 1373                Just (f', rhs') ->
 1374                  return (Just
 1375                          (L l (fld { hfbLHS
 1376                                       = L loc (Unambiguous
 1377                                                (foExt (unLoc f'))
 1378                                                (L (l2l loc) lbl))
 1379                                    , hfbRHS = rhs' }))) }
 1380 
 1381 tcRecordField :: ConLike -> Assoc Name Type
 1382               -> LFieldOcc GhcRn -> LHsExpr GhcRn
 1383               -> TcM (Maybe (LFieldOcc GhcTc, LHsExpr GhcTc))
 1384 tcRecordField con_like flds_w_tys (L loc (FieldOcc sel_name lbl)) rhs
 1385   | Just field_ty <- assocMaybe flds_w_tys sel_name
 1386       = addErrCtxt (fieldCtxt field_lbl) $
 1387         do { rhs' <- tcCheckPolyExprNC rhs field_ty
 1388            ; _concrete_ev <-
 1389                 hasFixedRuntimeRep (FRRRecordUpdate (unLoc lbl) (unLoc rhs))
 1390                   field_ty
 1391            ; let field_id = mkUserLocal (nameOccName sel_name)
 1392                                         (nameUnique sel_name)
 1393                                         Many field_ty (locA loc)
 1394                 -- Yuk: the field_id has the *unique* of the selector Id
 1395                 --          (so we can find it easily)
 1396                 --      but is a LocalId with the appropriate type of the RHS
 1397                 --          (so the desugarer knows the type of local binder to make)
 1398            ; return (Just (L loc (FieldOcc field_id lbl), rhs')) }
 1399       | otherwise
 1400       = do { addErrTc (badFieldCon con_like field_lbl)
 1401            ; return Nothing }
 1402   where
 1403         field_lbl = occNameFS $ rdrNameOcc (unLoc lbl)
 1404 
 1405 
 1406 checkMissingFields ::  ConLike -> HsRecordBinds GhcRn -> [Scaled TcType] -> TcM ()
 1407 checkMissingFields con_like rbinds arg_tys
 1408   | null field_labels   -- Not declared as a record;
 1409                         -- But C{} is still valid if no strict fields
 1410   = if any isBanged field_strs then
 1411         -- Illegal if any arg is strict
 1412         addErrTc (TcRnMissingStrictFields con_like [])
 1413     else do
 1414         when (notNull field_strs && null field_labels) $ do
 1415           let msg = TcRnMissingFields con_like []
 1416           (diagnosticTc True msg)
 1417 
 1418   | otherwise = do              -- A record
 1419     unless (null missing_s_fields) $ do
 1420         fs <- zonk_fields missing_s_fields
 1421         -- It is an error to omit a strict field, because
 1422         -- we can't substitute it with (error "Missing field f")
 1423         addErrTc (TcRnMissingStrictFields con_like fs)
 1424 
 1425     warn <- woptM Opt_WarnMissingFields
 1426     when (warn && notNull missing_ns_fields) $ do
 1427         fs <- zonk_fields missing_ns_fields
 1428         -- It is not an error (though we may want) to omit a
 1429         -- lazy field, because we can always use
 1430         -- (error "Missing field f") instead.
 1431         let msg = TcRnMissingFields con_like fs
 1432         diagnosticTc True msg
 1433 
 1434   where
 1435     -- we zonk the fields to get better types in error messages (#18869)
 1436     zonk_fields fs = forM fs $ \(str,ty) -> do
 1437         ty' <- zonkTcType ty
 1438         return (str,ty')
 1439     missing_s_fields
 1440         = [ (flLabel fl, scaledThing ty) | (fl,str,ty) <- field_info,
 1441                  isBanged str,
 1442                  not (fl `elemField` field_names_used)
 1443           ]
 1444     missing_ns_fields
 1445         = [ (flLabel fl, scaledThing ty) | (fl,str,ty) <- field_info,
 1446                  not (isBanged str),
 1447                  not (fl `elemField` field_names_used)
 1448           ]
 1449 
 1450     field_names_used = hsRecFields rbinds
 1451     field_labels     = conLikeFieldLabels con_like
 1452 
 1453     field_info = zip3 field_labels field_strs arg_tys
 1454 
 1455     field_strs = conLikeImplBangs con_like
 1456 
 1457     fl `elemField` flds = any (\ fl' -> flSelector fl == fl') flds
 1458 
 1459 {-
 1460 ************************************************************************
 1461 *                                                                      *
 1462 \subsection{Errors and contexts}
 1463 *                                                                      *
 1464 ************************************************************************
 1465 
 1466 Boring and alphabetical:
 1467 -}
 1468 
 1469 fieldCtxt :: FieldLabelString -> SDoc
 1470 fieldCtxt field_name
 1471   = text "In the" <+> quotes (ppr field_name) <+> text "field of a record"
 1472 
 1473 badFieldsUpd
 1474   :: [LHsFieldBind GhcTc (LAmbiguousFieldOcc GhcTc) (LHsExpr GhcRn)]
 1475                -- Field names that don't belong to a single datacon
 1476   -> [ConLike] -- Data cons of the type which the first field name belongs to
 1477   -> TcRnMessage
 1478 badFieldsUpd rbinds data_cons
 1479   = TcRnNoConstructorHasAllFields conflictingFields
 1480           -- See Note [Finding the conflicting fields]
 1481   where
 1482     -- A (preferably small) set of fields such that no constructor contains
 1483     -- all of them.  See Note [Finding the conflicting fields]
 1484     conflictingFields = case nonMembers of
 1485         -- nonMember belongs to a different type.
 1486         (nonMember, _) : _ -> [aMember, nonMember]
 1487         [] -> let
 1488             -- All of rbinds belong to one type. In this case, repeatedly add
 1489             -- a field to the set until no constructor contains the set.
 1490 
 1491             -- Each field, together with a list indicating which constructors
 1492             -- have all the fields so far.
 1493             growingSets :: [(FieldLabelString, [Bool])]
 1494             growingSets = scanl1 combine membership
 1495             combine (_, setMem) (field, fldMem)
 1496               = (field, zipWith (&&) setMem fldMem)
 1497             in
 1498             -- Fields that don't change the membership status of the set
 1499             -- are redundant and can be dropped.
 1500             map (fst . head) $ groupBy ((==) `on` snd) growingSets
 1501 
 1502     aMember = assert (not (null members) ) fst (head members)
 1503     (members, nonMembers) = partition (or . snd) membership
 1504 
 1505     -- For each field, which constructors contain the field?
 1506     membership :: [(FieldLabelString, [Bool])]
 1507     membership = sortMembership $
 1508         map (\fld -> (fld, map (fld `elementOfUniqSet`) fieldLabelSets)) $
 1509           map (occNameFS . rdrNameOcc . rdrNameAmbiguousFieldOcc . unLoc . hfbLHS . unLoc) rbinds
 1510 
 1511     fieldLabelSets :: [UniqSet FieldLabelString]
 1512     fieldLabelSets = map (mkUniqSet . map flLabel . conLikeFieldLabels) data_cons
 1513 
 1514     -- Sort in order of increasing number of True, so that a smaller
 1515     -- conflicting set can be found.
 1516     sortMembership =
 1517       map snd .
 1518       sortBy (compare `on` fst) .
 1519       map (\ item@(_, membershipRow) -> (countTrue membershipRow, item))
 1520 
 1521     countTrue = count id
 1522 
 1523 {-
 1524 Note [Finding the conflicting fields]
 1525 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 1526 Suppose we have
 1527   data A = A {a0, a1 :: Int}
 1528          | B {b0, b1 :: Int}
 1529 and we see a record update
 1530   x { a0 = 3, a1 = 2, b0 = 4, b1 = 5 }
 1531 Then we'd like to find the smallest subset of fields that no
 1532 constructor has all of.  Here, say, {a0,b0}, or {a0,b1}, etc.
 1533 We don't really want to report that no constructor has all of
 1534 {a0,a1,b0,b1}, because when there are hundreds of fields it's
 1535 hard to see what was really wrong.
 1536 
 1537 We may need more than two fields, though; eg
 1538   data T = A { x,y :: Int, v::Int }
 1539           | B { y,z :: Int, v::Int }
 1540           | C { z,x :: Int, v::Int }
 1541 with update
 1542    r { x=e1, y=e2, z=e3 }, we
 1543 
 1544 Finding the smallest subset is hard, so the code here makes
 1545 a decent stab, no more.  See #7989.
 1546 -}
 1547 
 1548 mixedSelectors :: [Id] -> [Id] -> TcRnMessage
 1549 mixedSelectors data_sels@(dc_rep_id:_) pat_syn_sels@(ps_rep_id:_)
 1550   = TcRnMixedSelectors (tyConName rep_dc) data_sels (patSynName rep_ps) pat_syn_sels
 1551   where
 1552     RecSelPatSyn rep_ps = recordSelectorTyCon ps_rep_id
 1553     RecSelData rep_dc = recordSelectorTyCon dc_rep_id
 1554 mixedSelectors _ _ = panic "GHC.Tc.Gen.Expr: mixedSelectors emptylists"
 1555 
 1556 {-
 1557 ************************************************************************
 1558 *                                                                      *
 1559 \subsection{Static Pointers}
 1560 *                                                                      *
 1561 ************************************************************************
 1562 -}
 1563 
 1564 -- | Checks if the given name is closed and emits an error if not.
 1565 --
 1566 -- See Note [Not-closed error messages].
 1567 checkClosedInStaticForm :: Name -> TcM ()
 1568 checkClosedInStaticForm name = do
 1569     type_env <- getLclTypeEnv
 1570     case checkClosed type_env name of
 1571       Nothing -> return ()
 1572       Just reason -> addErrTc $ explain name reason
 1573   where
 1574     -- See Note [Checking closedness].
 1575     checkClosed :: TcTypeEnv -> Name -> Maybe NotClosedReason
 1576     checkClosed type_env n = checkLoop type_env (unitNameSet n) n
 1577 
 1578     checkLoop :: TcTypeEnv -> NameSet -> Name -> Maybe NotClosedReason
 1579     checkLoop type_env visited n =
 1580       -- The @visited@ set is an accumulating parameter that contains the set of
 1581       -- visited nodes, so we avoid repeating cycles in the traversal.
 1582       case lookupNameEnv type_env n of
 1583         Just (ATcId { tct_id = tcid, tct_info = info }) -> case info of
 1584           ClosedLet   -> Nothing
 1585           NotLetBound -> Just NotLetBoundReason
 1586           NonClosedLet fvs type_closed -> listToMaybe $
 1587             -- Look for a non-closed variable in fvs
 1588             [ NotClosed n' reason
 1589             | n' <- nameSetElemsStable fvs
 1590             , not (elemNameSet n' visited)
 1591             , Just reason <- [checkLoop type_env (extendNameSet visited n') n']
 1592             ] ++
 1593             if type_closed then
 1594               []
 1595             else
 1596               -- We consider non-let-bound variables easier to figure out than
 1597               -- non-closed types, so we report non-closed types to the user
 1598               -- only if we cannot spot the former.
 1599               [ NotTypeClosed $ tyCoVarsOfType (idType tcid) ]
 1600         -- The binding is closed.
 1601         _ -> Nothing
 1602 
 1603     -- Converts a reason into a human-readable sentence.
 1604     --
 1605     -- @explain name reason@ starts with
 1606     --
 1607     -- "<name> is used in a static form but it is not closed because it"
 1608     --
 1609     -- and then follows a list of causes. For each id in the path, the text
 1610     --
 1611     -- "uses <id> which"
 1612     --
 1613     -- is appended, yielding something like
 1614     --
 1615     -- "uses <id> which uses <id1> which uses <id2> which"
 1616     --
 1617     -- until the end of the path is reached, which is reported as either
 1618     --
 1619     -- "is not let-bound"
 1620     --
 1621     -- when the final node is not let-bound, or
 1622     --
 1623     -- "has a non-closed type because it contains the type variables:
 1624     -- v1, v2, v3"
 1625     --
 1626     -- when the final node has a non-closed type.
 1627     --
 1628     explain :: Name -> NotClosedReason -> TcRnMessage
 1629     explain = TcRnStaticFormNotClosed
 1630 
 1631 -- Note [Not-closed error messages]
 1632 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 1633 --
 1634 -- When variables in a static form are not closed, we go through the trouble
 1635 -- of explaining why they aren't.
 1636 --
 1637 -- Thus, the following program
 1638 --
 1639 -- > {-# LANGUAGE StaticPointers #-}
 1640 -- > module M where
 1641 -- >
 1642 -- > f x = static g
 1643 -- >   where
 1644 -- >     g = h
 1645 -- >     h = x
 1646 --
 1647 -- produces the error
 1648 --
 1649 --    'g' is used in a static form but it is not closed because it
 1650 --    uses 'h' which uses 'x' which is not let-bound.
 1651 --
 1652 -- And a program like
 1653 --
 1654 -- > {-# LANGUAGE StaticPointers #-}
 1655 -- > module M where
 1656 -- >
 1657 -- > import Data.Typeable
 1658 -- > import GHC.StaticPtr
 1659 -- >
 1660 -- > f :: Typeable a => a -> StaticPtr TypeRep
 1661 -- > f x = const (static (g undefined)) (h x)
 1662 -- >   where
 1663 -- >     g = h
 1664 -- >     h = typeOf
 1665 --
 1666 -- produces the error
 1667 --
 1668 --    'g' is used in a static form but it is not closed because it
 1669 --    uses 'h' which has a non-closed type because it contains the
 1670 --    type variables: 'a'
 1671 --
 1672 
 1673 -- Note [Checking closedness]
 1674 -- ~~~~~~~~~~~~~~~~~~~~~~~~~~
 1675 --
 1676 -- @checkClosed@ checks if a binding is closed and returns a reason if it is
 1677 -- not.
 1678 --
 1679 -- The bindings define a graph where the nodes are ids, and there is an edge
 1680 -- from @id1@ to @id2@ if the rhs of @id1@ contains @id2@ among its free
 1681 -- variables.
 1682 --
 1683 -- When @n@ is not closed, it has to exist in the graph some node reachable
 1684 -- from @n@ that it is not a let-bound variable or that it has a non-closed
 1685 -- type. Thus, the "reason" is a path from @n@ to this offending node.
 1686 --
 1687 -- When @n@ is not closed, we traverse the graph reachable from @n@ to build
 1688 -- the reason.
 1689 --