| otherwise                    -> mk_fco (mkRepReflCo ty)

       MCo co                               -> mk_fco co

   where

     -- coreTyLamForAllTyFlag: See Note [The EtaInfo mechanism], particularly

     -- the (EtaInfo Invariant).  (sym co) wraps a lambda that always has

     -- a ForAllTyFlag of coreTyLamForAllTyFlag; see Note [Required foralls in Core]

     -- in GHC.Core.TyCo.Rep

 {-

 ************************************************************************

 type instance Anno (FamilyResultSig (GhcPass p)) = EpAnnCO

 type instance Anno (FamilyDecl (GhcPass p)) = SrcSpanAnnA

 type instance Anno (InjectivityAnn (GhcPass p)) = EpAnnCO

 type instance Anno (HsDerivingClause (GhcPass p)) = EpAnnCO

 type instance Anno (DerivClauseTys (GhcPass _)) = SrcSpanAnnA

 type instance Anno (StandaloneKindSig (GhcPass p)) = SrcSpanAnnA

   | otherwise

   = False

 -- This is called before type checking, when mg_arg_tys is not set

 hsLMatchPats :: LMatch (GhcPass id) body -> [LPat (GhcPass id)]

 hsLMatchPats (L _ (Match { m_pats = L _ pats })) = pats

 import GHC.Types.Name

 import GHC.Types.Var.Set

 import GHC.Types.Var.Env

 import GHC.Types.SrcLoc

 import GHC.Types.Basic

 import GHC.Types.Unique.Set( nonDetEltsUniqSet )

   = do  { core_expr <- dsLExpr expr

                 -- Dictionary bindings are always VarBinds,

                 -- so we only need do this here

               force_var = if xopt LangExt.Strict dflags

                           then [id]

                           else []

       ; let body' = mkOptTickBox tick body

             rhs   = core_wrap (mkLams args body')

             force_var

                 -- Bindings are strict when -XStrict is enabled

               | xopt LangExt.Strict dflags

               = [id]

               | isBangedHsBind b

               = [id]

        ; let global_id' = addIdSpecialisations global_id rules

              main_bind  = makeCorePair dflags global_id'

                                        (isDefaultMethod prags)

        ; return (force_vars', fromOL spec_binds ++ [main_bind]) } }

     mk_aux_bind (lcl_id, rhs) = let lcl_w_inline = lookupVarEnv inline_env lcl_id

                                                    `orElse` lcl_id

                                  in

     inline_env :: IdEnv Id -- Maps a monomorphic local Id to one with

                            -- the inline pragma from the source

 -- the unfolding in the interface file is made in `GHC.Iface.Tidy.addExternal`

 -- using this information.

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

              -> (Id, CoreExpr)

   | is_default_method    -- Default methods are *always* inlined

                          -- See Note [INLINE and default methods] in GHC.Tc.TyCl.Instance

   = (gbl_id `setIdUnfolding` mkCompulsoryUnfolding' simpl_opts rhs, rhs)

     inline_prag   = idInlinePragma gbl_id

     inlinable_unf = mkInlinableUnfolding simpl_opts StableUserSrc rhs

     inline_pair

         -- Add an Unfolding for an INLINE (but not for NOINLINE)

         -- And eta-expand the RHS; see Note [Eta-expanding INLINE things]

        | otherwise

        = pprTrace "makeCorePair: arity missing" (ppr gbl_id) $

          (gbl_id `setIdUnfolding` mkInlineUnfoldingNoArity simpl_opts StableUserSrc rhs, rhs)

 {-

 Note [Desugaring AbsBinds]

 -- There are three possible cases for matchWrapper's scrutinees argument:

 --

 -- 1. Nothing   Used for FunBind, HsLam, HsLamcase, where there is no explicit scrutinee

 --                  f p2 q2 = ...

 --

 --                  \cases | g1 -> ... -- matchGroupArity 0

 --                         | g2 -> ...

 --

 -- 2. Just [e]  Used for HsCase, RecordUpd; exactly one scrutinee

 --                            p2 -> e2

 --

 -- 3. Just es   Used for HsCmdLamCase; zero or more scrutinees

 --              The MatchGroup has matchGroupArity of (length es). Example:

 --                         p2 q2 -> ...

 matchWrapper

   -- We don't want to generate code for blacklisted positions

   -- We don't want redundant ticks on simple pattern bindings

   -- We don't want to tick non-exported bindings in TickExportedFunctions

                   -- A binding is a "simple pattern binding" if it is a

                   -- funbind with zero patterns

       toplev = null decl_path

         | type                      { sL1 $1 (Nothing, mkHsOuterImplicit, $1) }

 capi_ctype : '{-# CTYPE' STRING STRING '#-}'

            | '{-# CTYPE'        STRING '#-}'

            |           { Nothing }

 mkTyData :: SrcSpan

          -> Bool

          -> NewOrData

          -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs)

          -> Maybe (LHsKind GhcPs)

          -> [LConDecl GhcPs]

                                    tcdDataDefn = defn,

                                    tcdModifiers = [] })) }

            -> Maybe (LHsContext GhcPs)

            -> Maybe (LHsKind GhcPs)

            -> DataDefnCons (LConDecl GhcPs)

 mkDataFamInst :: SrcSpan

               -> NewOrData

               -> (Maybe ( LHsContext GhcPs), HsOuterFamEqnTyVarBndrs GhcPs

                         , LHsType GhcPs)

               -> Maybe (LHsKind GhcPs)

 -}

 {-# LANGUAGE TypeFamilies #-}

 module GHC.Stg.Lint ( lintStgTopBindings ) where

 import GHC.Data.Bag         ( Bag, emptyBag, isEmptyBag, snocBag, bagToList )

 import Control.Monad

 import GHC.Core.Multiplicity (scaledThing)

 import GHC.Settings (Platform)

 import GHC.Core.TyCon (primRepCompatible, primRepsCompatible)

 ************************************************************************

 -}

               -> [LintLocInfo]     -- Locations

               -> IdSet             -- Local vars in scope

               -> Bag SDoc        -- Error messages so far

               -> (a, Bag SDoc)   -- Result and error messages (if any)

     }

 data LintFlags = LintFlags { lf_unarised :: !Bool

                            , lf_platform :: !Platform

 initL :: Platform -> DiagOpts -> Module -> Bool -> StgPprOpts -> IdSet -> LintM a -> Maybe SDoc

 initL platform diag_opts this_mod unarised opts locals (LintM m) = do

   if isEmptyBag errs then

       Nothing

   else

       Just (vcat (punctuate blankLine (bagToList errs)))

 instance Applicative LintM where

       (<*>) = ap

       (*>)  = thenL_

     (>>)  = (*>)

 thenL :: LintM a -> (a -> LintM b) -> LintM b

 thenL_ :: LintM a -> LintM b -> LintM b

 checkL :: Bool -> SDoc -> LintM ()

 checkL True  _   = return ()

     id_ty = idType id

 addErrL :: SDoc -> LintM ()

 addErr :: DiagOpts -> Bag SDoc -> SDoc -> [LintLocInfo] -> Bag SDoc

 addErr diag_opts errs_so_far msg locs

     mk_msg []      = msg

 addLoc :: LintLocInfo -> LintM a -> LintM a

 addInScopeVars :: [Id] -> LintM a -> LintM a

  -> let

         new_set = mkVarSet ids

 getLintFlags :: LintM LintFlags

 getStgPprOpts :: LintM StgPprOpts

 checkInScope :: Id -> LintM ()

  -> if nameIsLocalOrFrom mod (idName id) && not (id `elemVarSet` scope) then

         ((), addErr diag_opts errs (hsep [ppr id, dcolon, ppr (idType id),

                                     text "is out of scope"]) loc)

     restricted (VarBind { var_ext = x })                 = dataConCantHappen x

     restricted b@(PatSynBind {}) = pprPanic "isRestrictedGroup/unrestricted" (ppr b)

         -- No args => like a pattern binding

         -- Some args => a function binding

           Nothing -> sig -- See Note [Pattern synonym inline arity]

     -- ar_env maps a local to the arity of its definition

 addInlinePragArity ar (L l (InlineSig x nm inl))  = L l (InlineSig x nm (add_inl_arity ar inl))

 addInlinePragArity ar (L l (SpecSig x nm ty inl)) = L l (SpecSig x nm ty (add_inl_arity ar inl))

 addInlinePragArity ar (L l (SpecSigE n x e inl))  = L l (SpecSigE n x e (add_inl_arity ar inl))

 addInlinePragArity _ sig = sig

 add_inl_arity ar prag@(InlinePragma { inl_inline = inl_spec })

   | Inline {} <- inl_spec  -- Add arity only for real INLINE pragmas, not INLINABLE

   = prag `setInlinePragmaSaturation` AppliedToAtLeast ar

   | otherwise

   = prag

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

     forall a b. (Num a, Ord b) => a -> b -> a  has arity <= 4

 * `VisArity` is the syntactic notion of arity. It is the number of /visible/

   In a function call `f x y z`, we can confidently say that f's vis-arity >= 3,

   simply because we see three arguments [x,y,z]. We write (>=) rather than (==)

 import Data.Functor ((<&>))

 import Control.DeepSeq (NFData(..))

 {-

 ************************************************************************

 defaultCType :: String -> CType (GhcPass p)

 defaultCType =

 typeCheckCType :: CType GhcRn -> CType GhcTc

 typeCheckCType (CType x y z) = CType x (typeCheckHeader <$> y) z

 data CTypeGhc = CTypeGhc

   { cTypeSourceText :: SourceText

   , cTypeOtherText  :: SourceText

   }

   deriving (Data, Eq)

       return $ CTypeGhc

         { cTypeSourceText = str1

         , cTypeOtherText  = str2

         }

 instance NFData StaticTargetGhc where

 import GHC.Data.FastString

 import GHC.Hs.Extension

 import GHC.Types.SourceText (SourceText(..))

 import GHC.Utils.Binary

 import GHC.Utils.Outputable

 -- | The arity /at which to/ inline a function.

 -- This may differ from the function's syntactic arity.

 data InlineSaturation

       -- ^ Inline only when applied to @n@ explicit

       --

       -- That is, 'AppliedToAtLeast' describes the number of

       --  *source-code* arguments the thing must be applied to.

     | AnySaturation

       -- ^ There does not exist an explicit number of arguments

       -- that the inlining process should be applied to.

         -- * PiTyBinder

         PiTyBinder(..), PiTyVarBinder,

         isInvisiblePiTyBinder, isInvisibleAnonPiTyBinder,

         isTyBinder, isNamedPiTyBinder, isAnonPiTyBinder,

         namedPiTyBinder_maybe, anonPiTyBinderType_maybe, piTyBinderType,

 -- not. See Note [PiTyBinders]

 data PiTyBinder

   = Named ForAllTyBinder          -- A type-lambda binder, with a ForAllTyFlag

                                   -- The arrow is described by the FunTyFlag

   deriving Data

 namedPiTyBinder_maybe (Named tv) = Just $ binderVar tv

 namedPiTyBinder_maybe _          = Nothing

 -- | Does this binder bind a variable that is /not/ erased? Returns

 -- 'True' for anonymous binders.

 isAnonPiTyBinder :: PiTyBinder -> Bool

 piTyBinderType (Anon ty _)         = scaledThing ty

 {- Note [PiTyBinders]

 But a type like

    forall a. Maybe a -> forall b. (a,b) -> b

 Pi-types:

  * Anon ty1 fun_flag: a non-dependent function type,

 Both forms of Pi-types classify terms/types that take an argument. In other

 words, if `x` is either a function or a polytype, `x arg` makes sense

 Wrinkles

   the PiTyBinder really only describes the /argument/ it should perhaps

   only have a TypeOrConstraint rather than a full FunTyFlag.  But it's

   very convenient to have the full FunTyFlag, say in mkPiTys, so that's

   what we do.

 Note [VarBndrs, ForAllTyBinders, TyConBinders, and visibility]

 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

       jump go1 eta

 fusionNotElemConcatMap

       joinrec {

         go1 ds

           = case ds of {

               [] -> True;

               : y ys ->

                   __DEFAULT ->

                       __DEFAULT -> jump go1 ys;

                       1# -> False

                     };

                 }

                 }

             }; } in

 fusionElemConcatMap

       joinrec {

         go1 ds

           = case ds of {

               [] -> False;

               : y ys ->

                   __DEFAULT ->

                       __DEFAULT -> jump go1 ys;

                       1# -> True

                     };

                 }

                 }

             }; } in

 fusionNotElemMap

   = \ x eta ->

 test('T27261', [extra_files(['T27261_aux.hs'])], multimod_compile, ['T27261', '-v0 -O'])

 test('T27296', [], makefile_test, ['T27296'])

 test('T27296b', [], makefile_test, ['T27296b'])

 test('ExpansionQLIm', normal, compile, [''])

 test('T23135', normal, compile, [''])

 test('LazyFieldAnnotations', normal, compile, [''])

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

     let stp  = cTypeSourceText ext

         stct = cTypeOtherText  ext

     o' <- markAnnOpen'' o stp "{-# CTYPE"

     l1' <- case mh of

              Nothing -> return l1

                printStringAtAA l1 (toSourceTextWithSuffix srcH "" "")

     l2' <- printStringAtAA l2 (toSourceTextWithSuffix stct (unpackHText ct) "")

     c' <- markEpToken c

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

 type instance Anno (HsSigType DocNameI) = SrcSpanAnnA

 type instance Anno (BooleanFormula DocNameI) = SrcSpanAnnBF

 type instance Anno (OverlapMode DocNameI) = SrcSpanAnnA