HsModule(..), AnnsModule(..),

         HsParsedModule(..), XModulePs(..),

 ) where

 -- friends:

        -- the .hi file, so that we can force recompilation if any of

        -- them change (#3589)

   }

 -- Warn about certain types of values discarded in monadic bindings (#3263)

 warnDiscardedDoBindings :: LHsExpr GhcTc -> Type -> Type -> DsM ()

        ; warn_wrong <- woptM Opt_WarnWrongDoBind

        ; when (warn_unused || warn_wrong) $

     do { fam_inst_envs <- dsGetFamInstEnvs

   = do { (fun@(rn_fun,fun_ctxt), rn_args) <- splitHsApps rn_expr

        ; do_ql <- wantQuickLook rn_fun

        ; (tc_fun, fun_sigma) <- tcInferAppHead fun

        ; (inst_args, app_res_sigma) <- tcInstFun do_ql inst fun_orig (tc_fun, rn_fun, fun_ctxt) fun_sigma rn_args

        ; tc_args <- tcValArgs do_ql rn_fun inst_args

        ; let tc_expr = rebuildHsApps (tc_fun, fun_ctxt) tc_args

        ; let tc_head = (tc_fun, fun_loc)

        -- Step 3: Instantiate the function type (taking a quick look at args)

        ; do_ql <- wantQuickLook rn_fun

        ; traceTc "tcApp:inferAppHead" $

          vcat [ text "tc_fun:" <+> ppr tc_fun

               , text "fun_sigma:" <+> ppr fun_sigma

     -- Rule IARG from Fig 4 of the QL paper:

     go1 pos acc fun_ty

         (EValArg { ea_arg = arg, ea_ctxt = ctxt } : rest_args)

            ; (wrap, arg_ty, res_ty) <-

                 -- NB: matchActualFunTy does the rep-poly check.

                 -- For example, suppose we have f :: forall r (a::TYPE r). a -> Int

     -- Make a fresh nus for each argument in rule IVAR

     new_arg_ty (L _ arg) i

       = do { arg_nu <- newOpenFlexiFRRTyVarTy $

                -- Following matchActualFunTy, we create nu_i :: TYPE kappa_i[conc],

                -- thereby ensuring that the arguments have concrete runtime representations

                -- fixed RuntimeRep, as needed to call mkWpFun.

            ; return (result, match_wrapper <.> fun_wrap) }

       where

     go rho_ty (SynType the_ty)

       = do { wrap   <- tcSubTypePat orig GenSigCtxt the_ty rho_ty

               thing_inside (arg_results ++ res_results) (map scaledMult arg_tys ++ arg_res_mults)

        ; return (result, match_wrapper, arg_wrappers, res_wrapper) }

   where

     tc_syn_args_e :: [TcSigmaTypeFRR] -> [SyntaxOpType]

                   -> ([TcSigmaTypeFRR] -> [Mult] -> TcM a)

        ; let

            thing    = NameThing from_name

            mb_thing = Just thing

        ; (wrap2, sarg_ty, res_ty) <- matchActualFunTy herald mb_thing (1, from_ty) from_ty

        ; co <- unifyType mb_thing (hsLitType hs_lit) (scaledThing sarg_ty)

   = assertPpr (funBindPrecondition matches) (pprMatches matches) $

     do  {  -- Check that they all have the same no of arguments

           arity <- checkArgCounts matches

         ; traceTc "tcFunBindMatches 1" (ppr fun_name $$ ppr mult $$ ppr exp_ty $$ ppr arity)

         ; (wrap_fun, r)

         ; return (wrap_fun, r) }

   where

     mctxt  = mkPrefixFunRhs (noLocA fun_name) noAnn

 funBindPrecondition :: MatchGroup GhcRn (LHsExpr GhcRn) -> Bool

 funBindPrecondition (MG { mg_alts = L _ alts })

                -- Note [View patterns and polymorphism]

          -- Expression must be a function

         ; (expr_wrap1, Scaled _mult inf_arg_ty, inf_res_sigma)

             <- matchActualFunTy herald (Just . HsExprRnThing $ unLoc expr) (1,expr_ty) expr_ty

                -- See Note [View patterns and polymorphism]

 import GHC.Parser.Annotation ( LocatedN, SrcSpanAnnA )

 import GHC.Tc.Errors.Types.PromotionErr ( TermLevelUseCtxt )

 import GHC.Tc.Utils.TcType   ( TcType, TcTyCon )

 import GHC.Tc.Zonk.Monad     ( ZonkM )

   -- | In a function application.

   | FunAppCtxt !FunAppCtxtFunArg !Int

   -- | In a function call.

   -- | In the result of a function call.

   | FunResCtxt !(HsExpr GhcTc) !Int !Type !Type !Int !Int

   -- | In the declaration of a type constructor.

   , setLclEnvTypeEnv

   , modifyLclEnvTcLevel

   , lclEnvInGeneratedCode

   , addLclEnvErrCtxt

   , ArrowCtxt(..)

   , ThBindEnv

   , TcTypeEnv

 import GHC.Prelude

 import GHC.Tc.Utils.TcType ( TcLevel )

 import GHC.Tc.Errors.Types ( TcRnMessage )

         tcl_errs :: TcRef (Messages TcRnMessage)     -- Place to accumulate diagnostics

     }

 data TcLclCtxt

   = TcLclCtxt {

         tcl_loc        :: RealSrcSpan,     -- Source span

         tcl_tclvl      :: TcLevel,

         tcl_bndrs      :: TcBinderStack,   -- Used for reporting relevant bindings,

                                            -- and for tidying type

 getLclEnvLoc = tcl_loc . tcl_lcl_ctxt

 getLclEnvErrCtxt :: TcLclEnv -> [ErrCtxt]

 setLclEnvErrCtxt :: [ErrCtxt] -> TcLclEnv -> TcLclEnv

 addLclEnvErrCtxt :: ErrCtxt -> TcLclEnv -> TcLclEnv

 getLclEnvBinderStack :: TcLclEnv -> TcBinderStack

 getLclEnvBinderStack = tcl_bndrs . tcl_lcl_ctxt

   -- * CtOrigin

   CtOrigin(..), exprCtOrigin, lexprCtOrigin, matchesCtOrigin, grhssCtOrigin,

   isVisibleOrigin, toInvisibleOrigin,

   pprCtOrigin, isGivenOrigin, isWantedWantedFunDepOrigin,

   isWantedSuperclassOrigin,

   FRRArrowContext(..), pprFRRArrowContext,

   -- ** ExpectedFunTy FixedRuntimeRepOrigin

   -- * InstanceWhat

   InstanceWhat(..), SafeOverlapping

   | AmbiguityCheckOrigin UserTypeCtxt

   | ImplicitLiftOrigin HsImplicitLiftSplice

 data NonLinearPatternReason

   = LazyPatternReason

   | GeneralisedPatternReason

 exprCtOrigin (OpApp _ _ op _)     = lexprCtOrigin op

 exprCtOrigin (NegApp _ e _)       = lexprCtOrigin e

 exprCtOrigin (HsPar _ e)          = lexprCtOrigin e

 exprCtOrigin (SectionL _ _ _)     = SectionOrigin

 exprCtOrigin (SectionR _ _ _)     = SectionOrigin

 exprCtOrigin (ExplicitTuple {})   = Shouldn'tHappenOrigin "explicit tuple"

 exprCtOrigin (HsForAll {})       = Shouldn'tHappenOrigin "forall telescope"    -- See Note [Types in terms]

 exprCtOrigin (HsQual {})         = Shouldn'tHappenOrigin "constraint context"  -- See Note [Types in terms]

 exprCtOrigin (HsFunArr {})       = Shouldn'tHappenOrigin "function arrow"      -- See Note [Types in terms]

 exprCtOrigin (XExpr (PopErrCtxt e)) = exprCtOrigin e

 exprCtOrigin (XExpr (HsRecSelRn f))  = OccurrenceOfRecSel (foExt f)

 -- | Extract a suitable CtOrigin from a MatchGroup

 matchesCtOrigin :: MatchGroup GhcRn (LHsExpr GhcRn) -> CtOrigin

 pprCtOrigin (GivenOrigin sk)

   = ctoHerald <+> ppr sk

 pprCtOrigin (GivenSCOrigin sk d blk)

   = vcat [ ctoHerald <+> pprSkolInfo sk

          , whenPprDebug (braces (text "given-sc:" <+> ppr d <> comma <> ppr blk)) ]

   = hang (ctoHerald <+> text "a non-linear pattern" <+> quotes (ppr pat))

        2 (pprNonLinearPatternReason reason)

 pprCtOrigin simple_origin

   = ctoHerald <+> pprCtO simple_origin

 -- | Short one-liners

 pprCtO :: HasDebugCallStack => CtOrigin -> SDoc

 pprCtO (OccurrenceOf name)   = hsep [text "a use of", quotes (ppr name)]

 pprCtO DerivClauseOrigin     = text "the 'deriving' clause of a data type declaration"

 pprCtO StandAloneDerivOrigin = text "a 'deriving' declaration"

 pprCtO DefaultOrigin         = text "a 'default' declaration"

 pprCtO MCompOrigin           = text "a statement in a monad comprehension"

 pprCtO ProcOrigin            = text "a proc expression"

 pprCtO ArrowCmdOrigin        = text "an arrow command"

 pprCtO (AmbiguityCheckOrigin {})    = text "a type ambiguity check"

 pprCtO (ImpedanceMatching {})       = text "combining required constraints"

 pprCtO (NonLinearPatternOrigin _ pat) = hsep [text "a non-linear pattern" <+> quotes (ppr pat)]

 pprNonLinearPatternReason :: HasDebugCallStack => NonLinearPatternReason -> SDoc

 pprNonLinearPatternReason LazyPatternReason = parens (text "non-variable lazy pattern aren't linear")

   --

   -- See 'ExpectedFunTyOrigin' for more details.

   | FRRExpectedFunTy

       !Int

         -- ^ argument position (1-indexed)

 -- and is reported separately.

 pprFixedRuntimeRepContext :: FixedRuntimeRepContext -> SDoc

 pprFixedRuntimeRepContext (FRRRecordCon lbl _arg)

         , text "of the record constructor" ]

 pprFixedRuntimeRepContext (FRRBinder binder)

   = sep [ text "The binder"

         , quotes (ppr binder) ]

   = sep [ text "The body of the bind statement" ]

 pprFixedRuntimeRepContext (FRRArrow arrowContext)

   = pprFRRArrowContext arrowContext

 instance Outputable FixedRuntimeRepContext where

   ppr = pprFixedRuntimeRepContext

 --     Uses 'pprExpectedFunTyOrigin'.

 --     See 'FixedRuntimeRepContext' for the situations in which

 --     representation-polymorphism checks are performed.

 pprExpectedFunTyHerald (ExpectedFunTySyntaxOp {})

   = text "This rebindable syntax expects a function with"

 pprExpectedFunTyHerald (ExpectedFunTyViewPat {})

   = text "A view pattern expression expects"

   = sep [ text "The function" <+> quotes (ppr fun)

         , text "is applied to" ]

   = text "The equation" <> plural alts <+> text "for" <+> quotes (ppr fun) <+> hasOrHave alts

 pprExpectedFunTyHerald (ExpectedFunTyLam lam_variant expr)

   = sep [ text "The" <+> lamCaseKeyword lam_variant <+> text "expression"

                      <+> quotes (pprSetDepth (PartWay 1) (ppr expr))

                -- The pprSetDepth makes the lambda abstraction print briefly

         , text "has" ]

 {- *******************************************************************

 *                                                                    *

   addDependentFiles,

   -- * Error management

   getSrcSpanM, setSrcSpan, setSrcSpanA, addLocM,

   inGeneratedCode, setInGeneratedCode,

   wrapLocM, wrapLocFstM, wrapLocFstMA, wrapLocSndM, wrapLocSndMA, wrapLocM_,

                 tcl_lcl_ctxt   = TcLclCtxt {

                 tcl_loc        = loc,

                 -- tcl_loc should be over-ridden very soon!

                 tcl_rdr        = emptyLocalRdrEnv,

                 tcl_th_ctxt    = topLevel,

                 tcl_th_bndrs   = emptyNameEnv,

 -- See Note [Error contexts in generated code]

 -- for the tcl_in_gen_code manipulation

 setSrcSpan (RealSrcSpan loc _) thing_inside

               thing_inside

 setSrcSpan (UnhelpfulSpan _) thing_inside

   = thing_inside

 -- | Mark the inner computation as being done inside generated code.

 --

 -- See Note [Error contexts in generated code]

 setInGeneratedCode :: SrcCodeOrigin -> TcRn a -> TcRn a

 setSrcSpanA :: EpAnn ann -> TcRn a -> TcRn a

 setSrcSpanA l = setSrcSpan (locA l)

 --

 -- See Note [Return arguments with a fixed RuntimeRep].

 matchActualFunTy

       -- ^ See Note [Herald for matchExpectedFunTys]

   -> Maybe TypedThing

       -- ^ The thing with type TcSigmaType

 -- INVARIANT: the returned argument types all have a syntactically fixed RuntimeRep

 -- in the sense of Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete.

 -- See Note [Return arguments with a fixed RuntimeRep].

                   -> CtOrigin

                   -> Arity

                   -> TcSigmaType

 -- in the sense of Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete.

 -- See Note [Return arguments with a fixed RuntimeRep].

 matchExpectedFunTys :: forall a.

                     -> UserTypeCtxt

                     -> VisArity

                     -> ExpSigmaType

            ; co <- unifyType Nothing (mkScaledFunTys more_arg_tys res_ty) fun_ty

            ; return (mkWpCastN co, result) }

 new_infer_arg_ty herald arg_pos -- position for error messages only

   = do { mult     <- newFlexiTyVarTy multiplicityTy

        ; inf_hole <- newInferExpTypeFRR (FRRExpectedFunTy herald arg_pos)

        ; return (mkScaled mult inf_hole) }

 new_check_arg_ty herald arg_pos -- Position for error messages only, 1 for first arg

   = do { mult   <- newFlexiTyVarTy multiplicityTy

        ; arg_ty <- newOpenFlexiFRRTyVarTy (FRRExpectedFunTy herald arg_pos)

        ; return (mkScaled mult arg_ty) }

             -> (VisArity, TcType)

             -> TidyEnv -> ZonkM (TidyEnv, ErrCtxtMsg)

 -- See Note [Reporting application arity errors]

     A do-notation statement discarded a result of type ‘String’

     Suggested fix:

       Suppress this warning by saying

         ‘_ <- return $ let a = "hello" in a’

     A do-notation statement discarded a result of type ‘Int’

     Suggested fix: Suppress this warning by saying ‘_ <- nonNullM’