import {-# SOURCE #-} GHC.Hs.Expr ( pprExpr, pprLExpr, pprFunBind, pprPatBind )

 import {-# SOURCE #-} GHC.Hs.Pat  (pprLPat )

 import GHC.Hs.Extension

 import GHC.Hs.Type

 import GHC.Tc.Types.Evidence

 import GHC.Core.Type

 import GHC.Types.Name.Set

 import GHC.Types.Basic

 import GHC.Types.SourceText

 import GHC.Types.Var

 import GHC.Types.Name

 import GHC.Utils.Outputable

 import GHC.Utils.Panic

 import GHC.Utils.Misc

 type family HsValBindGroup p

 type instance HsValBindGroup GhcPs = ()

 type instance HsValBindGroup GhcRn = (RecFlag, LHsBinds GhcRn)

 -- ---------------------------------------------------------------------

 -------------------------

 -- caller sets location

 dsValBinds :: HsValBinds GhcTc -> CoreExpr -> DsM CoreExpr

   = do { dflags <- getDynFlags

 dsValBinds (ValBinds {})       _    = panic "dsValBinds ValBindsIn"

 -------------------------

 -------------------------

 -- caller sets location

 -- Special case for bindings which bind unlifted variables

 -- We need to do a case right away, rather than building

 -- a tuple and doing selections.

 -- Silently ignore INLINE and SPECIALISE pragmas...

   | [L loc bind] <- hsbinds

         -- Non-recursive, non-overloaded bindings only come in ones

         -- ToDo: in some bizarre case it's conceivable that there

     is_polymorphic _ = False

   | any (isUnliftedHsBind . unLoc) binds  -- see Note [Strict binds checks] in GHC.HsToCore.Binds

   = assert (isRec is_rec )

     errDsCoreExpr $ DsRecBindsNotAllowedForUnliftedTys binds

 -- linear, but selectors as used in the general case aren't. So the general case

 -- would transform a linear definition into a non-linear one. See Wrinkle 2

 -- Note [Desugar Strict binds] in GHC.HsToCore.Binds.

   | [L _loc (PatBind { pat_lhs = pat, pat_rhs = grhss, pat_mult = mult_ann

                      , pat_ext = (ty, (rhs_tick, _var_ticks))})] <- hsbinds

         -- Non-recursive, non-overloaded bindings only come in ones

     -- problem?

 -- Ordinary case for bindings; none should be unlifted

   = do  { massert (isRec is_rec || isSingleton binds)

         ; (force_vars,prs) <- dsLHsBinds binds

         ; assertPpr (not (any (isUnliftedType . idType . fst) prs)) (ppr is_rec $$ ppr binds) $

           -- NB: bindings have a fixed RuntimeRep, so it's OK to call isUnliftedType

           case prs of

             [] -> return body

             -- We can make a non-recursive let because we make sure to return

             -- the bindings in dependency order in dsLHsBinds,

             -- see Note [Return non-recursive bindings in dependency order] in

             -- GHC.HsToCore.Binds

 -- | Helper function. You can use the result of 'mk_binds' with 'mkLets' for

 -- instance.

        ; static_id <- newStaticId (mkSpecForAllTys static_fvs whole_ty)

        ; return (mkVarApps (Var static_id) static_fvs) }

         DsMetaEnv, DsMetaVal(..), dsGetMetaEnv, dsLookupMetaEnv, dsExtendMetaEnv,

         -- Static bindings

         -- Getting and setting pattern match oracle states

         getPmNablas, updPmNablas,

 getCCIndexDsM :: FastString -> DsM CostCentreIndex

 getCCIndexDsM = getCCIndexM ds_cc_st

   = do { env <- getGblEnv

 getStaticBinds :: DsM (OrdList (Id,CoreExpr))

 getStaticBinds = do { env <- getGblEnv

   = concatMap get_scoped_tvs sigs

   where

     sigs = case binds of

 get_scoped_tvs :: LSig GhcRn -> [Name]

 get_scoped_tvs (L _ signature)

 rep_val_binds :: HsValBinds GhcRn -> MetaM [(SrcSpan, Core (M TH.Dec))]

 -- Assumes: all the binders of the binding are already in the meta-env

  = do { core1 <- rep_binds (concatMap snd binds)

       ; core2 <- rep_sigs sigs

       ; return (core1 ++ core2) }

 tcValBinds :: TopLevelFlag

            -> [(RecFlag, LHsBinds GhcRn)] -> [LSig GhcRn]

            -> TcM thing

 tcValBinds top_lvl grps sigs thing_inside

   = do  {   -- Typecheck the signatures

                        -- See Note [Pattern synonym builders don't yield dependencies]

                        --     in GHC.Rename.Bind

                     ; patsyn_builders <- mapM (tcPatSynBuilderBind prag_fn) patsyns

                                         | builder <- patsyn_builders ]

                     ; return (extra_binds, thing) }

         ; return (binds' ++ extra_binds', thing) }}

 tcBindGroups :: TopLevelFlag -> TcSigFun -> TcPragEnv

              -> [(RecFlag, LHsBinds GhcRn)] -> TcM thing

 -- Typecheck a whole lot of value bindings,

 -- one strongly-connected component at a time

 -- Here a "strongly connected component" has the straightforward

 tc_group :: forall thing.

             TopLevelFlag -> TcSigFun -> TcPragEnv

          -> (RecFlag, LHsBinds GhcRn) -> TcM thing

 -- Typecheck one strongly-connected component of the original program.

 tc_group top_lvl sig_fn prag_fn (rec_flag, binds) thing_inside

   = case rec_flag of

 tc_nonrec_group :: forall thing.

                    TopLevelFlag -> TcSigFun -> TcPragEnv

                 -> LHsBinds GhcRn -> TcM thing

 tc_nonrec_group  top_lvl sig_fn prag_fn [lbind] thing_inside

   | L loc (PatSynBind _ psb) <- lbind

   = do { (aux_binds, tcg_env) <- tcPatSynDecl (L loc psb) sig_fn prag_fn

        ; thing <- setGblEnv tcg_env thing_inside

   | otherwise

   =     -- A single non-recursive binding

 tc_rec_group :: forall thing.

                 TopLevelFlag -> TcSigFun -> TcPragEnv

              -> LHsBinds GhcRn -> TcM thing

 tc_rec_group top_lvl sig_fn prag_fn binds thing_inside

   = -- For a recursive group, to maximise polymorphism, we do a new

     -- strongly-connected-component analysis, this time omitting

 isClosedBndrGroup :: TcTypeEnv -> [LHsBind GhcRn] -> IsGroupClosed

 isClosedBndrGroup type_env binds

   where

     fv_env :: NameEnv NameSet

     fv_env = mkNameEnv $ [ (b,fvs) | (bs,fvs) <- bind_fvs, b <-bs ]

                 `delListFromNameSet` all_bndrs

                 -- all_fvs does not include the binders of this group

       | Just thing <- lookupNameEnv type_env name

       = case thing of

       | otherwise  -- Imported Ids

       = True

     is_closed_type_id name

       | Just thing <- lookupNameEnv type_env name

       = case thing of

           _ -> pprPanic "is_closed_id" (ppr name)

       | otherwise

 adjustClosedForUnlifted :: IsGroupClosed -> [Scaled TcId] -> IsGroupClosed

 adjustClosedForUnlifted closed@(IsGroupClosed top_lvl fv_env type_closed) ids

   , all definitely_lifted ids = closed

   where

     definitely_lifted (Scaled _ id) = definitelyLiftedType (idType id)

 sendToTopLevel (IsGroupClosed top _ _) = top

 lHsBindFreeVars :: LHsBind GhcRn -> NameSet

              let_binds :: HsLocalBindsLR GhcRn GhcRn

              let_binds = HsValBinds noAnn $ XValBindsLR

              upd_ids_lhs :: [(RecFlag, LHsBindsLR GhcRn GhcRn)]

              upd_ids_lhs = [ (NonRecursive, [genSimpleFunBind (idName id) [] rhs])

                            | (_, (id, rhs)) <- upd_ids ]

       -- visited nodes, so we avoid repeating cycles in the traversal.

       case lookupNameEnv type_env n of

         Just (ATcId { tct_id = tcid, tct_info = info }) -> case info of

           NotLetBound -> Just NotLetBoundReason

             -- Look for a non-closed variable in fvs

             [ NotClosed n' reason

             | n' <- nameSetElemsStable fvs

                             , hs_defds  = def_decls

                             , hs_ruleds = rule_decls

                             , hs_annds  = _

               <- rnTopSrcDecls first_group

         ; (gbl_env, lie) <- setGblEnv tcg_env $ captureTopConstraints $ do {

                          hs_annds  = annotation_decls,

                          hs_ruleds = rule_decls,

                          hs_valds  = hs_val_binds@(XValBindsLR

  = do {         -- Type-check the type and class decls, and all imported decls

                 -- The latter come in via tycl_decls

         traceTc "Tc2 (src)" empty ;

                 -- and import the supporting declarations

         traceTc "Tc3" empty ;

         (tcg_env, inst_infos, th_bndrs,

             <- tcTyClsInstDecls tycl_decls deriv_decls default_decls val_binds ;

         updLclCtxt (\tcl_env -> tcl_env { tcl_th_bndrs = th_bndrs `plusNameEnv` tcl_th_bndrs tcl_env }) $

               -- [let it = expr]

               let_stmt  = L loc $ LetStmt noAnn $ HsValBinds noAnn

                            $ XValBindsLR

               -- [it <- e]

               bind_stmt = L loc $ BindStmt

                                        -- See Note [Impredicative record selectors]

                                        setXOptM LangExt.ImpredicativeTypes $

                                        tcValBinds TopLevel binds sigs getGblEnv

   where

     sigs = [ L (noAnnSrcSpan loc) (XSig $ IdSig sel_id)

                                              | (sel_id, _) <- sel_bind_prs

 import GHC.Types.Name.Set

 import GHC.Hs.Extension ( GhcRn )

 import Language.Haskell.Syntax.Type ( LHsSigWcType )

   | ATcId           -- Ids defined in this module; may not be fully zonked

       { tct_id   :: Id

       }

   | ATyVar  Name TcTyVar   -- See Note [Type variables in the type environment]

 -- b) to figure out when a nested binding can be generalised,

 --    in 'GHC.Tc.Gen.Bind.decideGeneralisationPlan'.

 --

     = NotLetBound

     | LetBound

              -- E.g   f x = let ys = reverse [1,2]

              --                 zs = reverse ys

              --             in ...

         , lb_fvs :: RhsNames

              -- Free vars of the RHS that are NotLetBound, or LetBound NotTopLevel

 --   mutually-recursive /renamed/ (but not yet typechecked) bindings

 data IsGroupClosed

   = IsGroupClosed

       (NameEnv RhsNames)  -- Frees for the RHS of each binding in the group

                           --   (includes free vars of RHS bound in the same group)

       ClosedTypeId        -- True <=> all the free vars of the group have closed types

 type ClosedTypeId = Bool

   -- See Note [Meaning of IdBindingInfo]

 * NotLetBound means that

    - the Id is not let-bound (e.g. it is bound in a

      lambda-abstraction or in a case pattern)

 tcExtendRecIds pairs thing_inside

   = tc_extend_local_env NotTopLevel

           [ (name, ATcId { tct_id   = let_id

                                                , lb_fvs = emptyNameSet

                                                , lb_closed = False } })

           | (name, let_id) <- pairs ] $

                               , tct_info = info })

           | id <- sig_ids

           , let closed = isTypeClosedLetBndr id

                                   , lb_fvs = emptyNameSet

                                   , lb_closed = closed } ]

      thing_inside

 -- Used for both top-level value bindings and nested let/where-bindings

 -- Used for a single NonRec or a single Rec

 -- Adds to the TcBinderStack too

                ids thing_inside

   = tcExtendBinderStack [TcIdBndr id top_lvl | Scaled _ id <- ids] $

     tc_extend_local_env top_lvl

     foldr check_usage thing_inside scaled_names

   where

     mk_tct_info id

                  , lb_fvs = lookupNameEnv fv_env (idName id) `orElse` emptyNameSet

                  , lb_closed = isTypeClosedLetBndr id }