never executed always true always false
    1 
    2 {-# LANGUAGE ConstraintKinds  #-}
    3 {-# LANGUAGE FlexibleContexts #-}
    4 {-# LANGUAGE RankNTypes       #-}
    5 {-# LANGUAGE RecordWildCards  #-}
    6 {-# LANGUAGE TupleSections    #-}
    7 {-# LANGUAGE TypeFamilies     #-}
    8 
    9 {-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}
   10 
   11 {-
   12 (c) The University of Glasgow 2006
   13 (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   14 
   15 -}
   16 
   17 -- | Typecheck some @Matches@
   18 module GHC.Tc.Gen.Match
   19    ( tcMatchesFun
   20    , tcGRHS
   21    , tcGRHSsPat
   22    , tcMatchesCase
   23    , tcMatchLambda
   24    , TcMatchCtxt(..)
   25    , TcStmtChecker
   26    , TcExprStmtChecker
   27    , TcCmdStmtChecker
   28    , tcStmts
   29    , tcStmtsAndThen
   30    , tcDoStmts
   31    , tcBody
   32    , tcDoStmt
   33    , tcGuardStmt
   34    )
   35 where
   36 
   37 import GHC.Prelude
   38 
   39 import {-# SOURCE #-}   GHC.Tc.Gen.Expr( tcSyntaxOp, tcInferRho, tcInferRhoNC
   40                                        , tcMonoExpr, tcMonoExprNC, tcExpr
   41                                        , tcCheckMonoExpr, tcCheckMonoExprNC
   42                                        , tcCheckPolyExpr )
   43 
   44 import GHC.Tc.Errors.Types
   45 import GHC.Tc.Utils.Monad
   46 import GHC.Tc.Utils.Env
   47 import GHC.Tc.Gen.Pat
   48 import GHC.Tc.Gen.Head( tcCheckId )
   49 import GHC.Tc.Utils.TcMType
   50 import GHC.Tc.Utils.TcType
   51 import GHC.Tc.Gen.Bind
   52 import GHC.Tc.Utils.Concrete ( hasFixedRuntimeRep )
   53 import GHC.Tc.Utils.Unify
   54 import GHC.Tc.Types.Origin
   55 import GHC.Tc.Types.Evidence
   56 
   57 import GHC.Core.Multiplicity
   58 import GHC.Core.UsageEnv
   59 import GHC.Core.TyCon
   60 -- Create chunkified tuple tybes for monad comprehensions
   61 import GHC.Core.Make
   62 
   63 import GHC.Hs
   64 
   65 import GHC.Builtin.Types
   66 import GHC.Builtin.Types.Prim
   67 
   68 import GHC.Utils.Outputable
   69 import GHC.Utils.Panic
   70 import GHC.Utils.Misc
   71 import GHC.Driver.Session ( getDynFlags )
   72 
   73 import GHC.Types.Error
   74 import GHC.Types.Fixity (LexicalFixity(..))
   75 import GHC.Types.Name
   76 import GHC.Types.Id
   77 import GHC.Types.SrcLoc
   78 
   79 import Control.Monad
   80 import Control.Arrow ( second )
   81 
   82 {-
   83 ************************************************************************
   84 *                                                                      *
   85 \subsection{tcMatchesFun, tcMatchesCase}
   86 *                                                                      *
   87 ************************************************************************
   88 
   89 @tcMatchesFun@ typechecks a @[Match]@ list which occurs in a
   90 @FunMonoBind@.  The second argument is the name of the function, which
   91 is used in error messages.  It checks that all the equations have the
   92 same number of arguments before using @tcMatches@ to do the work.
   93 -}
   94 
   95 tcMatchesFun :: LocatedN Id -- MatchContext Id
   96              -> MatchGroup GhcRn (LHsExpr GhcRn)
   97              -> ExpRhoType    -- Expected type of function
   98              -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
   99                                 -- Returns type of body
  100 tcMatchesFun fun_id matches exp_ty
  101   = do  {  -- Check that they all have the same no of arguments
  102            -- Location is in the monad, set the caller so that
  103            -- any inter-equation error messages get some vaguely
  104            -- sensible location.        Note: we have to do this odd
  105            -- ann-grabbing, because we don't always have annotations in
  106            -- hand when we call tcMatchesFun...
  107           traceTc "tcMatchesFun" (ppr fun_name $$ ppr exp_ty)
  108         ; checkArgs fun_name matches
  109 
  110         ; matchExpectedFunTys herald ctxt arity exp_ty $ \ pat_tys rhs_ty ->
  111              -- NB: exp_type may be polymorphic, but
  112              --     matchExpectedFunTys can cope with that
  113           tcScalingUsage Many $
  114           -- toplevel bindings and let bindings are, at the
  115           -- moment, always unrestricted. The value being bound
  116           -- must, accordingly, be unrestricted. Hence them
  117           -- being scaled by Many. When let binders come with a
  118           -- multiplicity, then @tcMatchesFun@ will have to take
  119           -- a multiplicity argument, and scale accordingly.
  120           tcMatches match_ctxt pat_tys rhs_ty matches }
  121   where
  122     fun_name = idName (unLoc fun_id)
  123     arity  = matchGroupArity matches
  124     herald = text "The equation(s) for"
  125              <+> quotes (ppr fun_name) <+> text "have"
  126     ctxt   = GenSigCtxt  -- Was: FunSigCtxt fun_name True
  127                          -- But that's wrong for f :: Int -> forall a. blah
  128     what   = FunRhs { mc_fun = fun_id, mc_fixity = Prefix, mc_strictness = strictness }
  129                     -- Careful: this fun_id could be an unfilled
  130                     -- thunk from fixM in tcMonoBinds, so we're
  131                     -- not allowed to look at it, except for
  132                     -- idName.
  133                     -- See Note [fixM for rhs_ty in tcMonoBinds]
  134     match_ctxt = MC { mc_what = what, mc_body = tcBody }
  135     strictness
  136       | [L _ match] <- unLoc $ mg_alts matches
  137       , FunRhs{ mc_strictness = SrcStrict } <- m_ctxt match
  138       = SrcStrict
  139       | otherwise
  140       = NoSrcStrict
  141 
  142 {-
  143 @tcMatchesCase@ doesn't do the argument-count check because the
  144 parser guarantees that each equation has exactly one argument.
  145 -}
  146 
  147 tcMatchesCase :: (AnnoBody body) =>
  148                 TcMatchCtxt body                         -- Case context
  149              -> Scaled TcSigmaType                       -- Type of scrutinee
  150              -> MatchGroup GhcRn (LocatedA (body GhcRn)) -- The case alternatives
  151              -> ExpRhoType                    -- Type of whole case expressions
  152              -> TcM (MatchGroup GhcTc (LocatedA (body GhcTc)))
  153                 -- Translated alternatives
  154                 -- wrapper goes from MatchGroup's ty to expected ty
  155 
  156 tcMatchesCase ctxt (Scaled scrut_mult scrut_ty) matches res_ty
  157   = tcMatches ctxt [Scaled scrut_mult (mkCheckExpType scrut_ty)] res_ty matches
  158 
  159 tcMatchLambda :: SDoc -- see Note [Herald for matchExpectedFunTys] in GHC.Tc.Utils.Unify
  160               -> TcMatchCtxt HsExpr
  161               -> MatchGroup GhcRn (LHsExpr GhcRn)
  162               -> ExpRhoType
  163               -> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
  164 tcMatchLambda herald match_ctxt match res_ty
  165   = matchExpectedFunTys herald GenSigCtxt n_pats res_ty $ \ pat_tys rhs_ty ->
  166     tcMatches match_ctxt pat_tys rhs_ty match
  167   where
  168     n_pats | isEmptyMatchGroup match = 1   -- must be lambda-case
  169            | otherwise               = matchGroupArity match
  170 
  171 -- @tcGRHSsPat@ typechecks @[GRHSs]@ that occur in a @PatMonoBind@.
  172 
  173 tcGRHSsPat :: GRHSs GhcRn (LHsExpr GhcRn) -> ExpRhoType
  174            -> TcM (GRHSs GhcTc (LHsExpr GhcTc))
  175 -- Used for pattern bindings
  176 tcGRHSsPat grhss res_ty
  177   = tcScalingUsage Many $
  178       -- Like in tcMatchesFun, this scaling happens because all
  179       -- let bindings are unrestricted. A difference, here, is
  180       -- that when this is not the case, any more, we will have to
  181       -- make sure that the pattern is strict, otherwise this will
  182       -- desugar to incorrect code.
  183     tcGRHSs match_ctxt grhss res_ty
  184   where
  185     match_ctxt :: TcMatchCtxt HsExpr -- AZ
  186     match_ctxt = MC { mc_what = PatBindRhs,
  187                       mc_body = tcBody }
  188 
  189 {- *********************************************************************
  190 *                                                                      *
  191                 tcMatch
  192 *                                                                      *
  193 ********************************************************************* -}
  194 
  195 data TcMatchCtxt body   -- c.f. TcStmtCtxt, also in this module
  196   = MC { mc_what :: HsMatchContext GhcTc,  -- What kind of thing this is
  197          mc_body :: LocatedA (body GhcRn)  -- Type checker for a body of
  198                                            -- an alternative
  199                  -> ExpRhoType
  200                  -> TcM (LocatedA (body GhcTc)) }
  201 
  202 type AnnoBody body
  203   = ( Outputable (body GhcRn)
  204     , Anno (Match GhcRn (LocatedA (body GhcRn))) ~ SrcSpanAnnA
  205     , Anno (Match GhcTc (LocatedA (body GhcTc))) ~ SrcSpanAnnA
  206     , Anno [LocatedA (Match GhcRn (LocatedA (body GhcRn)))] ~ SrcSpanAnnL
  207     , Anno [LocatedA (Match GhcTc (LocatedA (body GhcTc)))] ~ SrcSpanAnnL
  208     , Anno (GRHS GhcRn (LocatedA (body GhcRn))) ~ SrcAnn NoEpAnns
  209     , Anno (GRHS GhcTc (LocatedA (body GhcTc))) ~ SrcAnn NoEpAnns
  210     , Anno (StmtLR GhcRn GhcRn (LocatedA (body GhcRn))) ~ SrcSpanAnnA
  211     , Anno (StmtLR GhcTc GhcTc (LocatedA (body GhcTc))) ~ SrcSpanAnnA
  212     )
  213 
  214 -- | Type-check a MatchGroup.
  215 tcMatches :: (AnnoBody body ) => TcMatchCtxt body
  216           -> [Scaled ExpSigmaType]      -- Expected pattern types
  217           -> ExpRhoType          -- Expected result-type of the Match.
  218           -> MatchGroup GhcRn (LocatedA (body GhcRn))
  219           -> TcM (MatchGroup GhcTc (LocatedA (body GhcTc)))
  220 
  221 tcMatches ctxt pat_tys rhs_ty (MG { mg_alts = L l matches
  222                                   , mg_origin = origin })
  223   | null matches  -- Deal with case e of {}
  224     -- Since there are no branches, no one else will fill in rhs_ty
  225     -- when in inference mode, so we must do it ourselves,
  226     -- here, using expTypeToType
  227   = do { tcEmitBindingUsage bottomUE
  228        ; pat_tys <- mapM scaledExpTypeToType pat_tys
  229        ; rhs_ty  <- expTypeToType rhs_ty
  230        ; _concrete_evs <- zipWithM
  231                        (\ i (Scaled _ pat_ty) ->
  232                          hasFixedRuntimeRep (FRRMatch (mc_what ctxt) i) pat_ty)
  233                        [1..] pat_tys
  234        ; return (MG { mg_alts = L l []
  235                     , mg_ext = MatchGroupTc pat_tys rhs_ty
  236                     , mg_origin = origin }) }
  237 
  238   | otherwise
  239   = do { umatches <- mapM (tcCollectingUsage . tcMatch ctxt pat_tys rhs_ty) matches
  240        ; let (usages,matches') = unzip umatches
  241        ; tcEmitBindingUsage $ supUEs usages
  242        ; pat_tys  <- mapM readScaledExpType pat_tys
  243        ; rhs_ty   <- readExpType rhs_ty
  244        ; _concrete_evs <- zipWithM
  245                        (\ i (Scaled _ pat_ty) ->
  246                          hasFixedRuntimeRep (FRRMatch (mc_what ctxt) i) pat_ty)
  247                        [1..] pat_tys
  248        ; return (MG { mg_alts   = L l matches'
  249                     , mg_ext    = MatchGroupTc pat_tys rhs_ty
  250                     , mg_origin = origin }) }
  251 
  252 -------------
  253 tcMatch :: (AnnoBody body) => TcMatchCtxt body
  254         -> [Scaled ExpSigmaType]        -- Expected pattern types
  255         -> ExpRhoType            -- Expected result-type of the Match.
  256         -> LMatch GhcRn (LocatedA (body GhcRn))
  257         -> TcM (LMatch GhcTc (LocatedA (body GhcTc)))
  258 
  259 tcMatch ctxt pat_tys rhs_ty match
  260   = wrapLocMA (tc_match ctxt pat_tys rhs_ty) match
  261   where
  262     tc_match ctxt pat_tys rhs_ty
  263              match@(Match { m_pats = pats, m_grhss = grhss })
  264       = add_match_ctxt match $
  265         do { (pats', grhss') <- tcPats (mc_what ctxt) pats pat_tys $
  266                                 tcGRHSs ctxt grhss rhs_ty
  267            ; return (Match { m_ext = noAnn
  268                            , m_ctxt = mc_what ctxt, m_pats = pats'
  269                            , m_grhss = grhss' }) }
  270 
  271         -- For (\x -> e), tcExpr has already said "In the expression \x->e"
  272         -- so we don't want to add "In the lambda abstraction \x->e"
  273     add_match_ctxt match thing_inside
  274         = case mc_what ctxt of
  275             LambdaExpr -> thing_inside
  276             _          -> addErrCtxt (pprMatchInCtxt match) thing_inside
  277 
  278 -------------
  279 tcGRHSs :: AnnoBody body
  280         => TcMatchCtxt body -> GRHSs GhcRn (LocatedA (body GhcRn)) -> ExpRhoType
  281         -> TcM (GRHSs GhcTc (LocatedA (body GhcTc)))
  282 
  283 -- Notice that we pass in the full res_ty, so that we get
  284 -- good inference from simple things like
  285 --      f = \(x::forall a.a->a) -> <stuff>
  286 -- We used to force it to be a monotype when there was more than one guard
  287 -- but we don't need to do that any more
  288 
  289 tcGRHSs ctxt (GRHSs _ grhss binds) res_ty
  290   = do  { (binds', ugrhss)
  291             <- tcLocalBinds binds $
  292                mapM (tcCollectingUsage . wrapLocMA (tcGRHS ctxt res_ty)) grhss
  293         ; let (usages, grhss') = unzip ugrhss
  294         ; tcEmitBindingUsage $ supUEs usages
  295         ; return (GRHSs emptyComments grhss' binds') }
  296 
  297 -------------
  298 tcGRHS :: TcMatchCtxt body -> ExpRhoType -> GRHS GhcRn (LocatedA (body GhcRn))
  299        -> TcM (GRHS GhcTc (LocatedA (body GhcTc)))
  300 
  301 tcGRHS ctxt res_ty (GRHS _ guards rhs)
  302   = do  { (guards', rhs')
  303             <- tcStmtsAndThen stmt_ctxt tcGuardStmt guards res_ty $
  304                mc_body ctxt rhs
  305         ; return (GRHS noAnn guards' rhs') }
  306   where
  307     stmt_ctxt  = PatGuard (mc_what ctxt)
  308 
  309 {-
  310 ************************************************************************
  311 *                                                                      *
  312 \subsection{@tcDoStmts@ typechecks a {\em list} of do statements}
  313 *                                                                      *
  314 ************************************************************************
  315 -}
  316 
  317 tcDoStmts :: HsDoFlavour
  318           -> LocatedL [LStmt GhcRn (LHsExpr GhcRn)]
  319           -> ExpRhoType
  320           -> TcM (HsExpr GhcTc)          -- Returns a HsDo
  321 tcDoStmts ListComp (L l stmts) res_ty
  322   = do  { res_ty <- expTypeToType res_ty
  323         ; (co, elt_ty) <- matchExpectedListTy res_ty
  324         ; let list_ty = mkListTy elt_ty
  325         ; stmts' <- tcStmts (HsDoStmt ListComp) (tcLcStmt listTyCon) stmts
  326                             (mkCheckExpType elt_ty)
  327         ; return $ mkHsWrapCo co (HsDo list_ty ListComp (L l stmts')) }
  328 
  329 tcDoStmts doExpr@(DoExpr _) (L l stmts) res_ty
  330   = do  { stmts' <- tcStmts (HsDoStmt doExpr) tcDoStmt stmts res_ty
  331         ; res_ty <- readExpType res_ty
  332         ; return (HsDo res_ty doExpr (L l stmts')) }
  333 
  334 tcDoStmts mDoExpr@(MDoExpr _) (L l stmts) res_ty
  335   = do  { stmts' <- tcStmts (HsDoStmt mDoExpr) tcDoStmt stmts res_ty
  336         ; res_ty <- readExpType res_ty
  337         ; return (HsDo res_ty mDoExpr (L l stmts')) }
  338 
  339 tcDoStmts MonadComp (L l stmts) res_ty
  340   = do  { stmts' <- tcStmts (HsDoStmt MonadComp) tcMcStmt stmts res_ty
  341         ; res_ty <- readExpType res_ty
  342         ; return (HsDo res_ty MonadComp (L l stmts')) }
  343 tcDoStmts ctxt@GhciStmtCtxt _ _ = pprPanic "tcDoStmts" (pprHsDoFlavour ctxt)
  344 
  345 tcBody :: LHsExpr GhcRn -> ExpRhoType -> TcM (LHsExpr GhcTc)
  346 tcBody body res_ty
  347   = do  { traceTc "tcBody" (ppr res_ty)
  348         ; tcMonoExpr body res_ty
  349         }
  350 
  351 {-
  352 ************************************************************************
  353 *                                                                      *
  354 \subsection{tcStmts}
  355 *                                                                      *
  356 ************************************************************************
  357 -}
  358 
  359 type TcExprStmtChecker = TcStmtChecker HsExpr ExpRhoType
  360 type TcCmdStmtChecker  = TcStmtChecker HsCmd  TcRhoType
  361 
  362 type TcStmtChecker body rho_type
  363   =  forall thing. HsStmtContext GhcTc
  364                 -> Stmt GhcRn (LocatedA (body GhcRn))
  365                 -> rho_type                 -- Result type for comprehension
  366                 -> (rho_type -> TcM thing)  -- Checker for what follows the stmt
  367                 -> TcM (Stmt GhcTc (LocatedA (body GhcTc)), thing)
  368 
  369 tcStmts :: (AnnoBody body) => HsStmtContext GhcTc
  370         -> TcStmtChecker body rho_type   -- NB: higher-rank type
  371         -> [LStmt GhcRn (LocatedA (body GhcRn))]
  372         -> rho_type
  373         -> TcM [LStmt GhcTc (LocatedA (body GhcTc))]
  374 tcStmts ctxt stmt_chk stmts res_ty
  375   = do { (stmts', _) <- tcStmtsAndThen ctxt stmt_chk stmts res_ty $
  376                         const (return ())
  377        ; return stmts' }
  378 
  379 tcStmtsAndThen :: (AnnoBody body) => HsStmtContext GhcTc
  380                -> TcStmtChecker body rho_type    -- NB: higher-rank type
  381                -> [LStmt GhcRn (LocatedA (body GhcRn))]
  382                -> rho_type
  383                -> (rho_type -> TcM thing)
  384                -> TcM ([LStmt GhcTc (LocatedA (body GhcTc))], thing)
  385 
  386 -- Note the higher-rank type.  stmt_chk is applied at different
  387 -- types in the equations for tcStmts
  388 
  389 tcStmtsAndThen _ _ [] res_ty thing_inside
  390   = do  { thing <- thing_inside res_ty
  391         ; return ([], thing) }
  392 
  393 -- LetStmts are handled uniformly, regardless of context
  394 tcStmtsAndThen ctxt stmt_chk (L loc (LetStmt x binds) : stmts)
  395                                                              res_ty thing_inside
  396   = do  { (binds', (stmts',thing)) <- tcLocalBinds binds $
  397               tcStmtsAndThen ctxt stmt_chk stmts res_ty thing_inside
  398         ; return (L loc (LetStmt x binds') : stmts', thing) }
  399 
  400 -- Don't set the error context for an ApplicativeStmt.  It ought to be
  401 -- possible to do this with a popErrCtxt in the tcStmt case for
  402 -- ApplicativeStmt, but it did something strange and broke a test (ado002).
  403 tcStmtsAndThen ctxt stmt_chk (L loc stmt : stmts) res_ty thing_inside
  404   | ApplicativeStmt{} <- stmt
  405   = do  { (stmt', (stmts', thing)) <-
  406              stmt_chk ctxt stmt res_ty $ \ res_ty' ->
  407                tcStmtsAndThen ctxt stmt_chk stmts res_ty'  $
  408                  thing_inside
  409         ; return (L loc stmt' : stmts', thing) }
  410 
  411   -- For the vanilla case, handle the location-setting part
  412   | otherwise
  413   = do  { (stmt', (stmts', thing)) <-
  414                 setSrcSpanA loc                             $
  415                 addErrCtxt (pprStmtInCtxt ctxt stmt)        $
  416                 stmt_chk ctxt stmt res_ty                   $ \ res_ty' ->
  417                 popErrCtxt                                  $
  418                 tcStmtsAndThen ctxt stmt_chk stmts res_ty'  $
  419                 thing_inside
  420         ; return (L loc stmt' : stmts', thing) }
  421 
  422 ---------------------------------------------------
  423 --              Pattern guards
  424 ---------------------------------------------------
  425 
  426 tcGuardStmt :: TcExprStmtChecker
  427 tcGuardStmt _ (BodyStmt _ guard _ _) res_ty thing_inside
  428   = do  { guard' <- tcScalingUsage Many $ tcCheckMonoExpr guard boolTy
  429           -- Scale the guard to Many (see #19120 and #19193)
  430         ; thing  <- thing_inside res_ty
  431         ; return (BodyStmt boolTy guard' noSyntaxExpr noSyntaxExpr, thing) }
  432 
  433 tcGuardStmt ctxt (BindStmt _ pat rhs) res_ty thing_inside
  434   = do  { -- The Many on the next line and the unrestricted on the line after
  435           -- are linked. These must be the same multiplicity. Consider
  436           --   x <- rhs -> u
  437           --
  438           -- The multiplicity of x in u must be the same as the multiplicity at
  439           -- which the rhs has been consumed. When solving #18738, we want these
  440           -- two multiplicity to still be the same.
  441           (rhs', rhs_ty) <- tcScalingUsage Many $ tcInferRhoNC rhs
  442                                    -- Stmt has a context already
  443         ; _concrete_ev <- hasFixedRuntimeRep FRRBindStmtGuard rhs_ty
  444         ; (pat', thing)  <- tcCheckPat_O (StmtCtxt ctxt) (lexprCtOrigin rhs)
  445                                          pat (unrestricted rhs_ty) $
  446                             thing_inside res_ty
  447         ; return (mkTcBindStmt pat' rhs', thing) }
  448 
  449 tcGuardStmt _ stmt _ _
  450   = pprPanic "tcGuardStmt: unexpected Stmt" (ppr stmt)
  451 
  452 
  453 ---------------------------------------------------
  454 --           List comprehensions
  455 --               (no rebindable syntax)
  456 ---------------------------------------------------
  457 
  458 -- Dealt with separately, rather than by tcMcStmt, because
  459 --   a) We have special desugaring rules for list comprehensions,
  460 --      which avoid creating intermediate lists.  They in turn
  461 --      assume that the bind/return operations are the regular
  462 --      polymorphic ones, and in particular don't have any
  463 --      coercion matching stuff in them.  It's hard to avoid the
  464 --      potential for non-trivial coercions in tcMcStmt
  465 
  466 tcLcStmt :: TyCon       -- The list type constructor ([])
  467          -> TcExprStmtChecker
  468 
  469 tcLcStmt _ _ (LastStmt x body noret _) elt_ty thing_inside
  470   = do { body' <- tcMonoExprNC body elt_ty
  471        ; thing <- thing_inside (panic "tcLcStmt: thing_inside")
  472        ; return (LastStmt x body' noret noSyntaxExpr, thing) }
  473 
  474 -- A generator, pat <- rhs
  475 tcLcStmt m_tc ctxt (BindStmt _ pat rhs) elt_ty thing_inside
  476  = do   { pat_ty <- newFlexiTyVarTy liftedTypeKind
  477         ; rhs'   <- tcCheckMonoExpr rhs (mkTyConApp m_tc [pat_ty])
  478         ; (pat', thing)  <- tcCheckPat (StmtCtxt ctxt) pat (unrestricted pat_ty) $
  479                             thing_inside elt_ty
  480         ; return (mkTcBindStmt pat' rhs', thing) }
  481 
  482 -- A boolean guard
  483 tcLcStmt _ _ (BodyStmt _ rhs _ _) elt_ty thing_inside
  484   = do  { rhs'  <- tcCheckMonoExpr rhs boolTy
  485         ; thing <- thing_inside elt_ty
  486         ; return (BodyStmt boolTy rhs' noSyntaxExpr noSyntaxExpr, thing) }
  487 
  488 -- ParStmt: See notes with tcMcStmt
  489 tcLcStmt m_tc ctxt (ParStmt _ bndr_stmts_s _ _) elt_ty thing_inside
  490   = do  { (pairs', thing) <- loop bndr_stmts_s
  491         ; return (ParStmt unitTy pairs' noExpr noSyntaxExpr, thing) }
  492   where
  493     -- loop :: [([LStmt GhcRn], [GhcRn])]
  494     --      -> TcM ([([LStmt GhcTc], [GhcTc])], thing)
  495     loop [] = do { thing <- thing_inside elt_ty
  496                  ; return ([], thing) }         -- matching in the branches
  497 
  498     loop (ParStmtBlock x stmts names _ : pairs)
  499       = do { (stmts', (ids, pairs', thing))
  500                 <- tcStmtsAndThen ctxt (tcLcStmt m_tc) stmts elt_ty $ \ _elt_ty' ->
  501                    do { ids <- tcLookupLocalIds names
  502                       ; (pairs', thing) <- loop pairs
  503                       ; return (ids, pairs', thing) }
  504            ; return ( ParStmtBlock x stmts' ids noSyntaxExpr : pairs', thing ) }
  505 
  506 tcLcStmt m_tc ctxt (TransStmt { trS_form = form, trS_stmts = stmts
  507                               , trS_bndrs =  bindersMap
  508                               , trS_by = by, trS_using = using }) elt_ty thing_inside
  509   = do { let (bndr_names, n_bndr_names) = unzip bindersMap
  510              unused_ty = pprPanic "tcLcStmt: inner ty" (ppr bindersMap)
  511              -- The inner 'stmts' lack a LastStmt, so the element type
  512              --  passed in to tcStmtsAndThen is never looked at
  513        ; (stmts', (bndr_ids, by'))
  514             <- tcStmtsAndThen (TransStmtCtxt ctxt) (tcLcStmt m_tc) stmts unused_ty $ \_ -> do
  515                { by' <- traverse tcInferRho by
  516                ; bndr_ids <- tcLookupLocalIds bndr_names
  517                ; return (bndr_ids, by') }
  518 
  519        ; let m_app ty = mkTyConApp m_tc [ty]
  520 
  521        --------------- Typecheck the 'using' function -------------
  522        -- using :: ((a,b,c)->t) -> m (a,b,c) -> m (a,b,c)m      (ThenForm)
  523        --       :: ((a,b,c)->t) -> m (a,b,c) -> m (m (a,b,c)))  (GroupForm)
  524 
  525          -- n_app :: Type -> Type   -- Wraps a 'ty' into '[ty]' for GroupForm
  526        ; let n_app = case form of
  527                        ThenForm -> (\ty -> ty)
  528                        _        -> m_app
  529 
  530              by_arrow :: Type -> Type     -- Wraps 'ty' to '(a->t) -> ty' if the By is present
  531              by_arrow = case by' of
  532                           Nothing       -> \ty -> ty
  533                           Just (_,e_ty) -> \ty -> (alphaTy `mkVisFunTyMany` e_ty) `mkVisFunTyMany` ty
  534 
  535              tup_ty        = mkBigCoreVarTupTy bndr_ids
  536              poly_arg_ty   = m_app alphaTy
  537              poly_res_ty   = m_app (n_app alphaTy)
  538              using_poly_ty = mkInfForAllTy alphaTyVar $
  539                              by_arrow $
  540                              poly_arg_ty `mkVisFunTyMany` poly_res_ty
  541 
  542        ; using' <- tcCheckPolyExpr using using_poly_ty
  543        ; let final_using = fmap (mkHsWrap (WpTyApp tup_ty)) using'
  544 
  545              -- 'stmts' returns a result of type (m1_ty tuple_ty),
  546              -- typically something like [(Int,Bool,Int)]
  547              -- We don't know what tuple_ty is yet, so we use a variable
  548        ; let mk_n_bndr :: Name -> TcId -> TcId
  549              mk_n_bndr n_bndr_name bndr_id = mkLocalId n_bndr_name Many (n_app (idType bndr_id))
  550 
  551              -- Ensure that every old binder of type `b` is linked up with its
  552              -- new binder which should have type `n b`
  553              -- See Note [GroupStmt binder map] in GHC.Hs.Expr
  554              n_bndr_ids  = zipWith mk_n_bndr n_bndr_names bndr_ids
  555              bindersMap' = bndr_ids `zip` n_bndr_ids
  556 
  557        -- Type check the thing in the environment with
  558        -- these new binders and return the result
  559        ; thing <- tcExtendIdEnv n_bndr_ids (thing_inside elt_ty)
  560 
  561        ; return (TransStmt { trS_stmts = stmts', trS_bndrs = bindersMap'
  562                            , trS_by = fmap fst by', trS_using = final_using
  563                            , trS_ret = noSyntaxExpr
  564                            , trS_bind = noSyntaxExpr
  565                            , trS_fmap = noExpr
  566                            , trS_ext = unitTy
  567                            , trS_form = form }, thing) }
  568 
  569 tcLcStmt _ _ stmt _ _
  570   = pprPanic "tcLcStmt: unexpected Stmt" (ppr stmt)
  571 
  572 
  573 ---------------------------------------------------
  574 --           Monad comprehensions
  575 --        (supports rebindable syntax)
  576 ---------------------------------------------------
  577 
  578 tcMcStmt :: TcExprStmtChecker
  579 
  580 tcMcStmt _ (LastStmt x body noret return_op) res_ty thing_inside
  581   = do  { (body', return_op')
  582             <- tcSyntaxOp MCompOrigin return_op [SynRho] res_ty $
  583                \ [a_ty] [mult]->
  584                tcScalingUsage mult $ tcCheckMonoExprNC body a_ty
  585         ; thing      <- thing_inside (panic "tcMcStmt: thing_inside")
  586         ; return (LastStmt x body' noret return_op', thing) }
  587 
  588 -- Generators for monad comprehensions ( pat <- rhs )
  589 --
  590 --   [ body | q <- gen ]  ->  gen :: m a
  591 --                            q   ::   a
  592 --
  593 
  594 tcMcStmt ctxt (BindStmt xbsrn pat rhs) res_ty thing_inside
  595            -- (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty
  596   = do  { ((rhs_ty, rhs', pat_mult, pat', thing, new_res_ty), bind_op')
  597             <- tcSyntaxOp MCompOrigin (xbsrn_bindOp xbsrn)
  598                           [SynRho, SynFun SynAny SynRho] res_ty $
  599                \ [rhs_ty, pat_ty, new_res_ty] [rhs_mult, fun_mult, pat_mult] ->
  600                do { rhs' <- tcScalingUsage rhs_mult $ tcCheckMonoExprNC rhs rhs_ty
  601                   ; (pat', thing) <- tcScalingUsage fun_mult $ tcCheckPat (StmtCtxt ctxt) pat (Scaled pat_mult pat_ty) $
  602                                      thing_inside (mkCheckExpType new_res_ty)
  603                   ; return (rhs_ty, rhs', pat_mult, pat', thing, new_res_ty) }
  604 
  605         ; _concrete_ev <- hasFixedRuntimeRep (FRRBindStmt MonadComprehension) rhs_ty
  606 
  607         -- If (but only if) the pattern can fail, typecheck the 'fail' operator
  608         ; fail_op' <- fmap join . forM (xbsrn_failOp xbsrn) $ \fail ->
  609             tcMonadFailOp (MCompPatOrigin pat) pat' fail new_res_ty
  610 
  611         ; let xbstc = XBindStmtTc
  612                 { xbstc_bindOp = bind_op'
  613                 , xbstc_boundResultType = new_res_ty
  614                 , xbstc_boundResultMult = pat_mult
  615                 , xbstc_failOp = fail_op'
  616                 }
  617         ; return (BindStmt xbstc pat' rhs', thing) }
  618 
  619 -- Boolean expressions.
  620 --
  621 --   [ body | stmts, expr ]  ->  expr :: m Bool
  622 --
  623 tcMcStmt _ (BodyStmt _ rhs then_op guard_op) res_ty thing_inside
  624   = do  { -- Deal with rebindable syntax:
  625           --    guard_op :: test_ty -> rhs_ty
  626           --    then_op  :: rhs_ty -> new_res_ty -> res_ty
  627           -- Where test_ty is, for example, Bool
  628         ; ((thing, rhs', rhs_ty, new_res_ty, test_ty, guard_op'), then_op')
  629             <- tcSyntaxOp MCompOrigin then_op [SynRho, SynRho] res_ty $
  630                \ [rhs_ty, new_res_ty] [rhs_mult, fun_mult] ->
  631                do { ((rhs', test_ty), guard_op')
  632                       <- tcScalingUsage rhs_mult $
  633                          tcSyntaxOp MCompOrigin guard_op [SynAny]
  634                                     (mkCheckExpType rhs_ty) $
  635                          \ [test_ty] [test_mult] -> do
  636                            rhs' <- tcScalingUsage test_mult $ tcCheckMonoExpr rhs test_ty
  637                            return $ (rhs', test_ty)
  638                   ; thing <- tcScalingUsage fun_mult $ thing_inside (mkCheckExpType new_res_ty)
  639                   ; return (thing, rhs', rhs_ty, new_res_ty, test_ty, guard_op') }
  640 
  641         ; _evTerm1 <- hasFixedRuntimeRep FRRBodyStmtGuard test_ty
  642         ; _evTerm2 <- hasFixedRuntimeRep (FRRBodyStmt MonadComprehension 1) rhs_ty
  643         ; _evTerm3 <- hasFixedRuntimeRep (FRRBodyStmt MonadComprehension 2) new_res_ty
  644 
  645         ; return (BodyStmt rhs_ty rhs' then_op' guard_op', thing) }
  646 
  647 -- Grouping statements
  648 --
  649 --   [ body | stmts, then group by e using f ]
  650 --     ->  e :: t
  651 --         f :: forall a. (a -> t) -> m a -> m (m a)
  652 --   [ body | stmts, then group using f ]
  653 --     ->  f :: forall a. m a -> m (m a)
  654 
  655 -- We type [ body | (stmts, group by e using f), ... ]
  656 --     f <optional by> [ (a,b,c) | stmts ] >>= \(a,b,c) -> ...body....
  657 --
  658 -- We type the functions as follows:
  659 --     f <optional by> :: m1 (a,b,c) -> m2 (a,b,c)              (ThenForm)
  660 --                     :: m1 (a,b,c) -> m2 (n (a,b,c))          (GroupForm)
  661 --     (>>=) :: m2 (a,b,c)     -> ((a,b,c)   -> res) -> res     (ThenForm)
  662 --           :: m2 (n (a,b,c)) -> (n (a,b,c) -> res) -> res     (GroupForm)
  663 --
  664 tcMcStmt ctxt (TransStmt { trS_stmts = stmts, trS_bndrs = bindersMap
  665                          , trS_by = by, trS_using = using, trS_form = form
  666                          , trS_ret = return_op, trS_bind = bind_op
  667                          , trS_fmap = fmap_op }) res_ty thing_inside
  668   = do { m1_ty   <- newFlexiTyVarTy typeToTypeKind
  669        ; m2_ty   <- newFlexiTyVarTy typeToTypeKind
  670        ; tup_ty  <- newFlexiTyVarTy liftedTypeKind
  671        ; by_e_ty <- newFlexiTyVarTy liftedTypeKind  -- The type of the 'by' expression (if any)
  672 
  673          -- n_app :: Type -> Type   -- Wraps a 'ty' into '(n ty)' for GroupForm
  674        ; n_app <- case form of
  675                     ThenForm -> return (\ty -> ty)
  676                     _        -> do { n_ty <- newFlexiTyVarTy typeToTypeKind
  677                                    ; return (n_ty `mkAppTy`) }
  678        ; let by_arrow :: Type -> Type
  679              -- (by_arrow res) produces ((alpha->e_ty) -> res)     ('by' present)
  680              --                          or res                    ('by' absent)
  681              by_arrow = case by of
  682                           Nothing -> \res -> res
  683                           Just {} -> \res -> (alphaTy `mkVisFunTyMany` by_e_ty) `mkVisFunTyMany` res
  684 
  685              poly_arg_ty  = m1_ty `mkAppTy` alphaTy
  686              using_arg_ty = m1_ty `mkAppTy` tup_ty
  687              poly_res_ty  = m2_ty `mkAppTy` n_app alphaTy
  688              using_res_ty = m2_ty `mkAppTy` n_app tup_ty
  689              using_poly_ty = mkInfForAllTy alphaTyVar $
  690                              by_arrow $
  691                              poly_arg_ty `mkVisFunTyMany` poly_res_ty
  692 
  693              -- 'stmts' returns a result of type (m1_ty tuple_ty),
  694              -- typically something like [(Int,Bool,Int)]
  695              -- We don't know what tuple_ty is yet, so we use a variable
  696        ; let (bndr_names, n_bndr_names) = unzip bindersMap
  697        ; (stmts', (bndr_ids, by', return_op')) <-
  698             tcStmtsAndThen (TransStmtCtxt ctxt) tcMcStmt stmts
  699                            (mkCheckExpType using_arg_ty) $ \res_ty' -> do
  700                 { by' <- case by of
  701                            Nothing -> return Nothing
  702                            Just e  -> do { e' <- tcCheckMonoExpr e by_e_ty
  703                                          ; return (Just e') }
  704 
  705                 -- Find the Ids (and hence types) of all old binders
  706                 ; bndr_ids <- tcLookupLocalIds bndr_names
  707 
  708                 -- 'return' is only used for the binders, so we know its type.
  709                 --   return :: (a,b,c,..) -> m (a,b,c,..)
  710                 ; (_, return_op') <- tcSyntaxOp MCompOrigin return_op
  711                                        [synKnownType (mkBigCoreVarTupTy bndr_ids)]
  712                                        res_ty' $ \ _ _ -> return ()
  713 
  714                 ; return (bndr_ids, by', return_op') }
  715 
  716        --------------- Typecheck the 'bind' function -------------
  717        -- (>>=) :: m2 (n (a,b,c)) -> ( n (a,b,c) -> new_res_ty ) -> res_ty
  718        ; new_res_ty <- newFlexiTyVarTy liftedTypeKind
  719        ; (_, bind_op')  <- tcSyntaxOp MCompOrigin bind_op
  720                              [ synKnownType using_res_ty
  721                              , synKnownType (n_app tup_ty `mkVisFunTyMany` new_res_ty) ]
  722                              res_ty $ \ _ _ -> return ()
  723 
  724        --------------- Typecheck the 'fmap' function -------------
  725        ; fmap_op' <- case form of
  726                        ThenForm -> return noExpr
  727                        _ -> fmap unLoc . tcCheckPolyExpr (noLocA fmap_op) $
  728                             mkInfForAllTy alphaTyVar $
  729                             mkInfForAllTy betaTyVar  $
  730                             (alphaTy `mkVisFunTyMany` betaTy)
  731                             `mkVisFunTyMany` (n_app alphaTy)
  732                             `mkVisFunTyMany` (n_app betaTy)
  733 
  734        --------------- Typecheck the 'using' function -------------
  735        -- using :: ((a,b,c)->t) -> m1 (a,b,c) -> m2 (n (a,b,c))
  736 
  737        ; using' <- tcCheckPolyExpr using using_poly_ty
  738        ; let final_using = fmap (mkHsWrap (WpTyApp tup_ty)) using'
  739 
  740        --------------- Building the bindersMap ----------------
  741        ; let mk_n_bndr :: Name -> TcId -> TcId
  742              mk_n_bndr n_bndr_name bndr_id = mkLocalId n_bndr_name Many (n_app (idType bndr_id))
  743 
  744              -- Ensure that every old binder of type `b` is linked up with its
  745              -- new binder which should have type `n b`
  746              -- See Note [GroupStmt binder map] in GHC.Hs.Expr
  747              n_bndr_ids = zipWithEqual "tcMcStmt" mk_n_bndr n_bndr_names bndr_ids
  748              bindersMap' = bndr_ids `zip` n_bndr_ids
  749 
  750        -- Type check the thing in the environment with
  751        -- these new binders and return the result
  752        ; thing <- tcExtendIdEnv n_bndr_ids $
  753                   thing_inside (mkCheckExpType new_res_ty)
  754 
  755        ; return (TransStmt { trS_stmts = stmts', trS_bndrs = bindersMap'
  756                            , trS_by = by', trS_using = final_using
  757                            , trS_ret = return_op', trS_bind = bind_op'
  758                            , trS_ext = n_app tup_ty
  759                            , trS_fmap = fmap_op', trS_form = form }, thing) }
  760 
  761 -- A parallel set of comprehensions
  762 --      [ (g x, h x) | ... ; let g v = ...
  763 --                   | ... ; let h v = ... ]
  764 --
  765 -- It's possible that g,h are overloaded, so we need to feed the LIE from the
  766 -- (g x, h x) up through both lots of bindings (so we get the bindLocalMethods).
  767 -- Similarly if we had an existential pattern match:
  768 --
  769 --      data T = forall a. Show a => C a
  770 --
  771 --      [ (show x, show y) | ... ; C x <- ...
  772 --                         | ... ; C y <- ... ]
  773 --
  774 -- Then we need the LIE from (show x, show y) to be simplified against
  775 -- the bindings for x and y.
  776 --
  777 -- It's difficult to do this in parallel, so we rely on the renamer to
  778 -- ensure that g,h and x,y don't duplicate, and simply grow the environment.
  779 -- So the binders of the first parallel group will be in scope in the second
  780 -- group.  But that's fine; there's no shadowing to worry about.
  781 --
  782 -- Note: The `mzip` function will get typechecked via:
  783 --
  784 --   ParStmt [st1::t1, st2::t2, st3::t3]
  785 --
  786 --   mzip :: m st1
  787 --        -> (m st2 -> m st3 -> m (st2, st3))   -- recursive call
  788 --        -> m (st1, (st2, st3))
  789 --
  790 tcMcStmt ctxt (ParStmt _ bndr_stmts_s mzip_op bind_op) res_ty thing_inside
  791   = do { m_ty   <- newFlexiTyVarTy typeToTypeKind
  792 
  793        ; let mzip_ty  = mkInfForAllTys [alphaTyVar, betaTyVar] $
  794                         (m_ty `mkAppTy` alphaTy)
  795                         `mkVisFunTyMany`
  796                         (m_ty `mkAppTy` betaTy)
  797                         `mkVisFunTyMany`
  798                         (m_ty `mkAppTy` mkBoxedTupleTy [alphaTy, betaTy])
  799        ; mzip_op' <- unLoc `fmap` tcCheckPolyExpr (noLocA mzip_op) mzip_ty
  800 
  801         -- type dummies since we don't know all binder types yet
  802        ; id_tys_s <- (mapM . mapM) (const (newFlexiTyVarTy liftedTypeKind))
  803                        [ names | ParStmtBlock _ _ names _ <- bndr_stmts_s ]
  804 
  805        -- Typecheck bind:
  806        ; let tup_tys  = [ mkBigCoreTupTy id_tys | id_tys <- id_tys_s ]
  807              tuple_ty = mk_tuple_ty tup_tys
  808 
  809        ; (((blocks', thing), inner_res_ty), bind_op')
  810            <- tcSyntaxOp MCompOrigin bind_op
  811                          [ synKnownType (m_ty `mkAppTy` tuple_ty)
  812                          , SynFun (synKnownType tuple_ty) SynRho ] res_ty $
  813               \ [inner_res_ty] _ ->
  814               do { stuff <- loop m_ty (mkCheckExpType inner_res_ty)
  815                                  tup_tys bndr_stmts_s
  816                  ; return (stuff, inner_res_ty) }
  817 
  818        ; return (ParStmt inner_res_ty blocks' mzip_op' bind_op', thing) }
  819 
  820   where
  821     mk_tuple_ty tys = foldr1 (\tn tm -> mkBoxedTupleTy [tn, tm]) tys
  822 
  823        -- loop :: Type                                  -- m_ty
  824        --      -> ExpRhoType                            -- inner_res_ty
  825        --      -> [TcType]                              -- tup_tys
  826        --      -> [ParStmtBlock Name]
  827        --      -> TcM ([([LStmt GhcTc], [TcId])], thing)
  828     loop _ inner_res_ty [] [] = do { thing <- thing_inside inner_res_ty
  829                                    ; return ([], thing) }
  830                                    -- matching in the branches
  831 
  832     loop m_ty inner_res_ty (tup_ty_in : tup_tys_in)
  833                            (ParStmtBlock x stmts names return_op : pairs)
  834       = do { let m_tup_ty = m_ty `mkAppTy` tup_ty_in
  835            ; (stmts', (ids, return_op', pairs', thing))
  836                 <- tcStmtsAndThen ctxt tcMcStmt stmts (mkCheckExpType m_tup_ty) $
  837                    \m_tup_ty' ->
  838                    do { ids <- tcLookupLocalIds names
  839                       ; let tup_ty = mkBigCoreVarTupTy ids
  840                       ; (_, return_op') <-
  841                           tcSyntaxOp MCompOrigin return_op
  842                                      [synKnownType tup_ty] m_tup_ty' $
  843                                      \ _ _ -> return ()
  844                       ; (pairs', thing) <- loop m_ty inner_res_ty tup_tys_in pairs
  845                       ; return (ids, return_op', pairs', thing) }
  846            ; return (ParStmtBlock x stmts' ids return_op' : pairs', thing) }
  847     loop _ _ _ _ = panic "tcMcStmt.loop"
  848 
  849 tcMcStmt _ stmt _ _
  850   = pprPanic "tcMcStmt: unexpected Stmt" (ppr stmt)
  851 
  852 
  853 ---------------------------------------------------
  854 --           Do-notation
  855 --        (supports rebindable syntax)
  856 ---------------------------------------------------
  857 
  858 tcDoStmt :: TcExprStmtChecker
  859 
  860 tcDoStmt _ (LastStmt x body noret _) res_ty thing_inside
  861   = do { body' <- tcMonoExprNC body res_ty
  862        ; thing <- thing_inside (panic "tcDoStmt: thing_inside")
  863        ; return (LastStmt x body' noret noSyntaxExpr, thing) }
  864 
  865 tcDoStmt ctxt (BindStmt xbsrn pat rhs) res_ty thing_inside
  866   = do  {       -- Deal with rebindable syntax:
  867                 --       (>>=) :: rhs_ty ->_rhs_mult (pat_ty ->_pat_mult new_res_ty) ->_fun_mult res_ty
  868                 -- This level of generality is needed for using do-notation
  869                 -- in full generality; see #1537
  870 
  871           ((rhs_ty, rhs', pat_mult, pat', new_res_ty, thing), bind_op')
  872             <- tcSyntaxOp DoOrigin (xbsrn_bindOp xbsrn) [SynRho, SynFun SynAny SynRho] res_ty $
  873                 \ [rhs_ty, pat_ty, new_res_ty] [rhs_mult,fun_mult,pat_mult] ->
  874                 do { rhs' <-tcScalingUsage rhs_mult $ tcCheckMonoExprNC rhs rhs_ty
  875                    ; (pat', thing) <- tcScalingUsage fun_mult $ tcCheckPat (StmtCtxt ctxt) pat (Scaled pat_mult pat_ty) $
  876                                       thing_inside (mkCheckExpType new_res_ty)
  877                    ; return (rhs_ty, rhs', pat_mult, pat', new_res_ty, thing) }
  878 
  879         ; _concrete_ev <- hasFixedRuntimeRep (FRRBindStmt DoNotation) rhs_ty
  880 
  881         -- If (but only if) the pattern can fail, typecheck the 'fail' operator
  882         ; fail_op' <- fmap join . forM (xbsrn_failOp xbsrn) $ \fail ->
  883             tcMonadFailOp (DoPatOrigin pat) pat' fail new_res_ty
  884         ; let xbstc = XBindStmtTc
  885                 { xbstc_bindOp = bind_op'
  886                 , xbstc_boundResultType = new_res_ty
  887                 , xbstc_boundResultMult = pat_mult
  888                 , xbstc_failOp = fail_op'
  889                 }
  890         ; return (BindStmt xbstc pat' rhs', thing) }
  891 
  892 tcDoStmt ctxt (ApplicativeStmt _ pairs mb_join) res_ty thing_inside
  893   = do  { let tc_app_stmts ty = tcApplicativeStmts ctxt pairs ty $
  894                                 thing_inside . mkCheckExpType
  895         ; ((pairs', body_ty, thing), mb_join') <- case mb_join of
  896             Nothing -> (, Nothing) <$> tc_app_stmts res_ty
  897             Just join_op ->
  898               second Just <$>
  899               (tcSyntaxOp DoOrigin join_op [SynRho] res_ty $
  900                \ [rhs_ty] [rhs_mult] -> tcScalingUsage rhs_mult $ tc_app_stmts (mkCheckExpType rhs_ty))
  901 
  902         ; return (ApplicativeStmt body_ty pairs' mb_join', thing) }
  903 
  904 tcDoStmt _ (BodyStmt _ rhs then_op _) res_ty thing_inside
  905   = do  {       -- Deal with rebindable syntax;
  906                 --   (>>) :: rhs_ty -> new_res_ty -> res_ty
  907         ; ((rhs', rhs_ty, new_res_ty, thing), then_op')
  908             <- tcSyntaxOp DoOrigin then_op [SynRho, SynRho] res_ty $
  909                \ [rhs_ty, new_res_ty] [rhs_mult,fun_mult] ->
  910                do { rhs' <- tcScalingUsage rhs_mult $ tcCheckMonoExprNC rhs rhs_ty
  911                   ; thing <- tcScalingUsage fun_mult $ thing_inside (mkCheckExpType new_res_ty)
  912                   ; return (rhs', rhs_ty, new_res_ty, thing) }
  913         ; _evTerm1 <- hasFixedRuntimeRep (FRRBodyStmt DoNotation 1) rhs_ty
  914         ; _evTerm2 <- hasFixedRuntimeRep (FRRBodyStmt DoNotation 2) new_res_ty
  915         ; return (BodyStmt rhs_ty rhs' then_op' noSyntaxExpr, thing) }
  916 
  917 tcDoStmt ctxt (RecStmt { recS_stmts = L l stmts, recS_later_ids = later_names
  918                        , recS_rec_ids = rec_names, recS_ret_fn = ret_op
  919                        , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op })
  920          res_ty thing_inside
  921   = do  { let tup_names = rec_names ++ filterOut (`elem` rec_names) later_names
  922         ; tup_elt_tys <- newFlexiTyVarTys (length tup_names) liftedTypeKind
  923         ; let tup_ids = zipWith (\n t -> mkLocalId n Many t) tup_names tup_elt_tys
  924                 -- Many because it's a recursive definition
  925               tup_ty  = mkBigCoreTupTy tup_elt_tys
  926 
  927         ; tcExtendIdEnv tup_ids $ do
  928         { ((stmts', (ret_op', tup_rets)), stmts_ty)
  929                 <- tcInfer $ \ exp_ty ->
  930                    tcStmtsAndThen ctxt tcDoStmt stmts exp_ty $ \ inner_res_ty ->
  931                    do { tup_rets <- zipWithM tcCheckId tup_names
  932                                       (map mkCheckExpType tup_elt_tys)
  933                              -- Unify the types of the "final" Ids (which may
  934                              -- be polymorphic) with those of "knot-tied" Ids
  935                       ; (_, ret_op')
  936                           <- tcSyntaxOp DoOrigin ret_op [synKnownType tup_ty]
  937                                         inner_res_ty $ \_ _ -> return ()
  938                       ; return (ret_op', tup_rets) }
  939 
  940         ; ((_, mfix_op'), mfix_res_ty)
  941             <- tcInfer $ \ exp_ty ->
  942                tcSyntaxOp DoOrigin mfix_op
  943                           [synKnownType (mkVisFunTyMany tup_ty stmts_ty)] exp_ty $
  944                \ _ _ -> return ()
  945 
  946         ; ((thing, new_res_ty), bind_op')
  947             <- tcSyntaxOp DoOrigin bind_op
  948                           [ synKnownType mfix_res_ty
  949                           , SynFun (synKnownType tup_ty) SynRho ]
  950                           res_ty $
  951                \ [new_res_ty] _ ->
  952                do { thing <- thing_inside (mkCheckExpType new_res_ty)
  953                   ; return (thing, new_res_ty) }
  954 
  955         ; let rec_ids = takeList rec_names tup_ids
  956         ; later_ids <- tcLookupLocalIds later_names
  957         ; traceTc "tcdo" $ vcat [ppr rec_ids <+> ppr (map idType rec_ids),
  958                                  ppr later_ids <+> ppr (map idType later_ids)]
  959         ; return (RecStmt { recS_stmts = L l stmts', recS_later_ids = later_ids
  960                           , recS_rec_ids = rec_ids, recS_ret_fn = ret_op'
  961                           , recS_mfix_fn = mfix_op', recS_bind_fn = bind_op'
  962                           , recS_ext = RecStmtTc
  963                             { recS_bind_ty = new_res_ty
  964                             , recS_later_rets = []
  965                             , recS_rec_rets = tup_rets
  966                             , recS_ret_ty = stmts_ty} }, thing)
  967         }}
  968 
  969 tcDoStmt _ stmt _ _
  970   = pprPanic "tcDoStmt: unexpected Stmt" (ppr stmt)
  971 
  972 
  973 
  974 ---------------------------------------------------
  975 -- MonadFail Proposal warnings
  976 ---------------------------------------------------
  977 
  978 -- The idea behind issuing MonadFail warnings is that we add them whenever a
  979 -- failable pattern is encountered. However, instead of throwing a type error
  980 -- when the constraint cannot be satisfied, we only issue a warning in
  981 -- "GHC.Tc.Errors".
  982 
  983 tcMonadFailOp :: CtOrigin
  984               -> LPat GhcTc
  985               -> SyntaxExpr GhcRn    -- The fail op
  986               -> TcType              -- Type of the whole do-expression
  987               -> TcRn (FailOperator GhcTc)  -- Typechecked fail op
  988 -- Get a 'fail' operator expression, to use if the pattern match fails.
  989 -- This won't be used in cases where we've already determined the pattern
  990 -- match can't fail (so the fail op is Nothing), however, it seems that the
  991 -- isIrrefutableHsPat test is still required here for some reason I haven't
  992 -- yet determined.
  993 tcMonadFailOp orig pat fail_op res_ty = do
  994     dflags <- getDynFlags
  995     if isIrrefutableHsPat dflags pat
  996       then return Nothing
  997       else Just . snd <$> (tcSyntaxOp orig fail_op [synKnownType stringTy]
  998                             (mkCheckExpType res_ty) $ \_ _ -> return ())
  999 
 1000 {-
 1001 Note [Treat rebindable syntax first]
 1002 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 1003 When typechecking
 1004         do { bar; ... } :: IO ()
 1005 we want to typecheck 'bar' in the knowledge that it should be an IO thing,
 1006 pushing info from the context into the RHS.  To do this, we check the
 1007 rebindable syntax first, and push that information into (tcLExprNC rhs).
 1008 Otherwise the error shows up when checking the rebindable syntax, and
 1009 the expected/inferred stuff is back to front (see #3613).
 1010 
 1011 Note [typechecking ApplicativeStmt]
 1012 
 1013 join ((\pat1 ... patn -> body) <$> e1 <*> ... <*> en)
 1014 
 1015 fresh type variables:
 1016    pat_ty_1..pat_ty_n
 1017    exp_ty_1..exp_ty_n
 1018    t_1..t_(n-1)
 1019 
 1020 body  :: body_ty
 1021 (\pat1 ... patn -> body) :: pat_ty_1 -> ... -> pat_ty_n -> body_ty
 1022 pat_i :: pat_ty_i
 1023 e_i   :: exp_ty_i
 1024 <$>   :: (pat_ty_1 -> ... -> pat_ty_n -> body_ty) -> exp_ty_1 -> t_1
 1025 <*>_i :: t_(i-1) -> exp_ty_i -> t_i
 1026 join :: tn -> res_ty
 1027 -}
 1028 
 1029 tcApplicativeStmts
 1030   :: HsStmtContext GhcTc
 1031   -> [(SyntaxExpr GhcRn, ApplicativeArg GhcRn)]
 1032   -> ExpRhoType                         -- rhs_ty
 1033   -> (TcRhoType -> TcM t)               -- thing_inside
 1034   -> TcM ([(SyntaxExpr GhcTc, ApplicativeArg GhcTc)], Type, t)
 1035 
 1036 tcApplicativeStmts ctxt pairs rhs_ty thing_inside
 1037  = do { body_ty <- newFlexiTyVarTy liftedTypeKind
 1038       ; let arity = length pairs
 1039       ; ts <- replicateM (arity-1) $ newInferExpType
 1040       ; exp_tys <- replicateM arity $ newFlexiTyVarTy liftedTypeKind
 1041       ; pat_tys <- replicateM arity $ newFlexiTyVarTy liftedTypeKind
 1042       ; let fun_ty = mkVisFunTysMany pat_tys body_ty
 1043 
 1044        -- NB. do the <$>,<*> operators first, we don't want type errors here
 1045        --     i.e. goOps before goArgs
 1046        -- See Note [Treat rebindable syntax first]
 1047       ; let (ops, args) = unzip pairs
 1048       ; ops' <- goOps fun_ty (zip3 ops (ts ++ [rhs_ty]) exp_tys)
 1049 
 1050       -- Typecheck each ApplicativeArg separately
 1051       -- See Note [ApplicativeDo and constraints]
 1052       ; args' <- mapM (goArg body_ty) (zip3 args pat_tys exp_tys)
 1053 
 1054       -- Bring into scope all the things bound by the args,
 1055       -- and typecheck the thing_inside
 1056       -- See Note [ApplicativeDo and constraints]
 1057       ; res <- tcExtendIdEnv (concatMap get_arg_bndrs args') $
 1058                thing_inside body_ty
 1059 
 1060       ; return (zip ops' args', body_ty, res) }
 1061   where
 1062     goOps _ [] = return []
 1063     goOps t_left ((op,t_i,exp_ty) : ops)
 1064       = do { (_, op')
 1065                <- tcSyntaxOp DoOrigin op
 1066                              [synKnownType t_left, synKnownType exp_ty] t_i $
 1067                    \ _ _ -> return ()
 1068            ; t_i <- readExpType t_i
 1069            ; ops' <- goOps t_i ops
 1070            ; return (op' : ops') }
 1071 
 1072     goArg :: Type -> (ApplicativeArg GhcRn, Type, Type)
 1073           -> TcM (ApplicativeArg GhcTc)
 1074 
 1075     goArg body_ty (ApplicativeArgOne
 1076                     { xarg_app_arg_one = fail_op
 1077                     , app_arg_pattern = pat
 1078                     , arg_expr = rhs
 1079                     , ..
 1080                     }, pat_ty, exp_ty)
 1081       = setSrcSpan (combineSrcSpans (getLocA pat) (getLocA rhs)) $
 1082         addErrCtxt (pprStmtInCtxt ctxt (mkRnBindStmt pat rhs))   $
 1083         do { rhs'      <- tcCheckMonoExprNC rhs exp_ty
 1084            ; (pat', _) <- tcCheckPat (StmtCtxt ctxt) pat (unrestricted pat_ty) $
 1085                           return ()
 1086            ; fail_op' <- fmap join . forM fail_op $ \fail ->
 1087                tcMonadFailOp (DoPatOrigin pat) pat' fail body_ty
 1088 
 1089            ; return (ApplicativeArgOne
 1090                       { xarg_app_arg_one = fail_op'
 1091                       , app_arg_pattern = pat'
 1092                       , arg_expr        = rhs'
 1093                       , .. }
 1094                     ) }
 1095 
 1096     goArg _body_ty (ApplicativeArgMany x stmts ret pat ctxt, pat_ty, exp_ty)
 1097       = do { (stmts', (ret',pat')) <-
 1098                 tcStmtsAndThen (HsDoStmt ctxt) tcDoStmt stmts (mkCheckExpType exp_ty) $
 1099                 \res_ty  -> do
 1100                   { ret'      <- tcExpr ret res_ty
 1101                   ; (pat', _) <- tcCheckPat (StmtCtxt (HsDoStmt ctxt)) pat (unrestricted pat_ty) $
 1102                                  return ()
 1103                   ; return (ret', pat')
 1104                   }
 1105            ; return (ApplicativeArgMany x stmts' ret' pat' ctxt) }
 1106 
 1107     get_arg_bndrs :: ApplicativeArg GhcTc -> [Id]
 1108     get_arg_bndrs (ApplicativeArgOne { app_arg_pattern = pat }) = collectPatBinders CollNoDictBinders pat
 1109     get_arg_bndrs (ApplicativeArgMany { bv_pattern =  pat })    = collectPatBinders CollNoDictBinders pat
 1110 
 1111 {- Note [ApplicativeDo and constraints]
 1112 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 1113 An applicative-do is supposed to take place in parallel, so
 1114 constraints bound in one arm can't possibly be available in another
 1115 (#13242).  Our current rule is this (more details and discussion
 1116 on the ticket). Consider
 1117 
 1118    ...stmts...
 1119    ApplicativeStmts [arg1, arg2, ... argN]
 1120    ...more stmts...
 1121 
 1122 where argi :: ApplicativeArg. Each 'argi' itself contains one or more Stmts.
 1123 Now, we say that:
 1124 
 1125 * Constraints required by the argi can be solved from
 1126   constraint bound by ...stmts...
 1127 
 1128 * Constraints and existentials bound by the argi are not available
 1129   to solve constraints required either by argj (where i /= j),
 1130   or by ...more stmts....
 1131 
 1132 * Within the stmts of each 'argi' individually, however, constraints bound
 1133   by earlier stmts can be used to solve later ones.
 1134 
 1135 To achieve this, we just typecheck each 'argi' separately, bring all
 1136 the variables they bind into scope, and typecheck the thing_inside.
 1137 
 1138 ************************************************************************
 1139 *                                                                      *
 1140 \subsection{Errors and contexts}
 1141 *                                                                      *
 1142 ************************************************************************
 1143 
 1144 @sameNoOfArgs@ takes a @[RenamedMatch]@ and decides whether the same
 1145 number of args are used in each equation.
 1146 -}
 1147 
 1148 checkArgs :: AnnoBody body
 1149           => Name -> MatchGroup GhcRn (LocatedA (body GhcRn)) -> TcM ()
 1150 checkArgs _ (MG { mg_alts = L _ [] })
 1151     = return ()
 1152 checkArgs fun (MG { mg_alts = L _ (match1:matches) })
 1153     | null bad_matches
 1154     = return ()
 1155     | otherwise
 1156     = failWithTc $ TcRnUnknownMessage $ mkPlainError noHints $
 1157       (vcat [ text "Equations for" <+> quotes (ppr fun) <+>
 1158                          text "have different numbers of arguments"
 1159                        , nest 2 (ppr (getLocA match1))
 1160                        , nest 2 (ppr (getLocA (head bad_matches)))])
 1161   where
 1162     n_args1 = args_in_match match1
 1163     bad_matches = [m | m <- matches, args_in_match m /= n_args1]
 1164 
 1165     args_in_match :: (LocatedA (Match GhcRn body1) -> Int)
 1166     args_in_match (L _ (Match { m_pats = pats })) = length pats