packages feed

ghc-lib-parser 9.8.5.20250214 → 9.10.1.20240511

raw patch · 285 files changed

+25620/−20827 lines, 285 filesdep ~basedep ~deepseqPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base, deepseq

API changes (from Hackage documentation)

- GHC.Builtin.Names: aRROW :: Module
- GHC.Builtin.Names: bindIO_RDR :: RdrName
- GHC.Builtin.Names: cONTROL_EXCEPTION_BASE :: Module
- GHC.Builtin.Names: dATA_COERCE :: Module
- GHC.Builtin.Names: dATA_EITHER :: Module
- GHC.Builtin.Names: dATA_FOLDABLE :: Module
- GHC.Builtin.Names: dATA_STRING :: Module
- GHC.Builtin.Names: dATA_TRAVERSABLE :: Module
- GHC.Builtin.Names: dEBUG_TRACE :: Module
- GHC.Builtin.Names: dYNAMIC :: Module
- GHC.Builtin.Names: enumClass_RDR :: RdrName
- GHC.Builtin.Names: eqClass_RDR :: RdrName
- GHC.Builtin.Names: fOREIGN_C_CONSTPTR :: Module
- GHC.Builtin.Names: fromInteger_RDR :: RdrName
- GHC.Builtin.Names: fromIntegral_RDR :: RdrName
- GHC.Builtin.Names: fromListN_RDR :: RdrName
- GHC.Builtin.Names: fromList_RDR :: RdrName
- GHC.Builtin.Names: fromRational_RDR :: RdrName
- GHC.Builtin.Names: fromString_RDR :: RdrName
- GHC.Builtin.Names: gENERICS :: Module
- GHC.Builtin.Names: gHC_BASE :: Module
- GHC.Builtin.Names: gHC_CONC :: Module
- GHC.Builtin.Names: gHC_DESUGAR :: Module
- GHC.Builtin.Names: gHC_ENUM :: Module
- GHC.Builtin.Names: gHC_ERR :: Module
- GHC.Builtin.Names: gHC_EXTS :: Module
- GHC.Builtin.Names: gHC_FINGERPRINT_TYPE :: Module
- GHC.Builtin.Names: gHC_FLOAT :: Module
- GHC.Builtin.Names: gHC_GENERICS :: Module
- GHC.Builtin.Names: gHC_GHCI :: Module
- GHC.Builtin.Names: gHC_GHCI_HELPERS :: Module
- GHC.Builtin.Names: gHC_INT :: Module
- GHC.Builtin.Names: gHC_IO :: Module
- GHC.Builtin.Names: gHC_IO_Exception :: Module
- GHC.Builtin.Names: gHC_IS_LIST :: Module
- GHC.Builtin.Names: gHC_IX :: Module
- GHC.Builtin.Names: gHC_LIST :: Module
- GHC.Builtin.Names: gHC_MAYBE :: Module
- GHC.Builtin.Names: gHC_NUM :: Module
- GHC.Builtin.Names: gHC_NUM_BIGNAT :: Module
- GHC.Builtin.Names: gHC_NUM_INTEGER :: Module
- GHC.Builtin.Names: gHC_NUM_NATURAL :: Module
- GHC.Builtin.Names: gHC_OVER_LABELS :: Module
- GHC.Builtin.Names: gHC_PTR :: Module
- GHC.Builtin.Names: gHC_READ :: Module
- GHC.Builtin.Names: gHC_REAL :: Module
- GHC.Builtin.Names: gHC_RECORDS :: Module
- GHC.Builtin.Names: gHC_SHOW :: Module
- GHC.Builtin.Names: gHC_SRCLOC :: Module
- GHC.Builtin.Names: gHC_ST :: Module
- GHC.Builtin.Names: gHC_STABLE :: Module
- GHC.Builtin.Names: gHC_STACK :: Module
- GHC.Builtin.Names: gHC_STACK_TYPES :: Module
- GHC.Builtin.Names: gHC_STATICPTR :: Module
- GHC.Builtin.Names: gHC_STATICPTR_INTERNAL :: Module
- GHC.Builtin.Names: gHC_TOP_HANDLER :: Module
- GHC.Builtin.Names: gHC_TUPLE :: Module
- GHC.Builtin.Names: gHC_TUPLE_PRIM :: Module
- GHC.Builtin.Names: gHC_TYPEERROR :: Module
- GHC.Builtin.Names: gHC_TYPELITS :: Module
- GHC.Builtin.Names: gHC_TYPELITS_INTERNAL :: Module
- GHC.Builtin.Names: gHC_TYPENATS :: Module
- GHC.Builtin.Names: gHC_TYPENATS_INTERNAL :: Module
- GHC.Builtin.Names: gHC_WORD :: Module
- GHC.Builtin.Names: integerAdd_RDR :: RdrName
- GHC.Builtin.Names: integerMul_RDR :: RdrName
- GHC.Builtin.Names: ioDataCon_RDR :: RdrName
- GHC.Builtin.Names: lEX :: Module
- GHC.Builtin.Names: mONAD :: Module
- GHC.Builtin.Names: mONAD_FAIL :: Module
- GHC.Builtin.Names: mONAD_FIX :: Module
- GHC.Builtin.Names: mONAD_ZIP :: Module
- GHC.Builtin.Names: minus_RDR :: RdrName
- GHC.Builtin.Names: monadClass_RDR :: RdrName
- GHC.Builtin.Names: newStablePtr_RDR :: RdrName
- GHC.Builtin.Names: numClass_RDR :: RdrName
- GHC.Builtin.Names: ordClass_RDR :: RdrName
- GHC.Builtin.Names: pretendNameIsInScope :: Name -> Bool
- GHC.Builtin.Names: rANDOM :: Module
- GHC.Builtin.Names: rEAD_PREC :: Module
- GHC.Builtin.Names: ratioDataCon_RDR :: RdrName
- GHC.Builtin.Names: returnIO_RDR :: RdrName
- GHC.Builtin.Names: sYSTEM_IO :: Module
- GHC.Builtin.Names: tYPEABLE :: Module
- GHC.Builtin.Names: tYPEABLE_INTERNAL :: Module
- GHC.Builtin.Names: toInteger_RDR :: RdrName
- GHC.Builtin.Names: toList_RDR :: RdrName
- GHC.Builtin.Names: toRational_RDR :: RdrName
- GHC.Builtin.Names: uNSAFE_COERCE :: Module
- GHC.Builtin.PrimOps: DataToTagOp :: PrimOp
- GHC.Builtin.PrimOps: ReturnsAlg :: TyCon -> PrimOpResultInfo
- GHC.Builtin.PrimOps: primOpOkForSideEffects :: PrimOp -> Bool
- GHC.Cmm.Dataflow.Collections: class IsMap map where {
- GHC.Cmm.Dataflow.Collections: class IsSet set where {
- GHC.Cmm.Dataflow.Collections: data UniqueMap v
- GHC.Cmm.Dataflow.Collections: data UniqueSet
- GHC.Cmm.Dataflow.Collections: instance Data.Foldable.Foldable GHC.Cmm.Dataflow.Collections.UniqueMap
- GHC.Cmm.Dataflow.Collections: instance Data.Traversable.Traversable GHC.Cmm.Dataflow.Collections.UniqueMap
- GHC.Cmm.Dataflow.Collections: instance GHC.Base.Functor GHC.Cmm.Dataflow.Collections.UniqueMap
- GHC.Cmm.Dataflow.Collections: instance GHC.Base.Monoid GHC.Cmm.Dataflow.Collections.UniqueSet
- GHC.Cmm.Dataflow.Collections: instance GHC.Base.Semigroup GHC.Cmm.Dataflow.Collections.UniqueSet
- GHC.Cmm.Dataflow.Collections: instance GHC.Classes.Eq GHC.Cmm.Dataflow.Collections.UniqueSet
- GHC.Cmm.Dataflow.Collections: instance GHC.Classes.Eq v => GHC.Classes.Eq (GHC.Cmm.Dataflow.Collections.UniqueMap v)
- GHC.Cmm.Dataflow.Collections: instance GHC.Classes.Ord GHC.Cmm.Dataflow.Collections.UniqueSet
- GHC.Cmm.Dataflow.Collections: instance GHC.Classes.Ord v => GHC.Classes.Ord (GHC.Cmm.Dataflow.Collections.UniqueMap v)
- GHC.Cmm.Dataflow.Collections: instance GHC.Cmm.Dataflow.Collections.IsMap GHC.Cmm.Dataflow.Collections.UniqueMap
- GHC.Cmm.Dataflow.Collections: instance GHC.Cmm.Dataflow.Collections.IsSet GHC.Cmm.Dataflow.Collections.UniqueSet
- GHC.Cmm.Dataflow.Collections: instance GHC.Show.Show GHC.Cmm.Dataflow.Collections.UniqueSet
- GHC.Cmm.Dataflow.Collections: instance GHC.Show.Show v => GHC.Show.Show (GHC.Cmm.Dataflow.Collections.UniqueMap v)
- GHC.Cmm.Dataflow.Collections: mapAdjust :: IsMap map => (a -> a) -> KeyOf map -> map a -> map a
- GHC.Cmm.Dataflow.Collections: mapAlter :: IsMap map => (Maybe a -> Maybe a) -> KeyOf map -> map a -> map a
- GHC.Cmm.Dataflow.Collections: mapDelete :: IsMap map => KeyOf map -> map a -> map a
- GHC.Cmm.Dataflow.Collections: mapDeleteList :: IsMap map => [KeyOf map] -> map a -> map a
- GHC.Cmm.Dataflow.Collections: mapDifference :: IsMap map => map a -> map a -> map a
- GHC.Cmm.Dataflow.Collections: mapElems :: IsMap map => map a -> [a]
- GHC.Cmm.Dataflow.Collections: mapEmpty :: IsMap map => map a
- GHC.Cmm.Dataflow.Collections: mapFilter :: IsMap map => (a -> Bool) -> map a -> map a
- GHC.Cmm.Dataflow.Collections: mapFilterWithKey :: IsMap map => (KeyOf map -> a -> Bool) -> map a -> map a
- GHC.Cmm.Dataflow.Collections: mapFindWithDefault :: IsMap map => a -> KeyOf map -> map a -> a
- GHC.Cmm.Dataflow.Collections: mapFoldMapWithKey :: (IsMap map, Monoid m) => (KeyOf map -> a -> m) -> map a -> m
- GHC.Cmm.Dataflow.Collections: mapFoldl :: IsMap map => (b -> a -> b) -> b -> map a -> b
- GHC.Cmm.Dataflow.Collections: mapFoldlWithKey :: IsMap map => (b -> KeyOf map -> a -> b) -> b -> map a -> b
- GHC.Cmm.Dataflow.Collections: mapFoldr :: IsMap map => (a -> b -> b) -> b -> map a -> b
- GHC.Cmm.Dataflow.Collections: mapFromList :: IsMap map => [(KeyOf map, a)] -> map a
- GHC.Cmm.Dataflow.Collections: mapFromListWith :: IsMap map => (a -> a -> a) -> [(KeyOf map, a)] -> map a
- GHC.Cmm.Dataflow.Collections: mapInsert :: IsMap map => KeyOf map -> a -> map a -> map a
- GHC.Cmm.Dataflow.Collections: mapInsertList :: IsMap map => [(KeyOf map, a)] -> map a -> map a
- GHC.Cmm.Dataflow.Collections: mapInsertWith :: IsMap map => (a -> a -> a) -> KeyOf map -> a -> map a -> map a
- GHC.Cmm.Dataflow.Collections: mapIntersection :: IsMap map => map a -> map a -> map a
- GHC.Cmm.Dataflow.Collections: mapIsSubmapOf :: (IsMap map, Eq a) => map a -> map a -> Bool
- GHC.Cmm.Dataflow.Collections: mapKeys :: IsMap map => map a -> [KeyOf map]
- GHC.Cmm.Dataflow.Collections: mapLookup :: IsMap map => KeyOf map -> map a -> Maybe a
- GHC.Cmm.Dataflow.Collections: mapMap :: IsMap map => (a -> b) -> map a -> map b
- GHC.Cmm.Dataflow.Collections: mapMapWithKey :: IsMap map => (KeyOf map -> a -> b) -> map a -> map b
- GHC.Cmm.Dataflow.Collections: mapMember :: IsMap map => KeyOf map -> map a -> Bool
- GHC.Cmm.Dataflow.Collections: mapNull :: IsMap map => map a -> Bool
- GHC.Cmm.Dataflow.Collections: mapSingleton :: IsMap map => KeyOf map -> a -> map a
- GHC.Cmm.Dataflow.Collections: mapSize :: IsMap map => map a -> Int
- GHC.Cmm.Dataflow.Collections: mapToList :: IsMap map => map a -> [(KeyOf map, a)]
- GHC.Cmm.Dataflow.Collections: mapUnion :: IsMap map => map a -> map a -> map a
- GHC.Cmm.Dataflow.Collections: mapUnionWithKey :: IsMap map => (KeyOf map -> a -> a -> a) -> map a -> map a -> map a
- GHC.Cmm.Dataflow.Collections: mapUnions :: IsMap map => [map a] -> map a
- GHC.Cmm.Dataflow.Collections: setDelete :: IsSet set => ElemOf set -> set -> set
- GHC.Cmm.Dataflow.Collections: setDeleteList :: IsSet set => [ElemOf set] -> set -> set
- GHC.Cmm.Dataflow.Collections: setDifference :: IsSet set => set -> set -> set
- GHC.Cmm.Dataflow.Collections: setElems :: IsSet set => set -> [ElemOf set]
- GHC.Cmm.Dataflow.Collections: setEmpty :: IsSet set => set
- GHC.Cmm.Dataflow.Collections: setFilter :: IsSet set => (ElemOf set -> Bool) -> set -> set
- GHC.Cmm.Dataflow.Collections: setFoldl :: IsSet set => (b -> ElemOf set -> b) -> b -> set -> b
- GHC.Cmm.Dataflow.Collections: setFoldr :: IsSet set => (ElemOf set -> b -> b) -> b -> set -> b
- GHC.Cmm.Dataflow.Collections: setFromList :: IsSet set => [ElemOf set] -> set
- GHC.Cmm.Dataflow.Collections: setInsert :: IsSet set => ElemOf set -> set -> set
- GHC.Cmm.Dataflow.Collections: setInsertList :: IsSet set => [ElemOf set] -> set -> set
- GHC.Cmm.Dataflow.Collections: setIntersection :: IsSet set => set -> set -> set
- GHC.Cmm.Dataflow.Collections: setIsSubsetOf :: IsSet set => set -> set -> Bool
- GHC.Cmm.Dataflow.Collections: setMember :: IsSet set => ElemOf set -> set -> Bool
- GHC.Cmm.Dataflow.Collections: setNull :: IsSet set => set -> Bool
- GHC.Cmm.Dataflow.Collections: setSingleton :: IsSet set => ElemOf set -> set
- GHC.Cmm.Dataflow.Collections: setSize :: IsSet set => set -> Int
- GHC.Cmm.Dataflow.Collections: setUnion :: IsSet set => set -> set -> set
- GHC.Cmm.Dataflow.Collections: setUnions :: IsSet set => [set] -> set
- GHC.Cmm.Dataflow.Collections: type ElemOf set;
- GHC.Cmm.Dataflow.Collections: type KeyOf map;
- GHC.Cmm.Dataflow.Collections: }
- GHC.Cmm.Dataflow.Label: instance GHC.Cmm.Dataflow.Collections.IsMap GHC.Cmm.Dataflow.Label.LabelMap
- GHC.Cmm.Dataflow.Label: instance GHC.Cmm.Dataflow.Collections.IsSet GHC.Cmm.Dataflow.Label.LabelSet
- GHC.Cmm.MachOp: MO_ReadBarrier :: CallishMachOp
- GHC.Cmm.MachOp: MO_WriteBarrier :: CallishMachOp
- GHC.CmmToLlvm.Config: LlvmVersion :: NonEmpty Int -> LlvmVersion
- GHC.CmmToLlvm.Config: [llvmVersionNE] :: LlvmVersion -> NonEmpty Int
- GHC.CmmToLlvm.Config: instance GHC.Classes.Eq GHC.CmmToLlvm.Config.LlvmVersion
- GHC.CmmToLlvm.Config: instance GHC.Classes.Ord GHC.CmmToLlvm.Config.LlvmVersion
- GHC.CmmToLlvm.Config: llvmVersionList :: LlvmVersion -> [Int]
- GHC.CmmToLlvm.Config: llvmVersionStr :: LlvmVersion -> String
- GHC.CmmToLlvm.Config: llvmVersionSupported :: LlvmVersion -> Bool
- GHC.CmmToLlvm.Config: newtype LlvmVersion
- GHC.CmmToLlvm.Config: parseLlvmVersion :: String -> Maybe LlvmVersion
- GHC.CmmToLlvm.Config: supportedLlvmVersionLowerBound :: LlvmVersion
- GHC.CmmToLlvm.Config: supportedLlvmVersionUpperBound :: LlvmVersion
- GHC.Core.Coercion: lcSubst :: LiftingContext -> Subst
- GHC.Core.Coercion: mkForAllCos :: [(TyCoVar, CoercionN)] -> Coercion -> Coercion
- GHC.Core.Coercion: mkHomoForAllMCo :: TyCoVar -> MCoercion -> MCoercion
- GHC.Core.Subst: mkSubst :: InScopeSet -> TvSubstEnv -> CvSubstEnv -> IdSubstEnv -> Subst
- GHC.Core.TyCo.Rep: CorePrepProv :: Bool -> UnivCoProvenance
- GHC.Core.TyCo.Subst: extendTvSubstBinderAndInScope :: Subst -> PiTyBinder -> Type -> Subst
- GHC.Core.TyCo.Subst: mkSubst :: InScopeSet -> TvSubstEnv -> CvSubstEnv -> IdSubstEnv -> Subst
- GHC.Core.TyCon: isVoidRep :: PrimRep -> Bool
- GHC.Core.Type: argsHaveFixedRuntimeRep :: Type -> Bool
- GHC.Core.Type: extendTvSubstBinderAndInScope :: Subst -> PiTyBinder -> Type -> Subst
- GHC.Core.Type: mkSubst :: InScopeSet -> TvSubstEnv -> CvSubstEnv -> IdSubstEnv -> Subst
- GHC.Core.Utils: exprOkForSideEffects :: CoreExpr -> Bool
- GHC.Core.Utils: isUnsafeEqualityProof :: CoreExpr -> Bool
- GHC.Data.EnumSet: instance Control.DeepSeq.NFData (GHC.Data.EnumSet.EnumSet a)
- GHC.Data.EnumSet: instance GHC.Base.Monoid (GHC.Data.EnumSet.EnumSet a)
- GHC.Data.EnumSet: instance GHC.Base.Semigroup (GHC.Data.EnumSet.EnumSet a)
- GHC.Data.EnumSet: instance GHC.Utils.Binary.Binary (GHC.Data.EnumSet.EnumSet a)
- GHC.Driver.Backend: DarwinClangAssemblerInfoGetter :: DefunctionalizedAssemblerInfoGetter
- GHC.Driver.Backend: DarwinClangAssemblerProg :: DefunctionalizedAssemblerProg
- GHC.Driver.Backend: JSAssemblerInfoGetter :: DefunctionalizedAssemblerInfoGetter
- GHC.Driver.Backend: JSAssemblerProg :: DefunctionalizedAssemblerProg
- GHC.Driver.Backend: StandardAssemblerInfoGetter :: DefunctionalizedAssemblerInfoGetter
- GHC.Driver.Backend: StandardAssemblerProg :: DefunctionalizedAssemblerProg
- GHC.Driver.Backend: backendAssemblerInfoGetter :: Backend -> DefunctionalizedAssemblerInfoGetter
- GHC.Driver.Backend: backendAssemblerProg :: Backend -> DefunctionalizedAssemblerProg
- GHC.Driver.Backend: data DefunctionalizedAssemblerInfoGetter
- GHC.Driver.Backend: data DefunctionalizedAssemblerProg
- GHC.Driver.DynFlags: Opt_D_dump_str_signatures :: DumpFlag
- GHC.Driver.DynFlags: Opt_D_dump_stranal :: DumpFlag
- GHC.Driver.DynFlags: Opt_LlvmTBAA :: GeneralFlag
- GHC.Driver.DynFlags: [rtasmInfo] :: DynFlags -> IORef (Maybe CompilerInfo)
- GHC.Driver.DynFlags: [rtccInfo] :: DynFlags -> IORef (Maybe CompilerInfo)
- GHC.Driver.DynFlags: [rtldInfo] :: DynFlags -> IORef (Maybe LinkerInfo)
- GHC.Driver.Flags: Opt_D_dump_str_signatures :: DumpFlag
- GHC.Driver.Flags: Opt_D_dump_stranal :: DumpFlag
- GHC.Driver.Flags: Opt_LlvmTBAA :: GeneralFlag
- GHC.Driver.Session: Opt_D_dump_str_signatures :: DumpFlag
- GHC.Driver.Session: Opt_D_dump_stranal :: DumpFlag
- GHC.Driver.Session: Opt_LlvmTBAA :: GeneralFlag
- GHC.Driver.Session: [rtasmInfo] :: DynFlags -> IORef (Maybe CompilerInfo)
- GHC.Driver.Session: [rtccInfo] :: DynFlags -> IORef (Maybe CompilerInfo)
- GHC.Driver.Session: [rtldInfo] :: DynFlags -> IORef (Maybe LinkerInfo)
- GHC.Driver.Session: opt_lcc :: DynFlags -> [String]
- GHC.Driver.Session: pgm_T :: DynFlags -> String
- GHC.Driver.Session: pgm_dll :: DynFlags -> (String, [Option])
- GHC.Driver.Session: pgm_lcc :: DynFlags -> (String, [Option])
- GHC.Driver.Session: sOpt_lcc :: Settings -> [String]
- GHC.Driver.Session: sPgm_T :: Settings -> String
- GHC.Driver.Session: sPgm_dll :: Settings -> (String, [Option])
- GHC.Driver.Session: sPgm_lcc :: Settings -> (String, [Option])
- GHC.Hs.Decls: [con_dcolon] :: ConDecl pass -> !LHsUniToken "::" "∷" pass
- GHC.Hs.Decls: [tcdLayout] :: TyClDecl pass -> !LayoutInfo pass
- GHC.Hs.Decls: type HsTyPats pass = [LHsTypeArg pass]
- GHC.Hs.Expr: ExpansionExpr :: {-# UNPACK #-} !HsExpansion (HsExpr GhcRn) (HsExpr GhcTc) -> XXExprGhcTc
- GHC.Hs.Expr: HsExpanded :: orig -> expanded -> HsExpansion orig expanded
- GHC.Hs.Expr: data HsExpansion orig expanded
- GHC.Hs.Expr: instance (Data.Data.Data orig, Data.Data.Data expanded) => Data.Data.Data (GHC.Hs.Expr.HsExpansion orig expanded)
- GHC.Hs.Expr: instance (GHC.Utils.Outputable.Outputable a, GHC.Utils.Outputable.Outputable b) => GHC.Utils.Outputable.Outputable (GHC.Hs.Expr.HsExpansion a b)
- GHC.Hs.Expr: instance (Language.Haskell.Syntax.Extension.Anno a GHC.Types.~ GHC.Parser.Annotation.SrcSpanAnn' (GHC.Parser.Annotation.EpAnn an)) => Language.Haskell.Syntax.Extension.WrapXRec (GHC.Hs.Extension.GhcPass p) a
- GHC.Hs.Expr: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Expr.HsMatchContext (GHC.Hs.Extension.GhcPass p))
- GHC.Hs.Expr: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Expr.HsStmtContext (GHC.Hs.Extension.GhcPass p))
- GHC.Hs.Expr: instance GHC.Utils.Outputable.Outputable Language.Haskell.Syntax.Expr.LamCaseVariant
- GHC.Hs.Extension: instance (GHC.TypeLits.KnownSymbol tok, GHC.TypeLits.KnownSymbol utok) => GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Concrete.HsUniToken tok utok)
- GHC.Hs.Extension: instance Data.Typeable.Internal.Typeable p => Data.Data.Data (Language.Haskell.Syntax.Concrete.LayoutInfo (GHC.Hs.Extension.GhcPass p))
- GHC.Hs.Extension: instance GHC.TypeLits.KnownSymbol tok => GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Concrete.HsToken tok)
- GHC.Hs.Extension: noHsTok :: GenLocated TokenLocation (HsToken tok)
- GHC.Hs.Extension: noHsUniTok :: GenLocated TokenLocation (HsUniToken tok utok)
- GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Expr.HsMatchContext GHC.Hs.Extension.GhcPs)
- GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Expr.HsMatchContext GHC.Hs.Extension.GhcRn)
- GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Expr.HsMatchContext GHC.Hs.Extension.GhcTc)
- GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Expr.HsStmtContext GHC.Hs.Extension.GhcPs)
- GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Expr.HsStmtContext GHC.Hs.Extension.GhcRn)
- GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Expr.HsStmtContext GHC.Hs.Extension.GhcTc)
- GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Type.HsLinearArrowTokens GHC.Hs.Extension.GhcPs)
- GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Type.HsLinearArrowTokens GHC.Hs.Extension.GhcRn)
- GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Type.HsLinearArrowTokens GHC.Hs.Extension.GhcTc)
- GHC.Hs.Instances: instance Data.Data.Data Language.Haskell.Syntax.Expr.HsDoFlavour
- GHC.Hs.Pat: instance (GHC.Utils.Outputable.Outputable arg, GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Extension.XRec p (Language.Haskell.Syntax.Pat.HsRecField p arg)), Language.Haskell.Syntax.Extension.XRec p Language.Haskell.Syntax.Pat.RecFieldsDotDot GHC.Types.~ GHC.Types.SrcLoc.Located Language.Haskell.Syntax.Pat.RecFieldsDotDot) => GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Pat.HsRecFields p arg)
- GHC.Hs.Pat: instance GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Type.HsPatSigType p) => GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Pat.HsConPatTyArg p)
- GHC.Hs.Pat: isIrrefutableHsPat :: forall p. OutputableBndrId p => Bool -> LPat (GhcPass p) -> Bool
- GHC.Hs.Type: HsLolly :: !LHsToken "⊸" pass -> HsLinearArrowTokens pass
- GHC.Hs.Type: HsPct1 :: !LHsToken "%1" pass -> !LHsUniToken "->" "→" pass -> HsLinearArrowTokens pass
- GHC.Hs.Type: data HsLinearArrowTokens pass
- GHC.Hs.Type: instance GHC.Hs.Type.OutputableBndrFlag (Language.Haskell.Syntax.Type.HsBndrVis p') p
- GHC.Iface.Syntax: IfaceJoinPoint :: JoinArity -> IfaceJoinInfo
- GHC.Iface.Syntax: IfaceNotJoinPoint :: IfaceJoinInfo
- GHC.Iface.Syntax: data IfaceJoinInfo
- GHC.Iface.Syntax: instance Control.DeepSeq.NFData GHC.Iface.Syntax.IfaceJoinInfo
- GHC.Iface.Syntax: instance GHC.Utils.Binary.Binary GHC.Iface.Syntax.IfaceJoinInfo
- GHC.Iface.Syntax: instance GHC.Utils.Outputable.Outputable GHC.Iface.Syntax.IfaceJoinInfo
- GHC.Iface.Type: IfaceCorePrepProv :: Bool -> IfaceUnivCoProv
- GHC.JS.Make: instance (GHC.JS.Make.ToSat a, b GHC.Types.~ GHC.JS.Unsat.Syntax.JExpr) => GHC.JS.Make.ToSat (b -> a)
- GHC.JS.Make: instance GHC.JS.Make.ToJExpr GHC.JS.Unsat.Syntax.Ident
- GHC.JS.Make: instance GHC.JS.Make.ToJExpr GHC.JS.Unsat.Syntax.JExpr
- GHC.JS.Make: instance GHC.JS.Make.ToJExpr GHC.JS.Unsat.Syntax.JVal
- GHC.JS.Make: instance GHC.JS.Make.ToSat GHC.JS.Unsat.Syntax.JExpr
- GHC.JS.Make: instance GHC.JS.Make.ToSat GHC.JS.Unsat.Syntax.JStat
- GHC.JS.Make: instance GHC.JS.Make.ToSat [GHC.JS.Unsat.Syntax.JExpr]
- GHC.JS.Make: instance GHC.JS.Make.ToSat [GHC.JS.Unsat.Syntax.JStat]
- GHC.JS.Make: instance GHC.JS.Make.ToStat GHC.JS.Unsat.Syntax.JExpr
- GHC.JS.Make: instance GHC.JS.Make.ToStat GHC.JS.Unsat.Syntax.JStat
- GHC.JS.Make: instance GHC.JS.Make.ToStat [GHC.JS.Unsat.Syntax.JExpr]
- GHC.JS.Make: instance GHC.JS.Make.ToStat [GHC.JS.Unsat.Syntax.JStat]
- GHC.JS.Make: instance GHC.Num.Num GHC.JS.Unsat.Syntax.JExpr
- GHC.JS.Make: instance GHC.Real.Fractional GHC.JS.Unsat.Syntax.JExpr
- GHC.JS.Make: jForNoDecl :: Ident -> JExpr -> JExpr -> JStat -> JStat -> JStat
- GHC.JS.Make: jFun :: ToSat a => Ident -> a -> JStat
- GHC.JS.Make: var :: FastString -> JExpr
- GHC.JS.Ppr: instance GHC.JS.Ppr.JsToDoc GHC.JS.Unsat.Syntax.Ident
- GHC.JS.Syntax: [itxt] :: Ident -> FastString
- GHC.JS.Syntax: jassignAll :: [JExpr] -> [JExpr] -> JStat
- GHC.JS.Syntax: jassignAllEqual :: [JExpr] -> [JExpr] -> JStat
- GHC.JS.Syntax: jvar :: FastString -> JExpr
- GHC.JS.Syntax: pattern JAdd :: JExpr -> JExpr -> JExpr
- GHC.JS.Syntax: pattern JBAnd :: JExpr -> JExpr -> JExpr
- GHC.JS.Syntax: pattern JBNot :: JExpr -> JExpr
- GHC.JS.Syntax: pattern JBOr :: JExpr -> JExpr -> JExpr
- GHC.JS.Syntax: pattern JBXor :: JExpr -> JExpr -> JExpr
- GHC.JS.Syntax: pattern JDiv :: JExpr -> JExpr -> JExpr
- GHC.JS.Syntax: pattern JLAnd :: JExpr -> JExpr -> JExpr
- GHC.JS.Syntax: pattern JLOr :: JExpr -> JExpr -> JExpr
- GHC.JS.Syntax: pattern JMod :: JExpr -> JExpr -> JExpr
- GHC.JS.Syntax: pattern JMul :: JExpr -> JExpr -> JExpr
- GHC.JS.Syntax: pattern JNegate :: JExpr -> JExpr
- GHC.JS.Syntax: pattern JNew :: JExpr -> JExpr
- GHC.JS.Syntax: pattern JNot :: JExpr -> JExpr
- GHC.JS.Syntax: pattern JPostDec :: JExpr -> JExpr
- GHC.JS.Syntax: pattern JPostInc :: JExpr -> JExpr
- GHC.JS.Syntax: pattern JPreDec :: JExpr -> JExpr
- GHC.JS.Syntax: pattern JPreInc :: JExpr -> JExpr
- GHC.JS.Syntax: pattern JString :: FastString -> JExpr
- GHC.JS.Syntax: pattern JSub :: JExpr -> JExpr -> JExpr
- GHC.JS.Syntax: pattern SatInt :: Integer -> JExpr
- GHC.JS.Transform: [JMGExpr] :: JExpr -> JMGadt JExpr
- GHC.JS.Transform: [JMGId] :: Ident -> JMGadt Ident
- GHC.JS.Transform: [JMGStat] :: JStat -> JMGadt JStat
- GHC.JS.Transform: [JMGVal] :: JVal -> JMGadt JVal
- GHC.JS.Transform: class Compos t
- GHC.JS.Transform: class JMacro a
- GHC.JS.Transform: compos :: Compos t => (forall a. a -> m a) -> (forall a b. m (a -> b) -> m a -> m b) -> (forall a. t a -> m (t a)) -> t c -> m (t c)
- GHC.JS.Transform: composOp :: Compos t => (forall a. t a -> t a) -> t b -> t b
- GHC.JS.Transform: composOpFold :: Compos t => b -> (b -> b -> b) -> (forall a. t a -> b) -> t c -> b
- GHC.JS.Transform: composOpM :: (Compos t, Monad m) => (forall a. t a -> m (t a)) -> t b -> m (t b)
- GHC.JS.Transform: composOpM_ :: (Compos t, Monad m) => (forall a. t a -> m ()) -> t b -> m ()
- GHC.JS.Transform: data JMGadt a
- GHC.JS.Transform: instance GHC.JS.Transform.Compos GHC.JS.Transform.JMGadt
- GHC.JS.Transform: instance GHC.JS.Transform.JMacro GHC.JS.Unsat.Syntax.Ident
- GHC.JS.Transform: instance GHC.JS.Transform.JMacro GHC.JS.Unsat.Syntax.JExpr
- GHC.JS.Transform: instance GHC.JS.Transform.JMacro GHC.JS.Unsat.Syntax.JStat
- GHC.JS.Transform: instance GHC.JS.Transform.JMacro GHC.JS.Unsat.Syntax.JVal
- GHC.JS.Transform: jfromGADT :: JMacro a => JMGadt a -> a
- GHC.JS.Transform: jtoGADT :: JMacro a => a -> JMGadt a
- GHC.JS.Transform: satJExpr :: Maybe FastString -> JExpr -> JExpr
- GHC.JS.Transform: satJStat :: Maybe FastString -> JStat -> JStat
- GHC.JS.Unsat.Syntax: AddOp :: JOp
- GHC.JS.Unsat.Syntax: ApplExpr :: JExpr -> [JExpr] -> JExpr
- GHC.JS.Unsat.Syntax: ApplStat :: JExpr -> [JExpr] -> JStat
- GHC.JS.Unsat.Syntax: AssignStat :: JExpr -> JExpr -> JStat
- GHC.JS.Unsat.Syntax: BAndOp :: JOp
- GHC.JS.Unsat.Syntax: BNotOp :: JUOp
- GHC.JS.Unsat.Syntax: BOrOp :: JOp
- GHC.JS.Unsat.Syntax: BXorOp :: JOp
- GHC.JS.Unsat.Syntax: BlockStat :: [JStat] -> JStat
- GHC.JS.Unsat.Syntax: BreakStat :: Maybe JsLabel -> JStat
- GHC.JS.Unsat.Syntax: ContinueStat :: Maybe JsLabel -> JStat
- GHC.JS.Unsat.Syntax: DeclStat :: !Ident -> !Maybe JExpr -> JStat
- GHC.JS.Unsat.Syntax: DeleteOp :: JUOp
- GHC.JS.Unsat.Syntax: DivOp :: JOp
- GHC.JS.Unsat.Syntax: EqOp :: JOp
- GHC.JS.Unsat.Syntax: ForInStat :: Bool -> Ident -> JExpr -> JStat -> JStat
- GHC.JS.Unsat.Syntax: ForStat :: JStat -> JExpr -> JStat -> JStat -> JStat
- GHC.JS.Unsat.Syntax: FuncStat :: !Ident -> [Ident] -> JStat -> JStat
- GHC.JS.Unsat.Syntax: GeOp :: JOp
- GHC.JS.Unsat.Syntax: GtOp :: JOp
- GHC.JS.Unsat.Syntax: IS :: State [Ident] a -> IdentSupply a
- GHC.JS.Unsat.Syntax: IdxExpr :: JExpr -> JExpr -> JExpr
- GHC.JS.Unsat.Syntax: IfExpr :: JExpr -> JExpr -> JExpr -> JExpr
- GHC.JS.Unsat.Syntax: IfStat :: JExpr -> JStat -> JStat -> JStat
- GHC.JS.Unsat.Syntax: InOp :: JOp
- GHC.JS.Unsat.Syntax: InfixExpr :: JOp -> JExpr -> JExpr -> JExpr
- GHC.JS.Unsat.Syntax: InstanceofOp :: JOp
- GHC.JS.Unsat.Syntax: JDouble :: SaneDouble -> JVal
- GHC.JS.Unsat.Syntax: JFunc :: [Ident] -> JStat -> JVal
- GHC.JS.Unsat.Syntax: JHash :: UniqMap FastString JExpr -> JVal
- GHC.JS.Unsat.Syntax: JInt :: Integer -> JVal
- GHC.JS.Unsat.Syntax: JList :: [JExpr] -> JVal
- GHC.JS.Unsat.Syntax: JRegEx :: FastString -> JVal
- GHC.JS.Unsat.Syntax: JStr :: FastString -> JVal
- GHC.JS.Unsat.Syntax: JVar :: Ident -> JVal
- GHC.JS.Unsat.Syntax: LAndOp :: JOp
- GHC.JS.Unsat.Syntax: LOrOp :: JOp
- GHC.JS.Unsat.Syntax: LabelStat :: JsLabel -> JStat -> JStat
- GHC.JS.Unsat.Syntax: LeOp :: JOp
- GHC.JS.Unsat.Syntax: LeftShiftOp :: JOp
- GHC.JS.Unsat.Syntax: LtOp :: JOp
- GHC.JS.Unsat.Syntax: ModOp :: JOp
- GHC.JS.Unsat.Syntax: MulOp :: JOp
- GHC.JS.Unsat.Syntax: NegOp :: JUOp
- GHC.JS.Unsat.Syntax: NeqOp :: JOp
- GHC.JS.Unsat.Syntax: NewOp :: JUOp
- GHC.JS.Unsat.Syntax: NotOp :: JUOp
- GHC.JS.Unsat.Syntax: PlusOp :: JUOp
- GHC.JS.Unsat.Syntax: PostDecOp :: JUOp
- GHC.JS.Unsat.Syntax: PostIncOp :: JUOp
- GHC.JS.Unsat.Syntax: PreDecOp :: JUOp
- GHC.JS.Unsat.Syntax: PreIncOp :: JUOp
- GHC.JS.Unsat.Syntax: ReturnStat :: JExpr -> JStat
- GHC.JS.Unsat.Syntax: RightShiftOp :: JOp
- GHC.JS.Unsat.Syntax: SaneDouble :: Double -> SaneDouble
- GHC.JS.Unsat.Syntax: SelExpr :: JExpr -> Ident -> JExpr
- GHC.JS.Unsat.Syntax: StrictEqOp :: JOp
- GHC.JS.Unsat.Syntax: StrictNeqOp :: JOp
- GHC.JS.Unsat.Syntax: SubOp :: JOp
- GHC.JS.Unsat.Syntax: SwitchStat :: JExpr -> [(JExpr, JStat)] -> JStat -> JStat
- GHC.JS.Unsat.Syntax: TryStat :: JStat -> Ident -> JStat -> JStat -> JStat
- GHC.JS.Unsat.Syntax: TxtI :: FastString -> Ident
- GHC.JS.Unsat.Syntax: TypeofOp :: JUOp
- GHC.JS.Unsat.Syntax: UOpExpr :: JUOp -> JExpr -> JExpr
- GHC.JS.Unsat.Syntax: UOpStat :: JUOp -> JExpr -> JStat
- GHC.JS.Unsat.Syntax: UnsatBlock :: IdentSupply JStat -> JStat
- GHC.JS.Unsat.Syntax: UnsatExpr :: IdentSupply JExpr -> JExpr
- GHC.JS.Unsat.Syntax: UnsatVal :: IdentSupply JVal -> JVal
- GHC.JS.Unsat.Syntax: ValExpr :: JVal -> JExpr
- GHC.JS.Unsat.Syntax: VoidOp :: JUOp
- GHC.JS.Unsat.Syntax: WhileStat :: Bool -> JExpr -> JStat -> JStat
- GHC.JS.Unsat.Syntax: YieldOp :: JUOp
- GHC.JS.Unsat.Syntax: ZRightShiftOp :: JOp
- GHC.JS.Unsat.Syntax: [itxt] :: Ident -> FastString
- GHC.JS.Unsat.Syntax: [runIdentSupply] :: IdentSupply a -> State [Ident] a
- GHC.JS.Unsat.Syntax: [unSaneDouble] :: SaneDouble -> Double
- GHC.JS.Unsat.Syntax: data JExpr
- GHC.JS.Unsat.Syntax: data JOp
- GHC.JS.Unsat.Syntax: data JStat
- GHC.JS.Unsat.Syntax: data JUOp
- GHC.JS.Unsat.Syntax: data JVal
- GHC.JS.Unsat.Syntax: identFS :: Ident -> FastString
- GHC.JS.Unsat.Syntax: instance Control.DeepSeq.NFData (GHC.JS.Unsat.Syntax.IdentSupply a)
- GHC.JS.Unsat.Syntax: instance Control.DeepSeq.NFData GHC.JS.Unsat.Syntax.JOp
- GHC.JS.Unsat.Syntax: instance Control.DeepSeq.NFData GHC.JS.Unsat.Syntax.JUOp
- GHC.JS.Unsat.Syntax: instance Data.Data.Data GHC.JS.Unsat.Syntax.JOp
- GHC.JS.Unsat.Syntax: instance Data.Data.Data GHC.JS.Unsat.Syntax.JUOp
- GHC.JS.Unsat.Syntax: instance GHC.Base.Functor GHC.JS.Unsat.Syntax.IdentSupply
- GHC.JS.Unsat.Syntax: instance GHC.Base.Monoid GHC.JS.Unsat.Syntax.JStat
- GHC.JS.Unsat.Syntax: instance GHC.Base.Semigroup GHC.JS.Unsat.Syntax.JStat
- GHC.JS.Unsat.Syntax: instance GHC.Classes.Eq GHC.JS.Unsat.Syntax.Ident
- GHC.JS.Unsat.Syntax: instance GHC.Classes.Eq GHC.JS.Unsat.Syntax.JExpr
- GHC.JS.Unsat.Syntax: instance GHC.Classes.Eq GHC.JS.Unsat.Syntax.JOp
- GHC.JS.Unsat.Syntax: instance GHC.Classes.Eq GHC.JS.Unsat.Syntax.JStat
- GHC.JS.Unsat.Syntax: instance GHC.Classes.Eq GHC.JS.Unsat.Syntax.JUOp
- GHC.JS.Unsat.Syntax: instance GHC.Classes.Eq GHC.JS.Unsat.Syntax.JVal
- GHC.JS.Unsat.Syntax: instance GHC.Classes.Eq a => GHC.Classes.Eq (GHC.JS.Unsat.Syntax.IdentSupply a)
- GHC.JS.Unsat.Syntax: instance GHC.Classes.Ord GHC.JS.Unsat.Syntax.JOp
- GHC.JS.Unsat.Syntax: instance GHC.Classes.Ord GHC.JS.Unsat.Syntax.JUOp
- GHC.JS.Unsat.Syntax: instance GHC.Classes.Ord a => GHC.Classes.Ord (GHC.JS.Unsat.Syntax.IdentSupply a)
- GHC.JS.Unsat.Syntax: instance GHC.Enum.Enum GHC.JS.Unsat.Syntax.JOp
- GHC.JS.Unsat.Syntax: instance GHC.Enum.Enum GHC.JS.Unsat.Syntax.JUOp
- GHC.JS.Unsat.Syntax: instance GHC.Generics.Generic GHC.JS.Unsat.Syntax.JExpr
- GHC.JS.Unsat.Syntax: instance GHC.Generics.Generic GHC.JS.Unsat.Syntax.JOp
- GHC.JS.Unsat.Syntax: instance GHC.Generics.Generic GHC.JS.Unsat.Syntax.JStat
- GHC.JS.Unsat.Syntax: instance GHC.Generics.Generic GHC.JS.Unsat.Syntax.JUOp
- GHC.JS.Unsat.Syntax: instance GHC.Generics.Generic GHC.JS.Unsat.Syntax.JVal
- GHC.JS.Unsat.Syntax: instance GHC.Show.Show GHC.JS.Unsat.Syntax.Ident
- GHC.JS.Unsat.Syntax: instance GHC.Show.Show GHC.JS.Unsat.Syntax.JOp
- GHC.JS.Unsat.Syntax: instance GHC.Show.Show GHC.JS.Unsat.Syntax.JUOp
- GHC.JS.Unsat.Syntax: instance GHC.Show.Show a => GHC.Show.Show (GHC.JS.Unsat.Syntax.IdentSupply a)
- GHC.JS.Unsat.Syntax: instance GHC.Types.Unique.Uniquable GHC.JS.Unsat.Syntax.Ident
- GHC.JS.Unsat.Syntax: newIdentSupply :: Maybe FastString -> [Ident]
- GHC.JS.Unsat.Syntax: newtype Ident
- GHC.JS.Unsat.Syntax: newtype IdentSupply a
- GHC.JS.Unsat.Syntax: newtype SaneDouble
- GHC.JS.Unsat.Syntax: pattern Add :: JExpr -> JExpr -> JExpr
- GHC.JS.Unsat.Syntax: pattern BAnd :: JExpr -> JExpr -> JExpr
- GHC.JS.Unsat.Syntax: pattern BNot :: JExpr -> JExpr
- GHC.JS.Unsat.Syntax: pattern BOr :: JExpr -> JExpr -> JExpr
- GHC.JS.Unsat.Syntax: pattern BXor :: JExpr -> JExpr -> JExpr
- GHC.JS.Unsat.Syntax: pattern Div :: JExpr -> JExpr -> JExpr
- GHC.JS.Unsat.Syntax: pattern Int :: Integer -> JExpr
- GHC.JS.Unsat.Syntax: pattern LAnd :: JExpr -> JExpr -> JExpr
- GHC.JS.Unsat.Syntax: pattern LOr :: JExpr -> JExpr -> JExpr
- GHC.JS.Unsat.Syntax: pattern Mod :: JExpr -> JExpr -> JExpr
- GHC.JS.Unsat.Syntax: pattern Mul :: JExpr -> JExpr -> JExpr
- GHC.JS.Unsat.Syntax: pattern Negate :: JExpr -> JExpr
- GHC.JS.Unsat.Syntax: pattern New :: JExpr -> JExpr
- GHC.JS.Unsat.Syntax: pattern Not :: JExpr -> JExpr
- GHC.JS.Unsat.Syntax: pattern PostDec :: JExpr -> JExpr
- GHC.JS.Unsat.Syntax: pattern PostInc :: JExpr -> JExpr
- GHC.JS.Unsat.Syntax: pattern PreDec :: JExpr -> JExpr
- GHC.JS.Unsat.Syntax: pattern PreInc :: JExpr -> JExpr
- GHC.JS.Unsat.Syntax: pattern String :: FastString -> JExpr
- GHC.JS.Unsat.Syntax: pattern Sub :: JExpr -> JExpr -> JExpr
- GHC.JS.Unsat.Syntax: pseudoSaturate :: IdentSupply a -> a
- GHC.JS.Unsat.Syntax: type JsLabel = LexicalFastString
- GHC.Linker.Types: [loaded_pkg_hs_dlls] :: LoadedPkgInfo -> ![RemotePtr LoadedDLL]
- GHC.Parser.Annotation: Anchor :: RealSrcSpan -> AnchorOperation -> Anchor
- GHC.Parser.Annotation: EpAnnNotUsed :: EpAnn ann
- GHC.Parser.Annotation: EpaEofComment :: EpaCommentTok
- GHC.Parser.Annotation: MovedAnchor :: DeltaPos -> AnchorOperation
- GHC.Parser.Annotation: SrcSpanAnn :: !a -> !SrcSpan -> SrcSpanAnn' a
- GHC.Parser.Annotation: UnchangedAnchor :: AnchorOperation
- GHC.Parser.Annotation: [anchor] :: Anchor -> RealSrcSpan
- GHC.Parser.Annotation: [anchor_op] :: Anchor -> AnchorOperation
- GHC.Parser.Annotation: [ann] :: SrcSpanAnn' a -> !a
- GHC.Parser.Annotation: [locA] :: SrcSpanAnn' a -> !SrcSpan
- GHC.Parser.Annotation: addCLocAA :: GenLocated (SrcSpanAnn' a1) e1 -> GenLocated (SrcSpanAnn' a2) e2 -> e3 -> GenLocated (SrcAnn ann) e3
- GHC.Parser.Annotation: addCommentsToSrcAnn :: Monoid ann => SrcAnn ann -> EpAnnComments -> SrcAnn ann
- GHC.Parser.Annotation: data Anchor
- GHC.Parser.Annotation: data AnchorOperation
- GHC.Parser.Annotation: data EpaLocation
- GHC.Parser.Annotation: data SrcSpanAnn' a
- GHC.Parser.Annotation: epAnnAnnsL :: EpAnn a -> [a]
- GHC.Parser.Annotation: epaLocationFromSrcAnn :: SrcAnn ann -> EpaLocation
- GHC.Parser.Annotation: extraToAnnList :: AnnList -> [AddEpAnn] -> AnnList
- GHC.Parser.Annotation: getTokenSrcSpan :: TokenLocation -> SrcSpan
- GHC.Parser.Annotation: instance (GHC.Utils.Outputable.Outputable a, GHC.Utils.Outputable.Outputable e) => GHC.Utils.Outputable.Outputable (GHC.Types.SrcLoc.GenLocated (GHC.Parser.Annotation.SrcSpanAnn' a) e)
- GHC.Parser.Annotation: instance (GHC.Utils.Outputable.Outputable a, GHC.Utils.Outputable.OutputableBndr e) => GHC.Utils.Outputable.OutputableBndr (GHC.Types.SrcLoc.GenLocated (GHC.Parser.Annotation.SrcSpanAnn' a) e)
- GHC.Parser.Annotation: instance Data.Data.Data GHC.Parser.Annotation.Anchor
- GHC.Parser.Annotation: instance Data.Data.Data GHC.Parser.Annotation.AnchorOperation
- GHC.Parser.Annotation: instance Data.Data.Data GHC.Parser.Annotation.AnnSortKey
- GHC.Parser.Annotation: instance Data.Data.Data GHC.Parser.Annotation.DeltaPos
- GHC.Parser.Annotation: instance Data.Data.Data GHC.Parser.Annotation.EpaLocation
- GHC.Parser.Annotation: instance Data.Data.Data a => Data.Data.Data (GHC.Parser.Annotation.SrcSpanAnn' a)
- GHC.Parser.Annotation: instance GHC.Base.Monoid GHC.Parser.Annotation.AnnList
- GHC.Parser.Annotation: instance GHC.Base.Monoid GHC.Parser.Annotation.AnnListItem
- GHC.Parser.Annotation: instance GHC.Base.Monoid GHC.Parser.Annotation.AnnSortKey
- GHC.Parser.Annotation: instance GHC.Base.Monoid GHC.Parser.Annotation.NameAnn
- GHC.Parser.Annotation: instance GHC.Base.Monoid a => GHC.Base.Monoid (GHC.Parser.Annotation.EpAnn a)
- GHC.Parser.Annotation: instance GHC.Base.Semigroup GHC.Parser.Annotation.Anchor
- GHC.Parser.Annotation: instance GHC.Base.Semigroup GHC.Parser.Annotation.AnnList
- GHC.Parser.Annotation: instance GHC.Base.Semigroup GHC.Parser.Annotation.AnnSortKey
- GHC.Parser.Annotation: instance GHC.Base.Semigroup GHC.Parser.Annotation.NameAnn
- GHC.Parser.Annotation: instance GHC.Base.Semigroup GHC.Parser.Annotation.NoEpAnns
- GHC.Parser.Annotation: instance GHC.Base.Semigroup an => GHC.Base.Semigroup (GHC.Parser.Annotation.SrcSpanAnn' an)
- GHC.Parser.Annotation: instance GHC.Classes.Eq GHC.Parser.Annotation.Anchor
- GHC.Parser.Annotation: instance GHC.Classes.Eq GHC.Parser.Annotation.AnchorOperation
- GHC.Parser.Annotation: instance GHC.Classes.Eq GHC.Parser.Annotation.AnnSortKey
- GHC.Parser.Annotation: instance GHC.Classes.Eq GHC.Parser.Annotation.DeltaPos
- GHC.Parser.Annotation: instance GHC.Classes.Eq GHC.Parser.Annotation.EpaLocation
- GHC.Parser.Annotation: instance GHC.Classes.Eq a => GHC.Classes.Eq (GHC.Parser.Annotation.SrcSpanAnn' a)
- GHC.Parser.Annotation: instance GHC.Classes.Ord GHC.Parser.Annotation.Anchor
- GHC.Parser.Annotation: instance GHC.Classes.Ord GHC.Parser.Annotation.DeltaPos
- GHC.Parser.Annotation: instance GHC.Show.Show GHC.Parser.Annotation.Anchor
- GHC.Parser.Annotation: instance GHC.Show.Show GHC.Parser.Annotation.AnchorOperation
- GHC.Parser.Annotation: instance GHC.Show.Show GHC.Parser.Annotation.DeltaPos
- GHC.Parser.Annotation: instance GHC.Utils.Outputable.Outputable (GHC.Types.SrcLoc.GenLocated GHC.Parser.Annotation.Anchor GHC.Parser.Annotation.EpaComment)
- GHC.Parser.Annotation: instance GHC.Utils.Outputable.Outputable GHC.Parser.Annotation.Anchor
- GHC.Parser.Annotation: instance GHC.Utils.Outputable.Outputable GHC.Parser.Annotation.AnchorOperation
- GHC.Parser.Annotation: instance GHC.Utils.Outputable.Outputable GHC.Parser.Annotation.AnnSortKey
- GHC.Parser.Annotation: instance GHC.Utils.Outputable.Outputable GHC.Parser.Annotation.DeltaPos
- GHC.Parser.Annotation: instance GHC.Utils.Outputable.Outputable GHC.Parser.Annotation.EpaLocation
- GHC.Parser.Annotation: instance GHC.Utils.Outputable.Outputable a => GHC.Utils.Outputable.Outputable (GHC.Parser.Annotation.SrcSpanAnn' a)
- GHC.Parser.Annotation: l2n :: LocatedAn a1 a2 -> LocatedN a2
- GHC.Parser.Annotation: la2e :: SrcSpanAnn' a -> EpaLocation
- GHC.Parser.Annotation: la2na :: SrcSpanAnn' a -> SrcSpanAnnN
- GHC.Parser.Annotation: n2l :: LocatedN a -> LocatedA a
- GHC.Parser.Annotation: na2la :: SrcSpanAnn' a -> SrcAnn ann
- GHC.Parser.Annotation: reAnn :: [TrailingAnn] -> EpAnnComments -> Located a -> LocatedA a
- GHC.Parser.Annotation: reLocA :: Located e -> LocatedAn ann e
- GHC.Parser.Annotation: reLocC :: LocatedN e -> LocatedC e
- GHC.Parser.Annotation: reLocL :: LocatedN e -> LocatedA e
- GHC.Parser.Annotation: reLocN :: LocatedN a -> Located a
- GHC.Parser.Annotation: setCommentsSrcAnn :: Monoid ann => SrcAnn ann -> EpAnnComments -> SrcAnn ann
- GHC.Parser.Annotation: type SrcAnn ann = SrcSpanAnn' (EpAnn ann)
- GHC.Parser.Annotation: widenAnchorR :: Anchor -> RealSrcSpan -> Anchor
- GHC.Parser.Errors.Types: PsErrLambdaCaseCmdInFunAppCmd :: !LamCaseVariant -> !LHsCmd GhcPs -> PsMessage
- GHC.Parser.Errors.Types: PsErrLambdaCaseInFunAppExpr :: !LamCaseVariant -> !LHsExpr GhcPs -> PsMessage
- GHC.Parser.Errors.Types: PsErrLambdaCaseInPat :: LamCaseVariant -> PsMessage
- GHC.Parser.PostProcess: mkHsLamCasePV :: DisambECP b => SrcSpan -> LamCaseVariant -> LocatedL [LMatch GhcPs (LocatedA b)] -> [AddEpAnn] -> PV (LocatedA b)
- GHC.Parser.PostProcess.Haddock: instance GHC.Base.Monoid GHC.Parser.PostProcess.Haddock.HasInnerDocs
- GHC.Parser.PostProcess.Haddock: instance GHC.Base.Semigroup GHC.Parser.PostProcess.Haddock.HasInnerDocs
- GHC.Runtime.Interpreter.Types: [interpLookupSymbolCache] :: Interp -> !MVar (UniqFM FastString (Ptr ()))
- GHC.Settings: [toolSettings_ldSupportsResponseFiles] :: ToolSettings -> Bool
- GHC.Settings: [toolSettings_opt_lcc] :: ToolSettings -> [String]
- GHC.Settings: [toolSettings_pgm_T] :: ToolSettings -> String
- GHC.Settings: [toolSettings_pgm_dll] :: ToolSettings -> (String, [Option])
- GHC.Settings: [toolSettings_pgm_lcc] :: ToolSettings -> (String, [Option])
- GHC.Settings: sLdSupportsResponseFiles :: Settings -> Bool
- GHC.Settings: sOpt_lcc :: Settings -> [String]
- GHC.Settings: sPgm_T :: Settings -> String
- GHC.Settings: sPgm_dll :: Settings -> (String, [Option])
- GHC.Settings: sPgm_lcc :: Settings -> (String, [Option])
- GHC.StgToJS.Linker.Types: ObjFile :: FilePath -> LinkedObj
- GHC.StgToJS.Linker.Types: ObjLoaded :: String -> Object -> LinkedObj
- GHC.StgToJS.Linker.Types: [lkp_extra_js] :: LinkPlan -> Set FilePath
- GHC.StgToJS.Linker.Types: data LinkedObj
- GHC.StgToJS.Linker.Types: defaultJSLinkConfig :: JSLinkConfig
- GHC.StgToJS.Linker.Types: instance GHC.Utils.Outputable.Outputable GHC.StgToJS.Linker.Types.LinkedObj
- GHC.StgToJS.Object: instance GHC.Utils.Binary.Binary GHC.JS.Unsat.Syntax.Ident
- GHC.StgToJS.Object: instance GHC.Utils.Binary.Binary GHC.StgToJS.Types.VarType
- GHC.StgToJS.Object: isJsObjectFile :: FilePath -> IO Bool
- GHC.StgToJS.Types: data VarType
- GHC.StgToJS.Types: instance GHC.Classes.Eq GHC.StgToJS.Types.VarType
- GHC.StgToJS.Types: instance GHC.Classes.Ord GHC.StgToJS.Types.VarType
- GHC.StgToJS.Types: instance GHC.Enum.Bounded GHC.StgToJS.Types.VarType
- GHC.StgToJS.Types: instance GHC.Enum.Enum GHC.StgToJS.Types.VarType
- GHC.StgToJS.Types: instance GHC.JS.Make.ToJExpr GHC.StgToJS.Types.VarType
- GHC.StgToJS.Types: instance GHC.Show.Show GHC.StgToJS.Types.VarType
- GHC.Tc.Errors.Types: NoDataKindsDC :: PromotionErr
- GHC.Tc.Errors.Types: [TcRnBindMultipleVariables] :: HsDocContext -> LocatedN RdrName -> TcRnMessage
- GHC.Tc.Errors.Types: [TcRnBindVarAlreadyInScope] :: [LocatedN RdrName] -> TcRnMessage
- GHC.Tc.Errors.Types: [TcRnForallIdentifier] :: RdrName -> TcRnMessage
- GHC.Tc.Errors.Types: [TcRnLoopySuperclassSolve] :: CtLoc -> PredType -> TcRnMessage
- GHC.Tc.Errors.Types: [sr_hints] :: SolverReport -> [GhcHint]
- GHC.Tc.Errors.Types.PromotionErr: NoDataKindsDC :: PromotionErr
- GHC.Tc.Types: CompleteSig :: TcId -> UserTypeCtxt -> SrcSpan -> TcIdSigInfo
- GHC.Tc.Types: NoDataKindsDC :: PromotionErr
- GHC.Tc.Types: PartialSig :: Name -> LHsSigWcType GhcRn -> UserTypeCtxt -> SrcSpan -> TcIdSigInfo
- GHC.Tc.Types: TPSI :: Name -> [InvisTVBinder] -> [InvisTVBinder] -> TcThetaType -> [InvisTVBinder] -> TcThetaType -> TcSigmaType -> TcPatSynInfo
- GHC.Tc.Types: [deProposalCandidates] :: DefaultingProposal -> [Type]
- GHC.Tc.Types: [deProposalTyVar] :: DefaultingProposal -> TcTyVar
- GHC.Tc.Types: [tcg_doc_hdr] :: TcGblEnv -> Maybe (LHsDoc GhcRn)
- GHC.Tc.Types: data TcIdSigInfo
- GHC.Tc.Types: data TcPatSynInfo
- GHC.Tc.Types: type DefaultingPluginResult = [DefaultingProposal]
- GHC.Tc.Types.BasicTypes: CompleteSig :: TcId -> UserTypeCtxt -> SrcSpan -> TcIdSigInfo
- GHC.Tc.Types.BasicTypes: PartialSig :: Name -> LHsSigWcType GhcRn -> UserTypeCtxt -> SrcSpan -> TcIdSigInfo
- GHC.Tc.Types.BasicTypes: TPSI :: Name -> [InvisTVBinder] -> [InvisTVBinder] -> TcThetaType -> [InvisTVBinder] -> TcThetaType -> TcSigmaType -> TcPatSynInfo
- GHC.Tc.Types.BasicTypes: data TcIdSigInfo
- GHC.Tc.Types.BasicTypes: data TcPatSynInfo
- GHC.Tc.Types.BasicTypes: instance GHC.Utils.Outputable.Outputable GHC.Tc.Types.BasicTypes.TcIdSigInfo
- GHC.Tc.Types.BasicTypes: instance GHC.Utils.Outputable.Outputable GHC.Tc.Types.BasicTypes.TcPatSynInfo
- GHC.Tc.Types.Origin: ExpectedFunTyLamCase :: LamCaseVariant -> !HsExpr GhcRn -> ExpectedFunTyOrigin
- GHC.Tc.Types.Origin: FRRNoBindingResArg :: !RepPolyFun -> !ArgPos -> FixedRuntimeRepContext
- GHC.Tc.Types.Origin: FRRTupleArg :: !Int -> FixedRuntimeRepContext
- GHC.Tc.Types.Origin: FRRTupleSection :: !Int -> FixedRuntimeRepContext
- GHC.Tc.Types.Origin: RepPolyDataCon :: !DataCon -> RepPolyFun
- GHC.Tc.Types.Origin: RepPolyWiredIn :: !Id -> RepPolyFun
- GHC.Tc.Types.Origin: data RepPolyFun
- GHC.Tc.Types.Origin: instance GHC.Utils.Outputable.Outputable GHC.Tc.Types.Origin.RepPolyFun
- GHC.Tc.Utils.TcType: mkSubst :: InScopeSet -> TvSubstEnv -> CvSubstEnv -> IdSubstEnv -> Subst
- GHC.Types.Demand: isUsedOnce :: Card -> Bool
- GHC.Types.Demand: isUsedOnceDmd :: Demand -> Bool
- GHC.Types.Error: LoopySuperclassSolveHint :: PredType -> ClsInstOrQC -> GhcHint
- GHC.Types.Error: SuggestRenameForall :: GhcHint
- GHC.Types.Error: SuggestTypeSignatureForm :: GhcHint
- GHC.Types.Error.Codes: instance (GHC.Types.Error.Codes.ConstructorCode con f recur, recur GHC.Types.~ GHC.Types.Error.Codes.ConRecursInto con) => GHC.Types.Error.Codes.GDiagnosticCode (GHC.Generics.M1 i ('GHC.Generics.MetaCons con x y) f)
- GHC.Types.Error.Codes: instance GHC.Types.Error.Codes.KnownConstructor con => GHC.Types.Error.Codes.ConstructorCode con f 'GHC.Maybe.Nothing
- GHC.Types.Hint: LoopySuperclassSolveHint :: PredType -> ClsInstOrQC -> GhcHint
- GHC.Types.Hint: SuggestRenameForall :: GhcHint
- GHC.Types.Hint: SuggestTypeSignatureForm :: GhcHint
- GHC.Types.Id: isJoinId_maybe :: Var -> Maybe JoinArity
- GHC.Types.Name.Occurrence: type OccSet = FastStringEnv (UniqSet NameSpace)
- GHC.Types.RepType: VoidRep :: PrimRep
- GHC.Types.RepType: isNvUnaryType :: Type -> Bool
- GHC.Types.RepType: tyConPrimRep1 :: HasDebugCallStack => TyCon -> PrimRep
- GHC.Types.RepType: typePrimRepArgs :: HasDebugCallStack => Type -> NonEmpty PrimRep
- GHC.Types.RepType: typeSlotTy :: UnaryType -> Maybe SlotTy
- GHC.Types.Unique.DFM: instance (Data.Data.Data key, Data.Data.Data ele) => Data.Data.Data (GHC.Types.Unique.DFM.UniqDFM key ele)
- GHC.Types.Unique.DFM: instance Data.Foldable.Foldable (GHC.Types.Unique.DFM.UniqDFM key)
- GHC.Types.Unique.DFM: instance Data.Traversable.Traversable (GHC.Types.Unique.DFM.UniqDFM key)
- GHC.Types.Unique.DFM: instance GHC.Base.Functor (GHC.Types.Unique.DFM.UniqDFM key)
- GHC.Types.Unique.DFM: instance GHC.Utils.Outputable.Outputable a => GHC.Utils.Outputable.Outputable (GHC.Types.Unique.DFM.UniqDFM key a)
- GHC.Types.Unique.FM: instance (Data.Data.Data key, Data.Data.Data ele) => Data.Data.Data (GHC.Types.Unique.FM.UniqFM key ele)
- GHC.Types.Unique.FM: instance Data.Foldable.Foldable (GHC.Types.Unique.FM.NonDetUniqFM key)
- GHC.Types.Unique.FM: instance Data.Traversable.Traversable (GHC.Types.Unique.FM.NonDetUniqFM key)
- GHC.Types.Unique.FM: instance GHC.Base.Functor (GHC.Types.Unique.FM.NonDetUniqFM key)
- GHC.Types.Unique.FM: instance GHC.Base.Functor (GHC.Types.Unique.FM.UniqFM key)
- GHC.Types.Unique.FM: instance GHC.Base.Monoid (GHC.Types.Unique.FM.UniqFM key a)
- GHC.Types.Unique.FM: instance GHC.Base.Semigroup (GHC.Types.Unique.FM.UniqFM key a)
- GHC.Types.Unique.FM: instance GHC.Classes.Eq ele => GHC.Classes.Eq (GHC.Types.Unique.FM.UniqFM key ele)
- GHC.Types.Unique.FM: instance GHC.Utils.Outputable.Outputable a => GHC.Utils.Outputable.Outputable (GHC.Types.Unique.FM.UniqFM key a)
- GHC.Unit.Module.Warnings: instance (GHC.Classes.Eq (Language.Haskell.Syntax.Concrete.HsToken "in"), GHC.Classes.Eq (Language.Haskell.Syntax.Extension.IdP pass)) => GHC.Classes.Eq (GHC.Unit.Module.Warnings.WarningTxt pass)
- GHC.Utils.Logger: jsonLogAction :: LogAction
- GHC.Utils.Misc: chunkList :: Int -> [a] -> [[a]]
- GHC.Utils.Misc: mapLastM :: Functor f => (a -> f a) -> NonEmpty a -> f (NonEmpty a)
- GHC.Utils.Panic: assertPanic :: String -> Int -> a
- GHC.Utils.Panic: cmdLineError :: String -> a
- GHC.Utils.Panic: cmdLineErrorIO :: String -> IO a
- GHC.Utils.Panic: panic :: HasCallStack => String -> a
- GHC.Utils.Panic: pgmError :: HasCallStack => String -> a
- GHC.Utils.Panic: sorry :: HasCallStack => String -> a
- GHCi.Message: [LookupSymbolInDLL] :: RemotePtr LoadedDLL -> String -> Message (Maybe (RemotePtr ()))
- GHCi.Message: data LoadedDLL
- GHCi.RemoteTypes: instance Control.DeepSeq.NFData (GHCi.RemoteTypes.ForeignRef a)
- GHCi.RemoteTypes: instance Control.DeepSeq.NFData (GHCi.RemoteTypes.RemotePtr a)
- GHCi.RemoteTypes: instance Data.Binary.Class.Binary (GHCi.RemoteTypes.RemotePtr a)
- GHCi.RemoteTypes: instance Data.Binary.Class.Binary (GHCi.RemoteTypes.RemoteRef a)
- GHCi.RemoteTypes: instance GHC.Show.Show (GHCi.RemoteTypes.RemotePtr a)
- GHCi.RemoteTypes: instance GHC.Show.Show (GHCi.RemoteTypes.RemoteRef a)
- Language.Haskell.Syntax.Concrete: ExplicitBraces :: !LHsToken "{" pass -> !LHsToken "}" pass -> LayoutInfo pass
- Language.Haskell.Syntax.Concrete: HsNormalTok :: HsUniToken (tok :: Symbol) (utok :: Symbol)
- Language.Haskell.Syntax.Concrete: HsTok :: HsToken (tok :: Symbol)
- Language.Haskell.Syntax.Concrete: HsUnicodeTok :: HsUniToken (tok :: Symbol) (utok :: Symbol)
- Language.Haskell.Syntax.Concrete: NoLayoutInfo :: LayoutInfo pass
- Language.Haskell.Syntax.Concrete: VirtualBraces :: !Int -> LayoutInfo pass
- Language.Haskell.Syntax.Concrete: data HsToken (tok :: Symbol)
- Language.Haskell.Syntax.Concrete: data HsUniToken (tok :: Symbol) (utok :: Symbol)
- Language.Haskell.Syntax.Concrete: data LayoutInfo pass
- Language.Haskell.Syntax.Concrete: instance (GHC.TypeLits.KnownSymbol tok, GHC.TypeLits.KnownSymbol utok) => Data.Data.Data (Language.Haskell.Syntax.Concrete.HsUniToken tok utok)
- Language.Haskell.Syntax.Concrete: instance GHC.Classes.Eq (Language.Haskell.Syntax.Concrete.HsToken tok)
- Language.Haskell.Syntax.Concrete: instance GHC.TypeLits.KnownSymbol tok => Data.Data.Data (Language.Haskell.Syntax.Concrete.HsToken tok)
- Language.Haskell.Syntax.Concrete: type LHsToken tok p = XRec p (HsToken tok)
- Language.Haskell.Syntax.Concrete: type LHsUniToken tok utok p = XRec p (HsUniToken tok utok)
- Language.Haskell.Syntax.Decls: [con_dcolon] :: ConDecl pass -> !LHsUniToken "::" "∷" pass
- Language.Haskell.Syntax.Decls: [tcdLayout] :: TyClDecl pass -> !LayoutInfo pass
- Language.Haskell.Syntax.Decls: type HsTyPats pass = [LHsTypeArg pass]
- Language.Haskell.Syntax.Expr: ArrowLamCaseAlt :: LamCaseVariant -> HsArrowMatchContext
- Language.Haskell.Syntax.Expr: HsCmdLamCase :: XCmdLamCase id -> LamCaseVariant -> MatchGroup id (LHsCmd id) -> HsCmd id
- Language.Haskell.Syntax.Expr: HsLamCase :: XLamCase p -> LamCaseVariant -> MatchGroup p (LHsExpr p) -> HsExpr p
- Language.Haskell.Syntax.Expr: KappaExpr :: HsArrowMatchContext
- Language.Haskell.Syntax.Expr: LamCaseAlt :: LamCaseVariant -> HsMatchContext p
- Language.Haskell.Syntax.Expr: LambdaExpr :: HsMatchContext p
- Language.Haskell.Syntax.Expr: data LamCaseVariant
- Language.Haskell.Syntax.Expr: instance Data.Data.Data Language.Haskell.Syntax.Expr.LamCaseVariant
- Language.Haskell.Syntax.Expr: instance GHC.Classes.Eq Language.Haskell.Syntax.Expr.LamCaseVariant
- Language.Haskell.Syntax.Type: HsLolly :: !LHsToken "⊸" pass -> HsLinearArrowTokens pass
- Language.Haskell.Syntax.Type: HsPct1 :: !LHsToken "%1" pass -> !LHsUniToken "->" "→" pass -> HsLinearArrowTokens pass
- Language.Haskell.Syntax.Type: data HsLinearArrowTokens pass
+ GHC.Builtin.Names: cONTROL_MONAD_ZIP :: Module
+ GHC.Builtin.Names: dATA_SUM_EXPERIMENTAL :: Module
+ GHC.Builtin.Names: dATA_TUPLE_EXPERIMENTAL :: Module
+ GHC.Builtin.Names: dataToTagClassKey :: Unique
+ GHC.Builtin.Names: dataToTagClassName :: Name
+ GHC.Builtin.Names: emptyExceptionContextKey :: Unique
+ GHC.Builtin.Names: emptyExceptionContextName :: Name
+ GHC.Builtin.Names: exceptionContextTyConKey :: Unique
+ GHC.Builtin.Names: exceptionContextTyConName :: Name
+ GHC.Builtin.Names: gHC_INTERNAL_ARROW :: Module
+ GHC.Builtin.Names: gHC_INTERNAL_BASE :: Module
+ GHC.Builtin.Names: gHC_INTERNAL_CONC :: Module
+ GHC.Builtin.Names: gHC_INTERNAL_CONTROL_EXCEPTION_BASE :: Module
+ GHC.Builtin.Names: gHC_INTERNAL_DATA_COERCE :: Module
+ GHC.Builtin.Names: gHC_INTERNAL_DATA_DATA :: Module
+ GHC.Builtin.Names: gHC_INTERNAL_DATA_EITHER :: Module
+ GHC.Builtin.Names: gHC_INTERNAL_DATA_FOLDABLE :: Module
+ GHC.Builtin.Names: gHC_INTERNAL_DATA_STRING :: Module
+ GHC.Builtin.Names: gHC_INTERNAL_DATA_TRAVERSABLE :: Module
+ GHC.Builtin.Names: gHC_INTERNAL_DEBUG_TRACE :: Module
+ GHC.Builtin.Names: gHC_INTERNAL_DESUGAR :: Module
+ GHC.Builtin.Names: gHC_INTERNAL_DYNAMIC :: Module
+ GHC.Builtin.Names: gHC_INTERNAL_ENUM :: Module
+ GHC.Builtin.Names: gHC_INTERNAL_ERR :: Module
+ GHC.Builtin.Names: gHC_INTERNAL_EXCEPTION_CONTEXT :: Module
+ GHC.Builtin.Names: gHC_INTERNAL_EXTS :: Module
+ GHC.Builtin.Names: gHC_INTERNAL_FINGERPRINT_TYPE :: Module
+ GHC.Builtin.Names: gHC_INTERNAL_FLOAT :: Module
+ GHC.Builtin.Names: gHC_INTERNAL_FOREIGN_C_CONSTPTR :: Module
+ GHC.Builtin.Names: gHC_INTERNAL_GENERICS :: Module
+ GHC.Builtin.Names: gHC_INTERNAL_GHCI :: Module
+ GHC.Builtin.Names: gHC_INTERNAL_GHCI_HELPERS :: Module
+ GHC.Builtin.Names: gHC_INTERNAL_INT :: Module
+ GHC.Builtin.Names: gHC_INTERNAL_IO :: Module
+ GHC.Builtin.Names: gHC_INTERNAL_IO_Exception :: Module
+ GHC.Builtin.Names: gHC_INTERNAL_IS_LIST :: Module
+ GHC.Builtin.Names: gHC_INTERNAL_IX :: Module
+ GHC.Builtin.Names: gHC_INTERNAL_LEX :: Module
+ GHC.Builtin.Names: gHC_INTERNAL_LIST :: Module
+ GHC.Builtin.Names: gHC_INTERNAL_MAYBE :: Module
+ GHC.Builtin.Names: gHC_INTERNAL_MONAD :: Module
+ GHC.Builtin.Names: gHC_INTERNAL_MONAD_FAIL :: Module
+ GHC.Builtin.Names: gHC_INTERNAL_MONAD_FIX :: Module
+ GHC.Builtin.Names: gHC_INTERNAL_NUM :: Module
+ GHC.Builtin.Names: gHC_INTERNAL_NUM_BIGNAT :: Module
+ GHC.Builtin.Names: gHC_INTERNAL_NUM_INTEGER :: Module
+ GHC.Builtin.Names: gHC_INTERNAL_NUM_NATURAL :: Module
+ GHC.Builtin.Names: gHC_INTERNAL_OVER_LABELS :: Module
+ GHC.Builtin.Names: gHC_INTERNAL_PTR :: Module
+ GHC.Builtin.Names: gHC_INTERNAL_RANDOM :: Module
+ GHC.Builtin.Names: gHC_INTERNAL_READ :: Module
+ GHC.Builtin.Names: gHC_INTERNAL_READ_PREC :: Module
+ GHC.Builtin.Names: gHC_INTERNAL_REAL :: Module
+ GHC.Builtin.Names: gHC_INTERNAL_RECORDS :: Module
+ GHC.Builtin.Names: gHC_INTERNAL_SHOW :: Module
+ GHC.Builtin.Names: gHC_INTERNAL_SRCLOC :: Module
+ GHC.Builtin.Names: gHC_INTERNAL_ST :: Module
+ GHC.Builtin.Names: gHC_INTERNAL_STABLE :: Module
+ GHC.Builtin.Names: gHC_INTERNAL_STACK :: Module
+ GHC.Builtin.Names: gHC_INTERNAL_STACK_TYPES :: Module
+ GHC.Builtin.Names: gHC_INTERNAL_STATICPTR :: Module
+ GHC.Builtin.Names: gHC_INTERNAL_STATICPTR_INTERNAL :: Module
+ GHC.Builtin.Names: gHC_INTERNAL_SYSTEM_IO :: Module
+ GHC.Builtin.Names: gHC_INTERNAL_TOP_HANDLER :: Module
+ GHC.Builtin.Names: gHC_INTERNAL_TUPLE :: Module
+ GHC.Builtin.Names: gHC_INTERNAL_TYPEABLE :: Module
+ GHC.Builtin.Names: gHC_INTERNAL_TYPEABLE_INTERNAL :: Module
+ GHC.Builtin.Names: gHC_INTERNAL_TYPEERROR :: Module
+ GHC.Builtin.Names: gHC_INTERNAL_TYPELITS :: Module
+ GHC.Builtin.Names: gHC_INTERNAL_TYPELITS_INTERNAL :: Module
+ GHC.Builtin.Names: gHC_INTERNAL_TYPENATS :: Module
+ GHC.Builtin.Names: gHC_INTERNAL_TYPENATS_INTERNAL :: Module
+ GHC.Builtin.Names: gHC_INTERNAL_UNSAFE_COERCE :: Module
+ GHC.Builtin.Names: gHC_INTERNAL_WORD :: Module
+ GHC.Builtin.Names: jsvalTyConKey :: Unique
+ GHC.Builtin.Names: jsvalTyConName :: Name
+ GHC.Builtin.Names: mkExperimentalModule :: FastString -> Module
+ GHC.Builtin.Names: mkGhcInternalModule :: FastString -> Module
+ GHC.Builtin.Names: mkGhcInternalModule_ :: ModuleName -> Module
+ GHC.Builtin.PrimOps: CanFail :: PrimOpEffect
+ GHC.Builtin.PrimOps: CastDoubleToWord64Op :: PrimOp
+ GHC.Builtin.PrimOps: CastFloatToWord32Op :: PrimOp
+ GHC.Builtin.PrimOps: CastWord32ToFloatOp :: PrimOp
+ GHC.Builtin.PrimOps: CastWord64ToDoubleOp :: PrimOp
+ GHC.Builtin.PrimOps: DataToTagLargeOp :: PrimOp
+ GHC.Builtin.PrimOps: DataToTagSmallOp :: PrimOp
+ GHC.Builtin.PrimOps: IndexOffAddrOp_Word8AsAddr :: PrimOp
+ GHC.Builtin.PrimOps: IndexOffAddrOp_Word8AsChar :: PrimOp
+ GHC.Builtin.PrimOps: IndexOffAddrOp_Word8AsDouble :: PrimOp
+ GHC.Builtin.PrimOps: IndexOffAddrOp_Word8AsFloat :: PrimOp
+ GHC.Builtin.PrimOps: IndexOffAddrOp_Word8AsInt :: PrimOp
+ GHC.Builtin.PrimOps: IndexOffAddrOp_Word8AsInt16 :: PrimOp
+ GHC.Builtin.PrimOps: IndexOffAddrOp_Word8AsInt32 :: PrimOp
+ GHC.Builtin.PrimOps: IndexOffAddrOp_Word8AsInt64 :: PrimOp
+ GHC.Builtin.PrimOps: IndexOffAddrOp_Word8AsStablePtr :: PrimOp
+ GHC.Builtin.PrimOps: IndexOffAddrOp_Word8AsWideChar :: PrimOp
+ GHC.Builtin.PrimOps: IndexOffAddrOp_Word8AsWord :: PrimOp
+ GHC.Builtin.PrimOps: IndexOffAddrOp_Word8AsWord16 :: PrimOp
+ GHC.Builtin.PrimOps: IndexOffAddrOp_Word8AsWord32 :: PrimOp
+ GHC.Builtin.PrimOps: IndexOffAddrOp_Word8AsWord64 :: PrimOp
+ GHC.Builtin.PrimOps: NoEffect :: PrimOpEffect
+ GHC.Builtin.PrimOps: ReadOffAddrOp_Word8AsAddr :: PrimOp
+ GHC.Builtin.PrimOps: ReadOffAddrOp_Word8AsChar :: PrimOp
+ GHC.Builtin.PrimOps: ReadOffAddrOp_Word8AsDouble :: PrimOp
+ GHC.Builtin.PrimOps: ReadOffAddrOp_Word8AsFloat :: PrimOp
+ GHC.Builtin.PrimOps: ReadOffAddrOp_Word8AsInt :: PrimOp
+ GHC.Builtin.PrimOps: ReadOffAddrOp_Word8AsInt16 :: PrimOp
+ GHC.Builtin.PrimOps: ReadOffAddrOp_Word8AsInt32 :: PrimOp
+ GHC.Builtin.PrimOps: ReadOffAddrOp_Word8AsInt64 :: PrimOp
+ GHC.Builtin.PrimOps: ReadOffAddrOp_Word8AsStablePtr :: PrimOp
+ GHC.Builtin.PrimOps: ReadOffAddrOp_Word8AsWideChar :: PrimOp
+ GHC.Builtin.PrimOps: ReadOffAddrOp_Word8AsWord :: PrimOp
+ GHC.Builtin.PrimOps: ReadOffAddrOp_Word8AsWord16 :: PrimOp
+ GHC.Builtin.PrimOps: ReadOffAddrOp_Word8AsWord32 :: PrimOp
+ GHC.Builtin.PrimOps: ReadOffAddrOp_Word8AsWord64 :: PrimOp
+ GHC.Builtin.PrimOps: ReadWriteEffect :: PrimOpEffect
+ GHC.Builtin.PrimOps: ReturnsTuple :: PrimOpResultInfo
+ GHC.Builtin.PrimOps: ReturnsVoid :: PrimOpResultInfo
+ GHC.Builtin.PrimOps: ThrowsException :: PrimOpEffect
+ GHC.Builtin.PrimOps: UnsafeThawByteArrayOp :: PrimOp
+ GHC.Builtin.PrimOps: WriteOffAddrOp_Word8AsAddr :: PrimOp
+ GHC.Builtin.PrimOps: WriteOffAddrOp_Word8AsChar :: PrimOp
+ GHC.Builtin.PrimOps: WriteOffAddrOp_Word8AsDouble :: PrimOp
+ GHC.Builtin.PrimOps: WriteOffAddrOp_Word8AsFloat :: PrimOp
+ GHC.Builtin.PrimOps: WriteOffAddrOp_Word8AsInt :: PrimOp
+ GHC.Builtin.PrimOps: WriteOffAddrOp_Word8AsInt16 :: PrimOp
+ GHC.Builtin.PrimOps: WriteOffAddrOp_Word8AsInt32 :: PrimOp
+ GHC.Builtin.PrimOps: WriteOffAddrOp_Word8AsInt64 :: PrimOp
+ GHC.Builtin.PrimOps: WriteOffAddrOp_Word8AsStablePtr :: PrimOp
+ GHC.Builtin.PrimOps: WriteOffAddrOp_Word8AsWideChar :: PrimOp
+ GHC.Builtin.PrimOps: WriteOffAddrOp_Word8AsWord :: PrimOp
+ GHC.Builtin.PrimOps: WriteOffAddrOp_Word8AsWord16 :: PrimOp
+ GHC.Builtin.PrimOps: WriteOffAddrOp_Word8AsWord32 :: PrimOp
+ GHC.Builtin.PrimOps: WriteOffAddrOp_Word8AsWord64 :: PrimOp
+ GHC.Builtin.PrimOps: data PrimOpEffect
+ GHC.Builtin.PrimOps: instance GHC.Classes.Eq GHC.Builtin.PrimOps.PrimOpEffect
+ GHC.Builtin.PrimOps: instance GHC.Classes.Ord GHC.Builtin.PrimOps.PrimOpEffect
+ GHC.Builtin.PrimOps: primOpEffect :: PrimOp -> PrimOpEffect
+ GHC.Builtin.PrimOps: primOpIsWorkFree :: PrimOp -> Bool
+ GHC.Builtin.PrimOps: primOpOkToDiscard :: PrimOp -> Bool
+ GHC.Builtin.Types: isSumTyOcc_maybe :: Module -> OccName -> Maybe Name
+ GHC.Builtin.Types: pretendNameIsInScope :: Name -> Bool
+ GHC.Builtin.Uniques: isSumTyConUnique :: Unique -> Maybe Arity
+ GHC.Builtin.Uniques: isTupleDataConLikeUnique :: Unique -> Maybe (Boxity, Arity)
+ GHC.Cmm.CLabel: mkOrigThunkInfoLabel :: CLabel
+ GHC.Cmm.Dataflow.Label: mapAdjust :: (v -> v) -> Label -> LabelMap v -> LabelMap v
+ GHC.Cmm.Dataflow.Label: mapAlter :: (Maybe v -> Maybe v) -> Label -> LabelMap v -> LabelMap v
+ GHC.Cmm.Dataflow.Label: mapDelete :: Label -> LabelMap v -> LabelMap v
+ GHC.Cmm.Dataflow.Label: mapDifference :: LabelMap v -> LabelMap b -> LabelMap v
+ GHC.Cmm.Dataflow.Label: mapElems :: LabelMap a -> [a]
+ GHC.Cmm.Dataflow.Label: mapEmpty :: LabelMap v
+ GHC.Cmm.Dataflow.Label: mapFilter :: (v -> Bool) -> LabelMap v -> LabelMap v
+ GHC.Cmm.Dataflow.Label: mapFilterWithKey :: (Label -> v -> Bool) -> LabelMap v -> LabelMap v
+ GHC.Cmm.Dataflow.Label: mapFindWithDefault :: a -> Label -> LabelMap a -> a
+ GHC.Cmm.Dataflow.Label: mapFoldMapWithKey :: Monoid m => (Label -> t -> m) -> LabelMap t -> m
+ GHC.Cmm.Dataflow.Label: mapFoldl :: (a -> b -> a) -> a -> LabelMap b -> a
+ GHC.Cmm.Dataflow.Label: mapFoldlWithKey :: (t -> Label -> b -> t) -> t -> LabelMap b -> t
+ GHC.Cmm.Dataflow.Label: mapFoldr :: (a -> b -> b) -> b -> LabelMap a -> b
+ GHC.Cmm.Dataflow.Label: mapFromList :: [(Label, v)] -> LabelMap v
+ GHC.Cmm.Dataflow.Label: mapFromListWith :: (v -> v -> v) -> [(Label, v)] -> LabelMap v
+ GHC.Cmm.Dataflow.Label: mapInsert :: Label -> v -> LabelMap v -> LabelMap v
+ GHC.Cmm.Dataflow.Label: mapInsertWith :: (v -> v -> v) -> Label -> v -> LabelMap v -> LabelMap v
+ GHC.Cmm.Dataflow.Label: mapIntersection :: LabelMap v -> LabelMap b -> LabelMap v
+ GHC.Cmm.Dataflow.Label: mapIsSubmapOf :: Eq a => LabelMap a -> LabelMap a -> Bool
+ GHC.Cmm.Dataflow.Label: mapKeys :: LabelMap a -> [Label]
+ GHC.Cmm.Dataflow.Label: mapLookup :: Label -> LabelMap a -> Maybe a
+ GHC.Cmm.Dataflow.Label: mapMap :: (a -> v) -> LabelMap a -> LabelMap v
+ GHC.Cmm.Dataflow.Label: mapMapWithKey :: (Label -> a -> v) -> LabelMap a -> LabelMap v
+ GHC.Cmm.Dataflow.Label: mapMember :: Label -> LabelMap a -> Bool
+ GHC.Cmm.Dataflow.Label: mapNull :: LabelMap a -> Bool
+ GHC.Cmm.Dataflow.Label: mapSingleton :: Label -> v -> LabelMap v
+ GHC.Cmm.Dataflow.Label: mapSize :: LabelMap a -> Int
+ GHC.Cmm.Dataflow.Label: mapToList :: LabelMap b -> [(Label, b)]
+ GHC.Cmm.Dataflow.Label: mapUnion :: LabelMap v -> LabelMap v -> LabelMap v
+ GHC.Cmm.Dataflow.Label: mapUnionWithKey :: (Label -> v -> v -> v) -> LabelMap v -> LabelMap v -> LabelMap v
+ GHC.Cmm.Dataflow.Label: mapUnions :: [LabelMap a] -> LabelMap a
+ GHC.Cmm.Dataflow.Label: setDelete :: Label -> LabelSet -> LabelSet
+ GHC.Cmm.Dataflow.Label: setDifference :: LabelSet -> LabelSet -> LabelSet
+ GHC.Cmm.Dataflow.Label: setElems :: LabelSet -> [Label]
+ GHC.Cmm.Dataflow.Label: setEmpty :: LabelSet
+ GHC.Cmm.Dataflow.Label: setFilter :: (Label -> Bool) -> LabelSet -> LabelSet
+ GHC.Cmm.Dataflow.Label: setFoldl :: (t -> Label -> t) -> t -> LabelSet -> t
+ GHC.Cmm.Dataflow.Label: setFoldr :: (Label -> t -> t) -> t -> LabelSet -> t
+ GHC.Cmm.Dataflow.Label: setFromList :: [Label] -> LabelSet
+ GHC.Cmm.Dataflow.Label: setInsert :: Label -> LabelSet -> LabelSet
+ GHC.Cmm.Dataflow.Label: setIntersection :: LabelSet -> LabelSet -> LabelSet
+ GHC.Cmm.Dataflow.Label: setIsSubsetOf :: LabelSet -> LabelSet -> Bool
+ GHC.Cmm.Dataflow.Label: setMember :: Label -> LabelSet -> Bool
+ GHC.Cmm.Dataflow.Label: setNull :: LabelSet -> Bool
+ GHC.Cmm.Dataflow.Label: setSingleton :: Label -> LabelSet
+ GHC.Cmm.Dataflow.Label: setSize :: LabelSet -> Int
+ GHC.Cmm.Dataflow.Label: setUnion :: LabelSet -> LabelSet -> LabelSet
+ GHC.Cmm.Dataflow.Label: setUnions :: [LabelSet] -> LabelSet
+ GHC.Cmm.MachOp: MO_AcquireFence :: CallishMachOp
+ GHC.Cmm.MachOp: MO_RelaxedRead :: Width -> MachOp
+ GHC.Cmm.MachOp: MO_ReleaseFence :: CallishMachOp
+ GHC.Cmm.MachOp: MO_SeqCstFence :: CallishMachOp
+ GHC.CmmToLlvm.Config: [llvmCgAvxEnabled] :: LlvmCgConfig -> !Bool
+ GHC.CmmToLlvm.Version.Type: LlvmVersion :: NonEmpty Int -> LlvmVersion
+ GHC.CmmToLlvm.Version.Type: [llvmVersionNE] :: LlvmVersion -> NonEmpty Int
+ GHC.CmmToLlvm.Version.Type: instance GHC.Classes.Eq GHC.CmmToLlvm.Version.Type.LlvmVersion
+ GHC.CmmToLlvm.Version.Type: instance GHC.Classes.Ord GHC.CmmToLlvm.Version.Type.LlvmVersion
+ GHC.CmmToLlvm.Version.Type: newtype LlvmVersion
+ GHC.Core: mkBinds :: RecFlag -> [(b, Expr b)] -> [Bind b]
+ GHC.Core: mkWord32LitWord32 :: Word32 -> Expr b
+ GHC.Core.Coercion: extendLiftingContextCvSubst :: LiftingContext -> CoVar -> Coercion -> LiftingContext
+ GHC.Core.Coercion: lcLookupCoVar :: LiftingContext -> CoVar -> Maybe Coercion
+ GHC.Core.Coercion: mkNakedForAllCo :: TyVar -> ForAllTyFlag -> ForAllTyFlag -> CoercionN -> Coercion -> Coercion
+ GHC.Core.DataCon: dataConConcreteTyVars :: DataCon -> ConcreteTyVars
+ GHC.Core.InstEnv: [is_warn] :: ClsInst -> Maybe (WarningTxt GhcRn)
+ GHC.Core.InstEnv: instanceWarning :: ClsInst -> Maybe (WarningTxt GhcRn)
+ GHC.Core.InstEnv: pprDFunId :: DFunId -> SDoc
+ GHC.Core.Opt.OccurAnal: instance GHC.Utils.Outputable.Outputable GHC.Core.Opt.OccurAnal.LocalOcc
+ GHC.Core.Predicate: isExceptionContextPred :: Class -> [Type] -> Maybe FastString
+ GHC.Core.Rules: matchExprs :: InScopeEnv -> [Var] -> [CoreExpr] -> [CoreExpr] -> Maybe (BindWrapper, [CoreExpr])
+ GHC.Core.Subst: mkTCvSubst :: InScopeSet -> TvSubstEnv -> CvSubstEnv -> Subst
+ GHC.Core.TyCo.Rep: [fco_body] :: Coercion -> Coercion
+ GHC.Core.TyCo.Rep: [fco_kind] :: Coercion -> KindCoercion
+ GHC.Core.TyCo.Rep: [fco_tcv] :: Coercion -> TyCoVar
+ GHC.Core.TyCo.Rep: [fco_visL] :: Coercion -> !ForAllTyFlag
+ GHC.Core.TyCo.Rep: [fco_visR] :: Coercion -> !ForAllTyFlag
+ GHC.Core.TyCo.Rep: tcMkScaledFunTy :: Scaled Type -> Type -> Type
+ GHC.Core.TyCo.Subst: mkTCvSubst :: InScopeSet -> TvSubstEnv -> CvSubstEnv -> Subst
+ GHC.Core.TyCon: NVRep :: PrimRep -> PrimOrVoidRep
+ GHC.Core.TyCon: data PrimOrVoidRep
+ GHC.Core.TyCon: isKindName :: Name -> Bool
+ GHC.Core.TyCon: isValidDTT2TyCon :: TyCon -> Bool
+ GHC.Core.TyCon: primElemRepSizeW64_B :: PrimElemRep -> Int
+ GHC.Core.TyCon: primRepSizeW64_B :: PrimRep -> Int
+ GHC.Core.Type: deepUserTypeError_maybe :: Type -> Maybe ErrorMsgType
+ GHC.Core.Type: mkTCvSubst :: InScopeSet -> TvSubstEnv -> CvSubstEnv -> Subst
+ GHC.Core.Type: mkTyCoForAllTy :: TyCoVar -> ForAllTyFlag -> Type -> Type
+ GHC.Core.Type: mkTyCoForAllTys :: [ForAllTyBinder] -> Type -> Type
+ GHC.Core.Type: splitForAllForAllTyBinder_maybe :: Type -> Maybe (ForAllTyBinder, Type)
+ GHC.Core.Type: typeLevity :: HasDebugCallStack => Type -> Levity
+ GHC.Core.Utils: exprOkToDiscard :: CoreExpr -> Bool
+ GHC.Core.Utils: isUnsafeEqualityCase :: CoreExpr -> Id -> [CoreAlt] -> Maybe CoreExpr
+ GHC.Core.Utils: needsCaseBindingL :: Levity -> CoreExpr -> Bool
+ GHC.Data.EnumSet: instance forall k (a :: k). Control.DeepSeq.NFData (GHC.Data.EnumSet.EnumSet a)
+ GHC.Data.EnumSet: instance forall k (a :: k). GHC.Base.Monoid (GHC.Data.EnumSet.EnumSet a)
+ GHC.Data.EnumSet: instance forall k (a :: k). GHC.Base.Semigroup (GHC.Data.EnumSet.EnumSet a)
+ GHC.Data.EnumSet: instance forall k (a :: k). GHC.Utils.Binary.Binary (GHC.Data.EnumSet.EnumSet a)
+ GHC.Data.OrdList: partitionOL :: (a -> Bool) -> OrdList a -> (OrdList a, OrdList a)
+ GHC.Driver.DynFlags: GHC2024 :: Language
+ GHC.Driver.DynFlags: Opt_D_dump_dmd_signatures :: DumpFlag
+ GHC.Driver.DynFlags: Opt_D_dump_dmdanal :: DumpFlag
+ GHC.Driver.DynFlags: Opt_DiagnosticsAsJSON :: GeneralFlag
+ GHC.Driver.DynFlags: Opt_DisableJsCsources :: GeneralFlag
+ GHC.Driver.DynFlags: Opt_DoCleverArgEtaExpansion :: GeneralFlag
+ GHC.Driver.DynFlags: Opt_KeepAutoRules :: GeneralFlag
+ GHC.Driver.DynFlags: Opt_OrigThunkInfo :: GeneralFlag
+ GHC.Driver.DynFlags: Opt_ProfLateOverloadedCcs :: GeneralFlag
+ GHC.Driver.DynFlags: Opt_ProfLateoverloadedCallsCCs :: GeneralFlag
+ GHC.Driver.DynFlags: Opt_WarnBadlyStagedTypes :: WarningFlag
+ GHC.Driver.DynFlags: Opt_WarnDataKindsTC :: WarningFlag
+ GHC.Driver.DynFlags: Opt_WarnDefaultedExceptionContext :: WarningFlag
+ GHC.Driver.DynFlags: Opt_WarnDeprecatedTypeAbstractions :: WarningFlag
+ GHC.Driver.DynFlags: Opt_WarnIncompleteRecordSelectors :: WarningFlag
+ GHC.Driver.DynFlags: [canUseErrorLinks] :: DynFlags -> Bool
+ GHC.Driver.DynFlags: [useErrorLinks] :: DynFlags -> OverridingBool
+ GHC.Driver.DynFlags: isAvx2Enabled :: DynFlags -> Bool
+ GHC.Driver.DynFlags: isAvx512cdEnabled :: DynFlags -> Bool
+ GHC.Driver.DynFlags: isAvx512erEnabled :: DynFlags -> Bool
+ GHC.Driver.DynFlags: isAvx512fEnabled :: DynFlags -> Bool
+ GHC.Driver.DynFlags: isAvx512pfEnabled :: DynFlags -> Bool
+ GHC.Driver.DynFlags: isAvxEnabled :: DynFlags -> Bool
+ GHC.Driver.DynFlags: isBmi2Enabled :: DynFlags -> Bool
+ GHC.Driver.DynFlags: isBmiEnabled :: DynFlags -> Bool
+ GHC.Driver.DynFlags: isFmaEnabled :: DynFlags -> Bool
+ GHC.Driver.DynFlags: isSse4_2Enabled :: DynFlags -> Bool
+ GHC.Driver.Flags: GHC2024 :: Language
+ GHC.Driver.Flags: Opt_D_dump_dmd_signatures :: DumpFlag
+ GHC.Driver.Flags: Opt_D_dump_dmdanal :: DumpFlag
+ GHC.Driver.Flags: Opt_DiagnosticsAsJSON :: GeneralFlag
+ GHC.Driver.Flags: Opt_DisableJsCsources :: GeneralFlag
+ GHC.Driver.Flags: Opt_DoCleverArgEtaExpansion :: GeneralFlag
+ GHC.Driver.Flags: Opt_KeepAutoRules :: GeneralFlag
+ GHC.Driver.Flags: Opt_OrigThunkInfo :: GeneralFlag
+ GHC.Driver.Flags: Opt_ProfLateOverloadedCcs :: GeneralFlag
+ GHC.Driver.Flags: Opt_ProfLateoverloadedCallsCCs :: GeneralFlag
+ GHC.Driver.Flags: Opt_WarnBadlyStagedTypes :: WarningFlag
+ GHC.Driver.Flags: Opt_WarnDataKindsTC :: WarningFlag
+ GHC.Driver.Flags: Opt_WarnDefaultedExceptionContext :: WarningFlag
+ GHC.Driver.Flags: Opt_WarnDeprecatedTypeAbstractions :: WarningFlag
+ GHC.Driver.Flags: Opt_WarnIncompleteRecordSelectors :: WarningFlag
+ GHC.Driver.Flags: defaultLanguage :: Language
+ GHC.Driver.Monad: popJsonLogHookM :: GhcMonad m => m ()
+ GHC.Driver.Monad: pushJsonLogHookM :: GhcMonad m => (LogJsonAction -> LogJsonAction) -> m ()
+ GHC.Driver.Pipeline.Phases: [T_LlvmAs] :: Bool -> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> TPhase FilePath
+ GHC.Driver.Plugins: [latePlugin] :: Plugin -> LatePlugin
+ GHC.Driver.Plugins: type LatePlugin = HscEnv -> [CommandLineOption] -> (CgGuts, CostCentreState) -> IO (CgGuts, CostCentreState)
+ GHC.Driver.Session: GHC2024 :: Language
+ GHC.Driver.Session: Opt_D_dump_dmd_signatures :: DumpFlag
+ GHC.Driver.Session: Opt_D_dump_dmdanal :: DumpFlag
+ GHC.Driver.Session: Opt_DiagnosticsAsJSON :: GeneralFlag
+ GHC.Driver.Session: Opt_DisableJsCsources :: GeneralFlag
+ GHC.Driver.Session: Opt_DoCleverArgEtaExpansion :: GeneralFlag
+ GHC.Driver.Session: Opt_KeepAutoRules :: GeneralFlag
+ GHC.Driver.Session: Opt_OrigThunkInfo :: GeneralFlag
+ GHC.Driver.Session: Opt_ProfLateOverloadedCcs :: GeneralFlag
+ GHC.Driver.Session: Opt_ProfLateoverloadedCallsCCs :: GeneralFlag
+ GHC.Driver.Session: Opt_WarnBadlyStagedTypes :: WarningFlag
+ GHC.Driver.Session: Opt_WarnDataKindsTC :: WarningFlag
+ GHC.Driver.Session: Opt_WarnDefaultedExceptionContext :: WarningFlag
+ GHC.Driver.Session: Opt_WarnDeprecatedTypeAbstractions :: WarningFlag
+ GHC.Driver.Session: Opt_WarnIncompleteRecordSelectors :: WarningFlag
+ GHC.Driver.Session: [canUseErrorLinks] :: DynFlags -> Bool
+ GHC.Driver.Session: [useErrorLinks] :: DynFlags -> OverridingBool
+ GHC.Driver.Session: opt_las :: DynFlags -> [String]
+ GHC.Driver.Session: pgm_cpp :: DynFlags -> (String, [Option])
+ GHC.Driver.Session: pgm_las :: DynFlags -> (String, [Option])
+ GHC.Driver.Session: sPgm_cpp :: Settings -> (String, [Option])
+ GHC.Driver.Session: sPgm_las :: Settings -> (String, [Option])
+ GHC.Exts.Heap: UnknownTypeWordSizedPrimitive :: !Word -> GenClosure b
+ GHC.Exts.Heap.Closures: AtomicallyFrame :: !StgInfoTable -> !b -> !b -> GenStackFrame b
+ GHC.Exts.Heap.Closures: CatchFrame :: !StgInfoTable -> !b -> GenStackFrame b
+ GHC.Exts.Heap.Closures: CatchRetryFrame :: !StgInfoTable -> !Word -> !b -> !b -> GenStackFrame b
+ GHC.Exts.Heap.Closures: CatchStmFrame :: !StgInfoTable -> !b -> !b -> GenStackFrame b
+ GHC.Exts.Heap.Closures: GenStgStackClosure :: !StgInfoTable -> !Word32 -> ![GenStackFrame b] -> GenStgStackClosure b
+ GHC.Exts.Heap.Closures: RetBCO :: !StgInfoTable -> !b -> ![GenStackField b] -> GenStackFrame b
+ GHC.Exts.Heap.Closures: RetBig :: !StgInfoTable -> ![GenStackField b] -> GenStackFrame b
+ GHC.Exts.Heap.Closures: RetFun :: !StgInfoTable -> !Word -> !b -> ![GenStackField b] -> GenStackFrame b
+ GHC.Exts.Heap.Closures: RetSmall :: !StgInfoTable -> ![GenStackField b] -> GenStackFrame b
+ GHC.Exts.Heap.Closures: StackBox :: !b -> GenStackField b
+ GHC.Exts.Heap.Closures: StackWord :: !Word -> GenStackField b
+ GHC.Exts.Heap.Closures: StopFrame :: !StgInfoTable -> GenStackFrame b
+ GHC.Exts.Heap.Closures: UnderflowFrame :: !StgInfoTable -> !GenStgStackClosure b -> GenStackFrame b
+ GHC.Exts.Heap.Closures: UnknownTypeWordSizedPrimitive :: !Word -> GenClosure b
+ GHC.Exts.Heap.Closures: UpdateFrame :: !StgInfoTable -> !b -> GenStackFrame b
+ GHC.Exts.Heap.Closures: [alt_code] :: GenStackFrame b -> !b
+ GHC.Exts.Heap.Closures: [atomicallyFrameCode] :: GenStackFrame b -> !b
+ GHC.Exts.Heap.Closures: [bcoArgs] :: GenStackFrame b -> ![GenStackField b]
+ GHC.Exts.Heap.Closures: [bco] :: GenStackFrame b -> !b
+ GHC.Exts.Heap.Closures: [catchFrameCode] :: GenStackFrame b -> !b
+ GHC.Exts.Heap.Closures: [first_code] :: GenStackFrame b -> !b
+ GHC.Exts.Heap.Closures: [handler] :: GenStackFrame b -> !b
+ GHC.Exts.Heap.Closures: [info_tbl] :: GenStackFrame b -> !StgInfoTable
+ GHC.Exts.Heap.Closures: [nextChunk] :: GenStackFrame b -> !GenStgStackClosure b
+ GHC.Exts.Heap.Closures: [result] :: GenStackFrame b -> !b
+ GHC.Exts.Heap.Closures: [retFunFun] :: GenStackFrame b -> !b
+ GHC.Exts.Heap.Closures: [retFunPayload] :: GenStackFrame b -> ![GenStackField b]
+ GHC.Exts.Heap.Closures: [retFunSize] :: GenStackFrame b -> !Word
+ GHC.Exts.Heap.Closures: [running_alt_code] :: GenStackFrame b -> !Word
+ GHC.Exts.Heap.Closures: [ssc_info] :: GenStgStackClosure b -> !StgInfoTable
+ GHC.Exts.Heap.Closures: [ssc_stack] :: GenStgStackClosure b -> ![GenStackFrame b]
+ GHC.Exts.Heap.Closures: [ssc_stack_size] :: GenStgStackClosure b -> !Word32
+ GHC.Exts.Heap.Closures: [stack_payload] :: GenStackFrame b -> ![GenStackField b]
+ GHC.Exts.Heap.Closures: [updatee] :: GenStackFrame b -> !b
+ GHC.Exts.Heap.Closures: data GenStackField b
+ GHC.Exts.Heap.Closures: data GenStackFrame b
+ GHC.Exts.Heap.Closures: data GenStgStackClosure b
+ GHC.Exts.Heap.Closures: instance Data.Foldable.Foldable GHC.Exts.Heap.Closures.GenStackField
+ GHC.Exts.Heap.Closures: instance Data.Foldable.Foldable GHC.Exts.Heap.Closures.GenStackFrame
+ GHC.Exts.Heap.Closures: instance Data.Foldable.Foldable GHC.Exts.Heap.Closures.GenStgStackClosure
+ GHC.Exts.Heap.Closures: instance Data.Traversable.Traversable GHC.Exts.Heap.Closures.GenStackField
+ GHC.Exts.Heap.Closures: instance Data.Traversable.Traversable GHC.Exts.Heap.Closures.GenStackFrame
+ GHC.Exts.Heap.Closures: instance Data.Traversable.Traversable GHC.Exts.Heap.Closures.GenStgStackClosure
+ GHC.Exts.Heap.Closures: instance GHC.Base.Functor GHC.Exts.Heap.Closures.GenStackField
+ GHC.Exts.Heap.Closures: instance GHC.Base.Functor GHC.Exts.Heap.Closures.GenStackFrame
+ GHC.Exts.Heap.Closures: instance GHC.Base.Functor GHC.Exts.Heap.Closures.GenStgStackClosure
+ GHC.Exts.Heap.Closures: instance GHC.Generics.Generic (GHC.Exts.Heap.Closures.GenStackField b)
+ GHC.Exts.Heap.Closures: instance GHC.Generics.Generic (GHC.Exts.Heap.Closures.GenStackFrame b)
+ GHC.Exts.Heap.Closures: instance GHC.Generics.Generic (GHC.Exts.Heap.Closures.GenStgStackClosure b)
+ GHC.Exts.Heap.Closures: instance GHC.Show.Show b => GHC.Show.Show (GHC.Exts.Heap.Closures.GenStackField b)
+ GHC.Exts.Heap.Closures: instance GHC.Show.Show b => GHC.Show.Show (GHC.Exts.Heap.Closures.GenStackFrame b)
+ GHC.Exts.Heap.Closures: instance GHC.Show.Show b => GHC.Show.Show (GHC.Exts.Heap.Closures.GenStgStackClosure b)
+ GHC.Exts.Heap.Closures: type StackField = GenStackField Box
+ GHC.Exts.Heap.Closures: type StackFrame = GenStackFrame Box
+ GHC.Exts.Heap.Closures: type StgStackClosure = GenStgStackClosure Box
+ GHC.Exts.Heap.InfoTable.Types: instance GHC.Classes.Eq GHC.Exts.Heap.InfoTable.Types.StgInfoTable
+ GHC.Hs: [am_cs] :: AnnsModule -> [LEpaComment]
+ GHC.Hs: instance GHC.Parser.Annotation.NoAnn GHC.Hs.AnnsModule
+ GHC.Hs.Binds: DataNamespaceSpecifier :: EpToken "data" -> NamespaceSpecifier
+ GHC.Hs.Binds: NoNamespaceSpecifier :: NamespaceSpecifier
+ GHC.Hs.Binds: TypeNamespaceSpecifier :: EpToken "type" -> NamespaceSpecifier
+ GHC.Hs.Binds: coveredByNamespaceSpecifier :: NamespaceSpecifier -> NameSpace -> Bool
+ GHC.Hs.Binds: data NamespaceSpecifier
+ GHC.Hs.Binds: getTcMultAnn :: HsMultAnn GhcTc -> Mult
+ GHC.Hs.Binds: instance Data.Data.Data GHC.Hs.Binds.NamespaceSpecifier
+ GHC.Hs.Binds: instance GHC.Classes.Eq GHC.Hs.Binds.NamespaceSpecifier
+ GHC.Hs.Binds: instance GHC.Parser.Annotation.NoAnn GHC.Hs.Binds.AnnSig
+ GHC.Hs.Binds: instance GHC.Utils.Outputable.Outputable GHC.Hs.Binds.NamespaceSpecifier
+ GHC.Hs.Binds: overlappingNamespaceSpecifiers :: NamespaceSpecifier -> NamespaceSpecifier -> Bool
+ GHC.Hs.Binds: pprHsMultAnn :: forall id. OutputableBndrId id => HsMultAnn (GhcPass id) -> SDoc
+ GHC.Hs.Binds: setTcMultAnn :: Mult -> HsMultAnn GhcRn -> HsMultAnn GhcTc
+ GHC.Hs.Decls: XConDeclGADTDetails :: !XXConDeclGADTDetails pass -> HsConDeclGADTDetails pass
+ GHC.Hs.Decls: instance GHC.Parser.Annotation.NoAnn GHC.Hs.Decls.HsRuleAnn
+ GHC.Hs.Decls: type HsFamEqnPats pass = [LHsTypeArg pass]
+ GHC.Hs.Doc: [docs_exports] :: Docs -> UniqMap Name (HsDoc GhcRn)
+ GHC.Hs.DocString: printDecorator :: HsDocStringDecorator -> String
+ GHC.Hs.Expr: ExpandedThingRn :: HsThingRn -> HsExpr GhcRn -> XXExprGhcRn
+ GHC.Hs.Expr: ExpandedThingTc :: HsThingRn -> HsExpr GhcTc -> XXExprGhcTc
+ GHC.Hs.Expr: OrigExpr :: HsExpr GhcRn -> HsThingRn
+ GHC.Hs.Expr: OrigPat :: LPat GhcRn -> HsThingRn
+ GHC.Hs.Expr: OrigStmt :: ExprLStmt GhcRn -> HsThingRn
+ GHC.Hs.Expr: PopErrCtxt :: {-# UNPACK #-} !LHsExpr GhcRn -> XXExprGhcRn
+ GHC.Hs.Expr: [xrn_expanded] :: XXExprGhcRn -> HsExpr GhcRn
+ GHC.Hs.Expr: [xrn_orig] :: XXExprGhcRn -> HsThingRn
+ GHC.Hs.Expr: [xtc_expanded] :: XXExprGhcTc -> HsExpr GhcTc
+ GHC.Hs.Expr: [xtc_orig] :: XXExprGhcTc -> HsThingRn
+ GHC.Hs.Expr: data HsThingRn
+ GHC.Hs.Expr: data XXExprGhcRn
+ GHC.Hs.Expr: instance GHC.Parser.Annotation.HasAnnotation (Language.Haskell.Syntax.Extension.Anno a) => Language.Haskell.Syntax.Extension.WrapXRec (GHC.Hs.Extension.GhcPass p) a
+ GHC.Hs.Expr: instance GHC.Parser.Annotation.NoAnn GHC.Hs.Expr.AnnExplicitSum
+ GHC.Hs.Expr: instance GHC.Parser.Annotation.NoAnn GHC.Hs.Expr.AnnFieldLabel
+ GHC.Hs.Expr: instance GHC.Parser.Annotation.NoAnn GHC.Hs.Expr.AnnProjection
+ GHC.Hs.Expr: instance GHC.Parser.Annotation.NoAnn GHC.Hs.Expr.AnnsIf
+ GHC.Hs.Expr: instance GHC.Parser.Annotation.NoAnn GHC.Hs.Expr.EpAnnHsCase
+ GHC.Hs.Expr: instance GHC.Parser.Annotation.NoAnn GHC.Hs.Expr.GrhsAnn
+ GHC.Hs.Expr: instance GHC.Utils.Outputable.Outputable GHC.Hs.Expr.HsThingRn
+ GHC.Hs.Expr: instance GHC.Utils.Outputable.Outputable GHC.Hs.Expr.XXExprGhcRn
+ GHC.Hs.Expr: instance GHC.Utils.Outputable.Outputable Language.Haskell.Syntax.Expr.HsLamVariant
+ GHC.Hs.Expr: instance GHC.Utils.Outputable.Outputable fn => GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Expr.HsMatchContext fn)
+ GHC.Hs.Expr: instance GHC.Utils.Outputable.Outputable fn => GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Expr.HsStmtContext fn)
+ GHC.Hs.Expr: isHsThingRnExpr :: HsThingRn -> Bool
+ GHC.Hs.Expr: isHsThingRnPat :: HsThingRn -> Bool
+ GHC.Hs.Expr: isHsThingRnStmt :: HsThingRn -> Bool
+ GHC.Hs.Expr: mkExpandedExpr :: HsExpr GhcRn -> HsExpr GhcRn -> HsExpr GhcRn
+ GHC.Hs.Expr: mkExpandedExprTc :: HsExpr GhcRn -> HsExpr GhcTc -> HsExpr GhcTc
+ GHC.Hs.Expr: mkExpandedPatRn :: LPat GhcRn -> HsExpr GhcRn -> HsExpr GhcRn
+ GHC.Hs.Expr: mkExpandedStmt :: ExprLStmt GhcRn -> HsExpr GhcRn -> HsExpr GhcRn
+ GHC.Hs.Expr: mkExpandedStmtAt :: SrcSpanAnnA -> ExprLStmt GhcRn -> HsExpr GhcRn -> LHsExpr GhcRn
+ GHC.Hs.Expr: mkExpandedStmtPopAt :: SrcSpanAnnA -> ExprLStmt GhcRn -> HsExpr GhcRn -> LHsExpr GhcRn
+ GHC.Hs.Expr: mkExpandedStmtTc :: ExprLStmt GhcRn -> HsExpr GhcTc -> HsExpr GhcTc
+ GHC.Hs.Expr: mkPopErrCtxtExpr :: LHsExpr GhcRn -> HsExpr GhcRn
+ GHC.Hs.Expr: mkPopErrCtxtExprAt :: SrcSpanAnnA -> LHsExpr GhcRn -> LHsExpr GhcRn
+ GHC.Hs.Expr: ppr_infix_hs_expansion :: HsThingRn -> Maybe SDoc
+ GHC.Hs.Expr: tupArgPresent_maybe :: HsTupArg (GhcPass p) -> Maybe (LHsExpr (GhcPass p))
+ GHC.Hs.Expr: tupArgsPresent_maybe :: [HsTupArg (GhcPass p)] -> Maybe [LHsExpr (GhcPass p)]
+ GHC.Hs.Expr: type HsMatchContextPs = HsMatchContext (LIdP GhcPs)
+ GHC.Hs.Expr: type HsMatchContextRn = HsMatchContext (LIdP GhcRn)
+ GHC.Hs.Expr: type HsStmtContextRn = HsStmtContext (LIdP GhcRn)
+ GHC.Hs.ImpExp: exportDocstring :: LHsDoc pass -> SDoc
+ GHC.Hs.ImpExp: instance GHC.Parser.Annotation.NoAnn GHC.Hs.ImpExp.EpAnnImportDecl
+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Binds.HsMultAnn GHC.Hs.Extension.GhcPs)
+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Binds.HsMultAnn GHC.Hs.Extension.GhcRn)
+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Binds.HsMultAnn GHC.Hs.Extension.GhcTc)
+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Type.HsTyPat GHC.Hs.Extension.GhcPs)
+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Type.HsTyPat GHC.Hs.Extension.GhcRn)
+ GHC.Hs.Instances: instance Data.Data.Data (Language.Haskell.Syntax.Type.HsTyPat GHC.Hs.Extension.GhcTc)
+ GHC.Hs.Instances: instance Data.Data.Data GHC.Hs.Expr.HsThingRn
+ GHC.Hs.Instances: instance Data.Data.Data GHC.Hs.Expr.XXExprGhcRn
+ GHC.Hs.Instances: instance Data.Data.Data fn => Data.Data.Data (Language.Haskell.Syntax.Expr.HsMatchContext fn)
+ GHC.Hs.Instances: instance Data.Data.Data fn => Data.Data.Data (Language.Haskell.Syntax.Expr.HsStmtContext fn)
+ GHC.Hs.Pat: EmbTyPat :: XEmbTyPat p -> HsTyPat (NoGhcTc p) -> Pat p
+ GHC.Hs.Pat: InvisPat :: XInvisPat p -> HsTyPat (NoGhcTc p) -> Pat p
+ GHC.Hs.Pat: hsConPatTyArgs :: forall p. HsConPatDetails p -> [HsConPatTyArg (NoGhcTc p)]
+ GHC.Hs.Pat: instance (GHC.Utils.Outputable.Outputable arg, GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Extension.XRec p (Language.Haskell.Syntax.Pat.HsRecField p arg)), Language.Haskell.Syntax.Extension.XRec p Language.Haskell.Syntax.Pat.RecFieldsDotDot GHC.Types.~ GHC.Parser.Annotation.LocatedE Language.Haskell.Syntax.Pat.RecFieldsDotDot) => GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Pat.HsRecFields p arg)
+ GHC.Hs.Pat: instance GHC.Parser.Annotation.NoAnn GHC.Hs.Pat.EpAnnSumPat
+ GHC.Hs.Pat: instance GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Type.HsTyPat p) => GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Pat.HsConPatTyArg p)
+ GHC.Hs.Pat: isInvisArgPat :: Pat p -> Bool
+ GHC.Hs.Pat: isIrrefutableHsPatHelper :: forall p. OutputableBndrId p => Bool -> LPat (GhcPass p) -> Bool
+ GHC.Hs.Pat: isIrrefutableHsPatHelperM :: forall m p. (Monad m, OutputableBndrId p) => LPatIrrefutableCheck m (GhcPass p)
+ GHC.Hs.Pat: isPatSyn :: LPat GhcTc -> Bool
+ GHC.Hs.Pat: isVisArgPat :: Pat p -> Bool
+ GHC.Hs.Type: EpLolly :: !EpToken "⊸" -> EpLinearArrow
+ GHC.Hs.Type: EpPct1 :: !EpToken "%1" -> !EpUniToken "->" "→" -> EpLinearArrow
+ GHC.Hs.Type: HsTP :: XHsTP pass -> LHsType pass -> HsTyPat pass
+ GHC.Hs.Type: HsTPRn :: [Name] -> [Name] -> [Name] -> HsTyPatRn
+ GHC.Hs.Type: XArg :: !XXArg p -> HsArg p tm ty
+ GHC.Hs.Type: XArrow :: !XXArrow pass -> HsArrow pass
+ GHC.Hs.Type: XHsTyPat :: !XXHsTyPat pass -> HsTyPat pass
+ GHC.Hs.Type: XXBndrVis :: !XXBndrVis pass -> HsBndrVis pass
+ GHC.Hs.Type: [hstp_body] :: HsTyPat pass -> LHsType pass
+ GHC.Hs.Type: [hstp_exp_tvs] :: HsTyPatRn -> [Name]
+ GHC.Hs.Type: [hstp_ext] :: HsTyPat pass -> XHsTP pass
+ GHC.Hs.Type: [hstp_imp_tvs] :: HsTyPatRn -> [Name]
+ GHC.Hs.Type: [hstp_nwcs] :: HsTyPatRn -> [Name]
+ GHC.Hs.Type: data EpLinearArrow
+ GHC.Hs.Type: data HsTyPat pass
+ GHC.Hs.Type: data HsTyPatRn
+ GHC.Hs.Type: hsForAllTelescopeNames :: HsForAllTelescope (GhcPass p) -> [IdP (GhcPass p)]
+ GHC.Hs.Type: instance Data.Data.Data GHC.Hs.Type.EpLinearArrow
+ GHC.Hs.Type: instance Data.Data.Data GHC.Hs.Type.HsTyPatRn
+ GHC.Hs.Type: instance GHC.Hs.Extension.OutputableBndrId p => GHC.Utils.Outputable.Outputable (Language.Haskell.Syntax.Type.HsTyPat (GHC.Hs.Extension.GhcPass p))
+ GHC.Hs.Type: instance GHC.Hs.Type.OutputableBndrFlag (Language.Haskell.Syntax.Type.HsBndrVis (GHC.Hs.Extension.GhcPass p')) p
+ GHC.Hs.Type: instance GHC.Parser.Annotation.NoAnn GHC.Hs.Type.EpLinearArrow
+ GHC.Hs.Type: mkHsTyPat :: LHsType GhcPs -> HsTyPat GhcPs
+ GHC.Hs.Utils: ImplicitFieldBinders :: Name -> [Name] -> ImplicitFieldBinders
+ GHC.Hs.Utils: [CollVarTyVarBinders] :: CollectFlag GhcRn
+ GHC.Hs.Utils: [implFlBndr_binders] :: ImplicitFieldBinders -> [Name]
+ GHC.Hs.Utils: [implFlBndr_field] :: ImplicitFieldBinders -> Name
+ GHC.Hs.Utils: data ImplicitFieldBinders
+ GHC.Hs.Utils: lHsRecFieldsImplicits :: [LHsRecField GhcRn (LPat GhcRn)] -> RecFieldsDotDot -> [ImplicitFieldBinders]
+ GHC.Hs.Utils: mkHsSyntaxApps :: SrcSpanAnnA -> SyntaxExprTc -> [LHsExpr GhcTc] -> LHsExpr GhcTc
+ GHC.Hs.Utils: mkLHsWrapPat :: HsWrapper -> LPat GhcTc -> Type -> LPat GhcTc
+ GHC.HsToCore.Errors.Types: DsIncompleteRecordSelector :: !Name -> ![ConLike] -> !Bool -> DsMessage
+ GHC.HsToCore.Pmc.Types: PmRecSel :: v -> CoreExpr -> [ConLike] -> PmRecSel v
+ GHC.HsToCore.Pmc.Types: [pr_arg] :: PmRecSel v -> CoreExpr
+ GHC.HsToCore.Pmc.Types: [pr_arg_var] :: PmRecSel v -> v
+ GHC.HsToCore.Pmc.Types: [pr_cons] :: PmRecSel v -> [ConLike]
+ GHC.HsToCore.Pmc.Types: data PmRecSel v
+ GHC.Iface.Syntax: IfaceBreakpoint :: Int -> [IfaceExpr] -> Module -> IfaceTickish
+ GHC.Iface.Syntax: [ifInstWarn] :: IfaceClsInst -> Maybe IfaceWarningTxt
+ GHC.Iface.Syntax: fromIfaceWarningTxt :: IfaceWarningTxt -> WarningTxt GhcRn
+ GHC.Iface.Type: instance GHC.Classes.Eq GHC.Iface.Type.TupleOrSum
+ GHC.JS.Ident: TxtI :: FastString -> Ident
+ GHC.JS.Ident: [identFS] :: Ident -> FastString
+ GHC.JS.Ident: global :: FastString -> Ident
+ GHC.JS.Ident: instance GHC.Classes.Eq GHC.JS.Ident.Ident
+ GHC.JS.Ident: instance GHC.Show.Show GHC.JS.Ident.Ident
+ GHC.JS.Ident: instance GHC.Types.Unique.Uniquable GHC.JS.Ident.Ident
+ GHC.JS.Ident: newtype Ident
+ GHC.JS.JStg.Monad: initJSM :: IO JEnv
+ GHC.JS.JStg.Monad: newIdent :: JSM Ident
+ GHC.JS.JStg.Monad: runJSM :: JEnv -> JSM a -> a
+ GHC.JS.JStg.Monad: type JSM a = State JEnv a
+ GHC.JS.JStg.Monad: withTag :: FastString -> JSM a -> JSM a
+ GHC.JS.JStg.Syntax: AddAssignOp :: AOp
+ GHC.JS.JStg.Syntax: AddOp :: Op
+ GHC.JS.JStg.Syntax: ApplExpr :: JStgExpr -> [JStgExpr] -> JStgExpr
+ GHC.JS.JStg.Syntax: ApplStat :: JStgExpr -> [JStgExpr] -> JStgStat
+ GHC.JS.JStg.Syntax: AssignOp :: AOp
+ GHC.JS.JStg.Syntax: AssignStat :: JStgExpr -> AOp -> JStgExpr -> JStgStat
+ GHC.JS.JStg.Syntax: BAndOp :: Op
+ GHC.JS.JStg.Syntax: BNotOp :: UOp
+ GHC.JS.JStg.Syntax: BOrOp :: Op
+ GHC.JS.JStg.Syntax: BXorOp :: Op
+ GHC.JS.JStg.Syntax: BlockStat :: [JStgStat] -> JStgStat
+ GHC.JS.JStg.Syntax: BreakStat :: Maybe JsLabel -> JStgStat
+ GHC.JS.JStg.Syntax: ContinueStat :: Maybe JsLabel -> JStgStat
+ GHC.JS.JStg.Syntax: DeclStat :: !Ident -> !Maybe JStgExpr -> JStgStat
+ GHC.JS.JStg.Syntax: DeleteOp :: UOp
+ GHC.JS.JStg.Syntax: DivOp :: Op
+ GHC.JS.JStg.Syntax: EqOp :: Op
+ GHC.JS.JStg.Syntax: ForInStat :: Bool -> Ident -> JStgExpr -> JStgStat -> JStgStat
+ GHC.JS.JStg.Syntax: ForStat :: JStgStat -> JStgExpr -> JStgStat -> JStgStat -> JStgStat
+ GHC.JS.JStg.Syntax: FuncStat :: !Ident -> [Ident] -> JStgStat -> JStgStat
+ GHC.JS.JStg.Syntax: GeOp :: Op
+ GHC.JS.JStg.Syntax: GtOp :: Op
+ GHC.JS.JStg.Syntax: IdxExpr :: JStgExpr -> JStgExpr -> JStgExpr
+ GHC.JS.JStg.Syntax: IfExpr :: JStgExpr -> JStgExpr -> JStgExpr -> JStgExpr
+ GHC.JS.JStg.Syntax: IfStat :: JStgExpr -> JStgStat -> JStgStat -> JStgStat
+ GHC.JS.JStg.Syntax: InOp :: Op
+ GHC.JS.JStg.Syntax: InfixExpr :: Op -> JStgExpr -> JStgExpr -> JStgExpr
+ GHC.JS.JStg.Syntax: InstanceofOp :: Op
+ GHC.JS.JStg.Syntax: JBool :: Bool -> JVal
+ GHC.JS.JStg.Syntax: JDouble :: SaneDouble -> JVal
+ GHC.JS.JStg.Syntax: JFunc :: [Ident] -> JStgStat -> JVal
+ GHC.JS.JStg.Syntax: JHash :: UniqMap FastString JStgExpr -> JVal
+ GHC.JS.JStg.Syntax: JInt :: Integer -> JVal
+ GHC.JS.JStg.Syntax: JList :: [JStgExpr] -> JVal
+ GHC.JS.JStg.Syntax: JRegEx :: FastString -> JVal
+ GHC.JS.JStg.Syntax: JStr :: FastString -> JVal
+ GHC.JS.JStg.Syntax: JVar :: Ident -> JVal
+ GHC.JS.JStg.Syntax: LAndOp :: Op
+ GHC.JS.JStg.Syntax: LOrOp :: Op
+ GHC.JS.JStg.Syntax: LabelStat :: JsLabel -> JStgStat -> JStgStat
+ GHC.JS.JStg.Syntax: LeOp :: Op
+ GHC.JS.JStg.Syntax: LeftShiftOp :: Op
+ GHC.JS.JStg.Syntax: LtOp :: Op
+ GHC.JS.JStg.Syntax: ModOp :: Op
+ GHC.JS.JStg.Syntax: MulOp :: Op
+ GHC.JS.JStg.Syntax: NegOp :: UOp
+ GHC.JS.JStg.Syntax: NeqOp :: Op
+ GHC.JS.JStg.Syntax: NewOp :: UOp
+ GHC.JS.JStg.Syntax: NotOp :: UOp
+ GHC.JS.JStg.Syntax: PlusOp :: UOp
+ GHC.JS.JStg.Syntax: PostDecOp :: UOp
+ GHC.JS.JStg.Syntax: PostIncOp :: UOp
+ GHC.JS.JStg.Syntax: PreDecOp :: UOp
+ GHC.JS.JStg.Syntax: PreIncOp :: UOp
+ GHC.JS.JStg.Syntax: ReturnStat :: JStgExpr -> JStgStat
+ GHC.JS.JStg.Syntax: RightShiftOp :: Op
+ GHC.JS.JStg.Syntax: SaneDouble :: Double -> SaneDouble
+ GHC.JS.JStg.Syntax: SelExpr :: JStgExpr -> Ident -> JStgExpr
+ GHC.JS.JStg.Syntax: StrictEqOp :: Op
+ GHC.JS.JStg.Syntax: StrictNeqOp :: Op
+ GHC.JS.JStg.Syntax: SubAssignOp :: AOp
+ GHC.JS.JStg.Syntax: SubOp :: Op
+ GHC.JS.JStg.Syntax: SwitchStat :: JStgExpr -> [(JStgExpr, JStgStat)] -> JStgStat -> JStgStat
+ GHC.JS.JStg.Syntax: TryStat :: JStgStat -> Ident -> JStgStat -> JStgStat -> JStgStat
+ GHC.JS.JStg.Syntax: TypeofOp :: UOp
+ GHC.JS.JStg.Syntax: UOpExpr :: UOp -> JStgExpr -> JStgExpr
+ GHC.JS.JStg.Syntax: UOpStat :: UOp -> JStgExpr -> JStgStat
+ GHC.JS.JStg.Syntax: ValExpr :: JVal -> JStgExpr
+ GHC.JS.JStg.Syntax: VoidOp :: UOp
+ GHC.JS.JStg.Syntax: WhileStat :: Bool -> JStgExpr -> JStgStat -> JStgStat
+ GHC.JS.JStg.Syntax: YieldOp :: UOp
+ GHC.JS.JStg.Syntax: ZRightShiftOp :: Op
+ GHC.JS.JStg.Syntax: [unSaneDouble] :: SaneDouble -> Double
+ GHC.JS.JStg.Syntax: data AOp
+ GHC.JS.JStg.Syntax: data JStgExpr
+ GHC.JS.JStg.Syntax: data JStgStat
+ GHC.JS.JStg.Syntax: data JVal
+ GHC.JS.JStg.Syntax: data Op
+ GHC.JS.JStg.Syntax: data UOp
+ GHC.JS.JStg.Syntax: instance Control.DeepSeq.NFData GHC.JS.JStg.Syntax.AOp
+ GHC.JS.JStg.Syntax: instance Control.DeepSeq.NFData GHC.JS.JStg.Syntax.Op
+ GHC.JS.JStg.Syntax: instance Control.DeepSeq.NFData GHC.JS.JStg.Syntax.UOp
+ GHC.JS.JStg.Syntax: instance Data.Data.Data GHC.JS.JStg.Syntax.AOp
+ GHC.JS.JStg.Syntax: instance Data.Data.Data GHC.JS.JStg.Syntax.Op
+ GHC.JS.JStg.Syntax: instance Data.Data.Data GHC.JS.JStg.Syntax.UOp
+ GHC.JS.JStg.Syntax: instance GHC.Base.Monoid GHC.JS.JStg.Syntax.JStgStat
+ GHC.JS.JStg.Syntax: instance GHC.Base.Semigroup GHC.JS.JStg.Syntax.JStgStat
+ GHC.JS.JStg.Syntax: instance GHC.Classes.Eq GHC.JS.JStg.Syntax.AOp
+ GHC.JS.JStg.Syntax: instance GHC.Classes.Eq GHC.JS.JStg.Syntax.JStgExpr
+ GHC.JS.JStg.Syntax: instance GHC.Classes.Eq GHC.JS.JStg.Syntax.JStgStat
+ GHC.JS.JStg.Syntax: instance GHC.Classes.Eq GHC.JS.JStg.Syntax.JVal
+ GHC.JS.JStg.Syntax: instance GHC.Classes.Eq GHC.JS.JStg.Syntax.Op
+ GHC.JS.JStg.Syntax: instance GHC.Classes.Eq GHC.JS.JStg.Syntax.UOp
+ GHC.JS.JStg.Syntax: instance GHC.Classes.Ord GHC.JS.JStg.Syntax.AOp
+ GHC.JS.JStg.Syntax: instance GHC.Classes.Ord GHC.JS.JStg.Syntax.Op
+ GHC.JS.JStg.Syntax: instance GHC.Classes.Ord GHC.JS.JStg.Syntax.UOp
+ GHC.JS.JStg.Syntax: instance GHC.Enum.Enum GHC.JS.JStg.Syntax.AOp
+ GHC.JS.JStg.Syntax: instance GHC.Enum.Enum GHC.JS.JStg.Syntax.Op
+ GHC.JS.JStg.Syntax: instance GHC.Enum.Enum GHC.JS.JStg.Syntax.UOp
+ GHC.JS.JStg.Syntax: instance GHC.Generics.Generic GHC.JS.JStg.Syntax.AOp
+ GHC.JS.JStg.Syntax: instance GHC.Generics.Generic GHC.JS.JStg.Syntax.JStgExpr
+ GHC.JS.JStg.Syntax: instance GHC.Generics.Generic GHC.JS.JStg.Syntax.JStgStat
+ GHC.JS.JStg.Syntax: instance GHC.Generics.Generic GHC.JS.JStg.Syntax.JVal
+ GHC.JS.JStg.Syntax: instance GHC.Generics.Generic GHC.JS.JStg.Syntax.Op
+ GHC.JS.JStg.Syntax: instance GHC.Generics.Generic GHC.JS.JStg.Syntax.UOp
+ GHC.JS.JStg.Syntax: instance GHC.Show.Show GHC.JS.JStg.Syntax.AOp
+ GHC.JS.JStg.Syntax: instance GHC.Show.Show GHC.JS.JStg.Syntax.Op
+ GHC.JS.JStg.Syntax: instance GHC.Show.Show GHC.JS.JStg.Syntax.UOp
+ GHC.JS.JStg.Syntax: instance GHC.Utils.Outputable.Outputable GHC.JS.JStg.Syntax.JStgExpr
+ GHC.JS.JStg.Syntax: newtype SaneDouble
+ GHC.JS.JStg.Syntax: pattern Add :: JStgExpr -> JStgExpr -> JStgExpr
+ GHC.JS.JStg.Syntax: pattern BAnd :: JStgExpr -> JStgExpr -> JStgExpr
+ GHC.JS.JStg.Syntax: pattern BNot :: JStgExpr -> JStgExpr
+ GHC.JS.JStg.Syntax: pattern BOr :: JStgExpr -> JStgExpr -> JStgExpr
+ GHC.JS.JStg.Syntax: pattern BXor :: JStgExpr -> JStgExpr -> JStgExpr
+ GHC.JS.JStg.Syntax: pattern Div :: JStgExpr -> JStgExpr -> JStgExpr
+ GHC.JS.JStg.Syntax: pattern Func :: [Ident] -> JStgStat -> JStgExpr
+ GHC.JS.JStg.Syntax: pattern Int :: Integer -> JStgExpr
+ GHC.JS.JStg.Syntax: pattern LAnd :: JStgExpr -> JStgExpr -> JStgExpr
+ GHC.JS.JStg.Syntax: pattern LOr :: JStgExpr -> JStgExpr -> JStgExpr
+ GHC.JS.JStg.Syntax: pattern Mod :: JStgExpr -> JStgExpr -> JStgExpr
+ GHC.JS.JStg.Syntax: pattern Mul :: JStgExpr -> JStgExpr -> JStgExpr
+ GHC.JS.JStg.Syntax: pattern Negate :: JStgExpr -> JStgExpr
+ GHC.JS.JStg.Syntax: pattern New :: JStgExpr -> JStgExpr
+ GHC.JS.JStg.Syntax: pattern Not :: JStgExpr -> JStgExpr
+ GHC.JS.JStg.Syntax: pattern PostDec :: JStgExpr -> JStgExpr
+ GHC.JS.JStg.Syntax: pattern PostInc :: JStgExpr -> JStgExpr
+ GHC.JS.JStg.Syntax: pattern PreDec :: JStgExpr -> JStgExpr
+ GHC.JS.JStg.Syntax: pattern PreInc :: JStgExpr -> JStgExpr
+ GHC.JS.JStg.Syntax: pattern String :: FastString -> JStgExpr
+ GHC.JS.JStg.Syntax: pattern Sub :: JStgExpr -> JStgExpr -> JStgExpr
+ GHC.JS.JStg.Syntax: pattern Var :: Ident -> JStgExpr
+ GHC.JS.JStg.Syntax: type JsLabel = LexicalFastString
+ GHC.JS.JStg.Syntax: var :: FastString -> JStgExpr
+ GHC.JS.Make: MkSolo :: a -> Solo a
+ GHC.JS.Make: argList :: JSArgument args => args -> [Ident]
+ GHC.JS.Make: args :: JSArgument args => JSM args
+ GHC.JS.Make: class JSArgument args
+ GHC.JS.Make: class JVarMagic a
+ GHC.JS.Make: data () => Solo a
+ GHC.JS.Make: fresh :: JVarMagic a => JSM a
+ GHC.JS.Make: instance (GHC.JS.Make.JVarMagic a, GHC.JS.Make.JVarMagic b, GHC.JS.Make.ToJExpr a, GHC.JS.Make.ToJExpr b) => GHC.JS.Make.JSArgument (a, b)
+ GHC.JS.Make: instance (GHC.JS.Make.JVarMagic a, GHC.JS.Make.ToJExpr a) => GHC.JS.Make.JSArgument (Solo a)
+ GHC.JS.Make: instance (GHC.JS.Make.JVarMagic a, GHC.JS.Make.ToJExpr a, GHC.JS.Make.JVarMagic b, GHC.JS.Make.ToJExpr b, GHC.JS.Make.JVarMagic c, GHC.JS.Make.ToJExpr c) => GHC.JS.Make.JSArgument (a, b, c)
+ GHC.JS.Make: instance (GHC.JS.Make.JVarMagic a, GHC.JS.Make.ToJExpr a, GHC.JS.Make.JVarMagic b, GHC.JS.Make.ToJExpr b, GHC.JS.Make.JVarMagic c, GHC.JS.Make.ToJExpr c, GHC.JS.Make.JVarMagic d, GHC.JS.Make.ToJExpr d) => GHC.JS.Make.JSArgument (a, b, c, d)
+ GHC.JS.Make: instance (GHC.JS.Make.JVarMagic a, GHC.JS.Make.ToJExpr a, GHC.JS.Make.JVarMagic b, GHC.JS.Make.ToJExpr b, GHC.JS.Make.JVarMagic c, GHC.JS.Make.ToJExpr c, GHC.JS.Make.JVarMagic d, GHC.JS.Make.ToJExpr d, GHC.JS.Make.JVarMagic e, GHC.JS.Make.ToJExpr e) => GHC.JS.Make.JSArgument (a, b, c, d, e)
+ GHC.JS.Make: instance (GHC.JS.Make.JVarMagic a, GHC.JS.Make.ToJExpr a, GHC.JS.Make.JVarMagic b, GHC.JS.Make.ToJExpr b, GHC.JS.Make.JVarMagic c, GHC.JS.Make.ToJExpr c, GHC.JS.Make.JVarMagic d, GHC.JS.Make.ToJExpr d, GHC.JS.Make.JVarMagic e, GHC.JS.Make.ToJExpr e, GHC.JS.Make.JVarMagic f, GHC.JS.Make.ToJExpr f) => GHC.JS.Make.JSArgument (a, b, c, d, e, f)
+ GHC.JS.Make: instance (GHC.JS.Make.JVarMagic a, GHC.JS.Make.ToJExpr a, GHC.JS.Make.JVarMagic b, GHC.JS.Make.ToJExpr b, GHC.JS.Make.JVarMagic c, GHC.JS.Make.ToJExpr c, GHC.JS.Make.JVarMagic d, GHC.JS.Make.ToJExpr d, GHC.JS.Make.JVarMagic e, GHC.JS.Make.ToJExpr e, GHC.JS.Make.JVarMagic f, GHC.JS.Make.ToJExpr f, GHC.JS.Make.JVarMagic g, GHC.JS.Make.ToJExpr g) => GHC.JS.Make.JSArgument (a, b, c, d, e, f, g)
+ GHC.JS.Make: instance (GHC.JS.Make.JVarMagic a, GHC.JS.Make.ToJExpr a, GHC.JS.Make.JVarMagic b, GHC.JS.Make.ToJExpr b, GHC.JS.Make.JVarMagic c, GHC.JS.Make.ToJExpr c, GHC.JS.Make.JVarMagic d, GHC.JS.Make.ToJExpr d, GHC.JS.Make.JVarMagic e, GHC.JS.Make.ToJExpr e, GHC.JS.Make.JVarMagic f, GHC.JS.Make.ToJExpr f, GHC.JS.Make.JVarMagic g, GHC.JS.Make.ToJExpr g, GHC.JS.Make.JVarMagic h, GHC.JS.Make.ToJExpr h) => GHC.JS.Make.JSArgument (a, b, c, d, e, f, g, h)
+ GHC.JS.Make: instance (GHC.JS.Make.JVarMagic a, GHC.JS.Make.ToJExpr a, GHC.JS.Make.JVarMagic b, GHC.JS.Make.ToJExpr b, GHC.JS.Make.JVarMagic c, GHC.JS.Make.ToJExpr c, GHC.JS.Make.JVarMagic d, GHC.JS.Make.ToJExpr d, GHC.JS.Make.JVarMagic e, GHC.JS.Make.ToJExpr e, GHC.JS.Make.JVarMagic f, GHC.JS.Make.ToJExpr f, GHC.JS.Make.JVarMagic g, GHC.JS.Make.ToJExpr g, GHC.JS.Make.JVarMagic h, GHC.JS.Make.ToJExpr h, GHC.JS.Make.JVarMagic i, GHC.JS.Make.ToJExpr i) => GHC.JS.Make.JSArgument (a, b, c, d, e, f, g, h, i)
+ GHC.JS.Make: instance (GHC.JS.Make.JVarMagic a, GHC.JS.Make.ToJExpr a, GHC.JS.Make.JVarMagic b, GHC.JS.Make.ToJExpr b, GHC.JS.Make.JVarMagic c, GHC.JS.Make.ToJExpr c, GHC.JS.Make.JVarMagic d, GHC.JS.Make.ToJExpr d, GHC.JS.Make.JVarMagic e, GHC.JS.Make.ToJExpr e, GHC.JS.Make.JVarMagic f, GHC.JS.Make.ToJExpr f, GHC.JS.Make.JVarMagic g, GHC.JS.Make.ToJExpr g, GHC.JS.Make.JVarMagic h, GHC.JS.Make.ToJExpr h, GHC.JS.Make.JVarMagic i, GHC.JS.Make.ToJExpr i, GHC.JS.Make.JVarMagic j, GHC.JS.Make.ToJExpr j) => GHC.JS.Make.JSArgument (a, b, c, d, e, f, g, h, i, j)
+ GHC.JS.Make: instance GHC.JS.Make.JVarMagic GHC.JS.Ident.Ident
+ GHC.JS.Make: instance GHC.JS.Make.JVarMagic GHC.JS.JStg.Syntax.JStgExpr
+ GHC.JS.Make: instance GHC.JS.Make.JVarMagic GHC.JS.JStg.Syntax.JVal
+ GHC.JS.Make: instance GHC.JS.Make.ToJExpr GHC.JS.Ident.Ident
+ GHC.JS.Make: instance GHC.JS.Make.ToJExpr GHC.JS.JStg.Syntax.JStgExpr
+ GHC.JS.Make: instance GHC.JS.Make.ToJExpr GHC.JS.JStg.Syntax.JVal
+ GHC.JS.Make: instance GHC.JS.Make.ToStat GHC.JS.JStg.Syntax.JStgExpr
+ GHC.JS.Make: instance GHC.JS.Make.ToStat GHC.JS.JStg.Syntax.JStgStat
+ GHC.JS.Make: instance GHC.JS.Make.ToStat [GHC.JS.JStg.Syntax.JStgExpr]
+ GHC.JS.Make: instance GHC.JS.Make.ToStat [GHC.JS.JStg.Syntax.JStgStat]
+ GHC.JS.Make: instance GHC.Num.Num GHC.JS.JStg.Syntax.JStgExpr
+ GHC.JS.Make: instance GHC.Real.Fractional GHC.JS.JStg.Syntax.JStgExpr
+ GHC.JS.Make: jBlock :: Monoid a => [JSM a] -> JSM a
+ GHC.JS.Make: jFunction' :: Ident -> JSM JStgStat -> JSM JStgStat
+ GHC.JS.Make: jFunctionSized :: Ident -> Int -> ([JStgExpr] -> JSM JStgStat) -> JSM JStgStat
+ GHC.JS.Make: jIf :: JStgExpr -> JSM JStgStat -> JSM JStgStat -> JSM JStgStat
+ GHC.JS.Make: jLam' :: JStgStat -> JStgExpr
+ GHC.JS.Make: jVars :: JSArgument args => (args -> JSM JStgStat) -> JSM JStgStat
+ GHC.JS.Make: pattern Solo :: a -> Solo a
+ GHC.JS.Ppr: instance GHC.JS.Ppr.JsToDoc GHC.JS.Ident.Ident
+ GHC.JS.Syntax: JBool :: Bool -> JVal
+ GHC.JS.Syntax: [identFS] :: Ident -> FastString
+ GHC.JS.Syntax: false_ :: JExpr
+ GHC.JS.Syntax: pattern Add :: JExpr -> JExpr -> JExpr
+ GHC.JS.Syntax: pattern BAnd :: JExpr -> JExpr -> JExpr
+ GHC.JS.Syntax: pattern BNot :: JExpr -> JExpr
+ GHC.JS.Syntax: pattern BOr :: JExpr -> JExpr -> JExpr
+ GHC.JS.Syntax: pattern BXor :: JExpr -> JExpr -> JExpr
+ GHC.JS.Syntax: pattern Div :: JExpr -> JExpr -> JExpr
+ GHC.JS.Syntax: pattern Int :: Integer -> JExpr
+ GHC.JS.Syntax: pattern LAnd :: JExpr -> JExpr -> JExpr
+ GHC.JS.Syntax: pattern LOr :: JExpr -> JExpr -> JExpr
+ GHC.JS.Syntax: pattern Mod :: JExpr -> JExpr -> JExpr
+ GHC.JS.Syntax: pattern Mul :: JExpr -> JExpr -> JExpr
+ GHC.JS.Syntax: pattern Negate :: JExpr -> JExpr
+ GHC.JS.Syntax: pattern New :: JExpr -> JExpr
+ GHC.JS.Syntax: pattern Not :: JExpr -> JExpr
+ GHC.JS.Syntax: pattern PostDec :: JExpr -> JExpr
+ GHC.JS.Syntax: pattern PostInc :: JExpr -> JExpr
+ GHC.JS.Syntax: pattern PreDec :: JExpr -> JExpr
+ GHC.JS.Syntax: pattern PreInc :: JExpr -> JExpr
+ GHC.JS.Syntax: pattern String :: FastString -> JExpr
+ GHC.JS.Syntax: pattern Sub :: JExpr -> JExpr -> JExpr
+ GHC.JS.Syntax: pattern Var :: Ident -> JExpr
+ GHC.JS.Syntax: true_ :: JExpr
+ GHC.JS.Syntax: var :: FastString -> JExpr
+ GHC.JS.Transform: jStgExprToJS :: JStgExpr -> JExpr
+ GHC.JS.Transform: jStgStatToJS :: JStgStat -> JStat
+ GHC.LanguageExtensions.Type: ListTuplePuns :: Extension
+ GHC.LanguageExtensions.Type: RequiredTypeArguments :: Extension
+ GHC.Linker.Config: FrameworkOpts :: [String] -> [String] -> FrameworkOpts
+ GHC.Linker.Config: LinkerConfig :: String -> [Option] -> [Option] -> TempDir -> (String -> String) -> LinkerConfig
+ GHC.Linker.Config: [foCmdlineFrameworks] :: FrameworkOpts -> [String]
+ GHC.Linker.Config: [foFrameworkPaths] :: FrameworkOpts -> [String]
+ GHC.Linker.Config: [linkerFilter] :: LinkerConfig -> String -> String
+ GHC.Linker.Config: [linkerOptionsPost] :: LinkerConfig -> [Option]
+ GHC.Linker.Config: [linkerOptionsPre] :: LinkerConfig -> [Option]
+ GHC.Linker.Config: [linkerProgram] :: LinkerConfig -> String
+ GHC.Linker.Config: [linkerTempDir] :: LinkerConfig -> TempDir
+ GHC.Linker.Config: data FrameworkOpts
+ GHC.Linker.Config: data LinkerConfig
+ GHC.Parser.Annotation: AddDarrowAnn :: EpaLocation -> TrailingAnn
+ GHC.Parser.Annotation: AddDarrowUAnn :: EpaLocation -> TrailingAnn
+ GHC.Parser.Annotation: BindTag :: BindTag
+ GHC.Parser.Annotation: ClsAtTag :: DeclTag
+ GHC.Parser.Annotation: ClsAtdTag :: DeclTag
+ GHC.Parser.Annotation: ClsMethodTag :: DeclTag
+ GHC.Parser.Annotation: ClsSigTag :: DeclTag
+ GHC.Parser.Annotation: EpExplicitBraces :: !EpToken "{" -> !EpToken "}" -> EpLayout
+ GHC.Parser.Annotation: EpNoLayout :: EpLayout
+ GHC.Parser.Annotation: EpTok :: !EpaLocation -> EpToken (tok :: Symbol)
+ GHC.Parser.Annotation: EpUniTok :: !EpaLocation -> !IsUnicodeSyntax -> EpUniToken (tok :: Symbol) (utok :: Symbol)
+ GHC.Parser.Annotation: EpVirtualBraces :: !Int -> EpLayout
+ GHC.Parser.Annotation: NoComments :: NoComments
+ GHC.Parser.Annotation: NoEpTok :: EpToken (tok :: Symbol)
+ GHC.Parser.Annotation: NoEpUniTok :: EpUniToken (tok :: Symbol) (utok :: Symbol)
+ GHC.Parser.Annotation: SigDTag :: BindTag
+ GHC.Parser.Annotation: [ta_location] :: TrailingAnn -> EpaLocation
+ GHC.Parser.Annotation: anchor :: EpaLocation' a -> RealSrcSpan
+ GHC.Parser.Annotation: class HasAnnotation e
+ GHC.Parser.Annotation: class HasLoc a
+ GHC.Parser.Annotation: class NoAnn a
+ GHC.Parser.Annotation: data BindTag
+ GHC.Parser.Annotation: data DeclTag
+ GHC.Parser.Annotation: data EpLayout
+ GHC.Parser.Annotation: data EpToken (tok :: Symbol)
+ GHC.Parser.Annotation: data EpUniToken (tok :: Symbol) (utok :: Symbol)
+ GHC.Parser.Annotation: data EpaLocation' a
+ GHC.Parser.Annotation: data NoComments
+ GHC.Parser.Annotation: epaToNoCommentsLocation :: EpaLocation -> NoCommentsLocation
+ GHC.Parser.Annotation: getEpTokenSrcSpan :: EpToken tok -> SrcSpan
+ GHC.Parser.Annotation: getHasLoc :: HasLoc a => a -> SrcSpan
+ GHC.Parser.Annotation: getHasLocList :: HasLoc a => [a] -> SrcSpan
+ GHC.Parser.Annotation: instance (GHC.Parser.Annotation.NoAnn a, GHC.Parser.Annotation.NoAnn b) => GHC.Parser.Annotation.NoAnn (a, b)
+ GHC.Parser.Annotation: instance (GHC.TypeLits.KnownSymbol tok, GHC.TypeLits.KnownSymbol utok) => Data.Data.Data (GHC.Parser.Annotation.EpUniToken tok utok)
+ GHC.Parser.Annotation: instance (GHC.Utils.Outputable.Outputable a, GHC.Utils.Outputable.Outputable e) => GHC.Utils.Outputable.Outputable (GHC.Types.SrcLoc.GenLocated (GHC.Parser.Annotation.EpAnn a) e)
+ GHC.Parser.Annotation: instance (GHC.Utils.Outputable.Outputable a, GHC.Utils.Outputable.OutputableBndr e) => GHC.Utils.Outputable.OutputableBndr (GHC.Types.SrcLoc.GenLocated (GHC.Parser.Annotation.EpAnn a) e)
+ GHC.Parser.Annotation: instance Data.Data.Data GHC.Parser.Annotation.BindTag
+ GHC.Parser.Annotation: instance Data.Data.Data GHC.Parser.Annotation.DeclTag
+ GHC.Parser.Annotation: instance Data.Data.Data GHC.Parser.Annotation.EpLayout
+ GHC.Parser.Annotation: instance Data.Data.Data tag => Data.Data.Data (GHC.Parser.Annotation.AnnSortKey tag)
+ GHC.Parser.Annotation: instance GHC.Base.Monoid (GHC.Parser.Annotation.AnnSortKey tag)
+ GHC.Parser.Annotation: instance GHC.Base.Semigroup (GHC.Parser.Annotation.AnnSortKey tag)
+ GHC.Parser.Annotation: instance GHC.Base.Semigroup GHC.Parser.Annotation.EpaLocation
+ GHC.Parser.Annotation: instance GHC.Classes.Eq (GHC.Parser.Annotation.EpToken tok)
+ GHC.Parser.Annotation: instance GHC.Classes.Eq GHC.Parser.Annotation.BindTag
+ GHC.Parser.Annotation: instance GHC.Classes.Eq GHC.Parser.Annotation.DeclTag
+ GHC.Parser.Annotation: instance GHC.Classes.Eq tag => GHC.Classes.Eq (GHC.Parser.Annotation.AnnSortKey tag)
+ GHC.Parser.Annotation: instance GHC.Classes.Ord GHC.Parser.Annotation.BindTag
+ GHC.Parser.Annotation: instance GHC.Classes.Ord GHC.Parser.Annotation.DeclTag
+ GHC.Parser.Annotation: instance GHC.Parser.Annotation.HasAnnotation GHC.Parser.Annotation.EpaLocation
+ GHC.Parser.Annotation: instance GHC.Parser.Annotation.HasAnnotation GHC.Types.SrcLoc.SrcSpan
+ GHC.Parser.Annotation: instance GHC.Parser.Annotation.HasLoc (GHC.Parser.Annotation.EpAnn a)
+ GHC.Parser.Annotation: instance GHC.Parser.Annotation.HasLoc GHC.Parser.Annotation.EpaLocation
+ GHC.Parser.Annotation: instance GHC.Parser.Annotation.HasLoc GHC.Types.SrcLoc.SrcSpan
+ GHC.Parser.Annotation: instance GHC.Parser.Annotation.HasLoc a => GHC.Parser.Annotation.HasLoc (GHC.Maybe.Maybe a)
+ GHC.Parser.Annotation: instance GHC.Parser.Annotation.HasLoc l => GHC.Parser.Annotation.HasLoc (GHC.Types.SrcLoc.GenLocated l a)
+ GHC.Parser.Annotation: instance GHC.Parser.Annotation.NoAnn (GHC.Maybe.Maybe a)
+ GHC.Parser.Annotation: instance GHC.Parser.Annotation.NoAnn (GHC.Parser.Annotation.EpToken s)
+ GHC.Parser.Annotation: instance GHC.Parser.Annotation.NoAnn (GHC.Parser.Annotation.EpUniToken s t)
+ GHC.Parser.Annotation: instance GHC.Parser.Annotation.NoAnn GHC.Parser.Annotation.AddEpAnn
+ GHC.Parser.Annotation: instance GHC.Parser.Annotation.NoAnn GHC.Parser.Annotation.AnnContext
+ GHC.Parser.Annotation: instance GHC.Parser.Annotation.NoAnn GHC.Parser.Annotation.AnnKeywordId
+ GHC.Parser.Annotation: instance GHC.Parser.Annotation.NoAnn GHC.Parser.Annotation.AnnList
+ GHC.Parser.Annotation: instance GHC.Parser.Annotation.NoAnn GHC.Parser.Annotation.AnnListItem
+ GHC.Parser.Annotation: instance GHC.Parser.Annotation.NoAnn GHC.Parser.Annotation.AnnParen
+ GHC.Parser.Annotation: instance GHC.Parser.Annotation.NoAnn GHC.Parser.Annotation.AnnPragma
+ GHC.Parser.Annotation: instance GHC.Parser.Annotation.NoAnn GHC.Parser.Annotation.EpaLocation
+ GHC.Parser.Annotation: instance GHC.Parser.Annotation.NoAnn GHC.Parser.Annotation.NameAnn
+ GHC.Parser.Annotation: instance GHC.Parser.Annotation.NoAnn GHC.Parser.Annotation.NoEpAnns
+ GHC.Parser.Annotation: instance GHC.Parser.Annotation.NoAnn GHC.Types.Bool
+ GHC.Parser.Annotation: instance GHC.Parser.Annotation.NoAnn [a]
+ GHC.Parser.Annotation: instance GHC.Parser.Annotation.NoAnn ann => GHC.Parser.Annotation.HasAnnotation (GHC.Parser.Annotation.EpAnn ann)
+ GHC.Parser.Annotation: instance GHC.Parser.Annotation.NoAnn ann => GHC.Parser.Annotation.NoAnn (GHC.Parser.Annotation.EpAnn ann)
+ GHC.Parser.Annotation: instance GHC.Show.Show GHC.Parser.Annotation.BindTag
+ GHC.Parser.Annotation: instance GHC.Show.Show GHC.Parser.Annotation.DeclTag
+ GHC.Parser.Annotation: instance GHC.Show.Show GHC.Parser.Annotation.ParenType
+ GHC.Parser.Annotation: instance GHC.TypeLits.KnownSymbol tok => Data.Data.Data (GHC.Parser.Annotation.EpToken tok)
+ GHC.Parser.Annotation: instance GHC.Utils.Outputable.Outputable (GHC.Types.SrcLoc.GenLocated GHC.Types.SrcLoc.NoCommentsLocation GHC.Parser.Annotation.EpaComment)
+ GHC.Parser.Annotation: instance GHC.Utils.Outputable.Outputable GHC.Parser.Annotation.BindTag
+ GHC.Parser.Annotation: instance GHC.Utils.Outputable.Outputable GHC.Parser.Annotation.DeclTag
+ GHC.Parser.Annotation: instance GHC.Utils.Outputable.Outputable GHC.Parser.Annotation.ParenType
+ GHC.Parser.Annotation: instance GHC.Utils.Outputable.Outputable e => GHC.Utils.Outputable.Outputable (GHC.Types.SrcLoc.GenLocated GHC.Parser.Annotation.EpaLocation e)
+ GHC.Parser.Annotation: instance GHC.Utils.Outputable.Outputable tag => GHC.Utils.Outputable.Outputable (GHC.Parser.Annotation.AnnSortKey tag)
+ GHC.Parser.Annotation: locA :: HasLoc a => a -> SrcSpan
+ GHC.Parser.Annotation: noCommentsToEpaLocation :: NoCommentsLocation -> EpaLocation
+ GHC.Parser.Annotation: noSpanAnchor :: NoAnn a => EpaLocation' a
+ GHC.Parser.Annotation: noTrailingN :: SrcSpanAnnN -> SrcSpanAnnN
+ GHC.Parser.Annotation: transferAnnsOnlyA :: SrcSpanAnnA -> SrcSpanAnnA -> (SrcSpanAnnA, SrcSpanAnnA)
+ GHC.Parser.Annotation: transferCommentsOnlyA :: EpAnn a -> EpAnn b -> (EpAnn a, EpAnn b)
+ GHC.Parser.Annotation: transferFollowingA :: SrcSpanAnnA -> SrcSpanAnnA -> (SrcSpanAnnA, SrcSpanAnnA)
+ GHC.Parser.Annotation: transferPriorCommentsA :: SrcSpanAnnA -> SrcSpanAnnA -> (SrcSpanAnnA, SrcSpanAnnA)
+ GHC.Parser.Annotation: type Anchor = EpaLocation
+ GHC.Parser.Annotation: type EpaLocation = EpaLocation' [LEpaComment]
+ GHC.Parser.Annotation: type LocatedE = GenLocated EpaLocation
+ GHC.Parser.Annotation: type NoCommentsLocation = EpaLocation' NoComments
+ GHC.Parser.Annotation: widenAnchorS :: Anchor -> SrcSpan -> Anchor
+ GHC.Parser.Errors.Types: PEP_QuoteDisambiguation :: PsErrPunDetails
+ GHC.Parser.Errors.Types: PEP_SumSyntaxType :: PsErrPunDetails
+ GHC.Parser.Errors.Types: PEP_TupleSyntaxType :: PsErrPunDetails
+ GHC.Parser.Errors.Types: PsErrInvalidPun :: !PsErrPunDetails -> PsMessage
+ GHC.Parser.Errors.Types: PsErrInvalidTypeSig_DataCon :: PsInvalidTypeSignature
+ GHC.Parser.Errors.Types: PsErrInvalidTypeSig_Other :: PsInvalidTypeSignature
+ GHC.Parser.Errors.Types: PsErrInvalidTypeSig_Qualified :: PsInvalidTypeSignature
+ GHC.Parser.Errors.Types: data PsErrPunDetails
+ GHC.Parser.Errors.Types: data PsInvalidTypeSignature
+ GHC.Parser.Lexer: ListTuplePunsBit :: ExtBits
+ GHC.Parser.PostProcess: hsHoleExpr :: Maybe EpAnnUnboundVar -> HsExpr GhcPs
+ GHC.Parser.PostProcess: instance GHC.Utils.Outputable.Outputable (GHC.Parser.PostProcess.ArgPatBuilder GHC.Hs.Extension.GhcPs)
+ GHC.Parser.PostProcess: mkHsEmbTyPV :: DisambECP b => SrcSpan -> EpToken "type" -> LHsType GhcPs -> PV (LocatedA b)
+ GHC.Parser.PostProcess: mkListSyntaxTy0 :: EpaLocation -> EpaLocation -> SrcSpan -> P (HsType GhcPs)
+ GHC.Parser.PostProcess: mkListSyntaxTy1 :: EpaLocation -> LocatedA (HsType GhcPs) -> EpaLocation -> P (HsType GhcPs)
+ GHC.Parser.PostProcess: mkMultAnn :: EpToken "%" -> LHsType GhcPs -> HsMultAnn GhcPs
+ GHC.Parser.PostProcess: mkTupleSyntaxTy :: EpaLocation -> [LocatedA (HsType GhcPs)] -> EpaLocation -> P (HsType GhcPs)
+ GHC.Parser.PostProcess: mkTupleSyntaxTycon :: Boxity -> Int -> P RdrName
+ GHC.Parser.PostProcess: mkUnboxedSumCon :: LHsType GhcPs -> ConTag -> Arity -> (LocatedN RdrName, HsConDeclH98Details GhcPs)
+ GHC.Parser.PostProcess: requireExplicitNamespaces :: MonadP m => SrcSpan -> m ()
+ GHC.Parser.PostProcess: requireLTPuns :: PsErrPunDetails -> Located a -> Located b -> P ()
+ GHC.Parser.PostProcess: withCombinedComments :: HasLoc l1 => HasLoc l2 => l1 -> l2 -> (SrcSpan -> P a) -> P (LocatedA a)
+ GHC.Platform: [pc_OFFSET_StgOrigThunkInfoFrame_info_ptr] :: PlatformConstants -> {-# UNPACK #-} !Int
+ GHC.Platform: [pc_SIZEOF_StgOrigThunkInfoFrame_NoHdr] :: PlatformConstants -> {-# UNPACK #-} !Int
+ GHC.Platform.ArchOS: isARM :: Arch -> Bool
+ GHC.Platform.ArchOS: osElfTarget :: OS -> Bool
+ GHC.Platform.ArchOS: osMachOTarget :: OS -> Bool
+ GHC.Platform.Constants: [pc_OFFSET_StgOrigThunkInfoFrame_info_ptr] :: PlatformConstants -> {-# UNPACK #-} !Int
+ GHC.Platform.Constants: [pc_SIZEOF_StgOrigThunkInfoFrame_NoHdr] :: PlatformConstants -> {-# UNPACK #-} !Int
+ GHC.Platform.Ways: wayOptcxx :: Platform -> Way -> [String]
+ GHC.Prelude: warnPprTraceM :: (Applicative f, HasCallStack) => Bool -> String -> SDoc -> f ()
+ GHC.Runtime.Interpreter.Types: [instLookupSymbolCache] :: ExtInterpInstance c -> !MVar (UniqFM FastString (Ptr ()))
+ GHC.Settings: [toolSettings_mergeObjsSupportsResponseFiles] :: ToolSettings -> Bool
+ GHC.Settings: [toolSettings_opt_las] :: ToolSettings -> [String]
+ GHC.Settings: [toolSettings_pgm_cpp] :: ToolSettings -> (String, [Option])
+ GHC.Settings: [toolSettings_pgm_las] :: ToolSettings -> (String, [Option])
+ GHC.Settings: sMergeObjsSupportsResponseFiles :: Settings -> Bool
+ GHC.Settings: sPgm_cpp :: Settings -> (String, [Option])
+ GHC.Settings: sPgm_las :: Settings -> (String, [Option])
+ GHC.Stg.Syntax: stgArgRep :: StgArg -> [PrimRep]
+ GHC.Stg.Syntax: stgArgRep1 :: StgArg -> PrimOrVoidRep
+ GHC.Stg.Syntax: stgArgRepU :: StgArg -> PrimRep
+ GHC.Stg.Syntax: stgArgRep_maybe :: StgArg -> Maybe [PrimRep]
+ GHC.StgToCmm.Config: [stgToCmmAllowBigQuot] :: StgToCmmConfig -> !Bool
+ GHC.StgToCmm.Config: [stgToCmmOrigThunkInfo] :: StgToCmmConfig -> !Bool
+ GHC.StgToJS.Linker.Types: [lcForceEmccRts] :: JSLinkConfig -> !Bool
+ GHC.StgToJS.Linker.Types: [lcLinkCsources] :: JSLinkConfig -> !Bool
+ GHC.StgToJS.Linker.Types: [lkp_objs_cc] :: LinkPlan -> !Set FilePath
+ GHC.StgToJS.Linker.Types: [lkp_objs_js] :: LinkPlan -> !Set FilePath
+ GHC.StgToJS.Object: JSOptions :: !Bool -> ![String] -> ![String] -> ![String] -> JSOptions
+ GHC.StgToJS.Object: ObjCc :: ObjectKind
+ GHC.StgToJS.Object: ObjHs :: ObjectKind
+ GHC.StgToJS.Object: ObjJs :: ObjectKind
+ GHC.StgToJS.Object: [emccExportedFunctions] :: JSOptions -> ![String]
+ GHC.StgToJS.Object: [emccExportedRuntimeMethods] :: JSOptions -> ![String]
+ GHC.StgToJS.Object: [emccExtraOptions] :: JSOptions -> ![String]
+ GHC.StgToJS.Object: [enableCPP] :: JSOptions -> !Bool
+ GHC.StgToJS.Object: data JSOptions
+ GHC.StgToJS.Object: data ObjectKind
+ GHC.StgToJS.Object: defaultJSOptions :: JSOptions
+ GHC.StgToJS.Object: getObjectKind :: FilePath -> IO (Maybe ObjectKind)
+ GHC.StgToJS.Object: getObjectKindBS :: ByteString -> Maybe ObjectKind
+ GHC.StgToJS.Object: getOptionsFromJsFile :: FilePath -> IO JSOptions
+ GHC.StgToJS.Object: instance GHC.Base.Semigroup GHC.StgToJS.Object.JSOptions
+ GHC.StgToJS.Object: instance GHC.Classes.Eq GHC.StgToJS.Object.JSOptions
+ GHC.StgToJS.Object: instance GHC.Classes.Eq GHC.StgToJS.Object.ObjectKind
+ GHC.StgToJS.Object: instance GHC.Classes.Ord GHC.StgToJS.Object.JSOptions
+ GHC.StgToJS.Object: instance GHC.Classes.Ord GHC.StgToJS.Object.ObjectKind
+ GHC.StgToJS.Object: instance GHC.Show.Show GHC.StgToJS.Object.ObjectKind
+ GHC.StgToJS.Object: instance GHC.Utils.Binary.Binary GHC.JS.Ident.Ident
+ GHC.StgToJS.Object: instance GHC.Utils.Binary.Binary GHC.StgToJS.Object.JSOptions
+ GHC.StgToJS.Object: instance GHC.Utils.Binary.Binary GHC.StgToJS.Types.JSRep
+ GHC.StgToJS.Object: parseJSObject :: BinHandle -> IO (JSOptions, ByteString)
+ GHC.StgToJS.Object: parseJSObjectBS :: ByteString -> IO (JSOptions, ByteString)
+ GHC.StgToJS.Object: readJSObject :: FilePath -> IO (JSOptions, ByteString)
+ GHC.StgToJS.Object: writeJSObject :: JSOptions -> ByteString -> FilePath -> IO ()
+ GHC.StgToJS.Types: [csLinkerConfig] :: StgToJSConfig -> !LinkerConfig
+ GHC.StgToJS.Types: data JSRep
+ GHC.StgToJS.Types: instance GHC.Classes.Eq GHC.StgToJS.Types.JSRep
+ GHC.StgToJS.Types: instance GHC.Classes.Ord GHC.StgToJS.Types.JSRep
+ GHC.StgToJS.Types: instance GHC.Enum.Bounded GHC.StgToJS.Types.JSRep
+ GHC.StgToJS.Types: instance GHC.Enum.Enum GHC.StgToJS.Types.JSRep
+ GHC.StgToJS.Types: instance GHC.JS.Make.ToJExpr GHC.StgToJS.Types.JSRep
+ GHC.StgToJS.Types: instance GHC.Show.Show GHC.StgToJS.Types.JSRep
+ GHC.StgToJS.Types: instance GHC.Utils.Outputable.Outputable GHC.StgToJS.Types.TypedExpr
+ GHC.Tc.Errors.Ppr: mismatchMsg_ExpectedActuals :: MismatchMsg -> Maybe (Type, Type)
+ GHC.Tc.Errors.Types: ClassTE :: TermLevelUseErr
+ GHC.Tc.Errors.Types: PragmaWarningExport :: OccName -> ModuleName -> PragmaWarningInfo
+ GHC.Tc.Errors.Types: PragmaWarningInstance :: DFunId -> CtOrigin -> PragmaWarningInfo
+ GHC.Tc.Errors.Types: PragmaWarningName :: OccName -> ModuleName -> ModuleName -> PragmaWarningInfo
+ GHC.Tc.Errors.Types: TyConTE :: TermLevelUseErr
+ GHC.Tc.Errors.Types: TyVarTE :: TermLevelUseErr
+ GHC.Tc.Errors.Types: [TcRnBadlyStagedType] :: !Name -> !Int -> !Int -> TcRnMessage
+ GHC.Tc.Errors.Types: [TcRnDefaultedExceptionContext] :: CtLoc -> TcRnMessage
+ GHC.Tc.Errors.Types: [TcRnHasFieldResolvedIncomplete] :: !Name -> TcRnMessage
+ GHC.Tc.Errors.Types: [TcRnIllegalImplicitTyVarInTypeArgument] :: RdrName -> TcRnMessage
+ GHC.Tc.Errors.Types: [TcRnIllegalInvisibleTypePattern] :: HsTyPat GhcPs -> TcRnMessage
+ GHC.Tc.Errors.Types: [TcRnIllegalNamedWildcardInTypeArgument] :: RdrName -> TcRnMessage
+ GHC.Tc.Errors.Types: [TcRnIllegalTermLevelUse] :: !Name -> !TermLevelUseErr -> TcRnMessage
+ GHC.Tc.Errors.Types: [TcRnIllegalTypeExpr] :: TcRnMessage
+ GHC.Tc.Errors.Types: [TcRnIllegalTypePattern] :: TcRnMessage
+ GHC.Tc.Errors.Types: [TcRnIllformedTypeArgument] :: !LHsExpr GhcRn -> TcRnMessage
+ GHC.Tc.Errors.Types: [TcRnIllformedTypePattern] :: !Pat GhcRn -> TcRnMessage
+ GHC.Tc.Errors.Types: [TcRnInvalidDefaultedTyVar] :: ![Ct] -> [(TcTyVar, Type)] -> NonEmpty TcTyVar -> TcRnMessage
+ GHC.Tc.Errors.Types: [TcRnInvisPatWithNoForAll] :: HsTyPat GhcRn -> TcRnMessage
+ GHC.Tc.Errors.Types: [TcRnMisplacedInvisPat] :: HsTyPat GhcPs -> TcRnMessage
+ GHC.Tc.Errors.Types: [TcRnNamespacedFixitySigWithoutFlag] :: FixitySig GhcPs -> TcRnMessage
+ GHC.Tc.Errors.Types: [TcRnNamespacedWarningPragmaWithoutFlag] :: WarnDecl GhcPs -> TcRnMessage
+ GHC.Tc.Errors.Types: [TcRnOutOfArityTyVar] :: Name -> Name -> TcRnMessage
+ GHC.Tc.Errors.Types: [pwarn_ctorig] :: PragmaWarningInfo -> CtOrigin
+ GHC.Tc.Errors.Types: [pwarn_declmod] :: PragmaWarningInfo -> ModuleName
+ GHC.Tc.Errors.Types: [pwarn_dfunid] :: PragmaWarningInfo -> DFunId
+ GHC.Tc.Errors.Types: [pwarn_impmod] :: PragmaWarningInfo -> ModuleName
+ GHC.Tc.Errors.Types: [pwarn_occname] :: PragmaWarningInfo -> OccName
+ GHC.Tc.Errors.Types: data PragmaWarningInfo
+ GHC.Tc.Errors.Types: data TermLevelUseErr
+ GHC.Tc.Errors.Types: teCategory :: TermLevelUseErr -> String
+ GHC.Tc.Errors.Types.PromotionErr: ClassTE :: TermLevelUseErr
+ GHC.Tc.Errors.Types.PromotionErr: TyConTE :: TermLevelUseErr
+ GHC.Tc.Errors.Types.PromotionErr: TyVarTE :: TermLevelUseErr
+ GHC.Tc.Errors.Types.PromotionErr: data TermLevelUseErr
+ GHC.Tc.Errors.Types.PromotionErr: instance GHC.Generics.Generic GHC.Tc.Errors.Types.PromotionErr.TermLevelUseErr
+ GHC.Tc.Errors.Types.PromotionErr: teCategory :: TermLevelUseErr -> String
+ GHC.Tc.Types: CSig :: TcId -> UserTypeCtxt -> SrcSpan -> TcCompleteSig
+ GHC.Tc.Types: PSig :: Name -> LHsSigWcType GhcRn -> UserTypeCtxt -> SrcSpan -> TcPartialSig
+ GHC.Tc.Types: PatSig :: Name -> [InvisTVBinder] -> [InvisTVBinder] -> TcThetaType -> [InvisTVBinder] -> TcThetaType -> TcSigmaType -> TcPatSynSig
+ GHC.Tc.Types: TcCompleteSig :: TcCompleteSig -> TcIdSig
+ GHC.Tc.Types: TcPartialSig :: TcPartialSig -> TcIdSig
+ GHC.Tc.Types: [deProposals] :: DefaultingProposal -> [[(TcTyVar, Type)]]
+ GHC.Tc.Types: [psig_ctxt] :: TcPartialSig -> UserTypeCtxt
+ GHC.Tc.Types: [psig_loc] :: TcPartialSig -> SrcSpan
+ GHC.Tc.Types: [tcg_hdr_info] :: TcGblEnv -> (Maybe (LHsDoc GhcRn), Maybe (XRec GhcRn ModuleName))
+ GHC.Tc.Types: completeSigPolyId_maybe :: TcSigInfo -> Maybe TcId
+ GHC.Tc.Types: data TcCompleteSig
+ GHC.Tc.Types: data TcIdSig
+ GHC.Tc.Types: data TcPartialSig
+ GHC.Tc.Types: data TcPatSynSig
+ GHC.Tc.Types: tcIdSigLoc :: TcIdSig -> SrcSpan
+ GHC.Tc.Types: tcSigInfoName :: TcSigInfo -> Name
+ GHC.Tc.Types.BasicTypes: CSig :: TcId -> UserTypeCtxt -> SrcSpan -> TcCompleteSig
+ GHC.Tc.Types.BasicTypes: PSig :: Name -> LHsSigWcType GhcRn -> UserTypeCtxt -> SrcSpan -> TcPartialSig
+ GHC.Tc.Types.BasicTypes: PatSig :: Name -> [InvisTVBinder] -> [InvisTVBinder] -> TcThetaType -> [InvisTVBinder] -> TcThetaType -> TcSigmaType -> TcPatSynSig
+ GHC.Tc.Types.BasicTypes: TcCompleteSig :: TcCompleteSig -> TcIdSig
+ GHC.Tc.Types.BasicTypes: TcPartialSig :: TcPartialSig -> TcIdSig
+ GHC.Tc.Types.BasicTypes: [psig_ctxt] :: TcPartialSig -> UserTypeCtxt
+ GHC.Tc.Types.BasicTypes: [psig_loc] :: TcPartialSig -> SrcSpan
+ GHC.Tc.Types.BasicTypes: completeSigPolyId_maybe :: TcSigInfo -> Maybe TcId
+ GHC.Tc.Types.BasicTypes: data TcCompleteSig
+ GHC.Tc.Types.BasicTypes: data TcIdSig
+ GHC.Tc.Types.BasicTypes: data TcPartialSig
+ GHC.Tc.Types.BasicTypes: data TcPatSynSig
+ GHC.Tc.Types.BasicTypes: instance GHC.Utils.Outputable.Outputable GHC.Tc.Types.BasicTypes.TcCompleteSig
+ GHC.Tc.Types.BasicTypes: instance GHC.Utils.Outputable.Outputable GHC.Tc.Types.BasicTypes.TcIdSig
+ GHC.Tc.Types.BasicTypes: instance GHC.Utils.Outputable.Outputable GHC.Tc.Types.BasicTypes.TcPartialSig
+ GHC.Tc.Types.BasicTypes: instance GHC.Utils.Outputable.Outputable GHC.Tc.Types.BasicTypes.TcPatSynSig
+ GHC.Tc.Types.BasicTypes: tcIdSigLoc :: TcIdSig -> SrcSpan
+ GHC.Tc.Types.BasicTypes: tcSigInfoName :: TcSigInfo -> Name
+ GHC.Tc.Types.Constraint: arisesFromGivens :: Ct -> Bool
+ GHC.Tc.Types.Evidence: mkWpVisTyLam :: TyVar -> Type -> HsWrapper
+ GHC.Tc.Types.Origin: FRRRepPolyId :: !Name -> !RepPolyId -> !Position Neg -> FixedRuntimeRepContext
+ GHC.Tc.Types.Origin: FRRRepPolyUnliftedNewtype :: !DataCon -> FixedRuntimeRepContext
+ GHC.Tc.Types.Origin: FRRUnboxedTuple :: !Int -> FixedRuntimeRepContext
+ GHC.Tc.Types.Origin: FRRUnboxedTupleSection :: !Int -> FixedRuntimeRepContext
+ GHC.Tc.Types.Origin: GeneralisedPatternReason :: NonLinearPatternReason
+ GHC.Tc.Types.Origin: HsExprTcThing :: HsExpr GhcTc -> TypedThing
+ GHC.Tc.Types.Origin: LazyPatternReason :: NonLinearPatternReason
+ GHC.Tc.Types.Origin: Neg :: Polarity
+ GHC.Tc.Types.Origin: OtherPatternReason :: NonLinearPatternReason
+ GHC.Tc.Types.Origin: PatternSynonymReason :: NonLinearPatternReason
+ GHC.Tc.Types.Origin: Pos :: Polarity
+ GHC.Tc.Types.Origin: RepPolyFunction :: RepPolyId
+ GHC.Tc.Types.Origin: RepPolyPrimOp :: RepPolyId
+ GHC.Tc.Types.Origin: RepPolySum :: RepPolyId
+ GHC.Tc.Types.Origin: RepPolyTuple :: RepPolyId
+ GHC.Tc.Types.Origin: ViewPatternReason :: NonLinearPatternReason
+ GHC.Tc.Types.Origin: [Argument] :: Int -> Position (FlipPolarity p) -> Position p
+ GHC.Tc.Types.Origin: [Result] :: Position p -> Position p
+ GHC.Tc.Types.Origin: [Top] :: Position Pos
+ GHC.Tc.Types.Origin: [iw_warn] :: InstanceWhat -> Maybe (WarningTxt GhcRn)
+ GHC.Tc.Types.Origin: data NonLinearPatternReason
+ GHC.Tc.Types.Origin: data Polarity
+ GHC.Tc.Types.Origin: data Position p
+ GHC.Tc.Types.Origin: data RepPolyId
+ GHC.Tc.Types.Origin: mkFRRUnboxedSum :: Maybe Int -> FixedRuntimeRepContext
+ GHC.Tc.Types.Origin: mkFRRUnboxedTuple :: Int -> FixedRuntimeRepContext
+ GHC.Tc.Utils.TcType: ExpForAllPatTy :: ForAllTyBinder -> ExpPatType
+ GHC.Tc.Utils.TcType: ExpFunPatTy :: Scaled ExpSigmaTypeFRR -> ExpPatType
+ GHC.Tc.Utils.TcType: data ExpPatType
+ GHC.Tc.Utils.TcType: instance GHC.Utils.Outputable.Outputable GHC.Tc.Utils.TcType.ExpPatType
+ GHC.Tc.Utils.TcType: isExpFunPatType :: ExpPatType -> Bool
+ GHC.Tc.Utils.TcType: isVisibleExpPatType :: ExpPatType -> Bool
+ GHC.Tc.Utils.TcType: mkCheckExpFunPatTy :: Scaled TcType -> ExpPatType
+ GHC.Tc.Utils.TcType: mkInvisExpPatType :: InvisTyBinder -> ExpPatType
+ GHC.Tc.Utils.TcType: mkTCvSubst :: InScopeSet -> TvSubstEnv -> CvSubstEnv -> Subst
+ GHC.Tc.Utils.TcType: noConcreteTyVars :: ConcreteTyVars
+ GHC.Tc.Utils.TcType: tcSplitSigmaTyBndrs :: Type -> ([TcInvisTVBinder], ThetaType, Type)
+ GHC.Tc.Utils.TcType: type ConcreteTyVars = NameEnv ConcreteTvOrigin
+ GHC.Types.Basic: DoExpansion :: HsDoFlavour -> GenReason
+ GHC.Types.Basic: JoinPoint :: {-# UNPACK #-} !Int -> JoinPointHood
+ GHC.Types.Basic: NotJoinPoint :: JoinPointHood
+ GHC.Types.Basic: OtherExpansion :: GenReason
+ GHC.Types.Basic: data GenReason
+ GHC.Types.Basic: data JoinPointHood
+ GHC.Types.Basic: doExpansionFlavour :: Origin -> Maybe HsDoFlavour
+ GHC.Types.Basic: doExpansionOrigin :: HsDoFlavour -> Origin
+ GHC.Types.Basic: instance Data.Data.Data GHC.Types.Basic.GenReason
+ GHC.Types.Basic: instance GHC.Classes.Eq GHC.Types.Basic.GenReason
+ GHC.Types.Basic: instance GHC.Utils.Outputable.Outputable GHC.Types.Basic.GenReason
+ GHC.Types.Basic: isDoExpansionGenerated :: Origin -> Bool
+ GHC.Types.Basic: isJoinPoint :: JoinPointHood -> Bool
+ GHC.Types.Basic: type VisArity = Int
+ GHC.Types.Demand: callCards :: SubDemand -> [Card]
+ GHC.Types.Demand: glbCard :: Card -> Card -> Card
+ GHC.Types.Demand: isAtMostOnce :: Card -> Bool
+ GHC.Types.Demand: isAtMostOnceDmd :: Demand -> Bool
+ GHC.Types.Error: SuggestAnonymousWildcard :: GhcHint
+ GHC.Types.Error: SuggestExplicitQuantification :: RdrName -> GhcHint
+ GHC.Types.Error: SuggestTypeSignatureRemoveQualifier :: GhcHint
+ GHC.Types.Error: filterMessages :: (MsgEnvelope e -> Bool) -> Messages e -> Messages e
+ GHC.Types.Error: instance GHC.Classes.Eq GHC.Types.Error.DiagnosticCode
+ GHC.Types.Error: instance GHC.Classes.Ord GHC.Types.Error.DiagnosticCode
+ GHC.Types.Error: instance GHC.Show.Show GHC.Types.Error.DiagnosticCode
+ GHC.Types.Error: instance GHC.Types.Error.Diagnostic e => GHC.Utils.Json.ToJson (GHC.Types.Error.Messages e)
+ GHC.Types.Error: instance GHC.Types.Error.Diagnostic e => GHC.Utils.Json.ToJson (GHC.Types.Error.MsgEnvelope e)
+ GHC.Types.Error: instance GHC.Utils.Json.ToJson GHC.Types.Error.DiagnosticCode
+ GHC.Types.Error: instance GHC.Utils.Outputable.Outputable GHC.Types.Error.LinkedDiagCode
+ GHC.Types.Error.Codes: constructorCodes :: forall diag. (Generic diag, GDiagnosticCodes '[diag] (Rep diag)) => Map DiagnosticCode String
+ GHC.Types.Error.Codes: instance (GHC.Types.Error.Codes.ConRecursInto con GHC.Types.~ 'GHC.Maybe.Just (GHC.Types.Error.UnknownDiagnostic opts)) => GHC.Types.Error.Codes.ConstructorCodes con f seen ('GHC.Maybe.Just (GHC.Types.Error.UnknownDiagnostic opts))
+ GHC.Types.Error.Codes: instance (GHC.Types.Error.Codes.ConRecursInto con GHC.Types.~ 'GHC.Maybe.Just ty, GHC.Types.Error.Codes.HasType ty con f, GHC.Generics.Generic ty, GHC.Types.Error.Codes.GDiagnosticCodes (GHC.Types.Error.Codes.Insert ty seen) (GHC.Generics.Rep ty), GHC.Types.Error.Codes.Seen seen ty) => GHC.Types.Error.Codes.ConstructorCodes con f seen ('GHC.Maybe.Just ty)
+ GHC.Types.Error.Codes: instance (GHC.Types.Error.Codes.ConstructorCode con f recur, recur GHC.Types.~ GHC.Types.Error.Codes.ConRecursInto con, GHC.TypeLits.KnownSymbol con) => GHC.Types.Error.Codes.GDiagnosticCode (GHC.Generics.M1 i ('GHC.Generics.MetaCons con x y) f)
+ GHC.Types.Error.Codes: instance (GHC.Types.Error.Codes.ConstructorCodes con f seen recur, recur GHC.Types.~ GHC.Types.Error.Codes.ConRecursInto con, GHC.TypeLits.KnownSymbol con) => GHC.Types.Error.Codes.GDiagnosticCodes seen (GHC.Generics.M1 i ('GHC.Generics.MetaCons con x y) f)
+ GHC.Types.Error.Codes: instance (GHC.Types.Error.Codes.GDiagnosticCodes seen f, GHC.Types.Error.Codes.GDiagnosticCodes seen g) => GHC.Types.Error.Codes.GDiagnosticCodes seen (f GHC.Generics.:+: g)
+ GHC.Types.Error.Codes: instance (GHC.Types.Error.Codes.KnownConstructor con, GHC.TypeLits.KnownSymbol con) => GHC.Types.Error.Codes.ConstructorCode con f 'GHC.Maybe.Nothing
+ GHC.Types.Error.Codes: instance (GHC.Types.Error.Codes.KnownConstructor con, GHC.TypeLits.KnownSymbol con) => GHC.Types.Error.Codes.ConstructorCodes con f seen 'GHC.Maybe.Nothing
+ GHC.Types.Error.Codes: instance GHC.Types.Error.Codes.GDiagnosticCodes seen f => GHC.Types.Error.Codes.GDiagnosticCodes seen (GHC.Generics.M1 i ('GHC.Generics.MetaData nm mod pkg nt) f)
+ GHC.Types.Error.Codes: instance GHC.Types.Error.Codes.Seen '[] ty
+ GHC.Types.Error.Codes: instance GHC.Types.Error.Codes.Seen (ty : tys) ty
+ GHC.Types.Error.Codes: instance GHC.Types.Error.Codes.Seen tys ty => GHC.Types.Error.Codes.Seen (ty' : tys) ty
+ GHC.Types.Error.Codes: type family GhcDiagnosticCode c = n | n -> c
+ GHC.Types.Hint: SuggestAnonymousWildcard :: GhcHint
+ GHC.Types.Hint: SuggestExplicitQuantification :: RdrName -> GhcHint
+ GHC.Types.Hint: SuggestTypeSignatureRemoveQualifier :: GhcHint
+ GHC.Types.Id: data JoinPointHood
+ GHC.Types.Id: idJoinPointHood :: Var -> JoinPointHood
+ GHC.Types.Id.Info: RepPolyId :: ConcreteTyVars -> IdDetails
+ GHC.Types.Id.Info: [id_concrete_tvs] :: IdDetails -> ConcreteTyVars
+ GHC.Types.Id.Info: [id_primop] :: IdDetails -> PrimOp
+ GHC.Types.Id.Info: [sel_cons] :: IdDetails -> ([ConLike], [ConLike])
+ GHC.Types.Id.Info: idDetailsConcreteTvs :: IdDetails -> ConcreteTyVars
+ GHC.Types.Id.Info: recSelParentCons :: RecSelParent -> [ConLike]
+ GHC.Types.Id.Make: mkRepPolyIdConcreteTyVars :: [((Type, Position Neg), TyVar)] -> Name -> ConcreteTyVars
+ GHC.Types.Id.Make: pcRepPolyId :: Name -> Type -> (Name -> ConcreteTyVars) -> IdInfo -> Id
+ GHC.Types.Name: isSumTyConName :: Name -> Bool
+ GHC.Types.Name: isUnboxedTupleDataConLikeName :: Name -> Bool
+ GHC.Types.Name.Occurrence: data OccSet
+ GHC.Types.Name.Occurrence: isUnderscore :: OccName -> Bool
+ GHC.Types.Name.Set: intersectsFVs :: FreeVars -> FreeVars -> Bool
+ GHC.Types.RepType: isNvUnaryRep :: [PrimRep] -> Bool
+ GHC.Types.RepType: repSlotTy :: [PrimRep] -> Maybe SlotTy
+ GHC.Types.RepType: typePrimRepU :: HasDebugCallStack => NvUnaryType -> PrimRep
+ GHC.Types.SrcLoc: DifferentLine :: !Int -> !Int -> DeltaPos
+ GHC.Types.SrcLoc: EpaDelta :: !DeltaPos -> !a -> EpaLocation' a
+ GHC.Types.SrcLoc: EpaSpan :: !SrcSpan -> EpaLocation' a
+ GHC.Types.SrcLoc: NoComments :: NoComments
+ GHC.Types.SrcLoc: SameLine :: !Int -> DeltaPos
+ GHC.Types.SrcLoc: [deltaColumn] :: DeltaPos -> !Int
+ GHC.Types.SrcLoc: [deltaLine] :: DeltaPos -> !Int
+ GHC.Types.SrcLoc: data DeltaPos
+ GHC.Types.SrcLoc: data EpaLocation' a
+ GHC.Types.SrcLoc: data NoComments
+ GHC.Types.SrcLoc: deltaPos :: Int -> Int -> DeltaPos
+ GHC.Types.SrcLoc: getDeltaLine :: DeltaPos -> Int
+ GHC.Types.SrcLoc: instance Data.Data.Data GHC.Types.SrcLoc.DeltaPos
+ GHC.Types.SrcLoc: instance Data.Data.Data GHC.Types.SrcLoc.NoComments
+ GHC.Types.SrcLoc: instance Data.Data.Data a => Data.Data.Data (GHC.Types.SrcLoc.EpaLocation' a)
+ GHC.Types.SrcLoc: instance GHC.Classes.Eq GHC.Types.SrcLoc.DeltaPos
+ GHC.Types.SrcLoc: instance GHC.Classes.Eq GHC.Types.SrcLoc.NoComments
+ GHC.Types.SrcLoc: instance GHC.Classes.Eq a => GHC.Classes.Eq (GHC.Types.SrcLoc.EpaLocation' a)
+ GHC.Types.SrcLoc: instance GHC.Classes.Ord GHC.Types.SrcLoc.DeltaPos
+ GHC.Types.SrcLoc: instance GHC.Classes.Ord GHC.Types.SrcLoc.NoComments
+ GHC.Types.SrcLoc: instance GHC.Show.Show GHC.Types.SrcLoc.DeltaPos
+ GHC.Types.SrcLoc: instance GHC.Show.Show GHC.Types.SrcLoc.NoComments
+ GHC.Types.SrcLoc: instance GHC.Show.Show a => GHC.Show.Show (GHC.Types.SrcLoc.EpaLocation' a)
+ GHC.Types.SrcLoc: instance GHC.Utils.Outputable.Outputable GHC.Types.SrcLoc.DeltaPos
+ GHC.Types.SrcLoc: instance GHC.Utils.Outputable.Outputable GHC.Types.SrcLoc.NoComments
+ GHC.Types.SrcLoc: instance GHC.Utils.Outputable.Outputable a => GHC.Utils.Outputable.Outputable (GHC.Types.SrcLoc.EpaLocation' a)
+ GHC.Types.SrcLoc: type NoCommentsLocation = EpaLocation' NoComments
+ GHC.Types.Tickish: [breakpointModule] :: GenTickish pass -> Module
+ GHC.Types.Unique.DFM: instance forall k (key :: k) ele. (Data.Typeable.Internal.Typeable key, Data.Typeable.Internal.Typeable k, Data.Data.Data ele) => Data.Data.Data (GHC.Types.Unique.DFM.UniqDFM key ele)
+ GHC.Types.Unique.DFM: instance forall k (key :: k). Data.Foldable.Foldable (GHC.Types.Unique.DFM.UniqDFM key)
+ GHC.Types.Unique.DFM: instance forall k (key :: k). Data.Traversable.Traversable (GHC.Types.Unique.DFM.UniqDFM key)
+ GHC.Types.Unique.DFM: instance forall k (key :: k). GHC.Base.Functor (GHC.Types.Unique.DFM.UniqDFM key)
+ GHC.Types.Unique.DFM: instance forall k a (key :: k). GHC.Utils.Outputable.Outputable a => GHC.Utils.Outputable.Outputable (GHC.Types.Unique.DFM.UniqDFM key a)
+ GHC.Types.Unique.FM: diffUFM :: Eq a => UniqFM key a -> UniqFM key a -> UniqFM key (Edit a)
+ GHC.Types.Unique.FM: instance GHC.Classes.Eq a => GHC.Classes.Eq (GHC.Types.Unique.FM.Edit a)
+ GHC.Types.Unique.FM: instance GHC.Utils.Outputable.Outputable a => GHC.Utils.Outputable.Outputable (GHC.Types.Unique.FM.Edit a)
+ GHC.Types.Unique.FM: instance forall k (key :: k) a. GHC.Base.Monoid (GHC.Types.Unique.FM.UniqFM key a)
+ GHC.Types.Unique.FM: instance forall k (key :: k) a. GHC.Base.Semigroup (GHC.Types.Unique.FM.UniqFM key a)
+ GHC.Types.Unique.FM: instance forall k (key :: k) ele. (Data.Typeable.Internal.Typeable key, Data.Typeable.Internal.Typeable k, Data.Data.Data ele) => Data.Data.Data (GHC.Types.Unique.FM.UniqFM key ele)
+ GHC.Types.Unique.FM: instance forall k (key :: k) ele. GHC.Classes.Eq ele => GHC.Classes.Eq (GHC.Types.Unique.FM.UniqFM key ele)
+ GHC.Types.Unique.FM: instance forall k (key :: k). Data.Foldable.Foldable (GHC.Types.Unique.FM.NonDetUniqFM key)
+ GHC.Types.Unique.FM: instance forall k (key :: k). Data.Traversable.Traversable (GHC.Types.Unique.FM.NonDetUniqFM key)
+ GHC.Types.Unique.FM: instance forall k (key :: k). GHC.Base.Functor (GHC.Types.Unique.FM.NonDetUniqFM key)
+ GHC.Types.Unique.FM: instance forall k (key :: k). GHC.Base.Functor (GHC.Types.Unique.FM.UniqFM key)
+ GHC.Types.Unique.FM: instance forall k a (key :: k). GHC.Utils.Outputable.Outputable a => GHC.Utils.Outputable.Outputable (GHC.Types.Unique.FM.UniqFM key a)
+ GHC.Types.Var: Exported :: ExportFlag
+ GHC.Types.Var: NotExported :: ExportFlag
+ GHC.Types.Var: coreTyLamForAllTyFlag :: ForAllTyFlag
+ GHC.Types.Var: data ExportFlag
+ GHC.Types.Var: instance Control.DeepSeq.NFData GHC.Types.Var.ForAllTyFlag
+ GHC.Types.Var: instance Control.DeepSeq.NFData GHC.Types.Var.Specificity
+ GHC.Types.Var: isInvisibleForAllTyBinder :: ForAllTyBinder -> Bool
+ GHC.Types.Var: isLocalId_maybe :: Var -> Maybe ExportFlag
+ GHC.Types.Var: isSpecifiedForAllTyFlag :: ForAllTyFlag -> Bool
+ GHC.Types.Var: isVisibleForAllTyBinder :: ForAllTyBinder -> Bool
+ GHC.Unit.Module.Warnings: instance GHC.Classes.Eq (Language.Haskell.Syntax.Extension.IdP pass) => GHC.Classes.Eq (GHC.Unit.Module.Warnings.WarningTxt pass)
+ GHC.Unit.Module.Warnings: type LWarningTxt pass = XRec pass (WarningTxt pass)
+ GHC.Unit.Types: experimentalUnit :: Unit
+ GHC.Unit.Types: ghcInternalUnit :: Unit
+ GHC.Unit.Types: ghcInternalUnitId :: UnitId
+ GHC.Utils.Binary: getByteString :: BinHandle -> Int -> IO ByteString
+ GHC.Utils.Binary: instance GHC.Utils.Binary.Binary GHC.Utils.Outputable.JoinPointHood
+ GHC.Utils.Binary: putByteString :: BinHandle -> ByteString -> IO ()
+ GHC.Utils.Logger: [log_diagnostics_as_json] :: LogFlags -> !Bool
+ GHC.Utils.Logger: defaultLogJsonAction :: LogJsonAction
+ GHC.Utils.Logger: logJsonMsg :: ToJson a => Logger -> MessageClass -> a -> IO ()
+ GHC.Utils.Logger: popJsonLogHook :: Logger -> Logger
+ GHC.Utils.Logger: pushJsonLogHook :: (LogJsonAction -> LogJsonAction) -> Logger -> Logger
+ GHC.Utils.Logger: type LogJsonAction = LogFlags -> MessageClass -> JsonDoc -> IO ()
+ GHC.Utils.Misc: partitionWithM :: Monad m => (a -> m (Either b c)) -> [a] -> m ([b], [c])
+ GHC.Utils.Outputable: JoinPoint :: {-# UNPACK #-} !Int -> JoinPointHood
+ GHC.Utils.Outputable: NotJoinPoint :: JoinPointHood
+ GHC.Utils.Outputable: [sdocPrintErrIndexLinks] :: SDocContext -> !Bool
+ GHC.Utils.Outputable: data JoinPointHood
+ GHC.Utils.Outputable: instance Control.DeepSeq.NFData GHC.Utils.Outputable.JoinPointHood
+ GHC.Utils.Outputable: instance GHC.Classes.Eq GHC.Utils.Outputable.JoinPointHood
+ GHC.Utils.Outputable: instance GHC.Utils.Outputable.Outputable GHC.Utils.Outputable.JoinPointHood
+ GHC.Utils.Outputable: isJoinPoint :: JoinPointHood -> Bool
+ GHC.Utils.Outputable: quoteIfPunsEnabled :: SDoc -> SDoc
+ GHC.Utils.Trace: warnPprTraceM :: (Applicative f, HasCallStack) => Bool -> String -> SDoc -> f ()
+ GHCi.BinaryArray: getArray :: (Binary i, Ix i, MArray IOUArray a IO) => Get (UArray i a)
+ GHCi.BinaryArray: putArray :: Binary i => UArray i a -> Put
+ GHCi.Message: EvalBreakpoint :: Int -> String -> EvalBreakpoint
+ GHCi.Message: data EvalBreakpoint
+ GHCi.Message: instance Data.Binary.Class.Binary GHCi.Message.EvalBreakpoint
+ GHCi.Message: instance GHC.Generics.Generic GHCi.Message.EvalBreakpoint
+ GHCi.Message: instance GHC.Show.Show GHCi.Message.EvalBreakpoint
+ GHCi.RemoteTypes: instance forall k (a :: k). Control.DeepSeq.NFData (GHCi.RemoteTypes.ForeignRef a)
+ GHCi.RemoteTypes: instance forall k (a :: k). Control.DeepSeq.NFData (GHCi.RemoteTypes.RemotePtr a)
+ GHCi.RemoteTypes: instance forall k (a :: k). Data.Binary.Class.Binary (GHCi.RemoteTypes.RemotePtr a)
+ GHCi.RemoteTypes: instance forall k (a :: k). Data.Binary.Class.Binary (GHCi.RemoteTypes.RemoteRef a)
+ GHCi.RemoteTypes: instance forall k (a :: k). GHC.Show.Show (GHCi.RemoteTypes.RemotePtr a)
+ GHCi.RemoteTypes: instance forall k (a :: k). GHC.Show.Show (GHCi.RemoteTypes.RemoteRef a)
+ GHCi.ResolvedBCO: ResolvedBCO :: Bool -> {-# UNPACK #-} !Int -> UArray Int Word16 -> UArray Int Word64 -> UArray Int Word64 -> SizedSeq ResolvedBCOPtr -> ResolvedBCO
+ GHCi.ResolvedBCO: ResolvedBCOPtr :: {-# UNPACK #-} !RemoteRef HValue -> ResolvedBCOPtr
+ GHCi.ResolvedBCO: ResolvedBCOPtrBCO :: ResolvedBCO -> ResolvedBCOPtr
+ GHCi.ResolvedBCO: ResolvedBCOPtrBreakArray :: {-# UNPACK #-} !RemoteRef BreakArray -> ResolvedBCOPtr
+ GHCi.ResolvedBCO: ResolvedBCORef :: {-# UNPACK #-} !Int -> ResolvedBCOPtr
+ GHCi.ResolvedBCO: ResolvedBCOStaticPtr :: {-# UNPACK #-} !RemotePtr () -> ResolvedBCOPtr
+ GHCi.ResolvedBCO: [resolvedBCOArity] :: ResolvedBCO -> {-# UNPACK #-} !Int
+ GHCi.ResolvedBCO: [resolvedBCOBitmap] :: ResolvedBCO -> UArray Int Word64
+ GHCi.ResolvedBCO: [resolvedBCOInstrs] :: ResolvedBCO -> UArray Int Word16
+ GHCi.ResolvedBCO: [resolvedBCOIsLE] :: ResolvedBCO -> Bool
+ GHCi.ResolvedBCO: [resolvedBCOLits] :: ResolvedBCO -> UArray Int Word64
+ GHCi.ResolvedBCO: [resolvedBCOPtrs] :: ResolvedBCO -> SizedSeq ResolvedBCOPtr
+ GHCi.ResolvedBCO: data ResolvedBCO
+ GHCi.ResolvedBCO: data ResolvedBCOPtr
+ GHCi.ResolvedBCO: instance Data.Binary.Class.Binary GHCi.ResolvedBCO.ResolvedBCO
+ GHCi.ResolvedBCO: instance Data.Binary.Class.Binary GHCi.ResolvedBCO.ResolvedBCOPtr
+ GHCi.ResolvedBCO: instance GHC.Generics.Generic GHCi.ResolvedBCO.ResolvedBCO
+ GHCi.ResolvedBCO: instance GHC.Generics.Generic GHCi.ResolvedBCO.ResolvedBCOPtr
+ GHCi.ResolvedBCO: instance GHC.Show.Show GHCi.ResolvedBCO.ResolvedBCO
+ GHCi.ResolvedBCO: instance GHC.Show.Show GHCi.ResolvedBCO.ResolvedBCOPtr
+ GHCi.ResolvedBCO: isLittleEndian :: Bool
+ GHCi.TH.Binary: instance Data.Binary.Class.Binary Language.Haskell.TH.Syntax.NamespaceSpecifier
+ Language.Haskell.Syntax.Binds: HsMultAnn :: !XMultAnn pass -> LHsType (NoGhcTc pass) -> HsMultAnn pass
+ Language.Haskell.Syntax.Binds: HsNoMultAnn :: !XNoMultAnn pass -> HsMultAnn pass
+ Language.Haskell.Syntax.Binds: HsPct1Ann :: !XPct1Ann pass -> HsMultAnn pass
+ Language.Haskell.Syntax.Binds: XMultAnn :: !XXMultAnn pass -> HsMultAnn pass
+ Language.Haskell.Syntax.Binds: [pat_mult] :: HsBindLR idL idR -> HsMultAnn idL
+ Language.Haskell.Syntax.Binds: data HsMultAnn pass
+ Language.Haskell.Syntax.Binds: type family XXMultAnn p
+ Language.Haskell.Syntax.Decls: XConDeclGADTDetails :: !XXConDeclGADTDetails pass -> HsConDeclGADTDetails pass
+ Language.Haskell.Syntax.Decls: type HsFamEqnPats pass = [LHsTypeArg pass]
+ Language.Haskell.Syntax.Decls: type family XXConDeclGADTDetails p
+ Language.Haskell.Syntax.Expr: ArrowLamAlt :: HsLamVariant -> HsArrowMatchContext
+ Language.Haskell.Syntax.Expr: HsEmbTy :: XEmbTy p -> LHsWcType (NoGhcTc p) -> HsExpr p
+ Language.Haskell.Syntax.Expr: LamAlt :: HsLamVariant -> HsMatchContext fn
+ Language.Haskell.Syntax.Expr: LamSingle :: HsLamVariant
+ Language.Haskell.Syntax.Expr: LazyPatCtx :: HsMatchContext fn
+ Language.Haskell.Syntax.Expr: data HsLamVariant
+ Language.Haskell.Syntax.Expr: instance Data.Data.Data Language.Haskell.Syntax.Expr.HsDoFlavour
+ Language.Haskell.Syntax.Expr: instance Data.Data.Data Language.Haskell.Syntax.Expr.HsLamVariant
+ Language.Haskell.Syntax.Expr: instance GHC.Classes.Eq Language.Haskell.Syntax.Expr.HsDoFlavour
+ Language.Haskell.Syntax.Expr: instance GHC.Classes.Eq Language.Haskell.Syntax.Expr.HsLamVariant
+ Language.Haskell.Syntax.ImpExp: type ExportDoc pass = LHsDoc pass
+ Language.Haskell.Syntax.Pat: EmbTyPat :: XEmbTyPat p -> HsTyPat (NoGhcTc p) -> Pat p
+ Language.Haskell.Syntax.Pat: InvisPat :: XInvisPat p -> HsTyPat (NoGhcTc p) -> Pat p
+ Language.Haskell.Syntax.Pat: hsConPatTyArgs :: forall p. HsConPatDetails p -> [HsConPatTyArg (NoGhcTc p)]
+ Language.Haskell.Syntax.Pat: isInvisArgPat :: Pat p -> Bool
+ Language.Haskell.Syntax.Pat: isVisArgPat :: Pat p -> Bool
+ Language.Haskell.Syntax.Type: HsTP :: XHsTP pass -> LHsType pass -> HsTyPat pass
+ Language.Haskell.Syntax.Type: XArg :: !XXArg p -> HsArg p tm ty
+ Language.Haskell.Syntax.Type: XArrow :: !XXArrow pass -> HsArrow pass
+ Language.Haskell.Syntax.Type: XHsTyPat :: !XXHsTyPat pass -> HsTyPat pass
+ Language.Haskell.Syntax.Type: XXBndrVis :: !XXBndrVis pass -> HsBndrVis pass
+ Language.Haskell.Syntax.Type: [hstp_body] :: HsTyPat pass -> LHsType pass
+ Language.Haskell.Syntax.Type: [hstp_ext] :: HsTyPat pass -> XHsTP pass
+ Language.Haskell.Syntax.Type: data HsTyPat pass
+ Language.Haskell.Syntax.Type: type LHsTyPat pass = XRec pass (HsTyPat pass)
+ Language.Haskell.Syntax.Type: type family XXArg p
+ Language.Haskell.TH: DataNamespaceSpecifier :: NamespaceSpecifier
+ Language.Haskell.TH: InvisP :: Type -> Pat
+ Language.Haskell.TH: ListTuplePuns :: Extension
+ Language.Haskell.TH: NoNamespaceSpecifier :: NamespaceSpecifier
+ Language.Haskell.TH: RequiredTypeArguments :: Extension
+ Language.Haskell.TH: SCCP :: Name -> Maybe String -> Pragma
+ Language.Haskell.TH: TypeE :: Type -> Exp
+ Language.Haskell.TH: TypeNamespaceSpecifier :: NamespaceSpecifier
+ Language.Haskell.TH: TypeP :: Type -> Pat
+ Language.Haskell.TH: data NamespaceSpecifier
+ Language.Haskell.TH.LanguageExtensions: ListTuplePuns :: Extension
+ Language.Haskell.TH.LanguageExtensions: RequiredTypeArguments :: Extension
+ Language.Haskell.TH.Lib: invisP :: Quote m => m Type -> m Pat
+ Language.Haskell.TH.Lib: typeE :: Quote m => m Type -> m Exp
+ Language.Haskell.TH.Lib: typeP :: Quote m => m Type -> m Pat
+ Language.Haskell.TH.Lib.Internal: infixLWithSpecD :: Quote m => Int -> NamespaceSpecifier -> Name -> m Dec
+ Language.Haskell.TH.Lib.Internal: infixNWithSpecD :: Quote m => Int -> NamespaceSpecifier -> Name -> m Dec
+ Language.Haskell.TH.Lib.Internal: infixRWithSpecD :: Quote m => Int -> NamespaceSpecifier -> Name -> m Dec
+ Language.Haskell.TH.Lib.Internal: invisP :: Quote m => m Type -> m Pat
+ Language.Haskell.TH.Lib.Internal: pragSCCFunD :: Quote m => Name -> m Dec
+ Language.Haskell.TH.Lib.Internal: pragSCCFunNamedD :: Quote m => Name -> String -> m Dec
+ Language.Haskell.TH.Lib.Internal: typeE :: Quote m => m Type -> m Exp
+ Language.Haskell.TH.Lib.Internal: typeP :: Quote m => m Type -> m Pat
+ Language.Haskell.TH.Ppr: pprNamespaceSpecifier :: NamespaceSpecifier -> Doc
+ Language.Haskell.TH.Syntax: DataNamespaceSpecifier :: NamespaceSpecifier
+ Language.Haskell.TH.Syntax: InvisP :: Type -> Pat
+ Language.Haskell.TH.Syntax: NoNamespaceSpecifier :: NamespaceSpecifier
+ Language.Haskell.TH.Syntax: SCCP :: Name -> Maybe String -> Pragma
+ Language.Haskell.TH.Syntax: TypeE :: Type -> Exp
+ Language.Haskell.TH.Syntax: TypeNamespaceSpecifier :: NamespaceSpecifier
+ Language.Haskell.TH.Syntax: TypeP :: Type -> Pat
+ Language.Haskell.TH.Syntax: data NamespaceSpecifier
+ Language.Haskell.TH.Syntax: instance Data.Data.Data Language.Haskell.TH.Syntax.NamespaceSpecifier
+ Language.Haskell.TH.Syntax: instance GHC.Classes.Eq Language.Haskell.TH.Syntax.NamespaceSpecifier
+ Language.Haskell.TH.Syntax: instance GHC.Classes.Ord Language.Haskell.TH.Syntax.NamespaceSpecifier
+ Language.Haskell.TH.Syntax: instance GHC.Generics.Generic Language.Haskell.TH.Syntax.NamespaceSpecifier
+ Language.Haskell.TH.Syntax: instance GHC.Show.Show Language.Haskell.TH.Syntax.NamespaceSpecifier
- GHC.ByteCode.Types: BCOPtrBreakArray :: BCOPtr
+ GHC.ByteCode.Types: BCOPtrBreakArray :: ForeignRef BreakArray -> BCOPtr
- GHC.CmmToLlvm.Config: LlvmCgConfig :: !Platform -> !SDocContext -> !Bool -> !Bool -> Maybe BmiVersion -> Maybe LlvmVersion -> !Bool -> !String -> !LlvmConfig -> LlvmCgConfig
+ GHC.CmmToLlvm.Config: LlvmCgConfig :: !Platform -> !SDocContext -> !Bool -> !Bool -> !Bool -> Maybe BmiVersion -> Maybe LlvmVersion -> !Bool -> !String -> !LlvmConfig -> LlvmCgConfig
- GHC.Core.Coercion: mkForAllCo :: TyCoVar -> CoercionN -> Coercion -> Coercion
+ GHC.Core.Coercion: mkForAllCo :: HasDebugCallStack => TyCoVar -> ForAllTyFlag -> ForAllTyFlag -> CoercionN -> Coercion -> Coercion
- GHC.Core.Coercion: mkHomoForAllCos :: [TyCoVar] -> Coercion -> Coercion
+ GHC.Core.Coercion: mkHomoForAllCos :: [ForAllTyBinder] -> Coercion -> Coercion
- GHC.Core.Coercion: promoteCoercion :: Coercion -> CoercionN
+ GHC.Core.Coercion: promoteCoercion :: HasDebugCallStack => Coercion -> CoercionN
- GHC.Core.Coercion: splitForAllCo_co_maybe :: Coercion -> Maybe (CoVar, Coercion, Coercion)
+ GHC.Core.Coercion: splitForAllCo_co_maybe :: Coercion -> Maybe (CoVar, ForAllTyFlag, ForAllTyFlag, Coercion, Coercion)
- GHC.Core.Coercion: splitForAllCo_maybe :: Coercion -> Maybe (TyCoVar, Coercion, Coercion)
+ GHC.Core.Coercion: splitForAllCo_maybe :: Coercion -> Maybe (TyCoVar, ForAllTyFlag, ForAllTyFlag, Coercion, Coercion)
- GHC.Core.Coercion: splitForAllCo_ty_maybe :: Coercion -> Maybe (TyVar, Coercion, Coercion)
+ GHC.Core.Coercion: splitForAllCo_ty_maybe :: Coercion -> Maybe (TyVar, ForAllTyFlag, ForAllTyFlag, Coercion, Coercion)
- GHC.Core.ConLike: conLikesWithFields :: [ConLike] -> [FieldLabelString] -> [ConLike]
+ GHC.Core.ConLike: conLikesWithFields :: [ConLike] -> [FieldLabelString] -> ([ConLike], [ConLike])
- GHC.Core.DataCon: mkDataCon :: Name -> Bool -> TyConRepName -> [HsSrcBang] -> [FieldLabel] -> [TyVar] -> [TyCoVar] -> [InvisTVBinder] -> [EqSpec] -> KnotTied ThetaType -> [KnotTied (Scaled Type)] -> KnotTied Type -> PromDataConInfo -> KnotTied TyCon -> ConTag -> ThetaType -> Id -> DataConRep -> DataCon
+ GHC.Core.DataCon: mkDataCon :: Name -> Bool -> TyConRepName -> [HsSrcBang] -> [FieldLabel] -> [TyVar] -> [TyCoVar] -> ConcreteTyVars -> [InvisTVBinder] -> [EqSpec] -> KnotTied ThetaType -> [KnotTied (Scaled Type)] -> KnotTied Type -> PromDataConInfo -> KnotTied TyCon -> ConTag -> ThetaType -> Id -> DataConRep -> DataCon
- GHC.Core.InstEnv: ClsInst :: Name -> [RoughMatchTc] -> Name -> [TyVar] -> Class -> [Type] -> DFunId -> OverlapFlag -> IsOrphan -> ClsInst
+ GHC.Core.InstEnv: ClsInst :: Name -> [RoughMatchTc] -> Name -> [TyVar] -> Class -> [Type] -> DFunId -> OverlapFlag -> IsOrphan -> Maybe (WarningTxt GhcRn) -> ClsInst
- GHC.Core.InstEnv: mkImportedClsInst :: Name -> [RoughMatchTc] -> Name -> DFunId -> OverlapFlag -> IsOrphan -> ClsInst
+ GHC.Core.InstEnv: mkImportedClsInst :: Name -> [RoughMatchTc] -> Name -> DFunId -> OverlapFlag -> IsOrphan -> Maybe (WarningTxt GhcRn) -> ClsInst
- GHC.Core.InstEnv: mkLocalClsInst :: DFunId -> OverlapFlag -> [TyVar] -> Class -> [Type] -> ClsInst
+ GHC.Core.InstEnv: mkLocalClsInst :: DFunId -> OverlapFlag -> [TyVar] -> Class -> [Type] -> Maybe (WarningTxt GhcRn) -> ClsInst
- GHC.Core.Make: mkBigCoreTupTy :: [Type] -> Type
+ GHC.Core.Make: mkBigCoreTupTy :: HasDebugCallStack => [Type] -> Type
- GHC.Core.Make: mkBigCoreVarTupTy :: [Id] -> Type
+ GHC.Core.Make: mkBigCoreVarTupTy :: HasDebugCallStack => [Id] -> Type
- GHC.Core.Opt.Arity: exprEtaExpandArity :: HasDebugCallStack => ArityOpts -> CoreExpr -> Maybe SafeArityType
+ GHC.Core.Opt.Arity: exprEtaExpandArity :: ArityOpts -> CoreExpr -> Maybe SafeArityType
- GHC.Core.Opt.Simplify.Env: DoneEx :: OutExpr -> Maybe JoinArity -> SimplSR
+ GHC.Core.Opt.Simplify.Env: DoneEx :: OutExpr -> JoinPointHood -> SimplSR
- GHC.Core.Opt.Simplify.Utils: FromBeta :: OutType -> FromWhat
+ GHC.Core.Opt.Simplify.Utils: FromBeta :: Levity -> FromWhat
- GHC.Core.TyCo.Rep: ForAllCo :: TyCoVar -> KindCoercion -> Coercion -> Coercion
+ GHC.Core.TyCo.Rep: ForAllCo :: TyCoVar -> !ForAllTyFlag -> !ForAllTyFlag -> KindCoercion -> Coercion -> Coercion
- GHC.Core.TyCo.Rep: Invisible :: Specificity -> ForAllTyFlag
+ GHC.Core.TyCo.Rep: Invisible :: !Specificity -> ForAllTyFlag
- GHC.Core.TyCo.Rep: mkPiTy :: PiTyBinder -> Type -> Type
+ GHC.Core.TyCo.Rep: mkPiTy :: HasDebugCallStack => PiTyBinder -> Type -> Type
- GHC.Core.TyCo.Rep: mkPiTys :: [PiTyBinder] -> Type -> Type
+ GHC.Core.TyCo.Rep: mkPiTys :: HasDebugCallStack => [PiTyBinder] -> Type -> Type
- GHC.Core.TyCo.Subst: substTyAddInScope :: Subst -> Type -> Type
+ GHC.Core.TyCo.Subst: substTyAddInScope :: HasDebugCallStack => Subst -> Type -> Type
- GHC.Core.TyCo.Subst: substTyWithInScope :: InScopeSet -> [TyVar] -> [Type] -> Type -> Type
+ GHC.Core.TyCo.Subst: substTyWithInScope :: HasDebugCallStack => InScopeSet -> [TyVar] -> [Type] -> Type -> Type
- GHC.Core.TyCo.Subst: substTysWith :: [TyVar] -> [Type] -> [Type] -> [Type]
+ GHC.Core.TyCo.Subst: substTysWith :: HasDebugCallStack => [TyVar] -> [Type] -> [Type] -> [Type]
- GHC.Core.TyCo.Subst: substTysWithCoVars :: [CoVar] -> [Coercion] -> [Type] -> [Type]
+ GHC.Core.TyCo.Subst: substTysWithCoVars :: HasDebugCallStack => [CoVar] -> [Coercion] -> [Type] -> [Type]
- GHC.Core.TyCon: VoidRep :: PrimRep
+ GHC.Core.TyCon: VoidRep :: PrimOrVoidRep
- GHC.Core.Type: Invisible :: Specificity -> ForAllTyFlag
+ GHC.Core.Type: Invisible :: !Specificity -> ForAllTyFlag
- GHC.Core.Type: funArgTy :: Type -> Type
+ GHC.Core.Type: funArgTy :: HasDebugCallStack => Type -> Type
- GHC.Core.Type: mkPiTy :: PiTyBinder -> Type -> Type
+ GHC.Core.Type: mkPiTy :: HasDebugCallStack => PiTyBinder -> Type -> Type
- GHC.Core.Type: mkPiTys :: [PiTyBinder] -> Type -> Type
+ GHC.Core.Type: mkPiTys :: HasDebugCallStack => [PiTyBinder] -> Type -> Type
- GHC.Core.Type: splitAppTys :: Type -> (Type, [Type])
+ GHC.Core.Type: splitAppTys :: HasDebugCallStack => Type -> (Type, [Type])
- GHC.Core.Type: splitTyConAppNoView_maybe :: Type -> Maybe (TyCon, [Type])
+ GHC.Core.Type: splitTyConAppNoView_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type])
- GHC.Core.Type: substTyAddInScope :: Subst -> Type -> Type
+ GHC.Core.Type: substTyAddInScope :: HasDebugCallStack => Subst -> Type -> Type
- GHC.Core.Type: substTysWith :: [TyVar] -> [Type] -> [Type] -> [Type]
+ GHC.Core.Type: substTysWith :: HasDebugCallStack => [TyVar] -> [Type] -> [Type] -> [Type]
- GHC.Core.Type: tcSplitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type])
+ GHC.Core.Type: tcSplitTyConApp_maybe :: HasCallStack => Type -> Maybe (TyCon, [Type])
- GHC.Core.Type: tyConAppArgs :: HasDebugCallStack => Type -> [Type]
+ GHC.Core.Type: tyConAppArgs :: HasCallStack => Type -> [Type]
- GHC.Core.Utils: needsCaseBinding :: Type -> CoreExpr -> Bool
+ GHC.Core.Utils: needsCaseBinding :: HasDebugCallStack => Type -> CoreExpr -> Bool
- GHC.CoreToIface: toIfaceTickish :: CoreTickish -> Maybe IfaceTickish
+ GHC.CoreToIface: toIfaceTickish :: CoreTickish -> IfaceTickish
- GHC.Data.Maybe: expectJust :: HasDebugCallStack => String -> Maybe a -> a
+ GHC.Data.Maybe: expectJust :: HasCallStack => String -> Maybe a -> a
- GHC.Driver.DynFlags: DynFlags :: GhcMode -> GhcLink -> !Backend -> {-# UNPACK #-} !GhcNameVersion -> {-# UNPACK #-} !FileSettings -> Platform -> {-# UNPACK #-} !ToolSettings -> {-# UNPACK #-} !PlatformMisc -> [(String, String)] -> TempDir -> Int -> Int -> Int -> Int -> Int -> Maybe String -> [Int] -> Maybe ParMakeCount -> Bool -> Maybe Int -> Maybe Int -> Maybe Int -> Maybe Int -> Maybe Int -> Int -> Int -> Int -> !Int -> Maybe Int -> Maybe Int -> Int -> Maybe Word -> Maybe Int -> Maybe Int -> Maybe Int -> Maybe Int -> Bool -> Maybe Int -> Int -> [FilePath] -> ModuleName -> Maybe String -> IntWithInf -> IntWithInf -> Int -> Int -> Int -> UnitId -> Maybe UnitId -> [(ModuleName, Module)] -> Maybe FilePath -> Maybe String -> Set ModuleName -> Set ModuleName -> Ways -> Maybe (String, Int) -> Maybe String -> Maybe String -> Maybe String -> Maybe String -> Maybe String -> Maybe String -> String -> String -> String -> String -> String -> String -> Maybe String -> Maybe String -> Maybe String -> Maybe String -> DynLibLoader -> !Bool -> FilePath -> Maybe FilePath -> [Option] -> IncludeSpecs -> [String] -> [String] -> [String] -> Maybe String -> RtsOptsEnabled -> Bool -> String -> [ModuleName] -> [(ModuleName, String)] -> [String] -> [ExternalPluginSpec] -> FilePath -> Bool -> Bool -> [ModuleName] -> [String] -> [PackageDBFlag] -> [IgnorePackageFlag] -> [PackageFlag] -> [PackageFlag] -> [TrustFlag] -> Maybe FilePath -> EnumSet DumpFlag -> EnumSet GeneralFlag -> EnumSet WarningFlag -> EnumSet WarningFlag -> WarningCategorySet -> WarningCategorySet -> Maybe Language -> SafeHaskellMode -> Bool -> Bool -> SrcSpan -> SrcSpan -> SrcSpan -> SrcSpan -> SrcSpan -> SrcSpan -> SrcSpan -> SrcSpan -> SrcSpan -> [OnOff Extension] -> EnumSet Extension -> !UnfoldingOpts -> Int -> Int -> FlushOut -> Maybe FilePath -> Maybe String -> [String] -> Int -> Int -> Bool -> OverridingBool -> Bool -> Scheme -> ProfAuto -> [CallerCcFilter] -> Maybe String -> Maybe SseVersion -> Maybe BmiVersion -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> IORef (Maybe LinkerInfo) -> IORef (Maybe CompilerInfo) -> IORef (Maybe CompilerInfo) -> Int -> Int -> Int -> Bool -> Maybe Int -> Word64 -> Int -> Weights -> DynFlags
+ GHC.Driver.DynFlags: DynFlags :: GhcMode -> GhcLink -> !Backend -> {-# UNPACK #-} !GhcNameVersion -> {-# UNPACK #-} !FileSettings -> Platform -> {-# UNPACK #-} !ToolSettings -> {-# UNPACK #-} !PlatformMisc -> [(String, String)] -> TempDir -> Int -> Int -> Int -> Int -> Int -> Maybe String -> [Int] -> Maybe ParMakeCount -> Bool -> Maybe Int -> Maybe Int -> Maybe Int -> Maybe Int -> Maybe Int -> Int -> Int -> Int -> !Int -> Maybe Int -> Maybe Int -> Int -> Maybe Word -> Maybe Int -> Maybe Int -> Maybe Int -> Maybe Int -> Bool -> Maybe Int -> Int -> [FilePath] -> ModuleName -> Maybe String -> IntWithInf -> IntWithInf -> Int -> Int -> Int -> UnitId -> Maybe UnitId -> [(ModuleName, Module)] -> Maybe FilePath -> Maybe String -> Set ModuleName -> Set ModuleName -> Ways -> Maybe (String, Int) -> Maybe String -> Maybe String -> Maybe String -> Maybe String -> Maybe String -> Maybe String -> String -> String -> String -> String -> String -> String -> Maybe String -> Maybe String -> Maybe String -> Maybe String -> DynLibLoader -> !Bool -> FilePath -> Maybe FilePath -> [Option] -> IncludeSpecs -> [String] -> [String] -> [String] -> Maybe String -> RtsOptsEnabled -> Bool -> String -> [ModuleName] -> [(ModuleName, String)] -> [String] -> [ExternalPluginSpec] -> FilePath -> Bool -> Bool -> [ModuleName] -> [String] -> [PackageDBFlag] -> [IgnorePackageFlag] -> [PackageFlag] -> [PackageFlag] -> [TrustFlag] -> Maybe FilePath -> EnumSet DumpFlag -> EnumSet GeneralFlag -> EnumSet WarningFlag -> EnumSet WarningFlag -> WarningCategorySet -> WarningCategorySet -> Maybe Language -> SafeHaskellMode -> Bool -> Bool -> SrcSpan -> SrcSpan -> SrcSpan -> SrcSpan -> SrcSpan -> SrcSpan -> SrcSpan -> SrcSpan -> SrcSpan -> [OnOff Extension] -> EnumSet Extension -> !UnfoldingOpts -> Int -> Int -> FlushOut -> Maybe FilePath -> Maybe String -> [String] -> Int -> Int -> Bool -> OverridingBool -> Bool -> OverridingBool -> Bool -> Scheme -> ProfAuto -> [CallerCcFilter] -> Maybe String -> Maybe SseVersion -> Maybe BmiVersion -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Int -> Int -> Int -> Bool -> Maybe Int -> Word64 -> Int -> Weights -> DynFlags
- GHC.Driver.Plugins: Plugin :: CorePlugin -> TcPlugin -> DefaultingPlugin -> HoleFitPlugin -> ([CommandLineOption] -> HscEnv -> IO HscEnv) -> ([CommandLineOption] -> IO PluginRecompile) -> ([CommandLineOption] -> ModSummary -> ParsedResult -> Hsc ParsedResult) -> ([CommandLineOption] -> TcGblEnv -> HsGroup GhcRn -> TcM (TcGblEnv, HsGroup GhcRn)) -> ([CommandLineOption] -> ModSummary -> TcGblEnv -> TcM TcGblEnv) -> ([CommandLineOption] -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc)) -> (forall lcl. [CommandLineOption] -> ModIface -> IfM lcl ModIface) -> Plugin
+ GHC.Driver.Plugins: Plugin :: CorePlugin -> TcPlugin -> DefaultingPlugin -> HoleFitPlugin -> ([CommandLineOption] -> HscEnv -> IO HscEnv) -> LatePlugin -> ([CommandLineOption] -> IO PluginRecompile) -> ([CommandLineOption] -> ModSummary -> ParsedResult -> Hsc ParsedResult) -> ([CommandLineOption] -> TcGblEnv -> HsGroup GhcRn -> TcM (TcGblEnv, HsGroup GhcRn)) -> ([CommandLineOption] -> ModSummary -> TcGblEnv -> TcM TcGblEnv) -> ([CommandLineOption] -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc)) -> (forall lcl. [CommandLineOption] -> ModIface -> IfM lcl ModIface) -> Plugin
- GHC.Driver.Session: DynFlags :: GhcMode -> GhcLink -> !Backend -> {-# UNPACK #-} !GhcNameVersion -> {-# UNPACK #-} !FileSettings -> Platform -> {-# UNPACK #-} !ToolSettings -> {-# UNPACK #-} !PlatformMisc -> [(String, String)] -> TempDir -> Int -> Int -> Int -> Int -> Int -> Maybe String -> [Int] -> Maybe ParMakeCount -> Bool -> Maybe Int -> Maybe Int -> Maybe Int -> Maybe Int -> Maybe Int -> Int -> Int -> Int -> !Int -> Maybe Int -> Maybe Int -> Int -> Maybe Word -> Maybe Int -> Maybe Int -> Maybe Int -> Maybe Int -> Bool -> Maybe Int -> Int -> [FilePath] -> ModuleName -> Maybe String -> IntWithInf -> IntWithInf -> Int -> Int -> Int -> UnitId -> Maybe UnitId -> [(ModuleName, Module)] -> Maybe FilePath -> Maybe String -> Set ModuleName -> Set ModuleName -> Ways -> Maybe (String, Int) -> Maybe String -> Maybe String -> Maybe String -> Maybe String -> Maybe String -> Maybe String -> String -> String -> String -> String -> String -> String -> Maybe String -> Maybe String -> Maybe String -> Maybe String -> DynLibLoader -> !Bool -> FilePath -> Maybe FilePath -> [Option] -> IncludeSpecs -> [String] -> [String] -> [String] -> Maybe String -> RtsOptsEnabled -> Bool -> String -> [ModuleName] -> [(ModuleName, String)] -> [String] -> [ExternalPluginSpec] -> FilePath -> Bool -> Bool -> [ModuleName] -> [String] -> [PackageDBFlag] -> [IgnorePackageFlag] -> [PackageFlag] -> [PackageFlag] -> [TrustFlag] -> Maybe FilePath -> EnumSet DumpFlag -> EnumSet GeneralFlag -> EnumSet WarningFlag -> EnumSet WarningFlag -> WarningCategorySet -> WarningCategorySet -> Maybe Language -> SafeHaskellMode -> Bool -> Bool -> SrcSpan -> SrcSpan -> SrcSpan -> SrcSpan -> SrcSpan -> SrcSpan -> SrcSpan -> SrcSpan -> SrcSpan -> [OnOff Extension] -> EnumSet Extension -> !UnfoldingOpts -> Int -> Int -> FlushOut -> Maybe FilePath -> Maybe String -> [String] -> Int -> Int -> Bool -> OverridingBool -> Bool -> Scheme -> ProfAuto -> [CallerCcFilter] -> Maybe String -> Maybe SseVersion -> Maybe BmiVersion -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> IORef (Maybe LinkerInfo) -> IORef (Maybe CompilerInfo) -> IORef (Maybe CompilerInfo) -> Int -> Int -> Int -> Bool -> Maybe Int -> Word64 -> Int -> Weights -> DynFlags
+ GHC.Driver.Session: DynFlags :: GhcMode -> GhcLink -> !Backend -> {-# UNPACK #-} !GhcNameVersion -> {-# UNPACK #-} !FileSettings -> Platform -> {-# UNPACK #-} !ToolSettings -> {-# UNPACK #-} !PlatformMisc -> [(String, String)] -> TempDir -> Int -> Int -> Int -> Int -> Int -> Maybe String -> [Int] -> Maybe ParMakeCount -> Bool -> Maybe Int -> Maybe Int -> Maybe Int -> Maybe Int -> Maybe Int -> Int -> Int -> Int -> !Int -> Maybe Int -> Maybe Int -> Int -> Maybe Word -> Maybe Int -> Maybe Int -> Maybe Int -> Maybe Int -> Bool -> Maybe Int -> Int -> [FilePath] -> ModuleName -> Maybe String -> IntWithInf -> IntWithInf -> Int -> Int -> Int -> UnitId -> Maybe UnitId -> [(ModuleName, Module)] -> Maybe FilePath -> Maybe String -> Set ModuleName -> Set ModuleName -> Ways -> Maybe (String, Int) -> Maybe String -> Maybe String -> Maybe String -> Maybe String -> Maybe String -> Maybe String -> String -> String -> String -> String -> String -> String -> Maybe String -> Maybe String -> Maybe String -> Maybe String -> DynLibLoader -> !Bool -> FilePath -> Maybe FilePath -> [Option] -> IncludeSpecs -> [String] -> [String] -> [String] -> Maybe String -> RtsOptsEnabled -> Bool -> String -> [ModuleName] -> [(ModuleName, String)] -> [String] -> [ExternalPluginSpec] -> FilePath -> Bool -> Bool -> [ModuleName] -> [String] -> [PackageDBFlag] -> [IgnorePackageFlag] -> [PackageFlag] -> [PackageFlag] -> [TrustFlag] -> Maybe FilePath -> EnumSet DumpFlag -> EnumSet GeneralFlag -> EnumSet WarningFlag -> EnumSet WarningFlag -> WarningCategorySet -> WarningCategorySet -> Maybe Language -> SafeHaskellMode -> Bool -> Bool -> SrcSpan -> SrcSpan -> SrcSpan -> SrcSpan -> SrcSpan -> SrcSpan -> SrcSpan -> SrcSpan -> SrcSpan -> [OnOff Extension] -> EnumSet Extension -> !UnfoldingOpts -> Int -> Int -> FlushOut -> Maybe FilePath -> Maybe String -> [String] -> Int -> Int -> Bool -> OverridingBool -> Bool -> OverridingBool -> Bool -> Scheme -> ProfAuto -> [CallerCcFilter] -> Maybe String -> Maybe SseVersion -> Maybe BmiVersion -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Int -> Int -> Int -> Bool -> Maybe Int -> Word64 -> Int -> Weights -> DynFlags
- GHC.Hs: AnnsModule :: [AddEpAnn] -> [TrailingAnn] -> Maybe (RealSrcSpan, RealSrcSpan) -> AnnsModule
+ GHC.Hs: AnnsModule :: [AddEpAnn] -> [TrailingAnn] -> [LEpaComment] -> Maybe (RealSrcSpan, RealSrcSpan) -> AnnsModule
- GHC.Hs: XModulePs :: EpAnn AnnsModule -> LayoutInfo GhcPs -> Maybe (LocatedP (WarningTxt GhcPs)) -> Maybe (LHsDoc GhcPs) -> XModulePs
+ GHC.Hs: XModulePs :: EpAnn AnnsModule -> EpLayout -> Maybe (LWarningTxt GhcPs) -> Maybe (LHsDoc GhcPs) -> XModulePs
- GHC.Hs: [hsmodDeprecMessage] :: XModulePs -> Maybe (LocatedP (WarningTxt GhcPs))
+ GHC.Hs: [hsmodDeprecMessage] :: XModulePs -> Maybe (LWarningTxt GhcPs)
- GHC.Hs: [hsmodLayout] :: XModulePs -> LayoutInfo GhcPs
+ GHC.Hs: [hsmodLayout] :: XModulePs -> EpLayout
- GHC.Hs.Decls: ClassDecl :: XClassDecl pass -> !LayoutInfo pass -> Maybe (LHsContext pass) -> LIdP pass -> LHsQTyVars pass -> LexicalFixity -> [LHsFunDep pass] -> [LSig pass] -> LHsBinds pass -> [LFamilyDecl pass] -> [LTyFamDefltDecl pass] -> [LDocDecl pass] -> TyClDecl pass
+ GHC.Hs.Decls: ClassDecl :: XClassDecl pass -> Maybe (LHsContext pass) -> LIdP pass -> LHsQTyVars pass -> LexicalFixity -> [LHsFunDep pass] -> [LSig pass] -> LHsBinds pass -> [LFamilyDecl pass] -> [LTyFamDefltDecl pass] -> [LDocDecl pass] -> TyClDecl pass
- GHC.Hs.Decls: ConDeclGADT :: XConDeclGADT pass -> NonEmpty (LIdP pass) -> !LHsUniToken "::" "∷" pass -> XRec pass (HsOuterSigTyVarBndrs pass) -> Maybe (LHsContext pass) -> HsConDeclGADTDetails pass -> LHsType pass -> Maybe (LHsDoc pass) -> ConDecl pass
+ GHC.Hs.Decls: ConDeclGADT :: XConDeclGADT pass -> NonEmpty (LIdP pass) -> XRec pass (HsOuterSigTyVarBndrs pass) -> Maybe (LHsContext pass) -> HsConDeclGADTDetails pass -> LHsType pass -> Maybe (LHsDoc pass) -> ConDecl pass
- GHC.Hs.Decls: FamEqn :: XCFamEqn pass rhs -> LIdP pass -> HsOuterFamEqnTyVarBndrs pass -> HsTyPats pass -> LexicalFixity -> rhs -> FamEqn pass rhs
+ GHC.Hs.Decls: FamEqn :: XCFamEqn pass rhs -> LIdP pass -> HsOuterFamEqnTyVarBndrs pass -> HsFamEqnPats pass -> LexicalFixity -> rhs -> FamEqn pass rhs
- GHC.Hs.Decls: PrefixConGADT :: [HsScaled pass (LBangType pass)] -> HsConDeclGADTDetails pass
+ GHC.Hs.Decls: PrefixConGADT :: !XPrefixConGADT pass -> [HsScaled pass (LBangType pass)] -> HsConDeclGADTDetails pass
- GHC.Hs.Decls: RecConGADT :: XRec pass [LConDeclField pass] -> LHsUniToken "->" "→" pass -> HsConDeclGADTDetails pass
+ GHC.Hs.Decls: RecConGADT :: !XRecConGADT pass -> XRec pass [LConDeclField pass] -> HsConDeclGADTDetails pass
- GHC.Hs.Decls: XViaStrategyPs :: EpAnn [AddEpAnn] -> LHsSigType GhcPs -> XViaStrategyPs
+ GHC.Hs.Decls: XViaStrategyPs :: [AddEpAnn] -> LHsSigType GhcPs -> XViaStrategyPs
- GHC.Hs.Decls: [feqn_pats] :: FamEqn pass rhs -> HsTyPats pass
+ GHC.Hs.Decls: [feqn_pats] :: FamEqn pass rhs -> HsFamEqnPats pass
- GHC.Hs.Decls: pprHsFamInstLHS :: OutputableBndrId p => IdP (GhcPass p) -> HsOuterFamEqnTyVarBndrs (GhcPass p) -> HsTyPats (GhcPass p) -> LexicalFixity -> Maybe (LHsContext (GhcPass p)) -> SDoc
+ GHC.Hs.Decls: pprHsFamInstLHS :: OutputableBndrId p => IdP (GhcPass p) -> HsOuterFamEqnTyVarBndrs (GhcPass p) -> HsFamEqnPats (GhcPass p) -> LexicalFixity -> Maybe (LHsContext (GhcPass p)) -> SDoc
- GHC.Hs.Doc: Docs :: Maybe (HsDoc GhcRn) -> UniqMap Name [HsDoc GhcRn] -> UniqMap Name (IntMap (HsDoc GhcRn)) -> DocStructure -> Map String (HsDoc GhcRn) -> Maybe String -> Maybe Language -> EnumSet Extension -> Docs
+ GHC.Hs.Doc: Docs :: Maybe (HsDoc GhcRn) -> UniqMap Name (HsDoc GhcRn) -> UniqMap Name [HsDoc GhcRn] -> UniqMap Name (IntMap (HsDoc GhcRn)) -> DocStructure -> Map String (HsDoc GhcRn) -> Maybe String -> Maybe Language -> EnumSet Extension -> Docs
- GHC.Hs.Expr: gHsPar :: LHsExpr (GhcPass id) -> HsExpr (GhcPass id)
+ GHC.Hs.Expr: gHsPar :: forall p. IsPass p => LHsExpr (GhcPass p) -> HsExpr (GhcPass p)
- GHC.Hs.Expr: lamCaseKeyword :: LamCaseVariant -> SDoc
+ GHC.Hs.Expr: lamCaseKeyword :: HsLamVariant -> SDoc
- GHC.Hs.Expr: matchContextErrString :: OutputableBndrId p => HsMatchContext (GhcPass p) -> SDoc
+ GHC.Hs.Expr: matchContextErrString :: Outputable fn => HsMatchContext fn -> SDoc
- GHC.Hs.Expr: matchSeparator :: HsMatchContext p -> SDoc
+ GHC.Hs.Expr: matchSeparator :: HsMatchContext fn -> SDoc
- GHC.Hs.Expr: pp_rhs :: Outputable body => HsMatchContext passL -> body -> SDoc
+ GHC.Hs.Expr: pp_rhs :: Outputable body => HsMatchContext fn -> body -> SDoc
- GHC.Hs.Expr: pprAStmtContext :: (Outputable (IdP (NoGhcTc p)), UnXRec (NoGhcTc p)) => HsStmtContext p -> SDoc
+ GHC.Hs.Expr: pprAStmtContext :: Outputable fn => HsStmtContext fn -> SDoc
- GHC.Hs.Expr: pprGRHS :: (OutputableBndrId idR, Outputable body) => HsMatchContext passL -> GRHS (GhcPass idR) body -> SDoc
+ GHC.Hs.Expr: pprGRHS :: (OutputableBndrId idR, Outputable body) => HsMatchContext fn -> GRHS (GhcPass idR) body -> SDoc
- GHC.Hs.Expr: pprGRHSs :: (OutputableBndrId idR, Outputable body) => HsMatchContext passL -> GRHSs (GhcPass idR) body -> SDoc
+ GHC.Hs.Expr: pprGRHSs :: (OutputableBndrId idR, Outputable body) => HsMatchContext fn -> GRHSs (GhcPass idR) body -> SDoc
- GHC.Hs.Expr: pprMatchContext :: (Outputable (IdP (NoGhcTc p)), UnXRec (NoGhcTc p)) => HsMatchContext p -> SDoc
+ GHC.Hs.Expr: pprMatchContext :: Outputable fn => HsMatchContext fn -> SDoc
- GHC.Hs.Expr: pprMatchContextNoun :: forall p. (Outputable (IdP (NoGhcTc p)), UnXRec (NoGhcTc p)) => HsMatchContext p -> SDoc
+ GHC.Hs.Expr: pprMatchContextNoun :: Outputable fn => HsMatchContext fn -> SDoc
- GHC.Hs.Expr: pprMatchContextNouns :: forall p. (Outputable (IdP (NoGhcTc p)), UnXRec (NoGhcTc p)) => HsMatchContext p -> SDoc
+ GHC.Hs.Expr: pprMatchContextNouns :: Outputable fn => HsMatchContext fn -> SDoc
- GHC.Hs.Expr: pprStmtContext :: (Outputable (IdP (NoGhcTc p)), UnXRec (NoGhcTc p)) => HsStmtContext p -> SDoc
+ GHC.Hs.Expr: pprStmtContext :: Outputable fn => HsStmtContext fn -> SDoc
- GHC.Hs.Expr: pprStmtInCtxt :: (OutputableBndrId idL, OutputableBndrId idR, OutputableBndrId ctx, Outputable body, Anno (StmtLR (GhcPass idL) (GhcPass idR) body) ~ SrcSpanAnnA) => HsStmtContext (GhcPass ctx) -> StmtLR (GhcPass idL) (GhcPass idR) body -> SDoc
+ GHC.Hs.Expr: pprStmtInCtxt :: (OutputableBndrId idL, OutputableBndrId idR, Outputable fn, Outputable body, Anno (StmtLR (GhcPass idL) (GhcPass idR) body) ~ SrcSpanAnnA) => HsStmtContext fn -> StmtLR (GhcPass idL) (GhcPass idR) body -> SDoc
- GHC.Hs.Expr: ppr_infix_expr_rn :: HsExpansion (HsExpr GhcRn) (HsExpr GhcRn) -> Maybe SDoc
+ GHC.Hs.Expr: ppr_infix_expr_rn :: XXExprGhcRn -> Maybe SDoc
- GHC.Hs.Extension: type IsSrcSpanAnn p a = (Anno (IdGhcP p) ~ SrcSpanAnn' (EpAnn a), IsPass p)
+ GHC.Hs.Extension: type IsSrcSpanAnn p a = (Anno (IdGhcP p) ~ EpAnn a, NoAnn a, IsPass p)
- GHC.Hs.Pat: AsPat :: XAsPat p -> LIdP p -> !LHsToken "@" p -> LPat p -> Pat p
+ GHC.Hs.Pat: AsPat :: XAsPat p -> LIdP p -> LPat p -> Pat p
- GHC.Hs.Pat: HsConPatTyArg :: !LHsToken "@" p -> HsPatSigType p -> HsConPatTyArg p
+ GHC.Hs.Pat: HsConPatTyArg :: !XConPatTyArg p -> HsTyPat p -> HsConPatTyArg p
- GHC.Hs.Pat: ParPat :: XParPat p -> !LHsToken "(" p -> LPat p -> !LHsToken ")" p -> Pat p
+ GHC.Hs.Pat: ParPat :: XParPat p -> LPat p -> Pat p
- GHC.Hs.Pat: gParPat :: LPat (GhcPass pass) -> Pat (GhcPass pass)
+ GHC.Hs.Pat: gParPat :: forall p. IsPass p => LPat (GhcPass p) -> Pat (GhcPass p)
- GHC.Hs.Type: HsAppKindTy :: XAppKindTy pass -> LHsType pass -> !LHsToken "@" pass -> LHsKind pass -> HsType pass
+ GHC.Hs.Type: HsAppKindTy :: XAppKindTy pass -> LHsType pass -> LHsKind pass -> HsType pass
- GHC.Hs.Type: HsArgPar :: SrcSpan -> HsArg p tm ty
+ GHC.Hs.Type: HsArgPar :: !XArgPar p -> HsArg p tm ty
- GHC.Hs.Type: HsBndrInvisible :: LHsToken "@" pass -> HsBndrVis pass
+ GHC.Hs.Type: HsBndrInvisible :: !XBndrInvisible pass -> HsBndrVis pass
- GHC.Hs.Type: HsBndrRequired :: HsBndrVis pass
+ GHC.Hs.Type: HsBndrRequired :: !XBndrRequired pass -> HsBndrVis pass
- GHC.Hs.Type: HsExplicitMult :: !LHsToken "%" pass -> !LHsType pass -> !LHsUniToken "->" "→" pass -> HsArrow pass
+ GHC.Hs.Type: HsExplicitMult :: !XExplicitMult pass -> !LHsType pass -> HsArrow pass
- GHC.Hs.Type: HsLinearArrow :: !HsLinearArrowTokens pass -> HsArrow pass
+ GHC.Hs.Type: HsLinearArrow :: !XLinearArrow pass -> HsArrow pass
- GHC.Hs.Type: HsTypeArg :: !LHsToken "@" p -> ty -> HsArg p tm ty
+ GHC.Hs.Type: HsTypeArg :: !XTypeArg p -> ty -> HsArg p tm ty
- GHC.Hs.Type: HsUnrestrictedArrow :: !LHsUniToken "->" "→" pass -> HsArrow pass
+ GHC.Hs.Type: HsUnrestrictedArrow :: !XUnrestrictedArrow pass -> HsArrow pass
- GHC.Hs.Type: HsValArg :: tm -> HsArg p tm ty
+ GHC.Hs.Type: HsValArg :: !XValArg p -> tm -> HsArg p tm ty
- GHC.Hs.Type: hsLinear :: a -> HsScaled (GhcPass p) a
+ GHC.Hs.Type: hsLinear :: forall p a. IsPass p => a -> HsScaled (GhcPass p) a
- GHC.Hs.Type: hsUnrestricted :: a -> HsScaled (GhcPass p) a
+ GHC.Hs.Type: hsUnrestricted :: forall p a. IsPass p => a -> HsScaled (GhcPass p) a
- GHC.Hs.Type: lhsTypeArgSrcSpan :: LHsTypeArg (GhcPass pass) -> SrcSpan
+ GHC.Hs.Type: lhsTypeArgSrcSpan :: LHsTypeArg GhcPs -> SrcSpan
- GHC.Hs.Type: mkHsAppKindTy :: LHsType (GhcPass p) -> LHsToken "@" (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)
+ GHC.Hs.Type: mkHsAppKindTy :: XAppKindTy (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)
- GHC.Hs.Type: pprHsArgsApp :: (OutputableBndr id, Outputable tm, Outputable ty) => id -> LexicalFixity -> [HsArg p tm ty] -> SDoc
+ GHC.Hs.Type: pprHsArgsApp :: (OutputableBndr id, Outputable tm, Outputable ty) => id -> LexicalFixity -> [HsArg (GhcPass p) tm ty] -> SDoc
- GHC.Hs.Type: splitLHsForAllTyInvis :: LHsType (GhcPass pass) -> ((EpAnnForallTy, [LHsTyVarBndr Specificity (GhcPass pass)]), LHsType (GhcPass pass))
+ GHC.Hs.Type: splitLHsForAllTyInvis :: LHsType (GhcPass pass) -> ([LHsTyVarBndr Specificity (GhcPass pass)], LHsType (GhcPass pass))
- GHC.Hs.Type: splitLHsForAllTyInvis_KP :: LHsType (GhcPass pass) -> (Maybe (EpAnnForallTy, [LHsTyVarBndr Specificity (GhcPass pass)]), LHsType (GhcPass pass))
+ GHC.Hs.Type: splitLHsForAllTyInvis_KP :: LHsType (GhcPass pass) -> (Maybe [LHsTyVarBndr Specificity (GhcPass pass)], LHsType (GhcPass pass))
- GHC.Hs.Utils: emptyTransStmt :: EpAnn [AddEpAnn] -> StmtLR GhcPs GhcPs (LHsExpr GhcPs)
+ GHC.Hs.Utils: emptyTransStmt :: [AddEpAnn] -> StmtLR GhcPs GhcPs (LHsExpr GhcPs)
- GHC.Hs.Utils: hsValBindsImplicits :: HsValBindsLR GhcRn (GhcPass idR) -> [(SrcSpan, [Name])]
+ GHC.Hs.Utils: hsValBindsImplicits :: HsValBindsLR GhcRn (GhcPass idR) -> [(SrcSpan, [ImplicitFieldBinders])]
- GHC.Hs.Utils: lPatImplicits :: LPat GhcRn -> [(SrcSpan, [Name])]
+ GHC.Hs.Utils: lPatImplicits :: LPat GhcRn -> [(SrcSpan, [ImplicitFieldBinders])]
- GHC.Hs.Utils: lStmtsImplicits :: [LStmtLR GhcRn (GhcPass idR) (LocatedA (body (GhcPass idR)))] -> [(SrcSpan, [Name])]
+ GHC.Hs.Utils: lStmtsImplicits :: [LStmtLR GhcRn (GhcPass idR) (LocatedA (body (GhcPass idR)))] -> [(SrcSpan, [ImplicitFieldBinders])]
- GHC.Hs.Utils: missingTupArg :: EpAnn EpaLocation -> HsTupArg GhcPs
+ GHC.Hs.Utils: missingTupArg :: EpAnn Bool -> HsTupArg GhcPs
- GHC.Hs.Utils: mkGroupByUsingStmt :: EpAnn [AddEpAnn] -> [ExprLStmt GhcPs] -> LHsExpr GhcPs -> LHsExpr GhcPs -> StmtLR GhcPs GhcPs (LHsExpr GhcPs)
+ GHC.Hs.Utils: mkGroupByUsingStmt :: [AddEpAnn] -> [ExprLStmt GhcPs] -> LHsExpr GhcPs -> LHsExpr GhcPs -> StmtLR GhcPs GhcPs (LHsExpr GhcPs)
- GHC.Hs.Utils: mkGroupUsingStmt :: EpAnn [AddEpAnn] -> [ExprLStmt GhcPs] -> LHsExpr GhcPs -> StmtLR GhcPs GhcPs (LHsExpr GhcPs)
+ GHC.Hs.Utils: mkGroupUsingStmt :: [AddEpAnn] -> [ExprLStmt GhcPs] -> LHsExpr GhcPs -> StmtLR GhcPs GhcPs (LHsExpr GhcPs)
- GHC.Hs.Utils: mkHsAppKindTy :: LHsType (GhcPass p) -> LHsToken "@" (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)
+ GHC.Hs.Utils: mkHsAppKindTy :: XAppKindTy (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)
- GHC.Hs.Utils: mkHsCaseAlt :: (Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcAnn NoEpAnns, Anno (Match (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcSpanAnnA) => LPat (GhcPass p) -> LocatedA (body (GhcPass p)) -> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
+ GHC.Hs.Utils: mkHsCaseAlt :: (Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) ~ EpAnn NoEpAnns, Anno (Match (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcSpanAnnA) => LPat (GhcPass p) -> LocatedA (body (GhcPass p)) -> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
- GHC.Hs.Utils: mkHsCmdIf :: LHsExpr GhcPs -> LHsCmd GhcPs -> LHsCmd GhcPs -> EpAnn AnnsIf -> HsCmd GhcPs
+ GHC.Hs.Utils: mkHsCmdIf :: LHsExpr GhcPs -> LHsCmd GhcPs -> LHsCmd GhcPs -> AnnsIf -> HsCmd GhcPs
- GHC.Hs.Utils: mkHsCompAnns :: HsDoFlavour -> [ExprLStmt GhcPs] -> LHsExpr GhcPs -> EpAnn AnnList -> HsExpr GhcPs
+ GHC.Hs.Utils: mkHsCompAnns :: HsDoFlavour -> [ExprLStmt GhcPs] -> LHsExpr GhcPs -> AnnList -> HsExpr GhcPs
- GHC.Hs.Utils: mkHsDoAnns :: HsDoFlavour -> LocatedL [ExprLStmt GhcPs] -> EpAnn AnnList -> HsExpr GhcPs
+ GHC.Hs.Utils: mkHsDoAnns :: HsDoFlavour -> LocatedL [ExprLStmt GhcPs] -> AnnList -> HsExpr GhcPs
- GHC.Hs.Utils: mkHsIf :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> EpAnn AnnsIf -> HsExpr GhcPs
+ GHC.Hs.Utils: mkHsIf :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> AnnsIf -> HsExpr GhcPs
- GHC.Hs.Utils: mkHsPar :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
+ GHC.Hs.Utils: mkHsPar :: IsPass p => LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
- GHC.Hs.Utils: mkLamCaseMatchGroup :: AnnoBody p body => Origin -> LamCaseVariant -> LocatedL [LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))] -> MatchGroup (GhcPass p) (LocatedA (body (GhcPass p)))
+ GHC.Hs.Utils: mkLamCaseMatchGroup :: AnnoBody p body => Origin -> HsLamVariant -> LocatedL [LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))] -> MatchGroup (GhcPass p) (LocatedA (body (GhcPass p)))
- GHC.Hs.Utils: mkLetStmt :: EpAnn [AddEpAnn] -> HsLocalBinds GhcPs -> StmtLR GhcPs GhcPs (LocatedA b)
+ GHC.Hs.Utils: mkLetStmt :: [AddEpAnn] -> HsLocalBinds GhcPs -> StmtLR GhcPs GhcPs (LocatedA b)
- GHC.Hs.Utils: mkLocatedList :: Semigroup a => [GenLocated (SrcAnn a) e2] -> LocatedAn an [GenLocated (SrcAnn a) e2]
+ GHC.Hs.Utils: mkLocatedList :: (Semigroup a, NoAnn an) => [GenLocated (EpAnn a) e2] -> LocatedAn an [GenLocated (EpAnn a) e2]
- GHC.Hs.Utils: mkMatch :: forall p. IsPass p => HsMatchContext (GhcPass p) -> [LPat (GhcPass p)] -> LHsExpr (GhcPass p) -> HsLocalBinds (GhcPass p) -> LMatch (GhcPass p) (LHsExpr (GhcPass p))
+ GHC.Hs.Utils: mkMatch :: forall p. IsPass p => HsMatchContext (LIdP (NoGhcTc (GhcPass p))) -> [LPat (GhcPass p)] -> LHsExpr (GhcPass p) -> HsLocalBinds (GhcPass p) -> LMatch (GhcPass p) (LHsExpr (GhcPass p))
- GHC.Hs.Utils: mkNPat :: LocatedAn NoEpAnns (HsOverLit GhcPs) -> Maybe (SyntaxExpr GhcPs) -> EpAnn [AddEpAnn] -> Pat GhcPs
+ GHC.Hs.Utils: mkNPat :: LocatedAn NoEpAnns (HsOverLit GhcPs) -> Maybe (SyntaxExpr GhcPs) -> [AddEpAnn] -> Pat GhcPs
- GHC.Hs.Utils: mkNPlusKPat :: LocatedN RdrName -> LocatedAn NoEpAnns (HsOverLit GhcPs) -> EpAnn EpaLocation -> Pat GhcPs
+ GHC.Hs.Utils: mkNPlusKPat :: LocatedN RdrName -> LocatedAn NoEpAnns (HsOverLit GhcPs) -> EpaLocation -> Pat GhcPs
- GHC.Hs.Utils: mkPatSynBind :: LocatedN RdrName -> HsPatSynDetails GhcPs -> LPat GhcPs -> HsPatSynDir GhcPs -> EpAnn [AddEpAnn] -> HsBind GhcPs
+ GHC.Hs.Utils: mkPatSynBind :: LocatedN RdrName -> HsPatSynDetails GhcPs -> LPat GhcPs -> HsPatSynDir GhcPs -> [AddEpAnn] -> HsBind GhcPs
- GHC.Hs.Utils: mkPrefixFunRhs :: LIdP (NoGhcTc p) -> HsMatchContext p
+ GHC.Hs.Utils: mkPrefixFunRhs :: fn -> HsMatchContext fn
- GHC.Hs.Utils: mkPsBindStmt :: EpAnn [AddEpAnn] -> LPat GhcPs -> LocatedA (bodyR GhcPs) -> StmtLR GhcPs GhcPs (LocatedA (bodyR GhcPs))
+ GHC.Hs.Utils: mkPsBindStmt :: [AddEpAnn] -> LPat GhcPs -> LocatedA (bodyR GhcPs) -> StmtLR GhcPs GhcPs (LocatedA (bodyR GhcPs))
- GHC.Hs.Utils: mkRecStmt :: forall (idL :: Pass) bodyR. Anno [GenLocated (Anno (StmtLR (GhcPass idL) GhcPs bodyR)) (StmtLR (GhcPass idL) GhcPs bodyR)] ~ SrcSpanAnnL => EpAnn AnnList -> LocatedL [LStmtLR (GhcPass idL) GhcPs bodyR] -> StmtLR (GhcPass idL) GhcPs bodyR
+ GHC.Hs.Utils: mkRecStmt :: forall (idL :: Pass) bodyR. Anno [GenLocated (Anno (StmtLR (GhcPass idL) GhcPs bodyR)) (StmtLR (GhcPass idL) GhcPs bodyR)] ~ SrcSpanAnnL => AnnList -> LocatedL [LStmtLR (GhcPass idL) GhcPs bodyR] -> StmtLR (GhcPass idL) GhcPs bodyR
- GHC.Hs.Utils: mkSimpleMatch :: (Anno (Match (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcSpanAnnA, Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcAnn NoEpAnns) => HsMatchContext (GhcPass p) -> [LPat (GhcPass p)] -> LocatedA (body (GhcPass p)) -> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
+ GHC.Hs.Utils: mkSimpleMatch :: (Anno (Match (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcSpanAnnA, Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) ~ EpAnn NoEpAnns) => HsMatchContext (LIdP (NoGhcTc (GhcPass p))) -> [LPat (GhcPass p)] -> LocatedA (body (GhcPass p)) -> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
- GHC.Hs.Utils: mkTransformByStmt :: EpAnn [AddEpAnn] -> [ExprLStmt GhcPs] -> LHsExpr GhcPs -> LHsExpr GhcPs -> StmtLR GhcPs GhcPs (LHsExpr GhcPs)
+ GHC.Hs.Utils: mkTransformByStmt :: [AddEpAnn] -> [ExprLStmt GhcPs] -> LHsExpr GhcPs -> LHsExpr GhcPs -> StmtLR GhcPs GhcPs (LHsExpr GhcPs)
- GHC.Hs.Utils: mkTransformStmt :: EpAnn [AddEpAnn] -> [ExprLStmt GhcPs] -> LHsExpr GhcPs -> StmtLR GhcPs GhcPs (LHsExpr GhcPs)
+ GHC.Hs.Utils: mkTransformStmt :: [AddEpAnn] -> [ExprLStmt GhcPs] -> LHsExpr GhcPs -> StmtLR GhcPs GhcPs (LHsExpr GhcPs)
- GHC.Hs.Utils: nlHsAppKindTy :: LHsType (GhcPass p) -> LHsKind (GhcPass p) -> LHsType (GhcPass p)
+ GHC.Hs.Utils: nlHsAppKindTy :: forall p. IsPass p => LHsType (GhcPass p) -> LHsKind (GhcPass p) -> LHsType (GhcPass p)
- GHC.Hs.Utils: nlHsFunTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)
+ GHC.Hs.Utils: nlHsFunTy :: forall p. IsPass p => LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)
- GHC.Hs.Utils: nlHsPar :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
+ GHC.Hs.Utils: nlHsPar :: IsPass p => LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
- GHC.Hs.Utils: nlHsTyConApp :: IsSrcSpanAnn p a => PromotionFlag -> LexicalFixity -> IdP (GhcPass p) -> [LHsTypeArg (GhcPass p)] -> LHsType (GhcPass p)
+ GHC.Hs.Utils: nlHsTyConApp :: forall p a. IsSrcSpanAnn p a => PromotionFlag -> LexicalFixity -> IdP (GhcPass p) -> [LHsTypeArg (GhcPass p)] -> LHsType (GhcPass p)
- GHC.Hs.Utils: nlParPat :: LPat (GhcPass name) -> LPat (GhcPass name)
+ GHC.Hs.Utils: nlParPat :: IsPass p => LPat (GhcPass p) -> LPat (GhcPass p)
- GHC.Hs.Utils: unguardedGRHSs :: Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcAnn NoEpAnns => SrcSpan -> LocatedA (body (GhcPass p)) -> EpAnn GrhsAnn -> GRHSs (GhcPass p) (LocatedA (body (GhcPass p)))
+ GHC.Hs.Utils: unguardedGRHSs :: Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) ~ EpAnn NoEpAnns => SrcSpan -> LocatedA (body (GhcPass p)) -> EpAnn GrhsAnn -> GRHSs (GhcPass p) (LocatedA (body (GhcPass p)))
- GHC.Hs.Utils: unguardedRHS :: Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcAnn NoEpAnns => EpAnn GrhsAnn -> SrcSpan -> LocatedA (body (GhcPass p)) -> [LGRHS (GhcPass p) (LocatedA (body (GhcPass p)))]
+ GHC.Hs.Utils: unguardedRHS :: Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) ~ EpAnn NoEpAnns => EpAnn GrhsAnn -> SrcSpan -> LocatedA (body (GhcPass p)) -> [LGRHS (GhcPass p) (LocatedA (body (GhcPass p)))]
- GHC.HsToCore.Errors.Ppr: pprContext :: Bool -> HsMatchContext GhcTc -> SDoc -> ((SDoc -> SDoc) -> SDoc) -> SDoc
+ GHC.HsToCore.Errors.Ppr: pprContext :: Bool -> HsMatchContextRn -> SDoc -> ((SDoc -> SDoc) -> SDoc) -> SDoc
- GHC.HsToCore.Errors.Ppr: pprEqn :: HsMatchContext GhcTc -> SDoc -> String -> SDoc
+ GHC.HsToCore.Errors.Ppr: pprEqn :: HsMatchContextRn -> SDoc -> String -> SDoc
- GHC.HsToCore.Errors.Types: DsInaccessibleRhs :: !HsMatchContext GhcTc -> !SDoc -> DsMessage
+ GHC.HsToCore.Errors.Types: DsInaccessibleRhs :: !HsMatchContextRn -> !SDoc -> DsMessage
- GHC.HsToCore.Errors.Types: DsNonExhaustivePatterns :: !HsMatchContext GhcTc -> !ExhaustivityCheckType -> !MaxUncoveredPatterns -> [Id] -> [Nabla] -> DsMessage
+ GHC.HsToCore.Errors.Types: DsNonExhaustivePatterns :: !HsMatchContextRn -> !ExhaustivityCheckType -> !MaxUncoveredPatterns -> [Id] -> [Nabla] -> DsMessage
- GHC.HsToCore.Errors.Types: DsOverlappingPatterns :: !HsMatchContext GhcTc -> !SDoc -> DsMessage
+ GHC.HsToCore.Errors.Types: DsOverlappingPatterns :: !HsMatchContextRn -> !SDoc -> DsMessage
- GHC.HsToCore.Errors.Types: DsRedundantBangPatterns :: !HsMatchContext GhcTc -> !SDoc -> DsMessage
+ GHC.HsToCore.Errors.Types: DsRedundantBangPatterns :: !HsMatchContextRn -> !SDoc -> DsMessage
- GHC.Iface.Syntax: IfLetBndr :: IfLclName -> IfaceType -> IfaceIdInfo -> IfaceJoinInfo -> IfaceLetBndr
+ GHC.Iface.Syntax: IfLetBndr :: IfLclName -> IfaceType -> IfaceIdInfo -> JoinPointHood -> IfaceLetBndr
- GHC.Iface.Syntax: IfaceClsInst :: IfExtName -> [Maybe IfaceTyCon] -> IfExtName -> OverlapFlag -> IsOrphan -> IfaceClsInst
+ GHC.Iface.Syntax: IfaceClsInst :: IfExtName -> [Maybe IfaceTyCon] -> IfExtName -> OverlapFlag -> IsOrphan -> Maybe IfaceWarningTxt -> IfaceClsInst
- GHC.Iface.Syntax: ShowSome :: [OccName] -> AltPpr -> ShowHowMuch
+ GHC.Iface.Syntax: ShowSome :: Maybe (OccName -> Bool) -> AltPpr -> ShowHowMuch
- GHC.Iface.Type: IfaceForAllCo :: IfaceBndr -> IfaceCoercion -> IfaceCoercion -> IfaceCoercion
+ GHC.Iface.Type: IfaceForAllCo :: IfaceBndr -> !ForAllTyFlag -> !ForAllTyFlag -> IfaceCoercion -> IfaceCoercion -> IfaceCoercion
- GHC.Iface.Type: Invisible :: Specificity -> ForAllTyFlag
+ GHC.Iface.Type: Invisible :: !Specificity -> ForAllTyFlag
- GHC.Iface.Type: ShowSome :: [OccName] -> AltPpr -> ShowHowMuch
+ GHC.Iface.Type: ShowSome :: Maybe (OccName -> Bool) -> AltPpr -> ShowHowMuch
- GHC.JS.Make: (.!) :: JExpr -> JExpr -> JExpr
+ GHC.JS.Make: (.!) :: JStgExpr -> JStgExpr -> JStgExpr
- GHC.JS.Make: (.!=.) :: JExpr -> JExpr -> JExpr
+ GHC.JS.Make: (.!=.) :: JStgExpr -> JStgExpr -> JStgExpr
- GHC.JS.Make: (.!==.) :: JExpr -> JExpr -> JExpr
+ GHC.JS.Make: (.!==.) :: JStgExpr -> JStgExpr -> JStgExpr
- GHC.JS.Make: (.&&.) :: JExpr -> JExpr -> JExpr
+ GHC.JS.Make: (.&&.) :: JStgExpr -> JStgExpr -> JStgExpr
- GHC.JS.Make: (.<.) :: JExpr -> JExpr -> JExpr
+ GHC.JS.Make: (.<.) :: JStgExpr -> JStgExpr -> JStgExpr
- GHC.JS.Make: (.<<.) :: JExpr -> JExpr -> JExpr
+ GHC.JS.Make: (.<<.) :: JStgExpr -> JStgExpr -> JStgExpr
- GHC.JS.Make: (.<=.) :: JExpr -> JExpr -> JExpr
+ GHC.JS.Make: (.<=.) :: JStgExpr -> JStgExpr -> JStgExpr
- GHC.JS.Make: (.==.) :: JExpr -> JExpr -> JExpr
+ GHC.JS.Make: (.==.) :: JStgExpr -> JStgExpr -> JStgExpr
- GHC.JS.Make: (.===.) :: JExpr -> JExpr -> JExpr
+ GHC.JS.Make: (.===.) :: JStgExpr -> JStgExpr -> JStgExpr
- GHC.JS.Make: (.>.) :: JExpr -> JExpr -> JExpr
+ GHC.JS.Make: (.>.) :: JStgExpr -> JStgExpr -> JStgExpr
- GHC.JS.Make: (.>=.) :: JExpr -> JExpr -> JExpr
+ GHC.JS.Make: (.>=.) :: JStgExpr -> JStgExpr -> JStgExpr
- GHC.JS.Make: (.>>.) :: JExpr -> JExpr -> JExpr
+ GHC.JS.Make: (.>>.) :: JStgExpr -> JStgExpr -> JStgExpr
- GHC.JS.Make: (.>>>.) :: JExpr -> JExpr -> JExpr
+ GHC.JS.Make: (.>>>.) :: JStgExpr -> JStgExpr -> JStgExpr
- GHC.JS.Make: (.^) :: JExpr -> FastString -> JExpr
+ GHC.JS.Make: (.^) :: JStgExpr -> FastString -> JStgExpr
- GHC.JS.Make: (.|.) :: JExpr -> JExpr -> JExpr
+ GHC.JS.Make: (.|.) :: JStgExpr -> JStgExpr -> JStgExpr
- GHC.JS.Make: (.||.) :: JExpr -> JExpr -> JExpr
+ GHC.JS.Make: (.||.) :: JStgExpr -> JStgExpr -> JStgExpr
- GHC.JS.Make: (|=) :: JExpr -> JExpr -> JStat
+ GHC.JS.Make: (|=) :: JStgExpr -> JStgExpr -> JStgStat
- GHC.JS.Make: (||=) :: Ident -> JExpr -> JStat
+ GHC.JS.Make: (||=) :: Ident -> JStgExpr -> JStgStat
- GHC.JS.Make: app :: FastString -> [JExpr] -> JExpr
+ GHC.JS.Make: app :: FastString -> [JStgExpr] -> JStgExpr
- GHC.JS.Make: appS :: FastString -> [JExpr] -> JStat
+ GHC.JS.Make: appS :: FastString -> [JStgExpr] -> JStgStat
- GHC.JS.Make: assignAll :: [JExpr] -> [JExpr] -> JStat
+ GHC.JS.Make: assignAll :: [JStgExpr] -> [JStgExpr] -> JStgStat
- GHC.JS.Make: assignAllEqual :: HasDebugCallStack => [JExpr] -> [JExpr] -> JStat
+ GHC.JS.Make: assignAllEqual :: HasDebugCallStack => [JStgExpr] -> [JStgExpr] -> JStgStat
- GHC.JS.Make: assignAllReverseOrder :: [JExpr] -> [JExpr] -> JStat
+ GHC.JS.Make: assignAllReverseOrder :: [JStgExpr] -> [JStgExpr] -> JStgStat
- GHC.JS.Make: decl :: Ident -> JStat
+ GHC.JS.Make: decl :: Ident -> JStgStat
- GHC.JS.Make: declAssignAll :: [Ident] -> [JExpr] -> JStat
+ GHC.JS.Make: declAssignAll :: [Ident] -> [JStgExpr] -> JStgStat
- GHC.JS.Make: false_ :: JExpr
+ GHC.JS.Make: false_ :: JStgExpr
- GHC.JS.Make: if01 :: JExpr -> JExpr
+ GHC.JS.Make: if01 :: JStgExpr -> JStgExpr
- GHC.JS.Make: if10 :: JExpr -> JExpr
+ GHC.JS.Make: if10 :: JStgExpr -> JStgExpr
- GHC.JS.Make: ifBlockS :: JExpr -> [JStat] -> [JStat] -> JStat
+ GHC.JS.Make: ifBlockS :: JStgExpr -> [JStgStat] -> [JStgStat] -> JStgStat
- GHC.JS.Make: ifS :: JExpr -> JStat -> JStat -> JStat
+ GHC.JS.Make: ifS :: JStgExpr -> JStgStat -> JStgStat -> JStgStat
- GHC.JS.Make: if_ :: JExpr -> JExpr -> JExpr -> JExpr
+ GHC.JS.Make: if_ :: JStgExpr -> JStgExpr -> JStgExpr -> JStgExpr
- GHC.JS.Make: jFor :: (JExpr -> JStat) -> (JExpr -> JExpr) -> (JExpr -> JStat) -> (JExpr -> JStat) -> JStat
+ GHC.JS.Make: jFor :: (JStgExpr -> JStgStat) -> (JStgExpr -> JStgExpr) -> (JStgExpr -> JStgStat) -> (JStgExpr -> JStgStat) -> JSM JStgStat
- GHC.JS.Make: jForEachIn :: ToSat a => JExpr -> (JExpr -> a) -> JStat
+ GHC.JS.Make: jForEachIn :: JStgExpr -> (JStgExpr -> JStgStat) -> JSM JStgStat
- GHC.JS.Make: jForIn :: ToSat a => JExpr -> (JExpr -> a) -> JStat
+ GHC.JS.Make: jForIn :: JStgExpr -> (JStgExpr -> JStgStat) -> JSM JStgStat
- GHC.JS.Make: jFunction :: Ident -> [Ident] -> JStat -> JStat
+ GHC.JS.Make: jFunction :: JSArgument args => Ident -> (args -> JSM JStgStat) -> JSM JStgStat
- GHC.JS.Make: jLam :: ToSat a => a -> JExpr
+ GHC.JS.Make: jLam :: JSArgument args => (args -> JSM JStgStat) -> JSM JStgExpr
- GHC.JS.Make: jString :: FastString -> JExpr
+ GHC.JS.Make: jString :: FastString -> JStgExpr
- GHC.JS.Make: jTryCatchFinally :: ToSat a => JStat -> a -> JStat -> JStat
+ GHC.JS.Make: jTryCatchFinally :: (Ident -> JStgStat) -> (Ident -> JStgStat) -> (Ident -> JStgStat) -> JSM JStgStat
- GHC.JS.Make: jVar :: ToSat a => a -> JStat
+ GHC.JS.Make: jVar :: (JVarMagic t, ToJExpr t) => (t -> JSM JStgStat) -> JSM JStgStat
- GHC.JS.Make: jhAdd :: (Ord k, ToJExpr a) => k -> a -> Map k JExpr -> Map k JExpr
+ GHC.JS.Make: jhAdd :: (Ord k, ToJExpr a) => k -> a -> Map k JStgExpr -> Map k JStgExpr
- GHC.JS.Make: jhEmpty :: Map k JExpr
+ GHC.JS.Make: jhEmpty :: Map k JStgExpr
- GHC.JS.Make: jhFromList :: [(FastString, JExpr)] -> JVal
+ GHC.JS.Make: jhFromList :: [(FastString, JStgExpr)] -> JVal
- GHC.JS.Make: jhSingle :: (Ord k, ToJExpr a) => k -> a -> Map k JExpr
+ GHC.JS.Make: jhSingle :: (Ord k, ToJExpr a) => k -> a -> Map k JStgExpr
- GHC.JS.Make: jwhenS :: JExpr -> JStat -> JStat
+ GHC.JS.Make: jwhenS :: JStgExpr -> JStgStat -> JStgStat
- GHC.JS.Make: loop :: JExpr -> (JExpr -> JExpr) -> (JExpr -> JStat) -> JStat
+ GHC.JS.Make: loop :: JStgExpr -> (JStgExpr -> JStgExpr) -> (JStgExpr -> JSM JStgStat) -> JSM JStgStat
- GHC.JS.Make: loopBlockS :: JExpr -> (JExpr -> JExpr) -> (JExpr -> [JStat]) -> JStat
+ GHC.JS.Make: loopBlockS :: JStgExpr -> (JStgExpr -> JStgExpr) -> (JStgExpr -> [JStgStat]) -> JSM JStgStat
- GHC.JS.Make: mask16 :: JExpr -> JExpr
+ GHC.JS.Make: mask16 :: JStgExpr -> JStgExpr
- GHC.JS.Make: mask8 :: JExpr -> JExpr
+ GHC.JS.Make: mask8 :: JStgExpr -> JStgExpr
- GHC.JS.Make: math_abs :: [JExpr] -> JExpr
+ GHC.JS.Make: math_abs :: [JStgExpr] -> JStgExpr
- GHC.JS.Make: math_acos :: [JExpr] -> JExpr
+ GHC.JS.Make: math_acos :: [JStgExpr] -> JStgExpr
- GHC.JS.Make: math_acosh :: [JExpr] -> JExpr
+ GHC.JS.Make: math_acosh :: [JStgExpr] -> JStgExpr
- GHC.JS.Make: math_asin :: [JExpr] -> JExpr
+ GHC.JS.Make: math_asin :: [JStgExpr] -> JStgExpr
- GHC.JS.Make: math_asinh :: [JExpr] -> JExpr
+ GHC.JS.Make: math_asinh :: [JStgExpr] -> JStgExpr
- GHC.JS.Make: math_atan :: [JExpr] -> JExpr
+ GHC.JS.Make: math_atan :: [JStgExpr] -> JStgExpr
- GHC.JS.Make: math_atanh :: [JExpr] -> JExpr
+ GHC.JS.Make: math_atanh :: [JStgExpr] -> JStgExpr
- GHC.JS.Make: math_cos :: [JExpr] -> JExpr
+ GHC.JS.Make: math_cos :: [JStgExpr] -> JStgExpr
- GHC.JS.Make: math_cosh :: [JExpr] -> JExpr
+ GHC.JS.Make: math_cosh :: [JStgExpr] -> JStgExpr
- GHC.JS.Make: math_exp :: [JExpr] -> JExpr
+ GHC.JS.Make: math_exp :: [JStgExpr] -> JStgExpr
- GHC.JS.Make: math_expm1 :: [JExpr] -> JExpr
+ GHC.JS.Make: math_expm1 :: [JStgExpr] -> JStgExpr
- GHC.JS.Make: math_fround :: [JExpr] -> JExpr
+ GHC.JS.Make: math_fround :: [JStgExpr] -> JStgExpr
- GHC.JS.Make: math_log :: [JExpr] -> JExpr
+ GHC.JS.Make: math_log :: [JStgExpr] -> JStgExpr
- GHC.JS.Make: math_log1p :: [JExpr] -> JExpr
+ GHC.JS.Make: math_log1p :: [JStgExpr] -> JStgExpr
- GHC.JS.Make: math_pow :: [JExpr] -> JExpr
+ GHC.JS.Make: math_pow :: [JStgExpr] -> JStgExpr
- GHC.JS.Make: math_sin :: [JExpr] -> JExpr
+ GHC.JS.Make: math_sin :: [JStgExpr] -> JStgExpr
- GHC.JS.Make: math_sinh :: [JExpr] -> JExpr
+ GHC.JS.Make: math_sinh :: [JStgExpr] -> JStgExpr
- GHC.JS.Make: math_sqrt :: [JExpr] -> JExpr
+ GHC.JS.Make: math_sqrt :: [JStgExpr] -> JStgExpr
- GHC.JS.Make: math_tan :: [JExpr] -> JExpr
+ GHC.JS.Make: math_tan :: [JStgExpr] -> JStgExpr
- GHC.JS.Make: math_tanh :: [JExpr] -> JExpr
+ GHC.JS.Make: math_tanh :: [JStgExpr] -> JStgExpr
- GHC.JS.Make: nullStat :: JStat
+ GHC.JS.Make: nullStat :: JStgStat
- GHC.JS.Make: null_ :: JExpr
+ GHC.JS.Make: null_ :: JStgExpr
- GHC.JS.Make: off16 :: JExpr -> JExpr -> JExpr
+ GHC.JS.Make: off16 :: JStgExpr -> JStgExpr -> JStgExpr
- GHC.JS.Make: off32 :: JExpr -> JExpr -> JExpr
+ GHC.JS.Make: off32 :: JStgExpr -> JStgExpr -> JStgExpr
- GHC.JS.Make: off64 :: JExpr -> JExpr -> JExpr
+ GHC.JS.Make: off64 :: JStgExpr -> JStgExpr -> JStgExpr
- GHC.JS.Make: off8 :: JExpr -> JExpr -> JExpr
+ GHC.JS.Make: off8 :: JStgExpr -> JStgExpr -> JStgExpr
- GHC.JS.Make: one_ :: JExpr
+ GHC.JS.Make: one_ :: JStgExpr
- GHC.JS.Make: postDecrS :: JExpr -> JStat
+ GHC.JS.Make: postDecrS :: JStgExpr -> JStgStat
- GHC.JS.Make: postIncrS :: JExpr -> JStat
+ GHC.JS.Make: postIncrS :: JStgExpr -> JStgStat
- GHC.JS.Make: preDecrS :: JExpr -> JStat
+ GHC.JS.Make: preDecrS :: JStgExpr -> JStgStat
- GHC.JS.Make: preIncrS :: JExpr -> JStat
+ GHC.JS.Make: preIncrS :: JStgExpr -> JStgStat
- GHC.JS.Make: returnS :: JExpr -> JStat
+ GHC.JS.Make: returnS :: JStgExpr -> JStgStat
- GHC.JS.Make: returnStack :: JStat
+ GHC.JS.Make: returnStack :: JStgStat
- GHC.JS.Make: signExtend16 :: JExpr -> JExpr
+ GHC.JS.Make: signExtend16 :: JStgExpr -> JStgExpr
- GHC.JS.Make: signExtend8 :: JExpr -> JExpr
+ GHC.JS.Make: signExtend8 :: JStgExpr -> JStgExpr
- GHC.JS.Make: three_ :: JExpr
+ GHC.JS.Make: three_ :: JStgExpr
- GHC.JS.Make: toJExpr :: ToJExpr a => a -> JExpr
+ GHC.JS.Make: toJExpr :: ToJExpr a => a -> JStgExpr
- GHC.JS.Make: toJExprFromList :: ToJExpr a => [a] -> JExpr
+ GHC.JS.Make: toJExprFromList :: ToJExpr a => [a] -> JStgExpr
- GHC.JS.Make: toStat :: ToStat a => a -> JStat
+ GHC.JS.Make: toStat :: ToStat a => a -> JStgStat
- GHC.JS.Make: trace :: ToJExpr a => a -> JStat
+ GHC.JS.Make: trace :: ToJExpr a => a -> JStgStat
- GHC.JS.Make: true_ :: JExpr
+ GHC.JS.Make: true_ :: JStgExpr
- GHC.JS.Make: two_ :: JExpr
+ GHC.JS.Make: two_ :: JStgExpr
- GHC.JS.Make: typeof :: JExpr -> JExpr
+ GHC.JS.Make: typeof :: JStgExpr -> JStgExpr
- GHC.JS.Make: undefined_ :: JExpr
+ GHC.JS.Make: undefined_ :: JStgExpr
- GHC.JS.Make: zero_ :: JExpr
+ GHC.JS.Make: zero_ :: JStgExpr
- GHC.JS.Ppr: renderPrefixJs :: (JsToDoc a, JMacro a) => a -> SDoc
+ GHC.JS.Ppr: renderPrefixJs :: JsToDoc a => a -> SDoc
- GHC.JS.Ppr: renderPrefixJs' :: (JsToDoc a, JMacro a, JsRender doc) => RenderJs doc -> a -> doc
+ GHC.JS.Ppr: renderPrefixJs' :: (JsToDoc a, JsRender doc) => RenderJs doc -> a -> doc
- GHC.JS.Transform: identsE :: JExpr -> [Ident]
+ GHC.JS.Transform: identsE :: JStgExpr -> [Ident]
- GHC.JS.Transform: identsS :: JStat -> [Ident]
+ GHC.JS.Transform: identsS :: JStgStat -> [Ident]
- GHC.Linker.Types: LoadedPkgInfo :: !UnitId -> ![LibrarySpec] -> ![LibrarySpec] -> ![RemotePtr LoadedDLL] -> UniqDSet UnitId -> LoadedPkgInfo
+ GHC.Linker.Types: LoadedPkgInfo :: !UnitId -> ![LibrarySpec] -> ![LibrarySpec] -> UniqDSet UnitId -> LoadedPkgInfo
- GHC.Parser.Annotation: AnnSortKey :: [RealSrcSpan] -> AnnSortKey
+ GHC.Parser.Annotation: AnnSortKey :: [tag] -> AnnSortKey tag
- GHC.Parser.Annotation: EpaDelta :: !DeltaPos -> ![LEpaComment] -> EpaLocation
+ GHC.Parser.Annotation: EpaDelta :: !DeltaPos -> !a -> EpaLocation' a
- GHC.Parser.Annotation: EpaSpan :: !RealSrcSpan -> !Maybe BufSpan -> EpaLocation
+ GHC.Parser.Annotation: EpaSpan :: !SrcSpan -> EpaLocation' a
- GHC.Parser.Annotation: NoAnnSortKey :: AnnSortKey
+ GHC.Parser.Annotation: NoAnnSortKey :: AnnSortKey tag
- GHC.Parser.Annotation: addCLocA :: GenLocated (SrcSpanAnn' a) e1 -> GenLocated SrcSpan e2 -> e3 -> GenLocated (SrcAnn ann) e3
+ GHC.Parser.Annotation: addCLocA :: (HasLoc a, HasLoc b, HasAnnotation l) => a -> b -> c -> GenLocated l c
- GHC.Parser.Annotation: addCommentsToEpAnn :: Monoid a => SrcSpan -> EpAnn a -> EpAnnComments -> EpAnn a
+ GHC.Parser.Annotation: addCommentsToEpAnn :: NoAnn ann => EpAnn ann -> EpAnnComments -> EpAnn ann
- GHC.Parser.Annotation: addTrailingAnnToA :: SrcSpan -> TrailingAnn -> EpAnnComments -> EpAnn AnnListItem -> EpAnn AnnListItem
+ GHC.Parser.Annotation: addTrailingAnnToA :: TrailingAnn -> EpAnnComments -> EpAnn AnnListItem -> EpAnn AnnListItem
- GHC.Parser.Annotation: addTrailingAnnToL :: SrcSpan -> TrailingAnn -> EpAnnComments -> EpAnn AnnList -> EpAnn AnnList
+ GHC.Parser.Annotation: addTrailingAnnToL :: TrailingAnn -> EpAnnComments -> EpAnn AnnList -> EpAnn AnnList
- GHC.Parser.Annotation: addTrailingCommaToN :: SrcSpan -> EpAnn NameAnn -> EpaLocation -> EpAnn NameAnn
+ GHC.Parser.Annotation: addTrailingCommaToN :: EpAnn NameAnn -> EpaLocation -> EpAnn NameAnn
- GHC.Parser.Annotation: annParen2AddEpAnn :: EpAnn AnnParen -> [AddEpAnn]
+ GHC.Parser.Annotation: annParen2AddEpAnn :: AnnParen -> [AddEpAnn]
- GHC.Parser.Annotation: combineLocsA :: Semigroup a => GenLocated (SrcAnn a) e1 -> GenLocated (SrcAnn a) e2 -> SrcAnn a
+ GHC.Parser.Annotation: combineLocsA :: Semigroup a => GenLocated (EpAnn a) e1 -> GenLocated (EpAnn a) e2 -> EpAnn a
- GHC.Parser.Annotation: combineSrcSpansA :: Semigroup a => SrcAnn a -> SrcAnn a -> SrcAnn a
+ GHC.Parser.Annotation: combineSrcSpansA :: Semigroup a => EpAnn a -> EpAnn a -> EpAnn a
- GHC.Parser.Annotation: commentsOnlyA :: Monoid ann => SrcAnn ann -> SrcAnn ann
+ GHC.Parser.Annotation: commentsOnlyA :: NoAnn ann => EpAnn ann -> EpAnn ann
- GHC.Parser.Annotation: data AnnSortKey
+ GHC.Parser.Annotation: data AnnSortKey tag
- GHC.Parser.Annotation: getLocA :: GenLocated (SrcSpanAnn' a) e -> SrcSpan
+ GHC.Parser.Annotation: getLocA :: HasLoc a => GenLocated a e -> SrcSpan
- GHC.Parser.Annotation: l2l :: SrcSpanAnn' a -> SrcAnn ann
+ GHC.Parser.Annotation: l2l :: (HasLoc a, HasAnnotation b) => a -> b
- GHC.Parser.Annotation: la2la :: LocatedAn ann1 a2 -> LocatedAn ann2 a2
+ GHC.Parser.Annotation: la2la :: (HasLoc l, HasAnnotation l2) => GenLocated l a -> GenLocated l2 a
- GHC.Parser.Annotation: mapLocA :: (a -> b) -> GenLocated SrcSpan a -> GenLocated (SrcAnn ann) b
+ GHC.Parser.Annotation: mapLocA :: NoAnn ann => (a -> b) -> GenLocated SrcSpan a -> GenLocated (EpAnn ann) b
- GHC.Parser.Annotation: noAnn :: EpAnn a
+ GHC.Parser.Annotation: noAnn :: NoAnn a => a
- GHC.Parser.Annotation: noAnnSrcSpan :: SrcSpan -> SrcAnn ann
+ GHC.Parser.Annotation: noAnnSrcSpan :: HasAnnotation e => SrcSpan -> e
- GHC.Parser.Annotation: noLocA :: a -> LocatedAn an a
+ GHC.Parser.Annotation: noLocA :: HasAnnotation e => a -> GenLocated e a
- GHC.Parser.Annotation: noSrcSpanA :: SrcAnn ann
+ GHC.Parser.Annotation: noSrcSpanA :: HasAnnotation e => e
- GHC.Parser.Annotation: reAnnL :: ann -> EpAnnComments -> Located e -> GenLocated (SrcAnn ann) e
+ GHC.Parser.Annotation: reAnnL :: ann -> EpAnnComments -> Located e -> GenLocated (EpAnn ann) e
- GHC.Parser.Annotation: reLoc :: LocatedAn a e -> Located e
+ GHC.Parser.Annotation: reLoc :: (HasLoc (GenLocated a e), HasAnnotation b) => GenLocated a e -> GenLocated b e
- GHC.Parser.Annotation: realSpanAsAnchor :: RealSrcSpan -> Anchor
+ GHC.Parser.Annotation: realSpanAsAnchor :: RealSrcSpan -> EpaLocation' a
- GHC.Parser.Annotation: removeCommentsA :: SrcAnn ann -> SrcAnn ann
+ GHC.Parser.Annotation: removeCommentsA :: EpAnn ann -> EpAnn ann
- GHC.Parser.Annotation: setCommentsEpAnn :: Monoid a => SrcSpan -> EpAnn a -> EpAnnComments -> EpAnn a
+ GHC.Parser.Annotation: setCommentsEpAnn :: NoAnn ann => EpAnn ann -> EpAnnComments -> EpAnn ann
- GHC.Parser.Annotation: sortLocatedA :: [GenLocated (SrcSpanAnn' a) e] -> [GenLocated (SrcSpanAnn' a) e]
+ GHC.Parser.Annotation: sortLocatedA :: HasLoc (EpAnn a) => [GenLocated (EpAnn a) e] -> [GenLocated (EpAnn a) e]
- GHC.Parser.Annotation: spanAsAnchor :: SrcSpan -> Anchor
+ GHC.Parser.Annotation: spanAsAnchor :: SrcSpan -> EpaLocation' a
- GHC.Parser.Annotation: type LEpaComment = GenLocated Anchor EpaComment
+ GHC.Parser.Annotation: type LEpaComment = GenLocated NoCommentsLocation EpaComment
- GHC.Parser.Annotation: type LocatedAn an = GenLocated (SrcAnn an)
+ GHC.Parser.Annotation: type LocatedAn an = GenLocated (EpAnn an)
- GHC.Parser.Annotation: type SrcSpanAnnA = SrcAnn AnnListItem
+ GHC.Parser.Annotation: type SrcSpanAnnA = EpAnn AnnListItem
- GHC.Parser.Annotation: type SrcSpanAnnC = SrcAnn AnnContext
+ GHC.Parser.Annotation: type SrcSpanAnnC = EpAnn AnnContext
- GHC.Parser.Annotation: type SrcSpanAnnL = SrcAnn AnnList
+ GHC.Parser.Annotation: type SrcSpanAnnL = EpAnn AnnList
- GHC.Parser.Annotation: type SrcSpanAnnN = SrcAnn NameAnn
+ GHC.Parser.Annotation: type SrcSpanAnnN = EpAnn NameAnn
- GHC.Parser.Annotation: type SrcSpanAnnP = SrcAnn AnnPragma
+ GHC.Parser.Annotation: type SrcSpanAnnP = EpAnn AnnPragma
- GHC.Parser.Annotation: widenLocatedAn :: SrcSpanAnn' an -> [AddEpAnn] -> SrcSpanAnn' an
+ GHC.Parser.Annotation: widenLocatedAn :: EpAnn an -> [AddEpAnn] -> EpAnn an
- GHC.Parser.Errors.Types: PsErrInvalidTypeSignature :: !LHsExpr GhcPs -> PsMessage
+ GHC.Parser.Errors.Types: PsErrInvalidTypeSignature :: !PsInvalidTypeSignature -> !LHsExpr GhcPs -> PsMessage
- GHC.Parser.Errors.Types: PsErrLambdaCmdInFunAppCmd :: !LHsCmd GhcPs -> PsMessage
+ GHC.Parser.Errors.Types: PsErrLambdaCmdInFunAppCmd :: !HsLamVariant -> !LHsCmd GhcPs -> PsMessage
- GHC.Parser.Errors.Types: PsErrLambdaInFunAppExpr :: !LHsExpr GhcPs -> PsMessage
+ GHC.Parser.Errors.Types: PsErrLambdaInFunAppExpr :: !HsLamVariant -> !LHsExpr GhcPs -> PsMessage
- GHC.Parser.Errors.Types: PsErrLambdaInPat :: PsMessage
+ GHC.Parser.Errors.Types: PsErrLambdaInPat :: HsLamVariant -> PsMessage
- GHC.Parser.PostProcess: RuleTyTmVar :: EpAnn [AddEpAnn] -> LocatedN RdrName -> Maybe (LHsType GhcPs) -> RuleTyTmVar
+ GHC.Parser.PostProcess: RuleTyTmVar :: [AddEpAnn] -> LocatedN RdrName -> Maybe (LHsType GhcPs) -> RuleTyTmVar
- GHC.Parser.PostProcess: Tuple :: [Either (EpAnn EpaLocation) (LocatedA b)] -> SumOrTuple b
+ GHC.Parser.PostProcess: Tuple :: [Either (EpAnn Bool) (LocatedA b)] -> SumOrTuple b
- GHC.Parser.PostProcess: checkValDef :: SrcSpan -> LocatedA (PatBuilder GhcPs) -> Maybe (AddEpAnn, LHsType GhcPs) -> Located (GRHSs GhcPs (LHsExpr GhcPs)) -> P (HsBind GhcPs)
+ GHC.Parser.PostProcess: checkValDef :: SrcSpan -> LocatedA (PatBuilder GhcPs) -> (HsMultAnn GhcPs, Maybe (AddEpAnn, LHsType GhcPs)) -> Located (GRHSs GhcPs (LHsExpr GhcPs)) -> P (HsBind GhcPs)
- GHC.Parser.PostProcess: dataConBuilderCon :: DataConBuilder -> LocatedN RdrName
+ GHC.Parser.PostProcess: dataConBuilderCon :: LocatedA DataConBuilder -> LocatedN RdrName
- GHC.Parser.PostProcess: dataConBuilderDetails :: DataConBuilder -> HsConDeclH98Details GhcPs
+ GHC.Parser.PostProcess: dataConBuilderDetails :: LocatedA DataConBuilder -> HsConDeclH98Details GhcPs
- GHC.Parser.PostProcess: mkBangTy :: EpAnn [AddEpAnn] -> SrcStrictness -> LHsType GhcPs -> HsType GhcPs
+ GHC.Parser.PostProcess: mkBangTy :: [AddEpAnn] -> SrcStrictness -> LHsType GhcPs -> HsType GhcPs
- GHC.Parser.PostProcess: mkClassDecl :: SrcSpan -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs) -> Located (a, [LHsFunDep GhcPs]) -> OrdList (LHsDecl GhcPs) -> LayoutInfo GhcPs -> [AddEpAnn] -> P (LTyClDecl GhcPs)
+ GHC.Parser.PostProcess: mkClassDecl :: SrcSpan -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs) -> Located (a, [LHsFunDep GhcPs]) -> OrdList (LHsDecl GhcPs) -> EpLayout -> [AddEpAnn] -> P (LTyClDecl GhcPs)
- GHC.Parser.PostProcess: mkConDeclH98 :: EpAnn [AddEpAnn] -> LocatedN RdrName -> Maybe [LHsTyVarBndr Specificity GhcPs] -> Maybe (LHsContext GhcPs) -> HsConDeclH98Details GhcPs -> ConDecl GhcPs
+ GHC.Parser.PostProcess: mkConDeclH98 :: [AddEpAnn] -> LocatedN RdrName -> Maybe [LHsTyVarBndr Specificity GhcPs] -> Maybe (LHsContext GhcPs) -> HsConDeclH98Details GhcPs -> ConDecl GhcPs
- GHC.Parser.PostProcess: mkExport :: Located CCallConv -> (Located StringLiteral, LocatedN RdrName, LHsSigType GhcPs) -> P (EpAnn [AddEpAnn] -> HsDecl GhcPs)
+ GHC.Parser.PostProcess: mkExport :: Located CCallConv -> (Located StringLiteral, LocatedN RdrName, LHsSigType GhcPs) -> P ([AddEpAnn] -> HsDecl GhcPs)
- GHC.Parser.PostProcess: mkGadtDecl :: SrcSpan -> NonEmpty (LocatedN RdrName) -> LHsUniToken "::" "∷" GhcPs -> LHsSigType GhcPs -> P (LConDecl GhcPs)
+ GHC.Parser.PostProcess: mkGadtDecl :: SrcSpan -> NonEmpty (LocatedN RdrName) -> EpUniToken "::" "∷" -> LHsSigType GhcPs -> P (LConDecl GhcPs)
- GHC.Parser.PostProcess: mkHsAppKindTyPV :: DisambTD b => LocatedA b -> LHsToken "@" GhcPs -> LHsType GhcPs -> PV (LocatedA b)
+ GHC.Parser.PostProcess: mkHsAppKindTyPV :: DisambTD b => LocatedA b -> EpToken "@" -> LHsType GhcPs -> PV (LocatedA b)
- GHC.Parser.PostProcess: mkHsAppTypePV :: DisambECP b => SrcSpanAnnA -> LocatedA b -> LHsToken "@" GhcPs -> LHsType GhcPs -> PV (LocatedA b)
+ GHC.Parser.PostProcess: mkHsAppTypePV :: DisambECP b => SrcSpanAnnA -> LocatedA b -> EpToken "@" -> LHsType GhcPs -> PV (LocatedA b)
- GHC.Parser.PostProcess: mkHsAsPatPV :: DisambECP b => SrcSpan -> LocatedN RdrName -> LHsToken "@" GhcPs -> LocatedA b -> PV (LocatedA b)
+ GHC.Parser.PostProcess: mkHsAsPatPV :: DisambECP b => SrcSpan -> LocatedN RdrName -> EpToken "@" -> LocatedA b -> PV (LocatedA b)
- GHC.Parser.PostProcess: mkHsInfixHolePV :: DisambInfixOp b => SrcSpan -> (EpAnnComments -> EpAnn EpAnnUnboundVar) -> PV (Located b)
+ GHC.Parser.PostProcess: mkHsInfixHolePV :: DisambInfixOp b => LocatedN (HsExpr GhcPs) -> PV (LocatedN b)
- GHC.Parser.PostProcess: mkHsLamPV :: DisambECP b => SrcSpan -> (EpAnnComments -> MatchGroup GhcPs (LocatedA b)) -> PV (LocatedA b)
+ GHC.Parser.PostProcess: mkHsLamPV :: DisambECP b => SrcSpan -> HsLamVariant -> LocatedL [LMatch GhcPs (LocatedA b)] -> [AddEpAnn] -> PV (LocatedA b)
- GHC.Parser.PostProcess: mkHsLetPV :: DisambECP b => SrcSpan -> LHsToken "let" GhcPs -> HsLocalBinds GhcPs -> LHsToken "in" GhcPs -> LocatedA b -> PV (LocatedA b)
+ GHC.Parser.PostProcess: mkHsLetPV :: DisambECP b => SrcSpan -> EpToken "let" -> HsLocalBinds GhcPs -> EpToken "in" -> LocatedA b -> PV (LocatedA b)
- GHC.Parser.PostProcess: mkHsLitPV :: DisambECP b => Located (HsLit GhcPs) -> PV (Located b)
+ GHC.Parser.PostProcess: mkHsLitPV :: DisambECP b => Located (HsLit GhcPs) -> PV (LocatedA b)
- GHC.Parser.PostProcess: mkHsParPV :: DisambECP b => SrcSpan -> LHsToken "(" GhcPs -> LocatedA b -> LHsToken ")" GhcPs -> PV (LocatedA b)
+ GHC.Parser.PostProcess: mkHsParPV :: DisambECP b => SrcSpan -> EpToken "(" -> LocatedA b -> EpToken ")" -> PV (LocatedA b)
- GHC.Parser.PostProcess: mkHsSectionR_PV :: DisambECP b => SrcSpan -> LocatedA (InfixOp b) -> LocatedA b -> PV (Located b)
+ GHC.Parser.PostProcess: mkHsSectionR_PV :: DisambECP b => SrcSpan -> LocatedA (InfixOp b) -> LocatedA b -> PV (LocatedA b)
- GHC.Parser.PostProcess: mkHsSplicePV :: DisambECP b => Located (HsUntypedSplice GhcPs) -> PV (Located b)
+ GHC.Parser.PostProcess: mkHsSplicePV :: DisambECP b => Located (HsUntypedSplice GhcPs) -> PV (LocatedA b)
- GHC.Parser.PostProcess: mkHsWildCardPV :: DisambECP b => SrcSpan -> PV (Located b)
+ GHC.Parser.PostProcess: mkHsWildCardPV :: (DisambECP b, NoAnn a) => SrcSpan -> PV (LocatedAn a b)
- GHC.Parser.PostProcess: mkImport :: Located CCallConv -> Located Safety -> (Located StringLiteral, LocatedN RdrName, LHsSigType GhcPs) -> P (EpAnn [AddEpAnn] -> HsDecl GhcPs)
+ GHC.Parser.PostProcess: mkImport :: Located CCallConv -> Located Safety -> (Located StringLiteral, LocatedN RdrName, LHsSigType GhcPs) -> P ([AddEpAnn] -> HsDecl GhcPs)
- GHC.Parser.PostProcess: mkModuleImpExp :: Maybe (LocatedP (WarningTxt GhcPs)) -> [AddEpAnn] -> LocatedA ImpExpQcSpec -> ImpExpSubSpec -> P (IE GhcPs)
+ GHC.Parser.PostProcess: mkModuleImpExp :: Maybe (LWarningTxt GhcPs) -> [AddEpAnn] -> LocatedA ImpExpQcSpec -> ImpExpSubSpec -> P (IE GhcPs)
- GHC.Parser.PostProcess: mkMultTy :: LHsToken "%" GhcPs -> LHsType GhcPs -> LHsUniToken "->" "→" GhcPs -> HsArrow GhcPs
+ GHC.Parser.PostProcess: mkMultTy :: EpToken "%" -> LHsType GhcPs -> EpUniToken "->" "→" -> HsArrow GhcPs
- GHC.Parser.PostProcess: mkRdrGetField :: SrcSpanAnnA -> LHsExpr GhcPs -> LocatedAn NoEpAnns (DotFieldOcc GhcPs) -> EpAnnCO -> LHsExpr GhcPs
+ GHC.Parser.PostProcess: mkRdrGetField :: LHsExpr GhcPs -> LocatedAn NoEpAnns (DotFieldOcc GhcPs) -> HsExpr GhcPs
- GHC.Parser.PostProcess: mkRdrProjection :: NonEmpty (LocatedAn NoEpAnns (DotFieldOcc GhcPs)) -> EpAnn AnnProjection -> HsExpr GhcPs
+ GHC.Parser.PostProcess: mkRdrProjection :: NonEmpty (LocatedAn NoEpAnns (DotFieldOcc GhcPs)) -> AnnProjection -> HsExpr GhcPs
- GHC.Parser.PostProcess: mkRdrRecordCon :: LocatedN RdrName -> HsRecordBinds GhcPs -> EpAnn [AddEpAnn] -> HsExpr GhcPs
+ GHC.Parser.PostProcess: mkRdrRecordCon :: LocatedN RdrName -> HsRecordBinds GhcPs -> [AddEpAnn] -> HsExpr GhcPs
- GHC.Parser.PostProcess: mkRdrRecordUpd :: Bool -> LHsExpr GhcPs -> [Fbind (HsExpr GhcPs)] -> EpAnn [AddEpAnn] -> PV (HsExpr GhcPs)
+ GHC.Parser.PostProcess: mkRdrRecordUpd :: Bool -> LHsExpr GhcPs -> [Fbind (HsExpr GhcPs)] -> [AddEpAnn] -> PV (HsExpr GhcPs)
- GHC.Parser.PostProcess: mkRecConstrOrUpdate :: Bool -> LHsExpr GhcPs -> SrcSpan -> ([Fbind (HsExpr GhcPs)], Maybe SrcSpan) -> EpAnn [AddEpAnn] -> PV (HsExpr GhcPs)
+ GHC.Parser.PostProcess: mkRecConstrOrUpdate :: Bool -> LHsExpr GhcPs -> SrcSpan -> ([Fbind (HsExpr GhcPs)], Maybe SrcSpan) -> [AddEpAnn] -> PV (HsExpr GhcPs)
- GHC.Parser.PostProcess: mkSpliceDecl :: LHsExpr GhcPs -> P (LHsDecl GhcPs)
+ GHC.Parser.PostProcess: mkSpliceDecl :: LHsExpr GhcPs -> LHsDecl GhcPs
- GHC.Parser.PostProcess: parseCImport :: Located CCallConv -> Located Safety -> FastString -> String -> Located SourceText -> Maybe (ForeignImport (GhcPass p))
+ GHC.Parser.PostProcess: parseCImport :: LocatedE CCallConv -> LocatedE Safety -> FastString -> String -> Located SourceText -> Maybe (ForeignImport (GhcPass p))
- GHC.Parser.PostProcess: stmtsAnchor :: Located (OrdList AddEpAnn, a) -> Anchor
+ GHC.Parser.PostProcess: stmtsAnchor :: Located (OrdList AddEpAnn, a) -> Maybe Anchor
- GHC.Parser.Types: PatBuilderAppType :: LocatedA (PatBuilder p) -> LHsToken "@" p -> HsPatSigType GhcPs -> PatBuilder p
+ GHC.Parser.Types: PatBuilderAppType :: LocatedA (PatBuilder p) -> EpToken "@" -> HsTyPat GhcPs -> PatBuilder p
- GHC.Parser.Types: PatBuilderOpApp :: LocatedA (PatBuilder p) -> LocatedN RdrName -> LocatedA (PatBuilder p) -> EpAnn [AddEpAnn] -> PatBuilder p
+ GHC.Parser.Types: PatBuilderOpApp :: LocatedA (PatBuilder p) -> LocatedN RdrName -> LocatedA (PatBuilder p) -> [AddEpAnn] -> PatBuilder p
- GHC.Parser.Types: PatBuilderPar :: LHsToken "(" p -> LocatedA (PatBuilder p) -> LHsToken ")" p -> PatBuilder p
+ GHC.Parser.Types: PatBuilderPar :: EpToken "(" -> LocatedA (PatBuilder p) -> EpToken ")" -> PatBuilder p
- GHC.Parser.Types: Tuple :: [Either (EpAnn EpaLocation) (LocatedA b)] -> SumOrTuple b
+ GHC.Parser.Types: Tuple :: [Either (EpAnn Bool) (LocatedA b)] -> SumOrTuple b
- GHC.Platform: PlatformConstants :: {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> !Integer -> !Integer -> !Integer -> !Bool -> PlatformConstants
+ GHC.Platform: PlatformConstants :: {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> !Integer -> !Integer -> !Integer -> !Bool -> PlatformConstants
- GHC.Platform.Constants: PlatformConstants :: {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> !Integer -> !Integer -> !Integer -> !Bool -> PlatformConstants
+ GHC.Platform.Constants: PlatformConstants :: {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> {-# UNPACK #-} !Int -> !Integer -> !Integer -> !Integer -> !Bool -> PlatformConstants
- GHC.Runtime.Interpreter.Types: ExtInterpInstance :: {-# UNPACK #-} !InterpProcess -> !MVar [HValueRef] -> !c -> ExtInterpInstance c
+ GHC.Runtime.Interpreter.Types: ExtInterpInstance :: {-# UNPACK #-} !InterpProcess -> !MVar [HValueRef] -> !MVar (UniqFM FastString (Ptr ())) -> !c -> ExtInterpInstance c
- GHC.Runtime.Interpreter.Types: Interp :: !InterpInstance -> !Loader -> !MVar (UniqFM FastString (Ptr ())) -> Interp
+ GHC.Runtime.Interpreter.Types: Interp :: !InterpInstance -> !Loader -> Interp
- GHC.Settings: ToolSettings :: Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> String -> (String, [Option]) -> String -> String -> String -> (String, [Option]) -> (String, [Option]) -> Maybe (String, [Option]) -> (String, [Option]) -> String -> String -> String -> String -> String -> String -> (String, [Option]) -> (String, [Option]) -> (String, [Option]) -> String -> [String] -> [String] -> Fingerprint -> [String] -> [String] -> [String] -> [String] -> [String] -> [String] -> [String] -> [String] -> [String] -> [String] -> [String] -> [String] -> ToolSettings
+ GHC.Settings: ToolSettings :: Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> String -> (String, [Option]) -> String -> String -> String -> (String, [Option]) -> (String, [Option]) -> (String, [Option]) -> Maybe (String, [Option]) -> String -> String -> String -> String -> String -> (String, [Option]) -> (String, [Option]) -> (String, [Option]) -> String -> [String] -> [String] -> Fingerprint -> [String] -> [String] -> [String] -> [String] -> [String] -> [String] -> [String] -> [String] -> [String] -> [String] -> [String] -> [String] -> ToolSettings
- GHC.Stg.Syntax: StgConApp :: DataCon -> ConstructorNumber -> [StgArg] -> [Type] -> GenStgExpr pass
+ GHC.Stg.Syntax: StgConApp :: DataCon -> ConstructorNumber -> [StgArg] -> [[PrimRep]] -> GenStgExpr pass
- GHC.StgToCmm.Config: StgToCmmConfig :: !Profile -> Module -> !TempDir -> !SDocContext -> !Bool -> !Maybe Word -> !Int -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> (FMASign -> Bool) -> !Bool -> Maybe String -> !Bool -> !Bool -> !Bool -> StgToCmmConfig
+ GHC.StgToCmm.Config: StgToCmmConfig :: !Profile -> Module -> !TempDir -> !SDocContext -> !Bool -> !Maybe Word -> !Int -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> (FMASign -> Bool) -> !Bool -> Maybe String -> !Bool -> !Bool -> !Bool -> StgToCmmConfig
- GHC.StgToJS.Linker.Types: JSLinkConfig :: !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> JSLinkConfig
+ GHC.StgToJS.Linker.Types: JSLinkConfig :: !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> JSLinkConfig
- GHC.StgToJS.Linker.Types: LinkPlan :: Map Module LocatedBlockInfo -> Set BlockRef -> Set FilePath -> Set FilePath -> LinkPlan
+ GHC.StgToJS.Linker.Types: LinkPlan :: Map Module LocatedBlockInfo -> Set BlockRef -> !Set FilePath -> !Set FilePath -> !Set FilePath -> LinkPlan
- GHC.StgToJS.Linker.Types: [lkp_archives] :: LinkPlan -> Set FilePath
+ GHC.StgToJS.Linker.Types: [lkp_archives] :: LinkPlan -> !Set FilePath
- GHC.StgToJS.Types: AddrV :: VarType
+ GHC.StgToJS.Types: AddrV :: JSRep
- GHC.StgToJS.Types: ArrV :: VarType
+ GHC.StgToJS.Types: ArrV :: JSRep
- GHC.StgToJS.Types: CILayoutFixed :: !Int -> [VarType] -> CILayout
+ GHC.StgToJS.Types: CILayoutFixed :: !Int -> [JSRep] -> CILayout
- GHC.StgToJS.Types: CIRegs :: Int -> [VarType] -> CIRegs
+ GHC.StgToJS.Types: CIRegs :: Int -> [JSRep] -> CIRegs
- GHC.StgToJS.Types: DoubleV :: VarType
+ GHC.StgToJS.Types: DoubleV :: JSRep
- GHC.StgToJS.Types: ExprInline :: Maybe [JExpr] -> ExprResult
+ GHC.StgToJS.Types: ExprInline :: ExprResult
- GHC.StgToJS.Types: ExprValData :: [JExpr] -> ExprValData
+ GHC.StgToJS.Types: ExprValData :: [JStgExpr] -> ExprValData
- GHC.StgToJS.Types: GenGroupState :: [JStat] -> [ClosureInfo] -> [StaticInfo] -> [StackSlot] -> Int -> Set OtherSymb -> GlobalIdCache -> [ForeignJSRef] -> GenGroupState
+ GHC.StgToJS.Types: GenGroupState :: [JStgStat] -> [ClosureInfo] -> [StaticInfo] -> [StackSlot] -> Int -> Set OtherSymb -> GlobalIdCache -> [ForeignJSRef] -> GenGroupState
- GHC.StgToJS.Types: GenState :: !StgToJSConfig -> !Module -> {-# UNPACK #-} !FastMutInt -> !IdCache -> !UniqFM Id CgStgExpr -> GenGroupState -> [JStat] -> GenState
+ GHC.StgToJS.Types: GenState :: !StgToJSConfig -> !Module -> {-# UNPACK #-} !FastMutInt -> !IdCache -> !UniqFM Id CgStgExpr -> GenGroupState -> [JStgStat] -> GenState
- GHC.StgToJS.Types: IntV :: VarType
+ GHC.StgToJS.Types: IntV :: JSRep
- GHC.StgToJS.Types: LongV :: VarType
+ GHC.StgToJS.Types: LongV :: JSRep
- GHC.StgToJS.Types: ObjV :: VarType
+ GHC.StgToJS.Types: ObjV :: JSRep
- GHC.StgToJS.Types: PRPrimCall :: JStat -> PrimRes
+ GHC.StgToJS.Types: PRPrimCall :: JStgStat -> PrimRes
- GHC.StgToJS.Types: PrimInline :: JStat -> PrimRes
+ GHC.StgToJS.Types: PrimInline :: JStgStat -> PrimRes
- GHC.StgToJS.Types: PtrV :: VarType
+ GHC.StgToJS.Types: PtrV :: JSRep
- GHC.StgToJS.Types: StgToJSConfig :: !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !SDocContext -> StgToJSConfig
+ GHC.StgToJS.Types: StgToJSConfig :: !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !SDocContext -> !LinkerConfig -> StgToJSConfig
- GHC.StgToJS.Types: TypedExpr :: !PrimRep -> [JExpr] -> TypedExpr
+ GHC.StgToJS.Types: TypedExpr :: !PrimRep -> [JStgExpr] -> TypedExpr
- GHC.StgToJS.Types: VoidV :: VarType
+ GHC.StgToJS.Types: VoidV :: JSRep
- GHC.StgToJS.Types: [ciRegsTypes] :: CIRegs -> [VarType]
+ GHC.StgToJS.Types: [ciRegsTypes] :: CIRegs -> [JSRep]
- GHC.StgToJS.Types: [ggsToplevelStats] :: GenGroupState -> [JStat]
+ GHC.StgToJS.Types: [ggsToplevelStats] :: GenGroupState -> [JStgStat]
- GHC.StgToJS.Types: [gsGlobal] :: GenState -> [JStat]
+ GHC.StgToJS.Types: [gsGlobal] :: GenState -> [JStgStat]
- GHC.StgToJS.Types: [layout] :: CILayout -> [VarType]
+ GHC.StgToJS.Types: [layout] :: CILayout -> [JSRep]
- GHC.StgToJS.Types: [typex_expr] :: TypedExpr -> [JExpr]
+ GHC.StgToJS.Types: [typex_expr] :: TypedExpr -> [JStgExpr]
- GHC.Tc.Errors.Types: BadImportAvailTyCon :: BadImportKind
+ GHC.Tc.Errors.Types: BadImportAvailTyCon :: Bool -> BadImportKind
- GHC.Tc.Errors.Types: OutOfScopeHole :: [ImportError] -> HoleError
+ GHC.Tc.Errors.Types: OutOfScopeHole :: [ImportError] -> [GhcHint] -> HoleError
- GHC.Tc.Errors.Types: PatternArgs :: !HsMatchContext GhcTc -> MatchArgsContext
+ GHC.Tc.Errors.Types: PatternArgs :: !HsMatchContextRn -> MatchArgsContext
- GHC.Tc.Errors.Types: SolverReport :: SolverReportWithCtxt -> [SolverReportSupplementary] -> [GhcHint] -> SolverReport
+ GHC.Tc.Errors.Types: SolverReport :: SolverReportWithCtxt -> [SolverReportSupplementary] -> SolverReport
- GHC.Tc.Errors.Types: [TcRnDataKindsError] :: TypeOrKind -> HsType GhcPs -> TcRnMessage
+ GHC.Tc.Errors.Types: [TcRnDataKindsError] :: TypeOrKind -> Either (HsType GhcPs) Type -> TcRnMessage
- GHC.Tc.Errors.Types: [TcRnEmptyCase] :: HsMatchContext GhcRn -> TcRnMessage
+ GHC.Tc.Errors.Types: [TcRnEmptyCase] :: HsMatchContextRn -> TcRnMessage
- GHC.Tc.Errors.Types: [TcRnLastStmtNotExpr] :: HsStmtContext GhcRn -> UnexpectedStatement -> TcRnMessage
+ GHC.Tc.Errors.Types: [TcRnLastStmtNotExpr] :: HsStmtContextRn -> UnexpectedStatement -> TcRnMessage
- GHC.Tc.Errors.Types: [TcRnMatchesHaveDiffNumArgs] :: !HsMatchContext GhcTc -> !MatchArgBadMatches -> TcRnMessage
+ GHC.Tc.Errors.Types: [TcRnMatchesHaveDiffNumArgs] :: !HsMatchContextRn -> !MatchArgBadMatches -> TcRnMessage
- GHC.Tc.Errors.Types: [TcRnNegativeNumTypeLiteral] :: HsType GhcPs -> TcRnMessage
+ GHC.Tc.Errors.Types: [TcRnNegativeNumTypeLiteral] :: HsTyLit GhcPs -> TcRnMessage
- GHC.Tc.Errors.Types: [TcRnOverloadedSig] :: TcIdSigInfo -> TcRnMessage
+ GHC.Tc.Errors.Types: [TcRnOverloadedSig] :: TcIdSig -> TcRnMessage
- GHC.Tc.Errors.Types: [TcRnPragmaWarning] :: OccName -> WarningTxt GhcRn -> ModuleName -> Maybe ModuleName -> TcRnMessage
+ GHC.Tc.Errors.Types: [TcRnPragmaWarning] :: PragmaWarningInfo -> WarningTxt GhcRn -> TcRnMessage
- GHC.Tc.Errors.Types: [TcRnSolverReport] :: SolverReportWithCtxt -> DiagnosticReason -> [GhcHint] -> TcRnMessage
+ GHC.Tc.Errors.Types: [TcRnSolverReport] :: SolverReportWithCtxt -> DiagnosticReason -> TcRnMessage
- GHC.Tc.Errors.Types: [TcRnUnexpectedStatementInContext] :: HsStmtContext GhcRn -> UnexpectedStatement -> Maybe Extension -> TcRnMessage
+ GHC.Tc.Errors.Types: [TcRnUnexpectedStatementInContext] :: HsStmtContextRn -> UnexpectedStatement -> Maybe Extension -> TcRnMessage
- GHC.Tc.Types: DefaultingProposal :: TcTyVar -> [Type] -> [Ct] -> DefaultingProposal
+ GHC.Tc.Types: DefaultingProposal :: [[(TcTyVar, Type)]] -> [Ct] -> DefaultingProposal
- GHC.Tc.Types: TISI :: TcIdSigInfo -> [(Name, InvisTVBinder)] -> TcThetaType -> TcSigmaType -> [(Name, TcTyVar)] -> Maybe TcType -> TcIdSigInst
+ GHC.Tc.Types: TISI :: TcIdSig -> [(Name, InvisTVBinder)] -> TcThetaType -> TcSigmaType -> [(Name, TcTyVar)] -> Maybe TcType -> TcIdSigInst
- GHC.Tc.Types: TcGblEnv :: Module -> Module -> HscSource -> GlobalRdrEnv -> Maybe [Type] -> FixityEnv -> TypeEnv -> KnotVars (IORef TypeEnv) -> !InstEnv -> !FamInstEnv -> AnnEnv -> [AvailInfo] -> ImportAvails -> DefUses -> TcRef [GlobalRdrElt] -> TcRef NameSet -> TcRef Bool -> TcRef Bool -> TcRef ([Linkable], PkgsLoaded) -> TcRef OccSet -> [(Module, Fingerprint)] -> Maybe [(LIE GhcRn, Avails)] -> [LImportDecl GhcRn] -> Maybe (HsGroup GhcRn) -> TcRef [FilePath] -> TcRef [LHsDecl GhcPs] -> TcRef [(ForeignSrcLang, FilePath)] -> TcRef NameSet -> TcRef [(TcLclEnv, ThModFinalizers)] -> TcRef [String] -> TcRef (Map TypeRep Dynamic) -> TcRef (Maybe (ForeignRef (IORef QState))) -> TcRef THDocs -> Bag EvBind -> Maybe Id -> LHsBinds GhcTc -> NameSet -> [LTcSpecPrag] -> Warnings GhcRn -> [Annotation] -> [TyCon] -> NameSet -> [ClsInst] -> [FamInst] -> [LRuleDecl GhcTc] -> [LForeignDecl GhcTc] -> [PatSyn] -> Maybe (LHsDoc GhcRn) -> !AnyHpcUsage -> SelfBootInfo -> Maybe Name -> TcRef Bool -> TcRef (Messages TcRnMessage) -> [TcPluginSolver] -> UniqFM TyCon [TcPluginRewriter] -> [FillDefaulting] -> [HoleFitPlugin] -> RealSrcSpan -> TcRef WantedConstraints -> !CompleteMatches -> TcRef CostCentreState -> TcRef (ModuleEnv Int) -> TcGblEnv
+ GHC.Tc.Types: TcGblEnv :: Module -> Module -> HscSource -> GlobalRdrEnv -> Maybe [Type] -> FixityEnv -> TypeEnv -> KnotVars (IORef TypeEnv) -> !InstEnv -> !FamInstEnv -> AnnEnv -> [AvailInfo] -> ImportAvails -> DefUses -> TcRef [GlobalRdrElt] -> TcRef NameSet -> TcRef Bool -> TcRef Bool -> TcRef ([Linkable], PkgsLoaded) -> TcRef OccSet -> [(Module, Fingerprint)] -> Maybe [(LIE GhcRn, Avails)] -> [LImportDecl GhcRn] -> Maybe (HsGroup GhcRn) -> TcRef [FilePath] -> TcRef [LHsDecl GhcPs] -> TcRef [(ForeignSrcLang, FilePath)] -> TcRef NameSet -> TcRef [(TcLclEnv, ThModFinalizers)] -> TcRef [String] -> TcRef (Map TypeRep Dynamic) -> TcRef (Maybe (ForeignRef (IORef QState))) -> TcRef THDocs -> Bag EvBind -> Maybe Id -> LHsBinds GhcTc -> NameSet -> [LTcSpecPrag] -> Warnings GhcRn -> [Annotation] -> [TyCon] -> NameSet -> [ClsInst] -> [FamInst] -> [LRuleDecl GhcTc] -> [LForeignDecl GhcTc] -> [PatSyn] -> (Maybe (LHsDoc GhcRn), Maybe (XRec GhcRn ModuleName)) -> !AnyHpcUsage -> SelfBootInfo -> Maybe Name -> TcRef Bool -> TcRef (Messages TcRnMessage) -> [TcPluginSolver] -> UniqFM TyCon [TcPluginRewriter] -> [FillDefaulting] -> [HoleFitPlugin] -> RealSrcSpan -> TcRef WantedConstraints -> !CompleteMatches -> TcRef CostCentreState -> TcRef (ModuleEnv Int) -> TcGblEnv
- GHC.Tc.Types: TcIdSig :: TcIdSigInfo -> TcSigInfo
+ GHC.Tc.Types: TcIdSig :: TcIdSig -> TcSigInfo
- GHC.Tc.Types: TcPatSynSig :: TcPatSynInfo -> TcSigInfo
+ GHC.Tc.Types: TcPatSynSig :: TcPatSynSig -> TcSigInfo
- GHC.Tc.Types: [patsig_body_ty] :: TcPatSynInfo -> TcSigmaType
+ GHC.Tc.Types: [patsig_body_ty] :: TcPatSynSig -> TcSigmaType
- GHC.Tc.Types: [patsig_ex_bndrs] :: TcPatSynInfo -> [InvisTVBinder]
+ GHC.Tc.Types: [patsig_ex_bndrs] :: TcPatSynSig -> [InvisTVBinder]
- GHC.Tc.Types: [patsig_implicit_bndrs] :: TcPatSynInfo -> [InvisTVBinder]
+ GHC.Tc.Types: [patsig_implicit_bndrs] :: TcPatSynSig -> [InvisTVBinder]
- GHC.Tc.Types: [patsig_name] :: TcPatSynInfo -> Name
+ GHC.Tc.Types: [patsig_name] :: TcPatSynSig -> Name
- GHC.Tc.Types: [patsig_prov] :: TcPatSynInfo -> TcThetaType
+ GHC.Tc.Types: [patsig_prov] :: TcPatSynSig -> TcThetaType
- GHC.Tc.Types: [patsig_req] :: TcPatSynInfo -> TcThetaType
+ GHC.Tc.Types: [patsig_req] :: TcPatSynSig -> TcThetaType
- GHC.Tc.Types: [patsig_univ_bndrs] :: TcPatSynInfo -> [InvisTVBinder]
+ GHC.Tc.Types: [patsig_univ_bndrs] :: TcPatSynSig -> [InvisTVBinder]
- GHC.Tc.Types: [psig_hs_ty] :: TcIdSigInfo -> LHsSigWcType GhcRn
+ GHC.Tc.Types: [psig_hs_ty] :: TcPartialSig -> LHsSigWcType GhcRn
- GHC.Tc.Types: [psig_name] :: TcIdSigInfo -> Name
+ GHC.Tc.Types: [psig_name] :: TcPartialSig -> Name
- GHC.Tc.Types: [sig_bndr] :: TcIdSigInfo -> TcId
+ GHC.Tc.Types: [sig_bndr] :: TcCompleteSig -> TcId
- GHC.Tc.Types: [sig_ctxt] :: TcIdSigInfo -> UserTypeCtxt
+ GHC.Tc.Types: [sig_ctxt] :: TcCompleteSig -> UserTypeCtxt
- GHC.Tc.Types: [sig_inst_sig] :: TcIdSigInst -> TcIdSigInfo
+ GHC.Tc.Types: [sig_inst_sig] :: TcIdSigInst -> TcIdSig
- GHC.Tc.Types: [sig_loc] :: TcIdSigInfo -> SrcSpan
+ GHC.Tc.Types: [sig_loc] :: TcCompleteSig -> SrcSpan
- GHC.Tc.Types: type FillDefaulting = WantedConstraints -> TcPluginM DefaultingPluginResult
+ GHC.Tc.Types: type FillDefaulting = WantedConstraints -> TcPluginM [DefaultingProposal]
- GHC.Tc.Types.BasicTypes: TISI :: TcIdSigInfo -> [(Name, InvisTVBinder)] -> TcThetaType -> TcSigmaType -> [(Name, TcTyVar)] -> Maybe TcType -> TcIdSigInst
+ GHC.Tc.Types.BasicTypes: TISI :: TcIdSig -> [(Name, InvisTVBinder)] -> TcThetaType -> TcSigmaType -> [(Name, TcTyVar)] -> Maybe TcType -> TcIdSigInst
- GHC.Tc.Types.BasicTypes: TcIdSig :: TcIdSigInfo -> TcSigInfo
+ GHC.Tc.Types.BasicTypes: TcIdSig :: TcIdSig -> TcSigInfo
- GHC.Tc.Types.BasicTypes: TcPatSynSig :: TcPatSynInfo -> TcSigInfo
+ GHC.Tc.Types.BasicTypes: TcPatSynSig :: TcPatSynSig -> TcSigInfo
- GHC.Tc.Types.BasicTypes: [patsig_body_ty] :: TcPatSynInfo -> TcSigmaType
+ GHC.Tc.Types.BasicTypes: [patsig_body_ty] :: TcPatSynSig -> TcSigmaType
- GHC.Tc.Types.BasicTypes: [patsig_ex_bndrs] :: TcPatSynInfo -> [InvisTVBinder]
+ GHC.Tc.Types.BasicTypes: [patsig_ex_bndrs] :: TcPatSynSig -> [InvisTVBinder]
- GHC.Tc.Types.BasicTypes: [patsig_implicit_bndrs] :: TcPatSynInfo -> [InvisTVBinder]
+ GHC.Tc.Types.BasicTypes: [patsig_implicit_bndrs] :: TcPatSynSig -> [InvisTVBinder]
- GHC.Tc.Types.BasicTypes: [patsig_name] :: TcPatSynInfo -> Name
+ GHC.Tc.Types.BasicTypes: [patsig_name] :: TcPatSynSig -> Name
- GHC.Tc.Types.BasicTypes: [patsig_prov] :: TcPatSynInfo -> TcThetaType
+ GHC.Tc.Types.BasicTypes: [patsig_prov] :: TcPatSynSig -> TcThetaType
- GHC.Tc.Types.BasicTypes: [patsig_req] :: TcPatSynInfo -> TcThetaType
+ GHC.Tc.Types.BasicTypes: [patsig_req] :: TcPatSynSig -> TcThetaType
- GHC.Tc.Types.BasicTypes: [patsig_univ_bndrs] :: TcPatSynInfo -> [InvisTVBinder]
+ GHC.Tc.Types.BasicTypes: [patsig_univ_bndrs] :: TcPatSynSig -> [InvisTVBinder]
- GHC.Tc.Types.BasicTypes: [psig_hs_ty] :: TcIdSigInfo -> LHsSigWcType GhcRn
+ GHC.Tc.Types.BasicTypes: [psig_hs_ty] :: TcPartialSig -> LHsSigWcType GhcRn
- GHC.Tc.Types.BasicTypes: [psig_name] :: TcIdSigInfo -> Name
+ GHC.Tc.Types.BasicTypes: [psig_name] :: TcPartialSig -> Name
- GHC.Tc.Types.BasicTypes: [sig_bndr] :: TcIdSigInfo -> TcId
+ GHC.Tc.Types.BasicTypes: [sig_bndr] :: TcCompleteSig -> TcId
- GHC.Tc.Types.BasicTypes: [sig_ctxt] :: TcIdSigInfo -> UserTypeCtxt
+ GHC.Tc.Types.BasicTypes: [sig_ctxt] :: TcCompleteSig -> UserTypeCtxt
- GHC.Tc.Types.BasicTypes: [sig_inst_sig] :: TcIdSigInst -> TcIdSigInfo
+ GHC.Tc.Types.BasicTypes: [sig_inst_sig] :: TcIdSigInst -> TcIdSig
- GHC.Tc.Types.BasicTypes: [sig_loc] :: TcIdSigInfo -> SrcSpan
+ GHC.Tc.Types.BasicTypes: [sig_loc] :: TcCompleteSig -> SrcSpan
- GHC.Tc.Types.Origin: ExpectedFunTyLam :: !MatchGroup GhcRn (LHsExpr GhcRn) -> ExpectedFunTyOrigin
+ GHC.Tc.Types.Origin: ExpectedFunTyLam :: HsLamVariant -> !HsExpr GhcRn -> ExpectedFunTyOrigin
- GHC.Tc.Types.Origin: ExpectedFunTySyntaxOp :: !CtOrigin -> !HsExpr GhcRn -> ExpectedFunTyOrigin
+ GHC.Tc.Types.Origin: ExpectedFunTySyntaxOp :: !CtOrigin -> !HsExpr (GhcPass p) -> ExpectedFunTyOrigin
- GHC.Tc.Types.Origin: FRRUnboxedSum :: FixedRuntimeRepContext
+ GHC.Tc.Types.Origin: FRRUnboxedSum :: !Maybe Int -> FixedRuntimeRepContext
- GHC.Tc.Types.Origin: NonLinearPatternOrigin :: CtOrigin
+ GHC.Tc.Types.Origin: NonLinearPatternOrigin :: NonLinearPatternReason -> LPat GhcRn -> CtOrigin
- GHC.Tc.Types.Origin: PatSkol :: ConLike -> HsMatchContext GhcTc -> SkolemInfoAnon
+ GHC.Tc.Types.Origin: PatSkol :: ConLike -> HsMatchContextRn -> SkolemInfoAnon
- GHC.Tc.Types.Origin: TopLevInstance :: DFunId -> SafeOverlapping -> InstanceWhat
+ GHC.Tc.Types.Origin: TopLevInstance :: DFunId -> SafeOverlapping -> Maybe (WarningTxt GhcRn) -> InstanceWhat
- GHC.Tc.Types.Origin: unkSkol :: HasDebugCallStack => SkolemInfo
+ GHC.Tc.Types.Origin: unkSkol :: HasCallStack => SkolemInfo
- GHC.Tc.Types.Origin: unkSkolAnon :: HasDebugCallStack => SkolemInfoAnon
+ GHC.Tc.Types.Origin: unkSkolAnon :: HasCallStack => SkolemInfoAnon
- GHC.Tc.Utils.TcType: Invisible :: Specificity -> ForAllTyFlag
+ GHC.Tc.Utils.TcType: Invisible :: !Specificity -> ForAllTyFlag
- GHC.Tc.Utils.TcType: checkingExpType :: String -> ExpType -> TcType
+ GHC.Tc.Utils.TcType: checkingExpType :: ExpType -> TcType
- GHC.Tc.Utils.TcType: substTyAddInScope :: Subst -> Type -> Type
+ GHC.Tc.Utils.TcType: substTyAddInScope :: HasDebugCallStack => Subst -> Type -> Type
- GHC.Tc.Utils.TcType: tcSplitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type])
+ GHC.Tc.Utils.TcType: tcSplitTyConApp_maybe :: HasCallStack => Type -> Maybe (TyCon, [Type])
- GHC.Tc.Utils.TcType: vanillaSkolemTvUnk :: HasDebugCallStack => TcTyVarDetails
+ GHC.Tc.Utils.TcType: vanillaSkolemTvUnk :: HasCallStack => TcTyVarDetails
- GHC.Types.Basic: AlwaysTailCalled :: JoinArity -> TailCallInfo
+ GHC.Types.Basic: AlwaysTailCalled :: {-# UNPACK #-} !JoinArity -> TailCallInfo
- GHC.Types.Basic: Generated :: DoPmc -> Origin
+ GHC.Types.Basic: Generated :: GenReason -> DoPmc -> Origin
- GHC.Types.Id: asJoinId_maybe :: Id -> Maybe JoinArity -> Id
+ GHC.Types.Id: asJoinId_maybe :: Id -> JoinPointHood -> Id
- GHC.Types.Id: mkLocalCoVar :: HasDebugCallStack => Name -> Type -> CoVar
+ GHC.Types.Id: mkLocalCoVar :: Name -> Type -> CoVar
- GHC.Types.Id: mkLocalIdOrCoVar :: HasDebugCallStack => Name -> Mult -> Type -> Id
+ GHC.Types.Id: mkLocalIdOrCoVar :: Name -> Mult -> Type -> Id
- GHC.Types.Id: mkVanillaGlobal :: HasDebugCallStack => Name -> Type -> Id
+ GHC.Types.Id: mkVanillaGlobal :: Name -> Type -> Id
- GHC.Types.Id: mkVanillaGlobalWithInfo :: HasDebugCallStack => Name -> Type -> IdInfo -> Id
+ GHC.Types.Id: mkVanillaGlobalWithInfo :: Name -> Type -> IdInfo -> Id
- GHC.Types.Id.Info: AlwaysTailCalled :: JoinArity -> TailCallInfo
+ GHC.Types.Id.Info: AlwaysTailCalled :: {-# UNPACK #-} !JoinArity -> TailCallInfo
- GHC.Types.Id.Info: PrimOpId :: PrimOp -> Bool -> IdDetails
+ GHC.Types.Id.Info: PrimOpId :: PrimOp -> ConcreteTyVars -> IdDetails
- GHC.Types.Id.Info: RecSelId :: RecSelParent -> FieldLabel -> Bool -> IdDetails
+ GHC.Types.Id.Info: RecSelId :: RecSelParent -> FieldLabel -> Bool -> ([ConLike], [ConLike]) -> IdDetails
- GHC.Types.RepType: typePrimRep1 :: HasDebugCallStack => UnaryType -> PrimRep
+ GHC.Types.RepType: typePrimRep1 :: HasDebugCallStack => UnaryType -> PrimOrVoidRep
- GHC.Types.SourceText: StringLiteral :: SourceText -> FastString -> Maybe RealSrcSpan -> StringLiteral
+ GHC.Types.SourceText: StringLiteral :: SourceText -> FastString -> Maybe NoCommentsLocation -> StringLiteral
- GHC.Types.SourceText: [sl_tc] :: StringLiteral -> Maybe RealSrcSpan
+ GHC.Types.SourceText: [sl_tc] :: StringLiteral -> Maybe NoCommentsLocation
- GHC.Types.Tickish: Breakpoint :: XBreakpoint pass -> !Int -> [XTickishId pass] -> GenTickish pass
+ GHC.Types.Tickish: Breakpoint :: XBreakpoint pass -> !Int -> [XTickishId pass] -> Module -> GenTickish pass
- GHC.Types.Var: Invisible :: Specificity -> ForAllTyFlag
+ GHC.Types.Var: Invisible :: !Specificity -> ForAllTyFlag
- GHC.Unit.Module.Warnings: DeprecatedTxt :: Located SourceText -> [Located (WithHsDocIdentifiers StringLiteral pass)] -> WarningTxt pass
+ GHC.Unit.Module.Warnings: DeprecatedTxt :: SourceText -> [LocatedE (WithHsDocIdentifiers StringLiteral pass)] -> WarningTxt pass
- GHC.Unit.Module.Warnings: InWarningCategory :: !Located (HsToken "in") -> !SourceText -> Located WarningCategory -> InWarningCategory
+ GHC.Unit.Module.Warnings: InWarningCategory :: !EpToken "in" -> !SourceText -> LocatedE WarningCategory -> InWarningCategory
- GHC.Unit.Module.Warnings: WarningTxt :: Maybe (Located InWarningCategory) -> Located SourceText -> [Located (WithHsDocIdentifiers StringLiteral pass)] -> WarningTxt pass
+ GHC.Unit.Module.Warnings: WarningTxt :: Maybe (LocatedE InWarningCategory) -> SourceText -> [LocatedE (WithHsDocIdentifiers StringLiteral pass)] -> WarningTxt pass
- GHC.Unit.Module.Warnings: [iwc_in] :: InWarningCategory -> !Located (HsToken "in")
+ GHC.Unit.Module.Warnings: [iwc_in] :: InWarningCategory -> !EpToken "in"
- GHC.Unit.Module.Warnings: [iwc_wc] :: InWarningCategory -> Located WarningCategory
+ GHC.Unit.Module.Warnings: [iwc_wc] :: InWarningCategory -> LocatedE WarningCategory
- GHC.Unit.Module.Warnings: warningTxtMessage :: WarningTxt p -> [Located (WithHsDocIdentifiers StringLiteral p)]
+ GHC.Unit.Module.Warnings: warningTxtMessage :: WarningTxt p -> [LocatedE (WithHsDocIdentifiers StringLiteral p)]
- GHC.Utils.Logger: LogFlags :: SDocContext -> SDocContext -> !EnumSet DumpFlag -> !Bool -> !Bool -> !Bool -> !Bool -> !Maybe FilePath -> !FilePath -> !Maybe FilePath -> !Bool -> !Bool -> !Int -> !Maybe Ways -> LogFlags
+ GHC.Utils.Logger: LogFlags :: SDocContext -> SDocContext -> !EnumSet DumpFlag -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Maybe FilePath -> !FilePath -> !Maybe FilePath -> !Bool -> !Bool -> !Int -> !Maybe Ways -> LogFlags
- GHC.Utils.Misc: expectNonEmpty :: HasDebugCallStack => String -> [a] -> NonEmpty a
+ GHC.Utils.Misc: expectNonEmpty :: HasCallStack => String -> [a] -> NonEmpty a
- GHC.Utils.Misc: expectOnly :: HasDebugCallStack => String -> [a] -> a
+ GHC.Utils.Misc: expectOnly :: HasCallStack => String -> [a] -> a
- GHC.Utils.Outputable: SDC :: !PprStyle -> !Scheme -> !PprColour -> !Bool -> !Int -> !Int -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !FastString -> SDoc -> SDocContext
+ GHC.Utils.Outputable: SDC :: !PprStyle -> !Scheme -> !PprColour -> !Bool -> !Int -> !Int -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !Bool -> !FastString -> SDoc -> SDocContext
- GHC.Utils.Outputable: bndrIsJoin_maybe :: OutputableBndr a => a -> Maybe Int
+ GHC.Utils.Outputable: bndrIsJoin_maybe :: OutputableBndr a => a -> JoinPointHood
- GHCi.Message: EvalBreak :: Bool -> HValueRef -> Int -> String -> RemoteRef (ResumeContext b) -> RemotePtr CostCentreStack -> EvalStatus_ a b
+ GHCi.Message: EvalBreak :: HValueRef -> Maybe EvalBreakpoint -> RemoteRef (ResumeContext b) -> RemotePtr CostCentreStack -> EvalStatus_ a b
- GHCi.Message: [CreateBCOs] :: [ByteString] -> Message [HValueRef]
+ GHCi.Message: [CreateBCOs] :: [ResolvedBCO] -> Message [HValueRef]
- GHCi.Message: [LoadDLL] :: String -> Message (Either String (RemotePtr LoadedDLL))
+ GHCi.Message: [LoadDLL] :: String -> Message (Maybe String)
- Language.Haskell.Syntax.Binds: CompleteMatchSig :: XCompleteMatchSig pass -> XRec pass [LIdP pass] -> Maybe (LIdP pass) -> Sig pass
+ Language.Haskell.Syntax.Binds: CompleteMatchSig :: XCompleteMatchSig pass -> [LIdP pass] -> Maybe (LIdP pass) -> Sig pass
- Language.Haskell.Syntax.Binds: PatBind :: XPatBind idL idR -> LPat idL -> GRHSs idR (LHsExpr idR) -> HsBindLR idL idR
+ Language.Haskell.Syntax.Binds: PatBind :: XPatBind idL idR -> LPat idL -> HsMultAnn idL -> GRHSs idR (LHsExpr idR) -> HsBindLR idL idR
- Language.Haskell.Syntax.Decls: ClassDecl :: XClassDecl pass -> !LayoutInfo pass -> Maybe (LHsContext pass) -> LIdP pass -> LHsQTyVars pass -> LexicalFixity -> [LHsFunDep pass] -> [LSig pass] -> LHsBinds pass -> [LFamilyDecl pass] -> [LTyFamDefltDecl pass] -> [LDocDecl pass] -> TyClDecl pass
+ Language.Haskell.Syntax.Decls: ClassDecl :: XClassDecl pass -> Maybe (LHsContext pass) -> LIdP pass -> LHsQTyVars pass -> LexicalFixity -> [LHsFunDep pass] -> [LSig pass] -> LHsBinds pass -> [LFamilyDecl pass] -> [LTyFamDefltDecl pass] -> [LDocDecl pass] -> TyClDecl pass
- Language.Haskell.Syntax.Decls: ConDeclGADT :: XConDeclGADT pass -> NonEmpty (LIdP pass) -> !LHsUniToken "::" "∷" pass -> XRec pass (HsOuterSigTyVarBndrs pass) -> Maybe (LHsContext pass) -> HsConDeclGADTDetails pass -> LHsType pass -> Maybe (LHsDoc pass) -> ConDecl pass
+ Language.Haskell.Syntax.Decls: ConDeclGADT :: XConDeclGADT pass -> NonEmpty (LIdP pass) -> XRec pass (HsOuterSigTyVarBndrs pass) -> Maybe (LHsContext pass) -> HsConDeclGADTDetails pass -> LHsType pass -> Maybe (LHsDoc pass) -> ConDecl pass
- Language.Haskell.Syntax.Decls: FamEqn :: XCFamEqn pass rhs -> LIdP pass -> HsOuterFamEqnTyVarBndrs pass -> HsTyPats pass -> LexicalFixity -> rhs -> FamEqn pass rhs
+ Language.Haskell.Syntax.Decls: FamEqn :: XCFamEqn pass rhs -> LIdP pass -> HsOuterFamEqnTyVarBndrs pass -> HsFamEqnPats pass -> LexicalFixity -> rhs -> FamEqn pass rhs
- Language.Haskell.Syntax.Decls: PrefixConGADT :: [HsScaled pass (LBangType pass)] -> HsConDeclGADTDetails pass
+ Language.Haskell.Syntax.Decls: PrefixConGADT :: !XPrefixConGADT pass -> [HsScaled pass (LBangType pass)] -> HsConDeclGADTDetails pass
- Language.Haskell.Syntax.Decls: RecConGADT :: XRec pass [LConDeclField pass] -> LHsUniToken "->" "→" pass -> HsConDeclGADTDetails pass
+ Language.Haskell.Syntax.Decls: RecConGADT :: !XRecConGADT pass -> XRec pass [LConDeclField pass] -> HsConDeclGADTDetails pass
- Language.Haskell.Syntax.Decls: [feqn_pats] :: FamEqn pass rhs -> HsTyPats pass
+ Language.Haskell.Syntax.Decls: [feqn_pats] :: FamEqn pass rhs -> HsFamEqnPats pass
- Language.Haskell.Syntax.Expr: ArrowExpr :: HsStmtContext p
+ Language.Haskell.Syntax.Expr: ArrowExpr :: HsStmtContext fn
- Language.Haskell.Syntax.Expr: ArrowMatchCtxt :: HsArrowMatchContext -> HsMatchContext p
+ Language.Haskell.Syntax.Expr: ArrowMatchCtxt :: HsArrowMatchContext -> HsMatchContext fn
- Language.Haskell.Syntax.Expr: CaseAlt :: HsMatchContext p
+ Language.Haskell.Syntax.Expr: CaseAlt :: HsMatchContext fn
- Language.Haskell.Syntax.Expr: FunRhs :: LIdP (NoGhcTc p) -> LexicalFixity -> SrcStrictness -> HsMatchContext p
+ Language.Haskell.Syntax.Expr: FunRhs :: fn -> LexicalFixity -> SrcStrictness -> HsMatchContext fn
- Language.Haskell.Syntax.Expr: HsAppType :: XAppTypeE p -> LHsExpr p -> !LHsToken "@" p -> LHsWcType (NoGhcTc p) -> HsExpr p
+ Language.Haskell.Syntax.Expr: HsAppType :: XAppTypeE p -> LHsExpr p -> LHsWcType (NoGhcTc p) -> HsExpr p
- Language.Haskell.Syntax.Expr: HsCmdLam :: XCmdLam id -> MatchGroup id (LHsCmd id) -> HsCmd id
+ Language.Haskell.Syntax.Expr: HsCmdLam :: XCmdLamCase id -> HsLamVariant -> MatchGroup id (LHsCmd id) -> HsCmd id
- Language.Haskell.Syntax.Expr: HsCmdLet :: XCmdLet id -> !LHsToken "let" id -> HsLocalBinds id -> !LHsToken "in" id -> LHsCmd id -> HsCmd id
+ Language.Haskell.Syntax.Expr: HsCmdLet :: XCmdLet id -> HsLocalBinds id -> LHsCmd id -> HsCmd id
- Language.Haskell.Syntax.Expr: HsCmdPar :: XCmdPar id -> !LHsToken "(" id -> LHsCmd id -> !LHsToken ")" id -> HsCmd id
+ Language.Haskell.Syntax.Expr: HsCmdPar :: XCmdPar id -> LHsCmd id -> HsCmd id
- Language.Haskell.Syntax.Expr: HsDoStmt :: HsDoFlavour -> HsStmtContext p
+ Language.Haskell.Syntax.Expr: HsDoStmt :: HsDoFlavour -> HsStmtContext fn
- Language.Haskell.Syntax.Expr: HsLam :: XLam p -> MatchGroup p (LHsExpr p) -> HsExpr p
+ Language.Haskell.Syntax.Expr: HsLam :: XLam p -> HsLamVariant -> MatchGroup p (LHsExpr p) -> HsExpr p
- Language.Haskell.Syntax.Expr: HsLet :: XLet p -> !LHsToken "let" p -> HsLocalBinds p -> !LHsToken "in" p -> LHsExpr p -> HsExpr p
+ Language.Haskell.Syntax.Expr: HsLet :: XLet p -> HsLocalBinds p -> LHsExpr p -> HsExpr p
- Language.Haskell.Syntax.Expr: HsPar :: XPar p -> !LHsToken "(" p -> LHsExpr p -> !LHsToken ")" p -> HsExpr p
+ Language.Haskell.Syntax.Expr: HsPar :: XPar p -> LHsExpr p -> HsExpr p
- Language.Haskell.Syntax.Expr: IfAlt :: HsMatchContext p
+ Language.Haskell.Syntax.Expr: IfAlt :: HsMatchContext fn
- Language.Haskell.Syntax.Expr: LamCase :: LamCaseVariant
+ Language.Haskell.Syntax.Expr: LamCase :: HsLamVariant
- Language.Haskell.Syntax.Expr: LamCases :: LamCaseVariant
+ Language.Haskell.Syntax.Expr: LamCases :: HsLamVariant
- Language.Haskell.Syntax.Expr: Match :: XCMatch p body -> HsMatchContext p -> [LPat p] -> GRHSs p body -> Match p body
+ Language.Haskell.Syntax.Expr: Match :: XCMatch p body -> HsMatchContext (LIdP (NoGhcTc p)) -> [LPat p] -> GRHSs p body -> Match p body
- Language.Haskell.Syntax.Expr: ParStmtCtxt :: HsStmtContext p -> HsStmtContext p
+ Language.Haskell.Syntax.Expr: ParStmtCtxt :: HsStmtContext fn -> HsStmtContext fn
- Language.Haskell.Syntax.Expr: PatBindGuards :: HsMatchContext p
+ Language.Haskell.Syntax.Expr: PatBindGuards :: HsMatchContext fn
- Language.Haskell.Syntax.Expr: PatBindRhs :: HsMatchContext p
+ Language.Haskell.Syntax.Expr: PatBindRhs :: HsMatchContext fn
- Language.Haskell.Syntax.Expr: PatGuard :: HsMatchContext p -> HsStmtContext p
+ Language.Haskell.Syntax.Expr: PatGuard :: HsMatchContext fn -> HsStmtContext fn
- Language.Haskell.Syntax.Expr: PatSyn :: HsMatchContext p
+ Language.Haskell.Syntax.Expr: PatSyn :: HsMatchContext fn
- Language.Haskell.Syntax.Expr: RecUpd :: HsMatchContext p
+ Language.Haskell.Syntax.Expr: RecUpd :: HsMatchContext fn
- Language.Haskell.Syntax.Expr: StmtCtxt :: HsStmtContext p -> HsMatchContext p
+ Language.Haskell.Syntax.Expr: StmtCtxt :: HsStmtContext fn -> HsMatchContext fn
- Language.Haskell.Syntax.Expr: ThPatQuote :: HsMatchContext p
+ Language.Haskell.Syntax.Expr: ThPatQuote :: HsMatchContext fn
- Language.Haskell.Syntax.Expr: ThPatSplice :: HsMatchContext p
+ Language.Haskell.Syntax.Expr: ThPatSplice :: HsMatchContext fn
- Language.Haskell.Syntax.Expr: TransStmtCtxt :: HsStmtContext p -> HsStmtContext p
+ Language.Haskell.Syntax.Expr: TransStmtCtxt :: HsStmtContext fn -> HsStmtContext fn
- Language.Haskell.Syntax.Expr: [m_ctxt] :: Match p body -> HsMatchContext p
+ Language.Haskell.Syntax.Expr: [m_ctxt] :: Match p body -> HsMatchContext (LIdP (NoGhcTc p))
- Language.Haskell.Syntax.Expr: [mc_fixity] :: HsMatchContext p -> LexicalFixity
+ Language.Haskell.Syntax.Expr: [mc_fixity] :: HsMatchContext fn -> LexicalFixity
- Language.Haskell.Syntax.Expr: [mc_fun] :: HsMatchContext p -> LIdP (NoGhcTc p)
+ Language.Haskell.Syntax.Expr: [mc_fun] :: HsMatchContext fn -> fn
- Language.Haskell.Syntax.Expr: [mc_strictness] :: HsMatchContext p -> SrcStrictness
+ Language.Haskell.Syntax.Expr: [mc_strictness] :: HsMatchContext fn -> SrcStrictness
- Language.Haskell.Syntax.Expr: data HsMatchContext p
+ Language.Haskell.Syntax.Expr: data HsMatchContext fn
- Language.Haskell.Syntax.Expr: data HsStmtContext p
+ Language.Haskell.Syntax.Expr: data HsStmtContext fn
- Language.Haskell.Syntax.Expr: isComprehensionContext :: HsStmtContext id -> Bool
+ Language.Haskell.Syntax.Expr: isComprehensionContext :: HsStmtContext fn -> Bool
- Language.Haskell.Syntax.Expr: isMonadCompContext :: HsStmtContext id -> Bool
+ Language.Haskell.Syntax.Expr: isMonadCompContext :: HsStmtContext fn -> Bool
- Language.Haskell.Syntax.Expr: isMonadStmtContext :: HsStmtContext id -> Bool
+ Language.Haskell.Syntax.Expr: isMonadStmtContext :: HsStmtContext fn -> Bool
- Language.Haskell.Syntax.Expr: isPatSynCtxt :: HsMatchContext p -> Bool
+ Language.Haskell.Syntax.Expr: isPatSynCtxt :: HsMatchContext fn -> Bool
- Language.Haskell.Syntax.Expr: qualifiedDoModuleName_maybe :: HsStmtContext p -> Maybe ModuleName
+ Language.Haskell.Syntax.Expr: qualifiedDoModuleName_maybe :: HsStmtContext fn -> Maybe ModuleName
- Language.Haskell.Syntax.ImpExp: IEThingAbs :: XIEThingAbs pass -> LIEWrappedName pass -> IE pass
+ Language.Haskell.Syntax.ImpExp: IEThingAbs :: XIEThingAbs pass -> LIEWrappedName pass -> Maybe (ExportDoc pass) -> IE pass
- Language.Haskell.Syntax.ImpExp: IEThingAll :: XIEThingAll pass -> LIEWrappedName pass -> IE pass
+ Language.Haskell.Syntax.ImpExp: IEThingAll :: XIEThingAll pass -> LIEWrappedName pass -> Maybe (ExportDoc pass) -> IE pass
- Language.Haskell.Syntax.ImpExp: IEThingWith :: XIEThingWith pass -> LIEWrappedName pass -> IEWildcard -> [LIEWrappedName pass] -> IE pass
+ Language.Haskell.Syntax.ImpExp: IEThingWith :: XIEThingWith pass -> LIEWrappedName pass -> IEWildcard -> [LIEWrappedName pass] -> Maybe (ExportDoc pass) -> IE pass
- Language.Haskell.Syntax.ImpExp: IEVar :: XIEVar pass -> LIEWrappedName pass -> IE pass
+ Language.Haskell.Syntax.ImpExp: IEVar :: XIEVar pass -> LIEWrappedName pass -> Maybe (ExportDoc pass) -> IE pass
- Language.Haskell.Syntax.Pat: AsPat :: XAsPat p -> LIdP p -> !LHsToken "@" p -> LPat p -> Pat p
+ Language.Haskell.Syntax.Pat: AsPat :: XAsPat p -> LIdP p -> LPat p -> Pat p
- Language.Haskell.Syntax.Pat: HsConPatTyArg :: !LHsToken "@" p -> HsPatSigType p -> HsConPatTyArg p
+ Language.Haskell.Syntax.Pat: HsConPatTyArg :: !XConPatTyArg p -> HsTyPat p -> HsConPatTyArg p
- Language.Haskell.Syntax.Pat: ParPat :: XParPat p -> !LHsToken "(" p -> LPat p -> !LHsToken ")" p -> Pat p
+ Language.Haskell.Syntax.Pat: ParPat :: XParPat p -> LPat p -> Pat p
- Language.Haskell.Syntax.Pat: type family ConLikeP x
+ Language.Haskell.Syntax.Pat: type family XConPatTyArg p
- Language.Haskell.Syntax.Type: HsAppKindTy :: XAppKindTy pass -> LHsType pass -> !LHsToken "@" pass -> LHsKind pass -> HsType pass
+ Language.Haskell.Syntax.Type: HsAppKindTy :: XAppKindTy pass -> LHsType pass -> LHsKind pass -> HsType pass
- Language.Haskell.Syntax.Type: HsArgPar :: SrcSpan -> HsArg p tm ty
+ Language.Haskell.Syntax.Type: HsArgPar :: !XArgPar p -> HsArg p tm ty
- Language.Haskell.Syntax.Type: HsBndrInvisible :: LHsToken "@" pass -> HsBndrVis pass
+ Language.Haskell.Syntax.Type: HsBndrInvisible :: !XBndrInvisible pass -> HsBndrVis pass
- Language.Haskell.Syntax.Type: HsBndrRequired :: HsBndrVis pass
+ Language.Haskell.Syntax.Type: HsBndrRequired :: !XBndrRequired pass -> HsBndrVis pass
- Language.Haskell.Syntax.Type: HsExplicitMult :: !LHsToken "%" pass -> !LHsType pass -> !LHsUniToken "->" "→" pass -> HsArrow pass
+ Language.Haskell.Syntax.Type: HsExplicitMult :: !XExplicitMult pass -> !LHsType pass -> HsArrow pass
- Language.Haskell.Syntax.Type: HsLinearArrow :: !HsLinearArrowTokens pass -> HsArrow pass
+ Language.Haskell.Syntax.Type: HsLinearArrow :: !XLinearArrow pass -> HsArrow pass
- Language.Haskell.Syntax.Type: HsTypeArg :: !LHsToken "@" p -> ty -> HsArg p tm ty
+ Language.Haskell.Syntax.Type: HsTypeArg :: !XTypeArg p -> ty -> HsArg p tm ty
- Language.Haskell.Syntax.Type: HsUnrestrictedArrow :: !LHsUniToken "->" "→" pass -> HsArrow pass
+ Language.Haskell.Syntax.Type: HsUnrestrictedArrow :: !XUnrestrictedArrow pass -> HsArrow pass
- Language.Haskell.Syntax.Type: HsValArg :: tm -> HsArg p tm ty
+ Language.Haskell.Syntax.Type: HsValArg :: !XValArg p -> tm -> HsArg p tm ty
- Language.Haskell.TH: InfixD :: Fixity -> Name -> Dec
+ Language.Haskell.TH: InfixD :: Fixity -> NamespaceSpecifier -> Name -> Dec
- Language.Haskell.TH.Ppr: pprFixity :: Name -> Fixity -> Doc
+ Language.Haskell.TH.Ppr: pprFixity :: Name -> Fixity -> NamespaceSpecifier -> Doc
- Language.Haskell.TH.Ppr: ppr_cxt_preds :: Cxt -> Doc
+ Language.Haskell.TH.Ppr: ppr_cxt_preds :: Precedence -> Cxt -> Doc
- Language.Haskell.TH.Ppr: ppr_data :: Doc -> Cxt -> Maybe Name -> Doc -> Maybe Kind -> [Con] -> [DerivClause] -> Doc
+ Language.Haskell.TH.Ppr: ppr_data :: Bool -> Doc -> Cxt -> Maybe Name -> Doc -> Maybe Kind -> [Con] -> [DerivClause] -> Doc
- Language.Haskell.TH.Ppr: ppr_newtype :: Doc -> Cxt -> Maybe Name -> Doc -> Maybe Kind -> Con -> [DerivClause] -> Doc
+ Language.Haskell.TH.Ppr: ppr_newtype :: Bool -> Doc -> Cxt -> Maybe Name -> Doc -> Maybe Kind -> Con -> [DerivClause] -> Doc
- Language.Haskell.TH.Ppr: ppr_type_data :: Doc -> Cxt -> Maybe Name -> Doc -> Maybe Kind -> [Con] -> [DerivClause] -> Doc
+ Language.Haskell.TH.Ppr: ppr_type_data :: Bool -> Doc -> Cxt -> Maybe Name -> Doc -> Maybe Kind -> [Con] -> [DerivClause] -> Doc
- Language.Haskell.TH.Ppr: ppr_typedef :: String -> Doc -> Cxt -> Maybe Name -> Doc -> Maybe Kind -> [Con] -> [DerivClause] -> Doc
+ Language.Haskell.TH.Ppr: ppr_typedef :: String -> Bool -> Doc -> Cxt -> Maybe Name -> Doc -> Maybe Kind -> [Con] -> [DerivClause] -> Doc
- Language.Haskell.TH.Syntax: InfixD :: Fixity -> Name -> Dec
+ Language.Haskell.TH.Syntax: InfixD :: Fixity -> NamespaceSpecifier -> Name -> Dec

Files

compiler/ClosureTypes.h view
@@ -16,6 +16,7 @@  *   - the closure flags table in rts/ClosureFlags.c  *   - isRetainer in rts/RetainerProfile.c  *   - the closure_type_names list in rts/Printer.c+ *   - the ClosureType sum type in libraries/ghc-internal/src/GHC/Internal/ClosureTypes.hs  */  /* CONSTR/THUNK/FUN_$A_$B mean they have $A pointers followed by $B
compiler/CodeGen.Platform.h view
@@ -480,6 +480,7 @@  #endif +-- See also Note [Caller saves and callee-saves regs.] callerSaves :: GlobalReg -> Bool #if defined(CALLER_SAVES_Base) callerSaves BaseReg           = True
compiler/GHC/Builtin/Names.hs view
@@ -270,10 +270,13 @@         -- WithDict         withDictClassName, +        -- DataToTag+        dataToTagClassName,+         -- Dynamic         toDynName, -        -- Numeric stuff+        -- GHC.Internal.Numeric stuff         negateName, minusName, geName, eqName,         mkRationalBase2Name, mkRationalBase10Name, @@ -355,6 +358,7 @@         stablePtrTyConName, ptrTyConName, funPtrTyConName, constPtrConName,         int8TyConName, int16TyConName, int32TyConName, int64TyConName,         word8TyConName, word16TyConName, word32TyConName, word64TyConName,+        jsvalTyConName,          -- Others         otherwiseIdName, inlineIdName,@@ -452,6 +456,10 @@         -- Overloaded record fields         hasFieldClassName, +        -- ExceptionContext+        exceptionContextTyConName,+        emptyExceptionContextName,+         -- Call Stacks         callStackTyConName,         emptyCallStackName, pushCallStackName,@@ -544,118 +552,125 @@ --MetaHaskell Extension Add a new module here -} -pRELUDE :: Module-pRELUDE         = mkBaseModule_ pRELUDE_NAME- gHC_PRIM, gHC_PRIM_PANIC,-    gHC_TYPES, gHC_GENERICS, gHC_MAGIC, gHC_MAGIC_DICT,-    gHC_CLASSES, gHC_PRIMOPWRAPPERS, gHC_BASE, gHC_ENUM,-    gHC_GHCI, gHC_GHCI_HELPERS, gHC_CSTRING,-    gHC_SHOW, gHC_READ, gHC_NUM, gHC_MAYBE,-    gHC_NUM_INTEGER, gHC_NUM_NATURAL, gHC_NUM_BIGNAT,-    gHC_LIST, gHC_TUPLE, gHC_TUPLE_PRIM, dATA_EITHER, dATA_LIST, dATA_STRING,-    dATA_FOLDABLE, dATA_TRAVERSABLE,-    gHC_CONC, gHC_IO, gHC_IO_Exception,-    gHC_ST, gHC_IX, gHC_STABLE, gHC_PTR, gHC_ERR, gHC_REAL,-    gHC_FLOAT, gHC_TOP_HANDLER, sYSTEM_IO, dYNAMIC,-    tYPEABLE, tYPEABLE_INTERNAL, gENERICS,-    rEAD_PREC, lEX, gHC_INT, gHC_WORD, mONAD, mONAD_FIX, mONAD_ZIP, mONAD_FAIL,-    aRROW, gHC_DESUGAR, rANDOM, gHC_EXTS, gHC_IS_LIST,-    cONTROL_EXCEPTION_BASE, gHC_TYPEERROR, gHC_TYPELITS, gHC_TYPELITS_INTERNAL,-    gHC_TYPENATS, gHC_TYPENATS_INTERNAL,-    dATA_COERCE, dEBUG_TRACE, uNSAFE_COERCE, fOREIGN_C_CONSTPTR :: Module--gHC_PRIM        = mkPrimModule (fsLit "GHC.Prim")   -- Primitive types and values-gHC_PRIM_PANIC  = mkPrimModule (fsLit "GHC.Prim.Panic")-gHC_TYPES       = mkPrimModule (fsLit "GHC.Types")-gHC_MAGIC       = mkPrimModule (fsLit "GHC.Magic")-gHC_MAGIC_DICT  = mkPrimModule (fsLit "GHC.Magic.Dict")-gHC_CSTRING     = mkPrimModule (fsLit "GHC.CString")-gHC_CLASSES     = mkPrimModule (fsLit "GHC.Classes")+    gHC_TYPES, gHC_INTERNAL_DATA_DATA, gHC_MAGIC, gHC_MAGIC_DICT,+    gHC_CLASSES, gHC_PRIMOPWRAPPERS :: Module+gHC_PRIM           = mkPrimModule (fsLit "GHC.Prim")   -- Primitive types and values+gHC_PRIM_PANIC     = mkPrimModule (fsLit "GHC.Prim.Panic")+gHC_TYPES          = mkPrimModule (fsLit "GHC.Types")+gHC_MAGIC          = mkPrimModule (fsLit "GHC.Magic")+gHC_MAGIC_DICT     = mkPrimModule (fsLit "GHC.Magic.Dict")+gHC_CSTRING        = mkPrimModule (fsLit "GHC.CString")+gHC_CLASSES        = mkPrimModule (fsLit "GHC.Classes") gHC_PRIMOPWRAPPERS = mkPrimModule (fsLit "GHC.PrimopWrappers") -gHC_BASE        = mkBaseModule (fsLit "GHC.Base")-gHC_ENUM        = mkBaseModule (fsLit "GHC.Enum")-gHC_GHCI        = mkBaseModule (fsLit "GHC.GHCi")-gHC_GHCI_HELPERS= mkBaseModule (fsLit "GHC.GHCi.Helpers")-gHC_SHOW        = mkBaseModule (fsLit "GHC.Show")-gHC_READ        = mkBaseModule (fsLit "GHC.Read")-gHC_NUM         = mkBaseModule (fsLit "GHC.Num")-gHC_MAYBE       = mkBaseModule (fsLit "GHC.Maybe")-gHC_NUM_INTEGER = mkBignumModule (fsLit "GHC.Num.Integer")-gHC_NUM_NATURAL = mkBignumModule (fsLit "GHC.Num.Natural")-gHC_NUM_BIGNAT  = mkBignumModule (fsLit "GHC.Num.BigNat")-gHC_LIST        = mkBaseModule (fsLit "GHC.List")-gHC_TUPLE       = mkPrimModule (fsLit "GHC.Tuple")-gHC_TUPLE_PRIM  = mkPrimModule (fsLit "GHC.Tuple.Prim")-dATA_EITHER     = mkBaseModule (fsLit "Data.Either")-dATA_LIST       = mkBaseModule (fsLit "Data.List")-dATA_STRING     = mkBaseModule (fsLit "Data.String")-dATA_FOLDABLE   = mkBaseModule (fsLit "Data.Foldable")-dATA_TRAVERSABLE= mkBaseModule (fsLit "Data.Traversable")-gHC_CONC        = mkBaseModule (fsLit "GHC.Conc")-gHC_IO          = mkBaseModule (fsLit "GHC.IO")-gHC_IO_Exception = mkBaseModule (fsLit "GHC.IO.Exception")-gHC_ST          = mkBaseModule (fsLit "GHC.ST")-gHC_IX          = mkBaseModule (fsLit "GHC.Ix")-gHC_STABLE      = mkBaseModule (fsLit "GHC.Stable")-gHC_PTR         = mkBaseModule (fsLit "GHC.Ptr")-gHC_ERR         = mkBaseModule (fsLit "GHC.Err")-gHC_REAL        = mkBaseModule (fsLit "GHC.Real")-gHC_FLOAT       = mkBaseModule (fsLit "GHC.Float")-gHC_TOP_HANDLER = mkBaseModule (fsLit "GHC.TopHandler")-sYSTEM_IO       = mkBaseModule (fsLit "System.IO")-dYNAMIC         = mkBaseModule (fsLit "Data.Dynamic")-tYPEABLE        = mkBaseModule (fsLit "Data.Typeable")-tYPEABLE_INTERNAL = mkBaseModule (fsLit "Data.Typeable.Internal")-gENERICS        = mkBaseModule (fsLit "Data.Data")-rEAD_PREC       = mkBaseModule (fsLit "Text.ParserCombinators.ReadPrec")-lEX             = mkBaseModule (fsLit "Text.Read.Lex")-gHC_INT         = mkBaseModule (fsLit "GHC.Int")-gHC_WORD        = mkBaseModule (fsLit "GHC.Word")-mONAD           = mkBaseModule (fsLit "Control.Monad")-mONAD_FIX       = mkBaseModule (fsLit "Control.Monad.Fix")-mONAD_ZIP       = mkBaseModule (fsLit "Control.Monad.Zip")-mONAD_FAIL      = mkBaseModule (fsLit "Control.Monad.Fail")-aRROW           = mkBaseModule (fsLit "Control.Arrow")-gHC_DESUGAR = mkBaseModule (fsLit "GHC.Desugar")-rANDOM          = mkBaseModule (fsLit "System.Random")-gHC_EXTS        = mkBaseModule (fsLit "GHC.Exts")-gHC_IS_LIST     = mkBaseModule (fsLit "GHC.IsList")-cONTROL_EXCEPTION_BASE = mkBaseModule (fsLit "Control.Exception.Base")-gHC_GENERICS    = mkBaseModule (fsLit "GHC.Generics")-gHC_TYPEERROR   = mkBaseModule (fsLit "GHC.TypeError")-gHC_TYPELITS    = mkBaseModule (fsLit "GHC.TypeLits")-gHC_TYPELITS_INTERNAL = mkBaseModule (fsLit "GHC.TypeLits.Internal")-gHC_TYPENATS    = mkBaseModule (fsLit "GHC.TypeNats")-gHC_TYPENATS_INTERNAL = mkBaseModule (fsLit "GHC.TypeNats.Internal")-dATA_COERCE     = mkBaseModule (fsLit "Data.Coerce")-dEBUG_TRACE     = mkBaseModule (fsLit "Debug.Trace")-uNSAFE_COERCE   = mkBaseModule (fsLit "Unsafe.Coerce")-fOREIGN_C_CONSTPTR = mkBaseModule (fsLit "Foreign.C.ConstPtr")+gHC_INTERNAL_TUPLE                  = mkPrimModule (fsLit "GHC.Tuple") -gHC_SRCLOC :: Module-gHC_SRCLOC = mkBaseModule (fsLit "GHC.SrcLoc")+pRELUDE, dATA_LIST, cONTROL_MONAD_ZIP :: Module+pRELUDE            = mkBaseModule_ pRELUDE_NAME+dATA_LIST          = mkBaseModule (fsLit "Data.List")+cONTROL_MONAD_ZIP  = mkBaseModule (fsLit "Control.Monad.Zip") -gHC_STACK, gHC_STACK_TYPES :: Module-gHC_STACK = mkBaseModule (fsLit "GHC.Stack")-gHC_STACK_TYPES = mkBaseModule (fsLit "GHC.Stack.Types")+gHC_INTERNAL_NUM_INTEGER, gHC_INTERNAL_NUM_NATURAL, gHC_INTERNAL_NUM_BIGNAT :: Module+gHC_INTERNAL_NUM_INTEGER            = mkBignumModule (fsLit "GHC.Num.Integer")+gHC_INTERNAL_NUM_NATURAL            = mkBignumModule (fsLit "GHC.Num.Natural")+gHC_INTERNAL_NUM_BIGNAT             = mkBignumModule (fsLit "GHC.Num.BigNat") -gHC_STATICPTR :: Module-gHC_STATICPTR = mkBaseModule (fsLit "GHC.StaticPtr")+gHC_INTERNAL_BASE, gHC_INTERNAL_ENUM,+    gHC_INTERNAL_GHCI, gHC_INTERNAL_GHCI_HELPERS, gHC_CSTRING, gHC_INTERNAL_DATA_STRING,+    gHC_INTERNAL_SHOW, gHC_INTERNAL_READ, gHC_INTERNAL_NUM, gHC_INTERNAL_MAYBE,+    gHC_INTERNAL_LIST, gHC_INTERNAL_TUPLE, gHC_INTERNAL_DATA_EITHER,+    gHC_INTERNAL_DATA_FOLDABLE, gHC_INTERNAL_DATA_TRAVERSABLE,+    gHC_INTERNAL_EXCEPTION_CONTEXT,+    gHC_INTERNAL_CONC, gHC_INTERNAL_IO, gHC_INTERNAL_IO_Exception,+    gHC_INTERNAL_ST, gHC_INTERNAL_IX, gHC_INTERNAL_STABLE, gHC_INTERNAL_PTR, gHC_INTERNAL_ERR, gHC_INTERNAL_REAL,+    gHC_INTERNAL_FLOAT, gHC_INTERNAL_TOP_HANDLER, gHC_INTERNAL_SYSTEM_IO, gHC_INTERNAL_DYNAMIC,+    gHC_INTERNAL_TYPEABLE, gHC_INTERNAL_TYPEABLE_INTERNAL, gHC_INTERNAL_GENERICS,+    gHC_INTERNAL_READ_PREC, gHC_INTERNAL_LEX, gHC_INTERNAL_INT, gHC_INTERNAL_WORD, gHC_INTERNAL_MONAD, gHC_INTERNAL_MONAD_FIX,  gHC_INTERNAL_MONAD_FAIL,+    gHC_INTERNAL_ARROW, gHC_INTERNAL_DESUGAR, gHC_INTERNAL_RANDOM, gHC_INTERNAL_EXTS, gHC_INTERNAL_IS_LIST,+    gHC_INTERNAL_CONTROL_EXCEPTION_BASE, gHC_INTERNAL_TYPEERROR, gHC_INTERNAL_TYPELITS, gHC_INTERNAL_TYPELITS_INTERNAL,+    gHC_INTERNAL_TYPENATS, gHC_INTERNAL_TYPENATS_INTERNAL,+    gHC_INTERNAL_DATA_COERCE, gHC_INTERNAL_DEBUG_TRACE, gHC_INTERNAL_UNSAFE_COERCE, gHC_INTERNAL_FOREIGN_C_CONSTPTR :: Module+gHC_INTERNAL_BASE                   = mkGhcInternalModule (fsLit "GHC.Internal.Base")+gHC_INTERNAL_ENUM                   = mkGhcInternalModule (fsLit "GHC.Internal.Enum")+gHC_INTERNAL_GHCI                   = mkGhcInternalModule (fsLit "GHC.Internal.GHCi")+gHC_INTERNAL_GHCI_HELPERS           = mkGhcInternalModule (fsLit "GHC.Internal.GHCi.Helpers")+gHC_INTERNAL_SHOW                   = mkGhcInternalModule (fsLit "GHC.Internal.Show")+gHC_INTERNAL_READ                   = mkGhcInternalModule (fsLit "GHC.Internal.Read")+gHC_INTERNAL_NUM                    = mkGhcInternalModule (fsLit "GHC.Internal.Num")+gHC_INTERNAL_MAYBE                  = mkGhcInternalModule (fsLit "GHC.Internal.Maybe")+gHC_INTERNAL_LIST                   = mkGhcInternalModule (fsLit "GHC.Internal.List")+gHC_INTERNAL_DATA_EITHER            = mkGhcInternalModule (fsLit "GHC.Internal.Data.Either")+gHC_INTERNAL_DATA_STRING            = mkGhcInternalModule (fsLit "GHC.Internal.Data.String")+gHC_INTERNAL_DATA_FOLDABLE          = mkGhcInternalModule (fsLit "GHC.Internal.Data.Foldable")+gHC_INTERNAL_DATA_TRAVERSABLE       = mkGhcInternalModule (fsLit "GHC.Internal.Data.Traversable")+gHC_INTERNAL_CONC                   = mkGhcInternalModule (fsLit "GHC.Internal.GHC.Conc")+gHC_INTERNAL_IO                     = mkGhcInternalModule (fsLit "GHC.Internal.IO")+gHC_INTERNAL_IO_Exception           = mkGhcInternalModule (fsLit "GHC.Internal.IO.Exception")+gHC_INTERNAL_ST                     = mkGhcInternalModule (fsLit "GHC.Internal.ST")+gHC_INTERNAL_IX                     = mkGhcInternalModule (fsLit "GHC.Internal.Ix")+gHC_INTERNAL_STABLE                 = mkGhcInternalModule (fsLit "GHC.Internal.Stable")+gHC_INTERNAL_PTR                    = mkGhcInternalModule (fsLit "GHC.Internal.Ptr")+gHC_INTERNAL_ERR                    = mkGhcInternalModule (fsLit "GHC.Internal.Err")+gHC_INTERNAL_REAL                   = mkGhcInternalModule (fsLit "GHC.Internal.Real")+gHC_INTERNAL_FLOAT                  = mkGhcInternalModule (fsLit "GHC.Internal.Float")+gHC_INTERNAL_TOP_HANDLER            = mkGhcInternalModule (fsLit "GHC.Internal.TopHandler")+gHC_INTERNAL_SYSTEM_IO              = mkGhcInternalModule (fsLit "GHC.Internal.System.IO")+gHC_INTERNAL_DYNAMIC                = mkGhcInternalModule (fsLit "GHC.Internal.Data.Dynamic")+gHC_INTERNAL_TYPEABLE               = mkGhcInternalModule (fsLit "GHC.Internal.Data.Typeable")+gHC_INTERNAL_TYPEABLE_INTERNAL      = mkGhcInternalModule (fsLit "GHC.Internal.Data.Typeable.Internal")+gHC_INTERNAL_DATA_DATA              = mkGhcInternalModule (fsLit "GHC.Internal.Data.Data")+gHC_INTERNAL_READ_PREC              = mkGhcInternalModule (fsLit "GHC.Internal.Text.ParserCombinators.ReadPrec")+gHC_INTERNAL_LEX                    = mkGhcInternalModule (fsLit "GHC.Internal.Text.Read.Lex")+gHC_INTERNAL_INT                    = mkGhcInternalModule (fsLit "GHC.Internal.Int")+gHC_INTERNAL_WORD                   = mkGhcInternalModule (fsLit "GHC.Internal.Word")+gHC_INTERNAL_MONAD                  = mkGhcInternalModule (fsLit "GHC.Internal.Control.Monad")+gHC_INTERNAL_MONAD_FIX              = mkGhcInternalModule (fsLit "GHC.Internal.Control.Monad.Fix")+gHC_INTERNAL_MONAD_FAIL             = mkGhcInternalModule (fsLit "GHC.Internal.Control.Monad.Fail")+gHC_INTERNAL_ARROW                  = mkGhcInternalModule (fsLit "GHC.Internal.Control.Arrow")+gHC_INTERNAL_DESUGAR                = mkGhcInternalModule (fsLit "GHC.Internal.Desugar")+gHC_INTERNAL_RANDOM                 = mkGhcInternalModule (fsLit "GHC.Internal.System.Random")+gHC_INTERNAL_EXTS                   = mkGhcInternalModule (fsLit "GHC.Internal.Exts")+gHC_INTERNAL_IS_LIST                = mkGhcInternalModule (fsLit "GHC.Internal.IsList")+gHC_INTERNAL_CONTROL_EXCEPTION_BASE = mkGhcInternalModule (fsLit "GHC.Internal.Control.Exception.Base")+gHC_INTERNAL_EXCEPTION_CONTEXT = mkGhcInternalModule (fsLit "GHC.Internal.Exception.Context")+gHC_INTERNAL_GENERICS               = mkGhcInternalModule (fsLit "GHC.Internal.Generics")+gHC_INTERNAL_TYPEERROR              = mkGhcInternalModule (fsLit "GHC.Internal.TypeError")+gHC_INTERNAL_TYPELITS               = mkGhcInternalModule (fsLit "GHC.Internal.TypeLits")+gHC_INTERNAL_TYPELITS_INTERNAL      = mkGhcInternalModule (fsLit "GHC.Internal.TypeLits.Internal")+gHC_INTERNAL_TYPENATS               = mkGhcInternalModule (fsLit "GHC.Internal.TypeNats")+gHC_INTERNAL_TYPENATS_INTERNAL      = mkGhcInternalModule (fsLit "GHC.Internal.TypeNats.Internal")+gHC_INTERNAL_DATA_COERCE            = mkGhcInternalModule (fsLit "GHC.Internal.Data.Coerce")+gHC_INTERNAL_DEBUG_TRACE            = mkGhcInternalModule (fsLit "GHC.Internal.Debug.Trace")+gHC_INTERNAL_UNSAFE_COERCE          = mkGhcInternalModule (fsLit "GHC.Internal.Unsafe.Coerce")+gHC_INTERNAL_FOREIGN_C_CONSTPTR     = mkGhcInternalModule (fsLit "GHC.Internal.Foreign.C.ConstPtr") -gHC_STATICPTR_INTERNAL :: Module-gHC_STATICPTR_INTERNAL = mkBaseModule (fsLit "GHC.StaticPtr.Internal")+gHC_INTERNAL_SRCLOC :: Module+gHC_INTERNAL_SRCLOC = mkGhcInternalModule (fsLit "GHC.Internal.SrcLoc") -gHC_FINGERPRINT_TYPE :: Module-gHC_FINGERPRINT_TYPE = mkBaseModule (fsLit "GHC.Fingerprint.Type")+gHC_INTERNAL_STACK, gHC_INTERNAL_STACK_TYPES :: Module+gHC_INTERNAL_STACK = mkGhcInternalModule (fsLit "GHC.Internal.Stack")+gHC_INTERNAL_STACK_TYPES = mkGhcInternalModule (fsLit "GHC.Internal.Stack.Types") -gHC_OVER_LABELS :: Module-gHC_OVER_LABELS = mkBaseModule (fsLit "GHC.OverloadedLabels")+gHC_INTERNAL_STATICPTR :: Module+gHC_INTERNAL_STATICPTR = mkGhcInternalModule (fsLit "GHC.Internal.StaticPtr") -gHC_RECORDS :: Module-gHC_RECORDS = mkBaseModule (fsLit "GHC.Records")+gHC_INTERNAL_STATICPTR_INTERNAL :: Module+gHC_INTERNAL_STATICPTR_INTERNAL = mkGhcInternalModule (fsLit "GHC.Internal.StaticPtr.Internal") +gHC_INTERNAL_FINGERPRINT_TYPE :: Module+gHC_INTERNAL_FINGERPRINT_TYPE = mkGhcInternalModule (fsLit "GHC.Internal.Fingerprint.Type")++gHC_INTERNAL_OVER_LABELS :: Module+gHC_INTERNAL_OVER_LABELS = mkGhcInternalModule (fsLit "GHC.Internal.OverloadedLabels")++gHC_INTERNAL_RECORDS :: Module+gHC_INTERNAL_RECORDS = mkGhcInternalModule (fsLit "GHC.Internal.Records")++dATA_TUPLE_EXPERIMENTAL, dATA_SUM_EXPERIMENTAL :: Module+dATA_TUPLE_EXPERIMENTAL = mkExperimentalModule (fsLit "Data.Tuple.Experimental")+dATA_SUM_EXPERIMENTAL = mkExperimentalModule (fsLit "Data.Sum.Experimental")+ rOOT_MAIN :: Module rOOT_MAIN       = mkMainModule (fsLit ":Main") -- Root module for initialisation @@ -673,6 +688,12 @@ mkBignumModule :: FastString -> Module mkBignumModule m = mkModule bignumUnit (mkModuleNameFS m) +mkGhcInternalModule :: FastString -> Module+mkGhcInternalModule m = mkGhcInternalModule_ (mkModuleNameFS m)++mkGhcInternalModule_ :: ModuleName -> Module+mkGhcInternalModule_ m = mkModule ghcInternalUnit m+ mkBaseModule :: FastString -> Module mkBaseModule m = mkBaseModule_ (mkModuleNameFS m) @@ -691,6 +712,9 @@ mkMainModule_ :: ModuleName -> Module mkMainModule_ m = mkModule mainUnit m +mkExperimentalModule :: FastString -> Module+mkExperimentalModule m = mkModule experimentalUnit (mkModuleNameFS m)+ {- ************************************************************************ *                                                                      *@@ -716,14 +740,6 @@ eqTag_RDR               = nameRdrName  ordEQDataConName gtTag_RDR               = nameRdrName  ordGTDataConName -eqClass_RDR, numClass_RDR, ordClass_RDR, enumClass_RDR, monadClass_RDR-    :: RdrName-eqClass_RDR             = nameRdrName eqClassName-numClass_RDR            = nameRdrName numClassName-ordClass_RDR            = nameRdrName ordClassName-enumClass_RDR           = nameRdrName enumClassName-monadClass_RDR          = nameRdrName monadClassName- map_RDR, append_RDR :: RdrName map_RDR                 = nameRdrName mapName append_RDR              = nameRdrName appendName@@ -741,8 +757,8 @@ right_RDR               = nameRdrName rightDataConName  fromEnum_RDR, toEnum_RDR :: RdrName-fromEnum_RDR            = varQual_RDR gHC_ENUM (fsLit "fromEnum")-toEnum_RDR              = varQual_RDR gHC_ENUM (fsLit "toEnum")+fromEnum_RDR            = varQual_RDR gHC_INTERNAL_ENUM (fsLit "fromEnum")+toEnum_RDR              = varQual_RDR gHC_INTERNAL_ENUM (fsLit "toEnum")  enumFrom_RDR, enumFromTo_RDR, enumFromThen_RDR, enumFromThenTo_RDR :: RdrName enumFrom_RDR            = nameRdrName enumFromName@@ -750,100 +766,69 @@ enumFromThen_RDR        = nameRdrName enumFromThenName enumFromThenTo_RDR      = nameRdrName enumFromThenToName -ratioDataCon_RDR, integerAdd_RDR, integerMul_RDR :: RdrName-ratioDataCon_RDR        = nameRdrName ratioDataConName-integerAdd_RDR          = nameRdrName integerAddName-integerMul_RDR          = nameRdrName integerMulName--ioDataCon_RDR :: RdrName-ioDataCon_RDR           = nameRdrName ioDataConName--newStablePtr_RDR :: RdrName-newStablePtr_RDR        = nameRdrName newStablePtrName--bindIO_RDR, returnIO_RDR :: RdrName-bindIO_RDR              = nameRdrName bindIOName-returnIO_RDR            = nameRdrName returnIOName--fromInteger_RDR, fromRational_RDR, minus_RDR, times_RDR, plus_RDR :: RdrName-fromInteger_RDR         = nameRdrName fromIntegerName-fromRational_RDR        = nameRdrName fromRationalName-minus_RDR               = nameRdrName minusName-times_RDR               = varQual_RDR  gHC_NUM (fsLit "*")-plus_RDR                = varQual_RDR gHC_NUM (fsLit "+")--toInteger_RDR, toRational_RDR, fromIntegral_RDR :: RdrName-toInteger_RDR           = nameRdrName toIntegerName-toRational_RDR          = nameRdrName toRationalName-fromIntegral_RDR        = nameRdrName fromIntegralName--fromString_RDR :: RdrName-fromString_RDR          = nameRdrName fromStringName--fromList_RDR, fromListN_RDR, toList_RDR :: RdrName-fromList_RDR = nameRdrName fromListName-fromListN_RDR = nameRdrName fromListNName-toList_RDR = nameRdrName toListName+times_RDR, plus_RDR :: RdrName+times_RDR               = varQual_RDR  gHC_INTERNAL_NUM (fsLit "*")+plus_RDR                = varQual_RDR gHC_INTERNAL_NUM (fsLit "+")  compose_RDR :: RdrName-compose_RDR             = varQual_RDR gHC_BASE (fsLit ".")+compose_RDR             = varQual_RDR gHC_INTERNAL_BASE (fsLit ".")  not_RDR, dataToTag_RDR, succ_RDR, pred_RDR, minBound_RDR, maxBound_RDR,     and_RDR, range_RDR, inRange_RDR, index_RDR,     unsafeIndex_RDR, unsafeRangeSize_RDR :: RdrName and_RDR                 = varQual_RDR gHC_CLASSES (fsLit "&&") not_RDR                 = varQual_RDR gHC_CLASSES (fsLit "not")-dataToTag_RDR           = varQual_RDR gHC_PRIM (fsLit "dataToTag#")-succ_RDR                = varQual_RDR gHC_ENUM (fsLit "succ")-pred_RDR                = varQual_RDR gHC_ENUM (fsLit "pred")-minBound_RDR            = varQual_RDR gHC_ENUM (fsLit "minBound")-maxBound_RDR            = varQual_RDR gHC_ENUM (fsLit "maxBound")-range_RDR               = varQual_RDR gHC_IX (fsLit "range")-inRange_RDR             = varQual_RDR gHC_IX (fsLit "inRange")-index_RDR               = varQual_RDR gHC_IX (fsLit "index")-unsafeIndex_RDR         = varQual_RDR gHC_IX (fsLit "unsafeIndex")-unsafeRangeSize_RDR     = varQual_RDR gHC_IX (fsLit "unsafeRangeSize")+dataToTag_RDR           = varQual_RDR gHC_MAGIC (fsLit "dataToTag#")+succ_RDR                = varQual_RDR gHC_INTERNAL_ENUM (fsLit "succ")+pred_RDR                = varQual_RDR gHC_INTERNAL_ENUM (fsLit "pred")+minBound_RDR            = varQual_RDR gHC_INTERNAL_ENUM (fsLit "minBound")+maxBound_RDR            = varQual_RDR gHC_INTERNAL_ENUM (fsLit "maxBound")+range_RDR               = varQual_RDR gHC_INTERNAL_IX (fsLit "range")+inRange_RDR             = varQual_RDR gHC_INTERNAL_IX (fsLit "inRange")+index_RDR               = varQual_RDR gHC_INTERNAL_IX (fsLit "index")+unsafeIndex_RDR         = varQual_RDR gHC_INTERNAL_IX (fsLit "unsafeIndex")+unsafeRangeSize_RDR     = varQual_RDR gHC_INTERNAL_IX (fsLit "unsafeRangeSize")  readList_RDR, readListDefault_RDR, readListPrec_RDR, readListPrecDefault_RDR,     readPrec_RDR, parens_RDR, choose_RDR, lexP_RDR, expectP_RDR :: RdrName-readList_RDR            = varQual_RDR gHC_READ (fsLit "readList")-readListDefault_RDR     = varQual_RDR gHC_READ (fsLit "readListDefault")-readListPrec_RDR        = varQual_RDR gHC_READ (fsLit "readListPrec")-readListPrecDefault_RDR = varQual_RDR gHC_READ (fsLit "readListPrecDefault")-readPrec_RDR            = varQual_RDR gHC_READ (fsLit "readPrec")-parens_RDR              = varQual_RDR gHC_READ (fsLit "parens")-choose_RDR              = varQual_RDR gHC_READ (fsLit "choose")-lexP_RDR                = varQual_RDR gHC_READ (fsLit "lexP")-expectP_RDR             = varQual_RDR gHC_READ (fsLit "expectP")+readList_RDR            = varQual_RDR gHC_INTERNAL_READ (fsLit "readList")+readListDefault_RDR     = varQual_RDR gHC_INTERNAL_READ (fsLit "readListDefault")+readListPrec_RDR        = varQual_RDR gHC_INTERNAL_READ (fsLit "readListPrec")+readListPrecDefault_RDR = varQual_RDR gHC_INTERNAL_READ (fsLit "readListPrecDefault")+readPrec_RDR            = varQual_RDR gHC_INTERNAL_READ (fsLit "readPrec")+parens_RDR              = varQual_RDR gHC_INTERNAL_READ (fsLit "parens")+choose_RDR              = varQual_RDR gHC_INTERNAL_READ (fsLit "choose")+lexP_RDR                = varQual_RDR gHC_INTERNAL_READ (fsLit "lexP")+expectP_RDR             = varQual_RDR gHC_INTERNAL_READ (fsLit "expectP")  readField_RDR, readFieldHash_RDR, readSymField_RDR :: RdrName-readField_RDR           = varQual_RDR gHC_READ (fsLit "readField")-readFieldHash_RDR       = varQual_RDR gHC_READ (fsLit "readFieldHash")-readSymField_RDR        = varQual_RDR gHC_READ (fsLit "readSymField")+readField_RDR           = varQual_RDR gHC_INTERNAL_READ (fsLit "readField")+readFieldHash_RDR       = varQual_RDR gHC_INTERNAL_READ (fsLit "readFieldHash")+readSymField_RDR        = varQual_RDR gHC_INTERNAL_READ (fsLit "readSymField")  punc_RDR, ident_RDR, symbol_RDR :: RdrName-punc_RDR                = dataQual_RDR lEX (fsLit "Punc")-ident_RDR               = dataQual_RDR lEX (fsLit "Ident")-symbol_RDR              = dataQual_RDR lEX (fsLit "Symbol")+punc_RDR                = dataQual_RDR gHC_INTERNAL_LEX (fsLit "Punc")+ident_RDR               = dataQual_RDR gHC_INTERNAL_LEX (fsLit "Ident")+symbol_RDR              = dataQual_RDR gHC_INTERNAL_LEX (fsLit "Symbol")  step_RDR, alt_RDR, reset_RDR, prec_RDR, pfail_RDR :: RdrName-step_RDR                = varQual_RDR  rEAD_PREC (fsLit "step")-alt_RDR                 = varQual_RDR  rEAD_PREC (fsLit "+++")-reset_RDR               = varQual_RDR  rEAD_PREC (fsLit "reset")-prec_RDR                = varQual_RDR  rEAD_PREC (fsLit "prec")-pfail_RDR               = varQual_RDR  rEAD_PREC (fsLit "pfail")+step_RDR                = varQual_RDR  gHC_INTERNAL_READ_PREC (fsLit "step")+alt_RDR                 = varQual_RDR  gHC_INTERNAL_READ_PREC (fsLit "+++")+reset_RDR               = varQual_RDR  gHC_INTERNAL_READ_PREC (fsLit "reset")+prec_RDR                = varQual_RDR  gHC_INTERNAL_READ_PREC (fsLit "prec")+pfail_RDR               = varQual_RDR  gHC_INTERNAL_READ_PREC (fsLit "pfail")  showsPrec_RDR, shows_RDR, showString_RDR,     showSpace_RDR, showCommaSpace_RDR, showParen_RDR :: RdrName-showsPrec_RDR           = varQual_RDR gHC_SHOW (fsLit "showsPrec")-shows_RDR               = varQual_RDR gHC_SHOW (fsLit "shows")-showString_RDR          = varQual_RDR gHC_SHOW (fsLit "showString")-showSpace_RDR           = varQual_RDR gHC_SHOW (fsLit "showSpace")-showCommaSpace_RDR      = varQual_RDR gHC_SHOW (fsLit "showCommaSpace")-showParen_RDR           = varQual_RDR gHC_SHOW (fsLit "showParen")+showsPrec_RDR           = varQual_RDR gHC_INTERNAL_SHOW (fsLit "showsPrec")+shows_RDR               = varQual_RDR gHC_INTERNAL_SHOW (fsLit "shows")+showString_RDR          = varQual_RDR gHC_INTERNAL_SHOW (fsLit "showString")+showSpace_RDR           = varQual_RDR gHC_INTERNAL_SHOW (fsLit "showSpace")+showCommaSpace_RDR      = varQual_RDR gHC_INTERNAL_SHOW (fsLit "showCommaSpace")+showParen_RDR           = varQual_RDR gHC_INTERNAL_SHOW (fsLit "showParen")  error_RDR :: RdrName-error_RDR = varQual_RDR gHC_ERR (fsLit "error")+error_RDR = varQual_RDR gHC_INTERNAL_ERR (fsLit "error")  -- Generics (constructors and functions) u1DataCon_RDR, par1DataCon_RDR, rec1DataCon_RDR,@@ -860,70 +845,70 @@   uAddrHash_RDR, uCharHash_RDR, uDoubleHash_RDR,   uFloatHash_RDR, uIntHash_RDR, uWordHash_RDR :: RdrName -u1DataCon_RDR    = dataQual_RDR gHC_GENERICS (fsLit "U1")-par1DataCon_RDR  = dataQual_RDR gHC_GENERICS (fsLit "Par1")-rec1DataCon_RDR  = dataQual_RDR gHC_GENERICS (fsLit "Rec1")-k1DataCon_RDR    = dataQual_RDR gHC_GENERICS (fsLit "K1")-m1DataCon_RDR    = dataQual_RDR gHC_GENERICS (fsLit "M1")+u1DataCon_RDR    = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "U1")+par1DataCon_RDR  = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "Par1")+rec1DataCon_RDR  = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "Rec1")+k1DataCon_RDR    = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "K1")+m1DataCon_RDR    = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "M1") -l1DataCon_RDR     = dataQual_RDR gHC_GENERICS (fsLit "L1")-r1DataCon_RDR     = dataQual_RDR gHC_GENERICS (fsLit "R1")+l1DataCon_RDR     = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "L1")+r1DataCon_RDR     = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "R1") -prodDataCon_RDR   = dataQual_RDR gHC_GENERICS (fsLit ":*:")-comp1DataCon_RDR  = dataQual_RDR gHC_GENERICS (fsLit "Comp1")+prodDataCon_RDR   = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit ":*:")+comp1DataCon_RDR  = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "Comp1") -unPar1_RDR  = fieldQual_RDR gHC_GENERICS (fsLit "Par1")  (fsLit "unPar1")-unRec1_RDR  = fieldQual_RDR gHC_GENERICS (fsLit "Rec1")  (fsLit "unRec1")-unK1_RDR    = fieldQual_RDR gHC_GENERICS (fsLit "K1")    (fsLit "unK1")-unComp1_RDR = fieldQual_RDR gHC_GENERICS (fsLit "Comp1") (fsLit "unComp1")+unPar1_RDR  = fieldQual_RDR gHC_INTERNAL_GENERICS (fsLit "Par1")  (fsLit "unPar1")+unRec1_RDR  = fieldQual_RDR gHC_INTERNAL_GENERICS (fsLit "Rec1")  (fsLit "unRec1")+unK1_RDR    = fieldQual_RDR gHC_INTERNAL_GENERICS (fsLit "K1")    (fsLit "unK1")+unComp1_RDR = fieldQual_RDR gHC_INTERNAL_GENERICS (fsLit "Comp1") (fsLit "unComp1") -from_RDR  = varQual_RDR gHC_GENERICS (fsLit "from")-from1_RDR = varQual_RDR gHC_GENERICS (fsLit "from1")-to_RDR    = varQual_RDR gHC_GENERICS (fsLit "to")-to1_RDR   = varQual_RDR gHC_GENERICS (fsLit "to1")+from_RDR  = varQual_RDR gHC_INTERNAL_GENERICS (fsLit "from")+from1_RDR = varQual_RDR gHC_INTERNAL_GENERICS (fsLit "from1")+to_RDR    = varQual_RDR gHC_INTERNAL_GENERICS (fsLit "to")+to1_RDR   = varQual_RDR gHC_INTERNAL_GENERICS (fsLit "to1") -datatypeName_RDR  = varQual_RDR gHC_GENERICS (fsLit "datatypeName")-moduleName_RDR    = varQual_RDR gHC_GENERICS (fsLit "moduleName")-packageName_RDR   = varQual_RDR gHC_GENERICS (fsLit "packageName")-isNewtypeName_RDR = varQual_RDR gHC_GENERICS (fsLit "isNewtype")-selName_RDR       = varQual_RDR gHC_GENERICS (fsLit "selName")-conName_RDR       = varQual_RDR gHC_GENERICS (fsLit "conName")-conFixity_RDR     = varQual_RDR gHC_GENERICS (fsLit "conFixity")-conIsRecord_RDR   = varQual_RDR gHC_GENERICS (fsLit "conIsRecord")+datatypeName_RDR  = varQual_RDR gHC_INTERNAL_GENERICS (fsLit "datatypeName")+moduleName_RDR    = varQual_RDR gHC_INTERNAL_GENERICS (fsLit "moduleName")+packageName_RDR   = varQual_RDR gHC_INTERNAL_GENERICS (fsLit "packageName")+isNewtypeName_RDR = varQual_RDR gHC_INTERNAL_GENERICS (fsLit "isNewtype")+selName_RDR       = varQual_RDR gHC_INTERNAL_GENERICS (fsLit "selName")+conName_RDR       = varQual_RDR gHC_INTERNAL_GENERICS (fsLit "conName")+conFixity_RDR     = varQual_RDR gHC_INTERNAL_GENERICS (fsLit "conFixity")+conIsRecord_RDR   = varQual_RDR gHC_INTERNAL_GENERICS (fsLit "conIsRecord") -prefixDataCon_RDR     = dataQual_RDR gHC_GENERICS (fsLit "Prefix")-infixDataCon_RDR      = dataQual_RDR gHC_GENERICS (fsLit "Infix")+prefixDataCon_RDR     = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "Prefix")+infixDataCon_RDR      = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "Infix") leftAssocDataCon_RDR  = nameRdrName leftAssociativeDataConName rightAssocDataCon_RDR = nameRdrName rightAssociativeDataConName notAssocDataCon_RDR   = nameRdrName notAssociativeDataConName -uAddrDataCon_RDR   = dataQual_RDR gHC_GENERICS (fsLit "UAddr")-uCharDataCon_RDR   = dataQual_RDR gHC_GENERICS (fsLit "UChar")-uDoubleDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "UDouble")-uFloatDataCon_RDR  = dataQual_RDR gHC_GENERICS (fsLit "UFloat")-uIntDataCon_RDR    = dataQual_RDR gHC_GENERICS (fsLit "UInt")-uWordDataCon_RDR   = dataQual_RDR gHC_GENERICS (fsLit "UWord")+uAddrDataCon_RDR   = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "UAddr")+uCharDataCon_RDR   = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "UChar")+uDoubleDataCon_RDR = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "UDouble")+uFloatDataCon_RDR  = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "UFloat")+uIntDataCon_RDR    = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "UInt")+uWordDataCon_RDR   = dataQual_RDR gHC_INTERNAL_GENERICS (fsLit "UWord") -uAddrHash_RDR   = fieldQual_RDR gHC_GENERICS (fsLit "UAddr")   (fsLit "uAddr#")-uCharHash_RDR   = fieldQual_RDR gHC_GENERICS (fsLit "UChar")   (fsLit "uChar#")-uDoubleHash_RDR = fieldQual_RDR gHC_GENERICS (fsLit "UDouble") (fsLit "uDouble#")-uFloatHash_RDR  = fieldQual_RDR gHC_GENERICS (fsLit "UFloat")  (fsLit "uFloat#")-uIntHash_RDR    = fieldQual_RDR gHC_GENERICS (fsLit "UInt")    (fsLit "uInt#")-uWordHash_RDR   = fieldQual_RDR gHC_GENERICS (fsLit "UWord")   (fsLit "uWord#")+uAddrHash_RDR   = fieldQual_RDR gHC_INTERNAL_GENERICS (fsLit "UAddr")   (fsLit "uAddr#")+uCharHash_RDR   = fieldQual_RDR gHC_INTERNAL_GENERICS (fsLit "UChar")   (fsLit "uChar#")+uDoubleHash_RDR = fieldQual_RDR gHC_INTERNAL_GENERICS (fsLit "UDouble") (fsLit "uDouble#")+uFloatHash_RDR  = fieldQual_RDR gHC_INTERNAL_GENERICS (fsLit "UFloat")  (fsLit "uFloat#")+uIntHash_RDR    = fieldQual_RDR gHC_INTERNAL_GENERICS (fsLit "UInt")    (fsLit "uInt#")+uWordHash_RDR   = fieldQual_RDR gHC_INTERNAL_GENERICS (fsLit "UWord")   (fsLit "uWord#")  fmap_RDR, replace_RDR, pure_RDR, ap_RDR, liftA2_RDR, foldable_foldr_RDR,     foldMap_RDR, null_RDR, all_RDR, traverse_RDR, mempty_RDR,     mappend_RDR :: RdrName fmap_RDR                = nameRdrName fmapName-replace_RDR             = varQual_RDR gHC_BASE (fsLit "<$")+replace_RDR             = varQual_RDR gHC_INTERNAL_BASE (fsLit "<$") pure_RDR                = nameRdrName pureAName ap_RDR                  = nameRdrName apAName-liftA2_RDR              = varQual_RDR gHC_BASE (fsLit "liftA2")-foldable_foldr_RDR      = varQual_RDR dATA_FOLDABLE       (fsLit "foldr")-foldMap_RDR             = varQual_RDR dATA_FOLDABLE       (fsLit "foldMap")-null_RDR                = varQual_RDR dATA_FOLDABLE       (fsLit "null")-all_RDR                 = varQual_RDR dATA_FOLDABLE       (fsLit "all")-traverse_RDR            = varQual_RDR dATA_TRAVERSABLE    (fsLit "traverse")+liftA2_RDR              = varQual_RDR gHC_INTERNAL_BASE (fsLit "liftA2")+foldable_foldr_RDR      = varQual_RDR gHC_INTERNAL_DATA_FOLDABLE       (fsLit "foldr")+foldMap_RDR             = varQual_RDR gHC_INTERNAL_DATA_FOLDABLE       (fsLit "foldMap")+null_RDR                = varQual_RDR gHC_INTERNAL_DATA_FOLDABLE       (fsLit "null")+all_RDR                 = varQual_RDR gHC_INTERNAL_DATA_FOLDABLE       (fsLit "all")+traverse_RDR            = varQual_RDR gHC_INTERNAL_DATA_TRAVERSABLE    (fsLit "traverse") mempty_RDR              = nameRdrName memptyName mappend_RDR             = nameRdrName mappendName @@ -954,7 +939,7 @@ wildCardName = mkSystemVarName wildCardKey (fsLit "wild")  runMainIOName, runRWName :: Name-runMainIOName = varQual gHC_TOP_HANDLER (fsLit "runMainIO") runMainKey+runMainIOName = varQual gHC_INTERNAL_TOP_HANDLER (fsLit "runMainIO") runMainKey runRWName     = varQual gHC_MAGIC       (fsLit "runRW#")    runRWKey  orderingTyConName, ordLTDataConName, ordEQDataConName, ordGTDataConName :: Name@@ -967,12 +952,12 @@ specTyConName     = tcQual gHC_TYPES (fsLit "SPEC") specTyConKey  eitherTyConName, leftDataConName, rightDataConName :: Name-eitherTyConName   = tcQual  dATA_EITHER (fsLit "Either") eitherTyConKey-leftDataConName   = dcQual dATA_EITHER (fsLit "Left")   leftDataConKey-rightDataConName  = dcQual dATA_EITHER (fsLit "Right")  rightDataConKey+eitherTyConName   = tcQual  gHC_INTERNAL_DATA_EITHER (fsLit "Either") eitherTyConKey+leftDataConName   = dcQual gHC_INTERNAL_DATA_EITHER (fsLit "Left")   leftDataConKey+rightDataConName  = dcQual gHC_INTERNAL_DATA_EITHER (fsLit "Right")  rightDataConKey  voidTyConName :: Name-voidTyConName = tcQual gHC_BASE (fsLit "Void") voidTyConKey+voidTyConName = tcQual gHC_INTERNAL_BASE (fsLit "Void") voidTyConKey  -- Generics (types) v1TyConName, u1TyConName, par1TyConName, rec1TyConName,@@ -991,57 +976,57 @@   decidedLazyDataConName, decidedStrictDataConName, decidedUnpackDataConName,   metaDataDataConName, metaConsDataConName, metaSelDataConName :: Name -v1TyConName  = tcQual gHC_GENERICS (fsLit "V1") v1TyConKey-u1TyConName  = tcQual gHC_GENERICS (fsLit "U1") u1TyConKey-par1TyConName  = tcQual gHC_GENERICS (fsLit "Par1") par1TyConKey-rec1TyConName  = tcQual gHC_GENERICS (fsLit "Rec1") rec1TyConKey-k1TyConName  = tcQual gHC_GENERICS (fsLit "K1") k1TyConKey-m1TyConName  = tcQual gHC_GENERICS (fsLit "M1") m1TyConKey+v1TyConName  = tcQual gHC_INTERNAL_GENERICS (fsLit "V1") v1TyConKey+u1TyConName  = tcQual gHC_INTERNAL_GENERICS (fsLit "U1") u1TyConKey+par1TyConName  = tcQual gHC_INTERNAL_GENERICS (fsLit "Par1") par1TyConKey+rec1TyConName  = tcQual gHC_INTERNAL_GENERICS (fsLit "Rec1") rec1TyConKey+k1TyConName  = tcQual gHC_INTERNAL_GENERICS (fsLit "K1") k1TyConKey+m1TyConName  = tcQual gHC_INTERNAL_GENERICS (fsLit "M1") m1TyConKey -sumTyConName    = tcQual gHC_GENERICS (fsLit ":+:") sumTyConKey-prodTyConName   = tcQual gHC_GENERICS (fsLit ":*:") prodTyConKey-compTyConName   = tcQual gHC_GENERICS (fsLit ":.:") compTyConKey+sumTyConName    = tcQual gHC_INTERNAL_GENERICS (fsLit ":+:") sumTyConKey+prodTyConName   = tcQual gHC_INTERNAL_GENERICS (fsLit ":*:") prodTyConKey+compTyConName   = tcQual gHC_INTERNAL_GENERICS (fsLit ":.:") compTyConKey -rTyConName  = tcQual gHC_GENERICS (fsLit "R") rTyConKey-dTyConName  = tcQual gHC_GENERICS (fsLit "D") dTyConKey-cTyConName  = tcQual gHC_GENERICS (fsLit "C") cTyConKey-sTyConName  = tcQual gHC_GENERICS (fsLit "S") sTyConKey+rTyConName  = tcQual gHC_INTERNAL_GENERICS (fsLit "R") rTyConKey+dTyConName  = tcQual gHC_INTERNAL_GENERICS (fsLit "D") dTyConKey+cTyConName  = tcQual gHC_INTERNAL_GENERICS (fsLit "C") cTyConKey+sTyConName  = tcQual gHC_INTERNAL_GENERICS (fsLit "S") sTyConKey -rec0TyConName  = tcQual gHC_GENERICS (fsLit "Rec0") rec0TyConKey-d1TyConName  = tcQual gHC_GENERICS (fsLit "D1") d1TyConKey-c1TyConName  = tcQual gHC_GENERICS (fsLit "C1") c1TyConKey-s1TyConName  = tcQual gHC_GENERICS (fsLit "S1") s1TyConKey+rec0TyConName  = tcQual gHC_INTERNAL_GENERICS (fsLit "Rec0") rec0TyConKey+d1TyConName  = tcQual gHC_INTERNAL_GENERICS (fsLit "D1") d1TyConKey+c1TyConName  = tcQual gHC_INTERNAL_GENERICS (fsLit "C1") c1TyConKey+s1TyConName  = tcQual gHC_INTERNAL_GENERICS (fsLit "S1") s1TyConKey -repTyConName  = tcQual gHC_GENERICS (fsLit "Rep")  repTyConKey-rep1TyConName = tcQual gHC_GENERICS (fsLit "Rep1") rep1TyConKey+repTyConName  = tcQual gHC_INTERNAL_GENERICS (fsLit "Rep")  repTyConKey+rep1TyConName = tcQual gHC_INTERNAL_GENERICS (fsLit "Rep1") rep1TyConKey -uRecTyConName      = tcQual gHC_GENERICS (fsLit "URec") uRecTyConKey-uAddrTyConName     = tcQual gHC_GENERICS (fsLit "UAddr") uAddrTyConKey-uCharTyConName     = tcQual gHC_GENERICS (fsLit "UChar") uCharTyConKey-uDoubleTyConName   = tcQual gHC_GENERICS (fsLit "UDouble") uDoubleTyConKey-uFloatTyConName    = tcQual gHC_GENERICS (fsLit "UFloat") uFloatTyConKey-uIntTyConName      = tcQual gHC_GENERICS (fsLit "UInt") uIntTyConKey-uWordTyConName     = tcQual gHC_GENERICS (fsLit "UWord") uWordTyConKey+uRecTyConName      = tcQual gHC_INTERNAL_GENERICS (fsLit "URec") uRecTyConKey+uAddrTyConName     = tcQual gHC_INTERNAL_GENERICS (fsLit "UAddr") uAddrTyConKey+uCharTyConName     = tcQual gHC_INTERNAL_GENERICS (fsLit "UChar") uCharTyConKey+uDoubleTyConName   = tcQual gHC_INTERNAL_GENERICS (fsLit "UDouble") uDoubleTyConKey+uFloatTyConName    = tcQual gHC_INTERNAL_GENERICS (fsLit "UFloat") uFloatTyConKey+uIntTyConName      = tcQual gHC_INTERNAL_GENERICS (fsLit "UInt") uIntTyConKey+uWordTyConName     = tcQual gHC_INTERNAL_GENERICS (fsLit "UWord") uWordTyConKey -prefixIDataConName = dcQual gHC_GENERICS (fsLit "PrefixI")  prefixIDataConKey-infixIDataConName  = dcQual gHC_GENERICS (fsLit "InfixI")   infixIDataConKey-leftAssociativeDataConName  = dcQual gHC_GENERICS (fsLit "LeftAssociative")   leftAssociativeDataConKey-rightAssociativeDataConName = dcQual gHC_GENERICS (fsLit "RightAssociative")  rightAssociativeDataConKey-notAssociativeDataConName   = dcQual gHC_GENERICS (fsLit "NotAssociative")    notAssociativeDataConKey+prefixIDataConName = dcQual gHC_INTERNAL_GENERICS (fsLit "PrefixI")  prefixIDataConKey+infixIDataConName  = dcQual gHC_INTERNAL_GENERICS (fsLit "InfixI")   infixIDataConKey+leftAssociativeDataConName  = dcQual gHC_INTERNAL_GENERICS (fsLit "LeftAssociative")   leftAssociativeDataConKey+rightAssociativeDataConName = dcQual gHC_INTERNAL_GENERICS (fsLit "RightAssociative")  rightAssociativeDataConKey+notAssociativeDataConName   = dcQual gHC_INTERNAL_GENERICS (fsLit "NotAssociative")    notAssociativeDataConKey -sourceUnpackDataConName         = dcQual gHC_GENERICS (fsLit "SourceUnpack")         sourceUnpackDataConKey-sourceNoUnpackDataConName       = dcQual gHC_GENERICS (fsLit "SourceNoUnpack")       sourceNoUnpackDataConKey-noSourceUnpackednessDataConName = dcQual gHC_GENERICS (fsLit "NoSourceUnpackedness") noSourceUnpackednessDataConKey-sourceLazyDataConName           = dcQual gHC_GENERICS (fsLit "SourceLazy")           sourceLazyDataConKey-sourceStrictDataConName         = dcQual gHC_GENERICS (fsLit "SourceStrict")         sourceStrictDataConKey-noSourceStrictnessDataConName   = dcQual gHC_GENERICS (fsLit "NoSourceStrictness")   noSourceStrictnessDataConKey-decidedLazyDataConName          = dcQual gHC_GENERICS (fsLit "DecidedLazy")          decidedLazyDataConKey-decidedStrictDataConName        = dcQual gHC_GENERICS (fsLit "DecidedStrict")        decidedStrictDataConKey-decidedUnpackDataConName        = dcQual gHC_GENERICS (fsLit "DecidedUnpack")        decidedUnpackDataConKey+sourceUnpackDataConName         = dcQual gHC_INTERNAL_GENERICS (fsLit "SourceUnpack")         sourceUnpackDataConKey+sourceNoUnpackDataConName       = dcQual gHC_INTERNAL_GENERICS (fsLit "SourceNoUnpack")       sourceNoUnpackDataConKey+noSourceUnpackednessDataConName = dcQual gHC_INTERNAL_GENERICS (fsLit "NoSourceUnpackedness") noSourceUnpackednessDataConKey+sourceLazyDataConName           = dcQual gHC_INTERNAL_GENERICS (fsLit "SourceLazy")           sourceLazyDataConKey+sourceStrictDataConName         = dcQual gHC_INTERNAL_GENERICS (fsLit "SourceStrict")         sourceStrictDataConKey+noSourceStrictnessDataConName   = dcQual gHC_INTERNAL_GENERICS (fsLit "NoSourceStrictness")   noSourceStrictnessDataConKey+decidedLazyDataConName          = dcQual gHC_INTERNAL_GENERICS (fsLit "DecidedLazy")          decidedLazyDataConKey+decidedStrictDataConName        = dcQual gHC_INTERNAL_GENERICS (fsLit "DecidedStrict")        decidedStrictDataConKey+decidedUnpackDataConName        = dcQual gHC_INTERNAL_GENERICS (fsLit "DecidedUnpack")        decidedUnpackDataConKey -metaDataDataConName  = dcQual gHC_GENERICS (fsLit "MetaData")  metaDataDataConKey-metaConsDataConName  = dcQual gHC_GENERICS (fsLit "MetaCons")  metaConsDataConKey-metaSelDataConName   = dcQual gHC_GENERICS (fsLit "MetaSel")   metaSelDataConKey+metaDataDataConName  = dcQual gHC_INTERNAL_GENERICS (fsLit "MetaData")  metaDataDataConKey+metaConsDataConName  = dcQual gHC_INTERNAL_GENERICS (fsLit "MetaCons")  metaConsDataConKey+metaSelDataConName   = dcQual gHC_INTERNAL_GENERICS (fsLit "MetaSel")   metaSelDataConKey  -- Primitive Int divIntName, modIntName :: Name@@ -1054,7 +1039,7 @@     unpackCStringAppendName, unpackCStringAppendUtf8Name,     eqStringName, cstringLengthName :: Name cstringLengthName       = varQual gHC_CSTRING (fsLit "cstringLength#") cstringLengthIdKey-eqStringName            = varQual gHC_BASE (fsLit "eqString")  eqStringIdKey+eqStringName            = varQual gHC_INTERNAL_BASE (fsLit "eqString")  eqStringIdKey  unpackCStringName       = varQual gHC_CSTRING (fsLit "unpackCString#") unpackCStringIdKey unpackCStringAppendName = varQual gHC_CSTRING (fsLit "unpackAppendCString#") unpackCStringAppendIdKey@@ -1075,50 +1060,50 @@ eqName            = varQual gHC_CLASSES (fsLit "==")      eqClassOpKey ordClassName      = clsQual gHC_CLASSES (fsLit "Ord")     ordClassKey geName            = varQual gHC_CLASSES (fsLit ">=")      geClassOpKey-functorClassName  = clsQual gHC_BASE    (fsLit "Functor") functorClassKey-fmapName          = varQual gHC_BASE    (fsLit "fmap")    fmapClassOpKey+functorClassName  = clsQual gHC_INTERNAL_BASE    (fsLit "Functor") functorClassKey+fmapName          = varQual gHC_INTERNAL_BASE    (fsLit "fmap")    fmapClassOpKey  -- Class Monad monadClassName, thenMName, bindMName, returnMName :: Name-monadClassName     = clsQual gHC_BASE (fsLit "Monad")  monadClassKey-thenMName          = varQual gHC_BASE (fsLit ">>")     thenMClassOpKey-bindMName          = varQual gHC_BASE (fsLit ">>=")    bindMClassOpKey-returnMName        = varQual gHC_BASE (fsLit "return") returnMClassOpKey+monadClassName     = clsQual gHC_INTERNAL_BASE (fsLit "Monad")  monadClassKey+thenMName          = varQual gHC_INTERNAL_BASE (fsLit ">>")     thenMClassOpKey+bindMName          = varQual gHC_INTERNAL_BASE (fsLit ">>=")    bindMClassOpKey+returnMName        = varQual gHC_INTERNAL_BASE (fsLit "return") returnMClassOpKey  -- Class MonadFail monadFailClassName, failMName :: Name-monadFailClassName = clsQual mONAD_FAIL (fsLit "MonadFail") monadFailClassKey-failMName          = varQual mONAD_FAIL (fsLit "fail")      failMClassOpKey+monadFailClassName = clsQual gHC_INTERNAL_MONAD_FAIL (fsLit "MonadFail") monadFailClassKey+failMName          = varQual gHC_INTERNAL_MONAD_FAIL (fsLit "fail")      failMClassOpKey  -- Class Applicative applicativeClassName, pureAName, apAName, thenAName :: Name-applicativeClassName = clsQual gHC_BASE (fsLit "Applicative") applicativeClassKey-apAName              = varQual gHC_BASE (fsLit "<*>")         apAClassOpKey-pureAName            = varQual gHC_BASE (fsLit "pure")        pureAClassOpKey-thenAName            = varQual gHC_BASE (fsLit "*>")          thenAClassOpKey+applicativeClassName = clsQual gHC_INTERNAL_BASE (fsLit "Applicative") applicativeClassKey+apAName              = varQual gHC_INTERNAL_BASE (fsLit "<*>")         apAClassOpKey+pureAName            = varQual gHC_INTERNAL_BASE (fsLit "pure")        pureAClassOpKey+thenAName            = varQual gHC_INTERNAL_BASE (fsLit "*>")          thenAClassOpKey  -- Classes (Foldable, Traversable) foldableClassName, traversableClassName :: Name-foldableClassName     = clsQual  dATA_FOLDABLE       (fsLit "Foldable")    foldableClassKey-traversableClassName  = clsQual  dATA_TRAVERSABLE    (fsLit "Traversable") traversableClassKey+foldableClassName     = clsQual  gHC_INTERNAL_DATA_FOLDABLE       (fsLit "Foldable")    foldableClassKey+traversableClassName  = clsQual  gHC_INTERNAL_DATA_TRAVERSABLE    (fsLit "Traversable") traversableClassKey  -- Classes (Semigroup, Monoid) semigroupClassName, sappendName :: Name-semigroupClassName = clsQual gHC_BASE       (fsLit "Semigroup") semigroupClassKey-sappendName        = varQual gHC_BASE       (fsLit "<>")        sappendClassOpKey+semigroupClassName = clsQual gHC_INTERNAL_BASE       (fsLit "Semigroup") semigroupClassKey+sappendName        = varQual gHC_INTERNAL_BASE       (fsLit "<>")        sappendClassOpKey monoidClassName, memptyName, mappendName, mconcatName :: Name-monoidClassName    = clsQual gHC_BASE       (fsLit "Monoid")    monoidClassKey-memptyName         = varQual gHC_BASE       (fsLit "mempty")    memptyClassOpKey-mappendName        = varQual gHC_BASE       (fsLit "mappend")   mappendClassOpKey-mconcatName        = varQual gHC_BASE       (fsLit "mconcat")   mconcatClassOpKey+monoidClassName    = clsQual gHC_INTERNAL_BASE       (fsLit "Monoid")    monoidClassKey+memptyName         = varQual gHC_INTERNAL_BASE       (fsLit "mempty")    memptyClassOpKey+mappendName        = varQual gHC_INTERNAL_BASE       (fsLit "mappend")   mappendClassOpKey+mconcatName        = varQual gHC_INTERNAL_BASE       (fsLit "mconcat")   mconcatClassOpKey    -- AMP additions  joinMName, alternativeClassName :: Name-joinMName            = varQual gHC_BASE (fsLit "join")        joinMIdKey-alternativeClassName = clsQual mONAD (fsLit "Alternative") alternativeClassKey+joinMName            = varQual gHC_INTERNAL_BASE (fsLit "join")        joinMIdKey+alternativeClassName = clsQual gHC_INTERNAL_MONAD (fsLit "Alternative") alternativeClassKey  -- joinMIdKey, apAClassOpKey, pureAClassOpKey, thenAClassOpKey,@@ -1132,28 +1117,28 @@  -- Functions for GHC extensions considerAccessibleName :: Name-considerAccessibleName = varQual gHC_EXTS (fsLit "considerAccessible") considerAccessibleIdKey+considerAccessibleName = varQual gHC_INTERNAL_EXTS (fsLit "considerAccessible") considerAccessibleIdKey --- Random GHC.Base functions+-- Random GHC.Internal.Base functions fromStringName, otherwiseIdName, foldrName, buildName, augmentName,     mapName, appendName, assertName,     dollarName :: Name-dollarName        = varQual gHC_BASE (fsLit "$")          dollarIdKey-otherwiseIdName   = varQual gHC_BASE (fsLit "otherwise")  otherwiseIdKey-foldrName         = varQual gHC_BASE (fsLit "foldr")      foldrIdKey-buildName         = varQual gHC_BASE (fsLit "build")      buildIdKey-augmentName       = varQual gHC_BASE (fsLit "augment")    augmentIdKey-mapName           = varQual gHC_BASE (fsLit "map")        mapIdKey-appendName        = varQual gHC_BASE (fsLit "++")         appendIdKey-assertName        = varQual gHC_BASE (fsLit "assert")     assertIdKey-fromStringName = varQual dATA_STRING (fsLit "fromString") fromStringClassOpKey+dollarName        = varQual gHC_INTERNAL_BASE (fsLit "$")          dollarIdKey+otherwiseIdName   = varQual gHC_INTERNAL_BASE (fsLit "otherwise")  otherwiseIdKey+foldrName         = varQual gHC_INTERNAL_BASE (fsLit "foldr")      foldrIdKey+buildName         = varQual gHC_INTERNAL_BASE (fsLit "build")      buildIdKey+augmentName       = varQual gHC_INTERNAL_BASE (fsLit "augment")    augmentIdKey+mapName           = varQual gHC_INTERNAL_BASE (fsLit "map")        mapIdKey+appendName        = varQual gHC_INTERNAL_BASE (fsLit "++")         appendIdKey+assertName        = varQual gHC_INTERNAL_BASE (fsLit "assert")     assertIdKey+fromStringName    = varQual gHC_INTERNAL_DATA_STRING (fsLit "fromString") fromStringClassOpKey --- Module GHC.Num+-- Module GHC.Internal.Num numClassName, fromIntegerName, minusName, negateName :: Name-numClassName      = clsQual gHC_NUM (fsLit "Num")         numClassKey-fromIntegerName   = varQual gHC_NUM (fsLit "fromInteger") fromIntegerClassOpKey-minusName         = varQual gHC_NUM (fsLit "-")           minusClassOpKey-negateName        = varQual gHC_NUM (fsLit "negate")      negateClassOpKey+numClassName      = clsQual gHC_INTERNAL_NUM (fsLit "Num")         numClassKey+fromIntegerName   = varQual gHC_INTERNAL_NUM (fsLit "fromInteger") fromIntegerClassOpKey+minusName         = varQual gHC_INTERNAL_NUM (fsLit "-")           minusClassOpKey+negateName        = varQual gHC_INTERNAL_NUM (fsLit "negate")      negateClassOpKey  --------------------------------- -- ghc-bignum@@ -1225,9 +1210,9 @@    :: Name  bnbVarQual, bnnVarQual, bniVarQual :: String -> Unique -> Name-bnbVarQual str key = varQual gHC_NUM_BIGNAT  (fsLit str) key-bnnVarQual str key = varQual gHC_NUM_NATURAL (fsLit str) key-bniVarQual str key = varQual gHC_NUM_INTEGER (fsLit str) key+bnbVarQual str key = varQual gHC_INTERNAL_NUM_BIGNAT  (fsLit str) key+bnnVarQual str key = varQual gHC_INTERNAL_NUM_NATURAL (fsLit str) key+bniVarQual str key = varQual gHC_INTERNAL_NUM_INTEGER (fsLit str) key  -- Types and DataCons bignatFromWordListName    = bnbVarQual "bigNatFromWordList#"       bignatFromWordListIdKey@@ -1303,44 +1288,44 @@ -- End of ghc-bignum --------------------------------- --- GHC.Real types and classes+-- GHC.Internal.Real types and classes rationalTyConName, ratioTyConName, ratioDataConName, realClassName,     integralClassName, realFracClassName, fractionalClassName,     fromRationalName, toIntegerName, toRationalName, fromIntegralName,     realToFracName, mkRationalBase2Name, mkRationalBase10Name :: Name-rationalTyConName   = tcQual  gHC_REAL (fsLit "Rational")     rationalTyConKey-ratioTyConName      = tcQual  gHC_REAL (fsLit "Ratio")        ratioTyConKey-ratioDataConName    = dcQual  gHC_REAL (fsLit ":%")           ratioDataConKey-realClassName       = clsQual gHC_REAL (fsLit "Real")         realClassKey-integralClassName   = clsQual gHC_REAL (fsLit "Integral")     integralClassKey-realFracClassName   = clsQual gHC_REAL (fsLit "RealFrac")     realFracClassKey-fractionalClassName = clsQual gHC_REAL (fsLit "Fractional")   fractionalClassKey-fromRationalName    = varQual gHC_REAL (fsLit "fromRational") fromRationalClassOpKey-toIntegerName       = varQual gHC_REAL (fsLit "toInteger")    toIntegerClassOpKey-toRationalName      = varQual gHC_REAL (fsLit "toRational")   toRationalClassOpKey-fromIntegralName    = varQual  gHC_REAL (fsLit "fromIntegral")fromIntegralIdKey-realToFracName      = varQual  gHC_REAL (fsLit "realToFrac")  realToFracIdKey-mkRationalBase2Name  = varQual  gHC_REAL  (fsLit "mkRationalBase2")  mkRationalBase2IdKey-mkRationalBase10Name = varQual  gHC_REAL  (fsLit "mkRationalBase10") mkRationalBase10IdKey--- GHC.Float classes+rationalTyConName   = tcQual  gHC_INTERNAL_REAL (fsLit "Rational")     rationalTyConKey+ratioTyConName      = tcQual  gHC_INTERNAL_REAL (fsLit "Ratio")        ratioTyConKey+ratioDataConName    = dcQual  gHC_INTERNAL_REAL (fsLit ":%")           ratioDataConKey+realClassName       = clsQual gHC_INTERNAL_REAL (fsLit "Real")         realClassKey+integralClassName   = clsQual gHC_INTERNAL_REAL (fsLit "Integral")     integralClassKey+realFracClassName   = clsQual gHC_INTERNAL_REAL (fsLit "RealFrac")     realFracClassKey+fractionalClassName = clsQual gHC_INTERNAL_REAL (fsLit "Fractional")   fractionalClassKey+fromRationalName    = varQual gHC_INTERNAL_REAL (fsLit "fromRational") fromRationalClassOpKey+toIntegerName       = varQual gHC_INTERNAL_REAL (fsLit "toInteger")    toIntegerClassOpKey+toRationalName      = varQual gHC_INTERNAL_REAL (fsLit "toRational")   toRationalClassOpKey+fromIntegralName    = varQual  gHC_INTERNAL_REAL (fsLit "fromIntegral")fromIntegralIdKey+realToFracName      = varQual  gHC_INTERNAL_REAL (fsLit "realToFrac")  realToFracIdKey+mkRationalBase2Name  = varQual  gHC_INTERNAL_REAL  (fsLit "mkRationalBase2")  mkRationalBase2IdKey+mkRationalBase10Name = varQual  gHC_INTERNAL_REAL  (fsLit "mkRationalBase10") mkRationalBase10IdKey+-- GHC.Internal.Float classes floatingClassName, realFloatClassName :: Name-floatingClassName  = clsQual gHC_FLOAT (fsLit "Floating")  floatingClassKey-realFloatClassName = clsQual gHC_FLOAT (fsLit "RealFloat") realFloatClassKey+floatingClassName  = clsQual gHC_INTERNAL_FLOAT (fsLit "Floating")  floatingClassKey+realFloatClassName = clsQual gHC_INTERNAL_FLOAT (fsLit "RealFloat") realFloatClassKey --- other GHC.Float functions+-- other GHC.Internal.Float functions integerToFloatName, integerToDoubleName,   naturalToFloatName, naturalToDoubleName,   rationalToFloatName, rationalToDoubleName :: Name-integerToFloatName   = varQual gHC_FLOAT (fsLit "integerToFloat#") integerToFloatIdKey-integerToDoubleName  = varQual gHC_FLOAT (fsLit "integerToDouble#") integerToDoubleIdKey-naturalToFloatName   = varQual gHC_FLOAT (fsLit "naturalToFloat#") naturalToFloatIdKey-naturalToDoubleName  = varQual gHC_FLOAT (fsLit "naturalToDouble#") naturalToDoubleIdKey-rationalToFloatName  = varQual gHC_FLOAT (fsLit "rationalToFloat") rationalToFloatIdKey-rationalToDoubleName = varQual gHC_FLOAT (fsLit "rationalToDouble") rationalToDoubleIdKey+integerToFloatName   = varQual gHC_INTERNAL_FLOAT (fsLit "integerToFloat#") integerToFloatIdKey+integerToDoubleName  = varQual gHC_INTERNAL_FLOAT (fsLit "integerToDouble#") integerToDoubleIdKey+naturalToFloatName   = varQual gHC_INTERNAL_FLOAT (fsLit "naturalToFloat#") naturalToFloatIdKey+naturalToDoubleName  = varQual gHC_INTERNAL_FLOAT (fsLit "naturalToDouble#") naturalToDoubleIdKey+rationalToFloatName  = varQual gHC_INTERNAL_FLOAT (fsLit "rationalToFloat") rationalToFloatIdKey+rationalToDoubleName = varQual gHC_INTERNAL_FLOAT (fsLit "rationalToDouble") rationalToDoubleIdKey  -- Class Ix ixClassName :: Name-ixClassName = clsQual gHC_IX (fsLit "Ix") ixClassKey+ixClassName = clsQual gHC_INTERNAL_IX (fsLit "Ix") ixClassKey  -- Typeable representation types trModuleTyConName@@ -1402,18 +1387,18 @@   , typeCharTypeRepName   , trGhcPrimModuleName   :: Name-typeableClassName     = clsQual tYPEABLE_INTERNAL (fsLit "Typeable")       typeableClassKey-typeRepTyConName      = tcQual  tYPEABLE_INTERNAL (fsLit "TypeRep")        typeRepTyConKey-someTypeRepTyConName   = tcQual tYPEABLE_INTERNAL (fsLit "SomeTypeRep")    someTypeRepTyConKey-someTypeRepDataConName = dcQual tYPEABLE_INTERNAL (fsLit "SomeTypeRep")    someTypeRepDataConKey-typeRepIdName         = varQual tYPEABLE_INTERNAL (fsLit "typeRep#")       typeRepIdKey-mkTrTypeName          = varQual tYPEABLE_INTERNAL (fsLit "mkTrType")       mkTrTypeKey-mkTrConName           = varQual tYPEABLE_INTERNAL (fsLit "mkTrCon")        mkTrConKey-mkTrAppName           = varQual tYPEABLE_INTERNAL (fsLit "mkTrApp")        mkTrAppKey-mkTrFunName           = varQual tYPEABLE_INTERNAL (fsLit "mkTrFun")        mkTrFunKey-typeNatTypeRepName    = varQual tYPEABLE_INTERNAL (fsLit "typeNatTypeRep") typeNatTypeRepKey-typeSymbolTypeRepName = varQual tYPEABLE_INTERNAL (fsLit "typeSymbolTypeRep") typeSymbolTypeRepKey-typeCharTypeRepName   = varQual tYPEABLE_INTERNAL (fsLit "typeCharTypeRep") typeCharTypeRepKey+typeableClassName     = clsQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "Typeable")       typeableClassKey+typeRepTyConName      = tcQual  gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "TypeRep")        typeRepTyConKey+someTypeRepTyConName   = tcQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "SomeTypeRep")    someTypeRepTyConKey+someTypeRepDataConName = dcQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "SomeTypeRep")    someTypeRepDataConKey+typeRepIdName         = varQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "typeRep#")       typeRepIdKey+mkTrTypeName          = varQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "mkTrType")       mkTrTypeKey+mkTrConName           = varQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "mkTrCon")        mkTrConKey+mkTrAppName           = varQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "mkTrApp")        mkTrAppKey+mkTrFunName           = varQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "mkTrFun")        mkTrFunKey+typeNatTypeRepName    = varQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "typeNatTypeRep") typeNatTypeRepKey+typeSymbolTypeRepName = varQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "typeSymbolTypeRep") typeSymbolTypeRepKey+typeCharTypeRepName   = varQual gHC_INTERNAL_TYPEABLE_INTERNAL (fsLit "typeCharTypeRep") typeCharTypeRepKey -- this is the Typeable 'Module' for GHC.Prim (which has no code, so we place in GHC.Types) -- See Note [Grand plan for Typeable] in GHC.Tc.Instance.Typeable. trGhcPrimModuleName   = varQual gHC_TYPES         (fsLit "tr$ModuleGHCPrim")  trGhcPrimModuleKey@@ -1431,8 +1416,12 @@ withDictClassName = clsQual gHC_MAGIC_DICT (fsLit "WithDict") withDictClassKey  nonEmptyTyConName :: Name-nonEmptyTyConName = tcQual gHC_BASE (fsLit "NonEmpty") nonEmptyTyConKey+nonEmptyTyConName = tcQual gHC_INTERNAL_BASE (fsLit "NonEmpty") nonEmptyTyConKey +-- DataToTag+dataToTagClassName :: Name+dataToTagClassName    = clsQual gHC_MAGIC      (fsLit "DataToTag") dataToTagClassKey+ -- Custom type errors errorMessageTypeErrorFamName   , typeErrorTextDataConName@@ -1442,185 +1431,185 @@   :: Name  errorMessageTypeErrorFamName =-  tcQual gHC_TYPEERROR (fsLit "TypeError") errorMessageTypeErrorFamKey+  tcQual gHC_INTERNAL_TYPEERROR (fsLit "TypeError") errorMessageTypeErrorFamKey  typeErrorTextDataConName =-  dcQual gHC_TYPEERROR (fsLit "Text") typeErrorTextDataConKey+  dcQual gHC_INTERNAL_TYPEERROR (fsLit "Text") typeErrorTextDataConKey  typeErrorAppendDataConName =-  dcQual gHC_TYPEERROR (fsLit ":<>:") typeErrorAppendDataConKey+  dcQual gHC_INTERNAL_TYPEERROR (fsLit ":<>:") typeErrorAppendDataConKey  typeErrorVAppendDataConName =-  dcQual gHC_TYPEERROR (fsLit ":$$:") typeErrorVAppendDataConKey+  dcQual gHC_INTERNAL_TYPEERROR (fsLit ":$$:") typeErrorVAppendDataConKey  typeErrorShowTypeDataConName =-  dcQual gHC_TYPEERROR (fsLit "ShowType") typeErrorShowTypeDataConKey+  dcQual gHC_INTERNAL_TYPEERROR (fsLit "ShowType") typeErrorShowTypeDataConKey  -- "Unsatisfiable" constraint unsatisfiableClassName, unsatisfiableIdName :: Name unsatisfiableClassName =-  clsQual gHC_TYPEERROR (fsLit "Unsatisfiable") unsatisfiableClassNameKey+  clsQual gHC_INTERNAL_TYPEERROR (fsLit "Unsatisfiable") unsatisfiableClassNameKey unsatisfiableIdName =-  varQual gHC_TYPEERROR (fsLit "unsatisfiable") unsatisfiableIdNameKey+  varQual gHC_INTERNAL_TYPEERROR (fsLit "unsatisfiable") unsatisfiableIdNameKey  -- Unsafe coercion proofs unsafeEqualityProofName, unsafeEqualityTyConName, unsafeCoercePrimName,   unsafeReflDataConName :: Name-unsafeEqualityProofName = varQual uNSAFE_COERCE (fsLit "unsafeEqualityProof") unsafeEqualityProofIdKey-unsafeEqualityTyConName = tcQual uNSAFE_COERCE (fsLit "UnsafeEquality") unsafeEqualityTyConKey-unsafeReflDataConName   = dcQual uNSAFE_COERCE (fsLit "UnsafeRefl")     unsafeReflDataConKey-unsafeCoercePrimName    = varQual uNSAFE_COERCE (fsLit "unsafeCoerce#") unsafeCoercePrimIdKey+unsafeEqualityProofName = varQual gHC_INTERNAL_UNSAFE_COERCE (fsLit "unsafeEqualityProof") unsafeEqualityProofIdKey+unsafeEqualityTyConName = tcQual gHC_INTERNAL_UNSAFE_COERCE (fsLit "UnsafeEquality") unsafeEqualityTyConKey+unsafeReflDataConName   = dcQual gHC_INTERNAL_UNSAFE_COERCE (fsLit "UnsafeRefl")     unsafeReflDataConKey+unsafeCoercePrimName    = varQual gHC_INTERNAL_UNSAFE_COERCE (fsLit "unsafeCoerce#") unsafeCoercePrimIdKey  -- Dynamic toDynName :: Name-toDynName = varQual dYNAMIC (fsLit "toDyn") toDynIdKey+toDynName = varQual gHC_INTERNAL_DYNAMIC (fsLit "toDyn") toDynIdKey  -- Class Data dataClassName :: Name-dataClassName = clsQual gENERICS (fsLit "Data") dataClassKey+dataClassName = clsQual gHC_INTERNAL_DATA_DATA (fsLit "Data") dataClassKey  -- Error module assertErrorName    :: Name-assertErrorName   = varQual gHC_IO_Exception (fsLit "assertError") assertErrorIdKey+assertErrorName   = varQual gHC_INTERNAL_IO_Exception (fsLit "assertError") assertErrorIdKey --- Debug.Trace+-- GHC.Internal.Debug.Trace traceName          :: Name-traceName         = varQual dEBUG_TRACE (fsLit "trace") traceKey+traceName         = varQual gHC_INTERNAL_DEBUG_TRACE (fsLit "trace") traceKey  -- Enum module (Enum, Bounded) enumClassName, enumFromName, enumFromToName, enumFromThenName,     enumFromThenToName, boundedClassName :: Name-enumClassName      = clsQual gHC_ENUM (fsLit "Enum")           enumClassKey-enumFromName       = varQual gHC_ENUM (fsLit "enumFrom")       enumFromClassOpKey-enumFromToName     = varQual gHC_ENUM (fsLit "enumFromTo")     enumFromToClassOpKey-enumFromThenName   = varQual gHC_ENUM (fsLit "enumFromThen")   enumFromThenClassOpKey-enumFromThenToName = varQual gHC_ENUM (fsLit "enumFromThenTo") enumFromThenToClassOpKey-boundedClassName   = clsQual gHC_ENUM (fsLit "Bounded")        boundedClassKey+enumClassName      = clsQual gHC_INTERNAL_ENUM (fsLit "Enum")           enumClassKey+enumFromName       = varQual gHC_INTERNAL_ENUM (fsLit "enumFrom")       enumFromClassOpKey+enumFromToName     = varQual gHC_INTERNAL_ENUM (fsLit "enumFromTo")     enumFromToClassOpKey+enumFromThenName   = varQual gHC_INTERNAL_ENUM (fsLit "enumFromThen")   enumFromThenClassOpKey+enumFromThenToName = varQual gHC_INTERNAL_ENUM (fsLit "enumFromThenTo") enumFromThenToClassOpKey+boundedClassName   = clsQual gHC_INTERNAL_ENUM (fsLit "Bounded")        boundedClassKey  -- List functions concatName, filterName, zipName :: Name-concatName        = varQual gHC_LIST (fsLit "concat") concatIdKey-filterName        = varQual gHC_LIST (fsLit "filter") filterIdKey-zipName           = varQual gHC_LIST (fsLit "zip")    zipIdKey+concatName        = varQual gHC_INTERNAL_LIST (fsLit "concat") concatIdKey+filterName        = varQual gHC_INTERNAL_LIST (fsLit "filter") filterIdKey+zipName           = varQual gHC_INTERNAL_LIST (fsLit "zip")    zipIdKey  -- Overloaded lists isListClassName, fromListName, fromListNName, toListName :: Name-isListClassName = clsQual gHC_IS_LIST (fsLit "IsList")    isListClassKey-fromListName    = varQual gHC_IS_LIST (fsLit "fromList")  fromListClassOpKey-fromListNName   = varQual gHC_IS_LIST (fsLit "fromListN") fromListNClassOpKey-toListName      = varQual gHC_IS_LIST (fsLit "toList")    toListClassOpKey+isListClassName = clsQual gHC_INTERNAL_IS_LIST (fsLit "IsList")    isListClassKey+fromListName    = varQual gHC_INTERNAL_IS_LIST (fsLit "fromList")  fromListClassOpKey+fromListNName   = varQual gHC_INTERNAL_IS_LIST (fsLit "fromListN") fromListNClassOpKey+toListName      = varQual gHC_INTERNAL_IS_LIST (fsLit "toList")    toListClassOpKey  -- HasField class ops getFieldName, setFieldName :: Name-getFieldName   = varQual gHC_RECORDS (fsLit "getField") getFieldClassOpKey-setFieldName   = varQual gHC_RECORDS (fsLit "setField") setFieldClassOpKey+getFieldName   = varQual gHC_INTERNAL_RECORDS (fsLit "getField") getFieldClassOpKey+setFieldName   = varQual gHC_INTERNAL_RECORDS (fsLit "setField") setFieldClassOpKey  -- Class Show showClassName :: Name-showClassName   = clsQual gHC_SHOW (fsLit "Show")      showClassKey+showClassName   = clsQual gHC_INTERNAL_SHOW (fsLit "Show")      showClassKey  -- Class Read readClassName :: Name-readClassName   = clsQual gHC_READ (fsLit "Read")      readClassKey+readClassName   = clsQual gHC_INTERNAL_READ (fsLit "Read")      readClassKey  -- Classes Generic and Generic1, Datatype, Constructor and Selector genClassName, gen1ClassName, datatypeClassName, constructorClassName,   selectorClassName :: Name-genClassName  = clsQual gHC_GENERICS (fsLit "Generic")  genClassKey-gen1ClassName = clsQual gHC_GENERICS (fsLit "Generic1") gen1ClassKey+genClassName  = clsQual gHC_INTERNAL_GENERICS (fsLit "Generic")  genClassKey+gen1ClassName = clsQual gHC_INTERNAL_GENERICS (fsLit "Generic1") gen1ClassKey -datatypeClassName    = clsQual gHC_GENERICS (fsLit "Datatype")    datatypeClassKey-constructorClassName = clsQual gHC_GENERICS (fsLit "Constructor") constructorClassKey-selectorClassName    = clsQual gHC_GENERICS (fsLit "Selector")    selectorClassKey+datatypeClassName    = clsQual gHC_INTERNAL_GENERICS (fsLit "Datatype")    datatypeClassKey+constructorClassName = clsQual gHC_INTERNAL_GENERICS (fsLit "Constructor") constructorClassKey+selectorClassName    = clsQual gHC_INTERNAL_GENERICS (fsLit "Selector")    selectorClassKey  genericClassNames :: [Name] genericClassNames = [genClassName, gen1ClassName]  -- GHCi things ghciIoClassName, ghciStepIoMName :: Name-ghciIoClassName = clsQual gHC_GHCI (fsLit "GHCiSandboxIO") ghciIoClassKey-ghciStepIoMName = varQual gHC_GHCI (fsLit "ghciStepIO") ghciStepIoMClassOpKey+ghciIoClassName = clsQual gHC_INTERNAL_GHCI (fsLit "GHCiSandboxIO") ghciIoClassKey+ghciStepIoMName = varQual gHC_INTERNAL_GHCI (fsLit "ghciStepIO") ghciStepIoMClassOpKey  -- IO things ioTyConName, ioDataConName,   thenIOName, bindIOName, returnIOName, failIOName :: Name ioTyConName       = tcQual  gHC_TYPES (fsLit "IO")       ioTyConKey ioDataConName     = dcQual  gHC_TYPES (fsLit "IO")       ioDataConKey-thenIOName        = varQual gHC_BASE  (fsLit "thenIO")   thenIOIdKey-bindIOName        = varQual gHC_BASE  (fsLit "bindIO")   bindIOIdKey-returnIOName      = varQual gHC_BASE  (fsLit "returnIO") returnIOIdKey-failIOName        = varQual gHC_IO    (fsLit "failIO")   failIOIdKey+thenIOName        = varQual gHC_INTERNAL_BASE  (fsLit "thenIO")   thenIOIdKey+bindIOName        = varQual gHC_INTERNAL_BASE  (fsLit "bindIO")   bindIOIdKey+returnIOName      = varQual gHC_INTERNAL_BASE  (fsLit "returnIO") returnIOIdKey+failIOName        = varQual gHC_INTERNAL_IO    (fsLit "failIO")   failIOIdKey  -- IO things printName :: Name-printName         = varQual sYSTEM_IO (fsLit "print") printIdKey+printName         = varQual gHC_INTERNAL_SYSTEM_IO (fsLit "print") printIdKey  -- Int, Word, and Addr things int8TyConName, int16TyConName, int32TyConName, int64TyConName :: Name-int8TyConName     = tcQual gHC_INT  (fsLit "Int8")  int8TyConKey-int16TyConName    = tcQual gHC_INT  (fsLit "Int16") int16TyConKey-int32TyConName    = tcQual gHC_INT  (fsLit "Int32") int32TyConKey-int64TyConName    = tcQual gHC_INT  (fsLit "Int64") int64TyConKey+int8TyConName     = tcQual gHC_INTERNAL_INT  (fsLit "Int8")  int8TyConKey+int16TyConName    = tcQual gHC_INTERNAL_INT  (fsLit "Int16") int16TyConKey+int32TyConName    = tcQual gHC_INTERNAL_INT  (fsLit "Int32") int32TyConKey+int64TyConName    = tcQual gHC_INTERNAL_INT  (fsLit "Int64") int64TyConKey  -- Word module word8TyConName, word16TyConName, word32TyConName, word64TyConName :: Name-word8TyConName    = tcQual  gHC_WORD (fsLit "Word8")  word8TyConKey-word16TyConName   = tcQual  gHC_WORD (fsLit "Word16") word16TyConKey-word32TyConName   = tcQual  gHC_WORD (fsLit "Word32") word32TyConKey-word64TyConName   = tcQual  gHC_WORD (fsLit "Word64") word64TyConKey+word8TyConName    = tcQual  gHC_INTERNAL_WORD (fsLit "Word8")  word8TyConKey+word16TyConName   = tcQual  gHC_INTERNAL_WORD (fsLit "Word16") word16TyConKey+word32TyConName   = tcQual  gHC_INTERNAL_WORD (fsLit "Word32") word32TyConKey+word64TyConName   = tcQual  gHC_INTERNAL_WORD (fsLit "Word64") word64TyConKey  -- PrelPtr module ptrTyConName, funPtrTyConName :: Name-ptrTyConName      = tcQual   gHC_PTR (fsLit "Ptr")    ptrTyConKey-funPtrTyConName   = tcQual   gHC_PTR (fsLit "FunPtr") funPtrTyConKey+ptrTyConName      = tcQual   gHC_INTERNAL_PTR (fsLit "Ptr")    ptrTyConKey+funPtrTyConName   = tcQual   gHC_INTERNAL_PTR (fsLit "FunPtr") funPtrTyConKey  -- Foreign objects and weak pointers stablePtrTyConName, newStablePtrName :: Name-stablePtrTyConName    = tcQual   gHC_STABLE (fsLit "StablePtr")    stablePtrTyConKey-newStablePtrName      = varQual  gHC_STABLE (fsLit "newStablePtr") newStablePtrIdKey+stablePtrTyConName    = tcQual   gHC_INTERNAL_STABLE (fsLit "StablePtr")    stablePtrTyConKey+newStablePtrName      = varQual  gHC_INTERNAL_STABLE (fsLit "newStablePtr") newStablePtrIdKey  -- Recursive-do notation monadFixClassName, mfixName :: Name-monadFixClassName  = clsQual mONAD_FIX (fsLit "MonadFix") monadFixClassKey-mfixName           = varQual mONAD_FIX (fsLit "mfix")     mfixIdKey+monadFixClassName  = clsQual gHC_INTERNAL_MONAD_FIX (fsLit "MonadFix") monadFixClassKey+mfixName           = varQual gHC_INTERNAL_MONAD_FIX (fsLit "mfix")     mfixIdKey  -- Arrow notation arrAName, composeAName, firstAName, appAName, choiceAName, loopAName :: Name-arrAName           = varQual aRROW (fsLit "arr")       arrAIdKey-composeAName       = varQual gHC_DESUGAR (fsLit ">>>") composeAIdKey-firstAName         = varQual aRROW (fsLit "first")     firstAIdKey-appAName           = varQual aRROW (fsLit "app")       appAIdKey-choiceAName        = varQual aRROW (fsLit "|||")       choiceAIdKey-loopAName          = varQual aRROW (fsLit "loop")      loopAIdKey+arrAName           = varQual gHC_INTERNAL_ARROW (fsLit "arr")       arrAIdKey+composeAName       = varQual gHC_INTERNAL_DESUGAR (fsLit ">>>") composeAIdKey+firstAName         = varQual gHC_INTERNAL_ARROW (fsLit "first")     firstAIdKey+appAName           = varQual gHC_INTERNAL_ARROW (fsLit "app")       appAIdKey+choiceAName        = varQual gHC_INTERNAL_ARROW (fsLit "|||")       choiceAIdKey+loopAName          = varQual gHC_INTERNAL_ARROW (fsLit "loop")      loopAIdKey  -- Monad comprehensions guardMName, liftMName, mzipName :: Name-guardMName         = varQual mONAD (fsLit "guard")    guardMIdKey-liftMName          = varQual mONAD (fsLit "liftM")    liftMIdKey-mzipName           = varQual mONAD_ZIP (fsLit "mzip") mzipIdKey+guardMName         = varQual gHC_INTERNAL_MONAD (fsLit "guard")    guardMIdKey+liftMName          = varQual gHC_INTERNAL_MONAD (fsLit "liftM")    liftMIdKey+mzipName           = varQual cONTROL_MONAD_ZIP (fsLit "mzip") mzipIdKey   -- Annotation type checking toAnnotationWrapperName :: Name-toAnnotationWrapperName = varQual gHC_DESUGAR (fsLit "toAnnotationWrapper") toAnnotationWrapperIdKey+toAnnotationWrapperName = varQual gHC_INTERNAL_DESUGAR (fsLit "toAnnotationWrapper") toAnnotationWrapperIdKey  -- Other classes, needed for type defaulting monadPlusClassName, isStringClassName :: Name-monadPlusClassName  = clsQual mONAD (fsLit "MonadPlus")      monadPlusClassKey-isStringClassName   = clsQual dATA_STRING (fsLit "IsString") isStringClassKey+monadPlusClassName  = clsQual gHC_INTERNAL_MONAD (fsLit "MonadPlus")      monadPlusClassKey+isStringClassName   = clsQual gHC_INTERNAL_DATA_STRING (fsLit "IsString") isStringClassKey  -- Type-level naturals knownNatClassName :: Name-knownNatClassName     = clsQual gHC_TYPENATS (fsLit "KnownNat") knownNatClassNameKey+knownNatClassName     = clsQual gHC_INTERNAL_TYPENATS (fsLit "KnownNat") knownNatClassNameKey knownSymbolClassName :: Name-knownSymbolClassName  = clsQual gHC_TYPELITS (fsLit "KnownSymbol") knownSymbolClassNameKey+knownSymbolClassName  = clsQual gHC_INTERNAL_TYPELITS (fsLit "KnownSymbol") knownSymbolClassNameKey knownCharClassName :: Name-knownCharClassName  = clsQual gHC_TYPELITS (fsLit "KnownChar") knownCharClassNameKey+knownCharClassName  = clsQual gHC_INTERNAL_TYPELITS (fsLit "KnownChar") knownCharClassNameKey  -- Overloaded labels fromLabelClassOpName :: Name fromLabelClassOpName- = varQual gHC_OVER_LABELS (fsLit "fromLabel") fromLabelClassOpKey+ = varQual gHC_INTERNAL_OVER_LABELS (fsLit "fromLabel") fromLabelClassOpKey  -- Implicit Parameters ipClassName :: Name@@ -1630,19 +1619,26 @@ -- Overloaded record fields hasFieldClassName :: Name hasFieldClassName- = clsQual gHC_RECORDS (fsLit "HasField") hasFieldClassNameKey+ = clsQual gHC_INTERNAL_RECORDS (fsLit "HasField") hasFieldClassNameKey +-- ExceptionContext+exceptionContextTyConName, emptyExceptionContextName :: Name+exceptionContextTyConName =+    tcQual gHC_INTERNAL_EXCEPTION_CONTEXT (fsLit "ExceptionContext") exceptionContextTyConKey+emptyExceptionContextName+  = varQual gHC_INTERNAL_EXCEPTION_CONTEXT (fsLit "emptyExceptionContext") emptyExceptionContextKey+ -- Source Locations callStackTyConName, emptyCallStackName, pushCallStackName,   srcLocDataConName :: Name callStackTyConName-  = tcQual gHC_STACK_TYPES  (fsLit "CallStack") callStackTyConKey+  = tcQual gHC_INTERNAL_STACK_TYPES  (fsLit "CallStack") callStackTyConKey emptyCallStackName-  = varQual gHC_STACK_TYPES (fsLit "emptyCallStack") emptyCallStackKey+  = varQual gHC_INTERNAL_STACK_TYPES (fsLit "emptyCallStack") emptyCallStackKey pushCallStackName-  = varQual gHC_STACK_TYPES (fsLit "pushCallStack") pushCallStackKey+  = varQual gHC_INTERNAL_STACK_TYPES (fsLit "pushCallStack") pushCallStackKey srcLocDataConName-  = dcQual gHC_STACK_TYPES  (fsLit "SrcLoc")    srcLocDataConKey+  = dcQual gHC_INTERNAL_STACK_TYPES  (fsLit "SrcLoc")    srcLocDataConKey  -- plugins pLUGINS :: Module@@ -1655,36 +1651,39 @@ -- Static pointers makeStaticName :: Name makeStaticName =-    varQual gHC_STATICPTR_INTERNAL (fsLit "makeStatic") makeStaticKey+    varQual gHC_INTERNAL_STATICPTR_INTERNAL (fsLit "makeStatic") makeStaticKey  staticPtrInfoTyConName :: Name staticPtrInfoTyConName =-    tcQual gHC_STATICPTR (fsLit "StaticPtrInfo") staticPtrInfoTyConKey+    tcQual gHC_INTERNAL_STATICPTR (fsLit "StaticPtrInfo") staticPtrInfoTyConKey  staticPtrInfoDataConName :: Name staticPtrInfoDataConName =-    dcQual gHC_STATICPTR (fsLit "StaticPtrInfo") staticPtrInfoDataConKey+    dcQual gHC_INTERNAL_STATICPTR (fsLit "StaticPtrInfo") staticPtrInfoDataConKey  staticPtrTyConName :: Name staticPtrTyConName =-    tcQual gHC_STATICPTR (fsLit "StaticPtr") staticPtrTyConKey+    tcQual gHC_INTERNAL_STATICPTR (fsLit "StaticPtr") staticPtrTyConKey  staticPtrDataConName :: Name staticPtrDataConName =-    dcQual gHC_STATICPTR (fsLit "StaticPtr") staticPtrDataConKey+    dcQual gHC_INTERNAL_STATICPTR (fsLit "StaticPtr") staticPtrDataConKey  fromStaticPtrName :: Name fromStaticPtrName =-    varQual gHC_STATICPTR (fsLit "fromStaticPtr") fromStaticPtrClassOpKey+    varQual gHC_INTERNAL_STATICPTR (fsLit "fromStaticPtr") fromStaticPtrClassOpKey  fingerprintDataConName :: Name fingerprintDataConName =-    dcQual gHC_FINGERPRINT_TYPE (fsLit "Fingerprint") fingerprintDataConKey+    dcQual gHC_INTERNAL_FINGERPRINT_TYPE (fsLit "Fingerprint") fingerprintDataConKey  constPtrConName :: Name constPtrConName =-    tcQual fOREIGN_C_CONSTPTR (fsLit "ConstPtr") constPtrTyConKey+    tcQual gHC_INTERNAL_FOREIGN_C_CONSTPTR (fsLit "ConstPtr") constPtrTyConKey +jsvalTyConName :: Name+jsvalTyConName = tcQual (mkGhcInternalModule (fsLit "GHC.Internal.Wasm.Prim.Types")) (fsLit "JSVal") jsvalTyConKey+ {- ************************************************************************ *                                                                      *@@ -1748,6 +1747,9 @@ withDictClassKey :: Unique withDictClassKey        = mkPreludeClassUnique 21 +dataToTagClassKey :: Unique+dataToTagClassKey       = mkPreludeClassUnique 23+ monadFixClassKey :: Unique monadFixClassKey        = mkPreludeClassUnique 28 @@ -1776,11 +1778,11 @@ constructorClassKey = mkPreludeClassUnique 40 selectorClassKey    = mkPreludeClassUnique 41 --- KnownNat: see Note [KnownNat & KnownSymbol and EvLit] in GHC.Tc.Types.Evidence+-- KnownNat: see Note [KnownNat & KnownSymbol and EvLit] in GHC.Tc.Instance.Class knownNatClassNameKey :: Unique knownNatClassNameKey = mkPreludeClassUnique 42 --- KnownSymbol: see Note [KnownNat & KnownSymbol and EvLit] in GHC.Tc.Types.Evidence+-- KnownSymbol: see Note [KnownNat & KnownSymbol and EvLit] in GHC.Tc.Instance.Class knownSymbolClassNameKey :: Unique knownSymbolClassNameKey = mkPreludeClassUnique 43 @@ -1886,7 +1888,7 @@     funPtrTyConKey, tVarPrimTyConKey, eqPrimTyConKey,     eqReprPrimTyConKey, eqPhantPrimTyConKey,     compactPrimTyConKey, stackSnapshotPrimTyConKey,-    promptTagPrimTyConKey, constPtrTyConKey :: Unique+    promptTagPrimTyConKey, constPtrTyConKey, jsvalTyConKey :: Unique statePrimTyConKey                       = mkPreludeTyConUnique 50 stableNamePrimTyConKey                  = mkPreludeTyConUnique 51 stableNameTyConKey                      = mkPreludeTyConUnique 52@@ -2103,6 +2105,11 @@ typeNatToCharTyFamNameKey = mkPreludeTyConUnique 416 constPtrTyConKey = mkPreludeTyConUnique 417 +jsvalTyConKey = mkPreludeTyConUnique 418++exceptionContextTyConKey :: Unique+exceptionContextTyConKey = mkPreludeTyConUnique 420+ {- ************************************************************************ *                                                                      *@@ -2553,6 +2560,9 @@ makeStaticKey :: Unique makeStaticKey = mkPreludeMiscIdUnique 561 +emptyExceptionContextKey :: Unique+emptyExceptionContextKey = mkPreludeMiscIdUnique 562+ -- Unsafe coercion proofs unsafeEqualityProofIdKey, unsafeCoercePrimIdKey :: Unique unsafeEqualityProofIdKey = mkPreludeMiscIdUnique 570@@ -2776,57 +2786,3 @@  interactiveClassKeys :: [Unique] interactiveClassKeys = map getUnique interactiveClassNames--{--************************************************************************-*                                                                      *-   Semi-builtin names-*                                                                      *-************************************************************************--Note [pretendNameIsInScope]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-In general, we filter out instances that mention types whose names are-not in scope. However, in the situations listed below, we make an exception-for some commonly used names, such as Data.Kind.Type, which may not actually-be in scope but should be treated as though they were in scope.-This includes built-in names, as well as a few extra names such as-'Type', 'TYPE', 'BoxedRep', etc.--Situations in which we apply this special logic:--  - GHCi's :info command, see GHC.Runtime.Eval.getInfo.-    This fixes #1581.--  - When reporting instance overlap errors. Not doing so could mean-    that we would omit instances for typeclasses like--      type Cls :: k -> Constraint-      class Cls a--    because BoxedRep/Lifted were not in scope.-    See GHC.Tc.Errors.potentialInstancesErrMsg.-    This fixes one of the issues reported in #20465.--}---- | Should this name be considered in-scope, even though it technically isn't?------ This ensures that we don't filter out information because, e.g.,--- Data.Kind.Type isn't imported.------ See Note [pretendNameIsInScope].-pretendNameIsInScope :: Name -> Bool-pretendNameIsInScope n-  = isBuiltInSyntax n-  || isTupleTyConName n-  || any (n `hasKey`)-    [ liftedTypeKindTyConKey, unliftedTypeKindTyConKey-    , liftedDataConKey, unliftedDataConKey-    , tYPETyConKey-    , cONSTRAINTTyConKey-    , runtimeRepTyConKey, boxedRepDataConKey-    , eqTyConKey-    , listTyConKey-    , oneDataConKey-    , manyDataConKey-    , fUNTyConKey, unrestrictedFunTyConKey ]
compiler/GHC/Builtin/PrimOps.hs view
@@ -17,10 +17,12 @@         tagToEnumKey,          primOpOutOfLine, primOpCodeSize,-        primOpOkForSpeculation, primOpOkForSideEffects,-        primOpIsCheap, primOpFixity, primOpDocs,+        primOpOkForSpeculation, primOpOkToDiscard,+        primOpIsWorkFree, primOpIsCheap, primOpFixity, primOpDocs,         primOpIsDiv, primOpIsReallyInline, +        PrimOpEffect(..), primOpEffect,+         getPrimOpResultInfo,  isComparisonPrimOp, PrimOpResultInfo(..),          PrimCall(..)@@ -33,7 +35,7 @@ import GHC.Builtin.Uniques (mkPrimOpIdUnique, mkPrimOpWrapperUnique ) import GHC.Builtin.Names ( gHC_PRIMOPWRAPPERS ) -import GHC.Core.TyCon    ( TyCon, isPrimTyCon, PrimRep(..) )+import GHC.Core.TyCon    ( isPrimTyCon, isUnboxedTupleTyCon, PrimRep(..) ) import GHC.Core.Type  import GHC.Cmm.Type@@ -42,17 +44,18 @@ import GHC.Types.Id import GHC.Types.Id.Info import GHC.Types.Name-import GHC.Types.RepType ( tyConPrimRep1 )+import GHC.Types.RepType ( tyConPrimRep ) import GHC.Types.Basic import GHC.Types.Fixity  ( Fixity(..), FixityDirection(..) ) import GHC.Types.SrcLoc  ( wiredInSrcSpan ) import GHC.Types.ForeignCall ( CLabelString ) import GHC.Types.SourceText  ( SourceText(..) )-import GHC.Types.Unique  ( Unique)+import GHC.Types.Unique  ( Unique )  import GHC.Unit.Types    ( Unit )  import GHC.Utils.Outputable+import GHC.Utils.Panic  import GHC.Data.FastString @@ -311,221 +314,316 @@ *                                                                      * ************************************************************************ -Note [Checking versus non-checking primops]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -  In GHC primops break down into two classes:+Note [Exceptions: asynchronous, synchronous, and unchecked]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There are three very different sorts of things in GHC-Haskell that are+sometimes called exceptions: -   a. Checking primops behave, for instance, like division. In this-      case the primop may throw an exception (e.g. division-by-zero)-      and is consequently is marked with the can_fail flag described below.-      The ability to fail comes at the expense of precluding some optimizations.+* Haskell exceptions: -   b. Non-checking primops behavior, for instance, like addition. While-      addition can overflow it does not produce an exception. So can_fail is-      set to False, and we get more optimisation opportunities.  But we must-      never throw an exception, so we cannot rewrite to a call to error.+  These are ordinary exceptions that users can raise with the likes+  of 'throw' and handle with the likes of 'catch'.  They come in two+  very different flavors: -  It is important that a non-checking primop never be transformed in a way that-  would cause it to bottom. Doing so would violate Core's let-can-float invariant-  (see Note [Core let-can-float invariant] in GHC.Core) which is critical to-  the simplifier's ability to float without fear of changing program meaning.+  * Asynchronous exceptions:+    * These can arise at nearly any time, and may have nothing to do+      with the code being executed.+    * The compiler itself mostly doesn't need to care about them.+    * Examples: a signal from another process, running out of heap or stack+    * Even pure code can receive asynchronous exceptions; in this+      case, executing the same code again may lead to different+      results, because the exception may not happen next time.+    * See rts/RaiseAsync.c for the gory details of how they work. +  * Synchronous exceptions:+    * These are produced by the code being executed, most commonly via+      a call to the `raise#` or `raiseIO#` primops.+    * At run-time, if a piece of pure code raises a synchronous+      exception, it will always raise the same synchronous exception+      if it is run again (and not interrupted by an asynchronous+      exception).+    * In particular, if an updatable thunk does some work and then+      raises a synchronous exception, it is safe to overwrite it with+      a thunk that /immediately/ raises the same exception.+    * Although we are careful not to discard synchronous exceptions, we+      are very liberal about re-ordering them with respect to most other+      operations.  See the paper "A semantics for imprecise exceptions"+      as well as Note [Precise exceptions and strictness analysis] in+      GHC.Types.Demand. -Note [PrimOp can_fail and has_side_effects]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Both can_fail and has_side_effects mean that the primop has-some effect that is not captured entirely by its result value.+* Unchecked exceptions: -----------  has_side_effects ----------------------A primop "has_side_effects" if it has some side effect, visible-elsewhere, apart from the result it returns-    - reading or writing to the world (I/O)-    - reading or writing to a mutable data structure (writeIORef)-    - throwing a synchronous Haskell exception+  * These are nasty failures like seg-faults or primitive Int# division+    by zero.  They differ from Haskell exceptions in that they are+    un-recoverable and typically bring execution to an immediate halt.+  * We generally treat unchecked exceptions as undefined behavior, on+    the assumption that the programmer never intends to crash the+    program in this way.  Thus we have no qualms about replacing a+    division-by-zero with a recoverable Haskell exception or+    discarding an indexArray# operation whose result is unused. -Often such primops have a type like-   State -> input -> (State, output)-so the state token guarantees ordering.  In general we rely on-data dependencies of the state token to enforce write-effect ordering,-but as the notes below make clear, the matter is a bit more complicated-than that. - * NB1: if you inline unsafePerformIO, you may end up with-   side-effecting ops whose 'state' output is discarded.-   And programmers may do that by hand; see #9390.-   That is why we (conservatively) do not discard write-effecting-   primops even if both their state and result is discarded.+Note [Classifying primop effects]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Each primop has an associated 'PrimOpEffect', based on what that+primop can or cannot do at runtime.  This classification is - * NB2: We consider primops, such as raiseIO#, that can raise a-   (Haskell) synchronous exception to "have_side_effects" but not-   "can_fail".  We must be careful about not discarding such things;-   see the paper "A semantics for imprecise exceptions".+* Recorded in the 'effect' field in primops.txt.pp, and+* Exposed to the compiler via the 'primOpEffect' function in this module. - * NB3: *Read* effects on *mutable* cells (like reading an IORef or a-   MutableArray#) /are/ included.  You may find this surprising because it-   doesn't matter if we don't do them, or do them more than once.  *Sequencing*-   is maintained by the data dependency of the state token.  But see-   "Duplication" below under-   Note [Transformations affected by can_fail and has_side_effects]+See Note [Transformations affected by primop effects] for how we make+use of this categorisation. -   Note that read operations on *immutable* values (like indexArray#) do not-   have has_side_effects.   (They might be marked can_fail, however, because-   you might index out of bounds.)+The meanings of the four constructors of 'PrimOpEffect' are as+follows, in decreasing order of permissiveness: -   Using has_side_effects in this way is a bit of a blunt instrument.  We could-   be more refined by splitting read and write effects (see comments with #3207-   and #20195)+* ReadWriteEffect+    A primop is marked ReadWriteEffect if it can+    - read or write to the world (I/O), or+    - read or write to a mutable data structure (e.g. readMutVar#). -----------  can_fail -----------------------------A primop "can_fail" if it can fail with an *unchecked* exception on-some elements of its input domain. Main examples:-   division (fails on zero denominator)-   array indexing (fails if the index is out of bounds)+    Every such primop uses State# tokens for sequencing, with a type like:+      Inputs -> State# s -> (# State# s, Outputs #)+    The state token threading expresses ordering, but duplicating even+    a read-only effect would defeat this.  (See "duplication" under+    Note [Transformations affected by primop effects] for details.) -An "unchecked exception" is one that is an outright error, (not-turned into a Haskell exception,) such as seg-fault or-divide-by-zero error.  Such can_fail primops are ALWAYS surrounded-with a test that checks for the bad cases, but we need to be-very careful about code motion that might move it out of-the scope of the test.+    Note that operations like `indexArray#` that read *immutable*+    data structures do not need such special sequencing-related care,+    and are therefore not marked ReadWriteEffect. -Note [Transformations affected by can_fail and has_side_effects]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The can_fail and has_side_effects properties have the following effect-on program transformations.  Summary table is followed by details.+* ThrowsException+    A primop is marked ThrowsException if+    - it is not marked ReadWriteEffect, and+    - it may diverge or throw a synchronous Haskell exception+      even when used in a "correct" and well-specified way. -            can_fail     has_side_effects-Discard        YES           NO-Float in       YES           YES-Float out      NO            NO-Duplicate      YES           NO+    See also Note [Exceptions: asynchronous, synchronous, and unchecked].+    Examples include raise#, raiseIO#, dataToTagLarge#, and seq#. -* Discarding.   case (a `op` b) of _ -> rhs  ===>   rhs-  You should not discard a has_side_effects primop; e.g.-     case (writeIntArray# a i v s of (# _, _ #) -> True-  Arguably you should be able to discard this, since the-  returned stat token is not used, but that relies on NEVER-  inlining unsafePerformIO, and programmers sometimes write-  this kind of stuff by hand (#9390).  So we (conservatively)-  never discard a has_side_effects primop.+    Note that whether an exception is considered precise or imprecise+    does not matter for the purposes of the PrimOpEffect flag. -  However, it's fine to discard a can_fail primop.  For example-     case (indexIntArray# a i) of _ -> True-  We can discard indexIntArray#; it has can_fail, but not-  has_side_effects; see #5658 which was all about this.-  Notice that indexIntArray# is (in a more general handling of-  effects) read effect, but we don't care about that here, and-  treat read effects as *not* has_side_effects.+* CanFail+    A primop is marked CanFail if+    - it is not marked ReadWriteEffect or ThrowsException, and+    - it can trigger a (potentially-unchecked) exception when used incorrectly. -  Similarly (a `/#` b) can be discarded.  It can seg-fault or-  cause a hardware exception, but not a synchronous Haskell-  exception.+    See Note [Exceptions: asynchronous, synchronous, and unchecked].+    Examples include quotWord# and indexIntArray#, which can fail with+    division-by-zero and a segfault respectively. +    A correct use of a CanFail primop is usually surrounded by a test+    that screens out the bad cases such as a zero divisor or an+    out-of-bounds array index.  We must take care never to move a+    CanFail primop outside the scope of such a test. +* NoEffect+    A primop is marked NoEffect if it does not belong to any of the+    other three categories.  We can very aggressively shuffle these+    operations around without fear of changing a program's meaning. -  Synchronous Haskell exceptions, e.g. from raiseIO#, are treated-  as has_side_effects and hence are not discarded.+    Perhaps surprisingly, this aggressive shuffling imposes another+    restriction: The tricky NoEffect primop uncheckedShiftLWord32# has+    an undefined result when the provided shift amount is not between+    0 and 31.  Thus, a call like `uncheckedShiftLWord32# x 95#` is+    obviously invalid.  But since uncheckedShiftLWord32# is marked+    NoEffect, we may float such an invalid call out of a dead branch+    and speculatively evaluate it. -* Float in.  You can float a can_fail or has_side_effects primop-  *inwards*, but not inside a lambda (see Duplication below).+    In particular, we cannot safely rewrite such an invalid call to a+    runtime error; we must emit code that produces a valid Word32#.+    (If we're lucky, Core Lint may complain that the result of such a+    rewrite violates the let-can-float invariant (#16742), but the+    rewrite is always wrong!)  See also Note [Guarding against silly shifts]+    in GHC.Core.Opt.ConstantFold. -* Float out.  You must not float a can_fail primop *outwards* lest-  you escape the dynamic scope of the test.  Example:+    Marking uncheckedShiftLWord32# as CanFail instead of NoEffect+    would give us the freedom to rewrite such invalid calls to runtime+    errors, but would get in the way of optimization: When speculatively+    executing a bit-shift prevents the allocation of a thunk, that's a+    big win.+++Note [Transformations affected by primop effects]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++The PrimOpEffect properties have the following effect on program+transformations.  The summary table is followed by details.  See also+Note [Classifying primop effects] for exactly what each column means.++                    NoEffect    CanFail    ThrowsException    ReadWriteEffect+Discard                YES        YES            NO                 NO+Defer (float in)       YES        YES           SAFE               SAFE+Speculate (float out)  YES        NO             NO                 NO+Duplicate              YES        YES            YES                NO++(SAFE means we could perform the transformation but do not.)++* Discarding:   case (a `op` b) of _ -> rhs  ===>   rhs+    You should not discard a ReadWriteEffect primop; e.g.+       case (writeIntArray# a i v s of (# _, _ #) -> True+    One could argue in favor of discarding this, since the returned+    State# token is not used.  But in practice unsafePerformIO can+    easily produce similar code, and programmers sometimes write this+    kind of stuff by hand (#9390).  So we (conservatively) never discard+    a ReadWriteEffect primop.++      Digression: We could try to track read-only effects separately+      from write effects to allow the former to be discarded.  But in+      fact we want a more general rewrite for read-only operations:+        case readOp# state# of (# newState#, _unused_result #) -> body+        ==> case state# of newState# -> body+      Such a rewrite is not yet implemented, but would have to be done+      in a different place anyway.++    Discarding a ThrowsException primop would also discard any exception+    it might have thrown.  For `raise#` or `raiseIO#` this would defeat+    the whole point of the primop, while for `dataToTagLarge#` or `seq#`+    this would make programs unexpectly lazier.++    However, it's fine to discard a CanFail primop.  For example+       case (indexIntArray# a i) of _ -> True+    We can discard indexIntArray# here; this came up in #5658.  Notice+    that CanFail primops like indexIntArray# can only trigger an+    exception when used incorrectly, i.e. a call that might not succeed+    is undefined behavior anyway.++* Deferring (float-in):+    See Note [Floating primops] in GHC.Core.Opt.FloatIn.++    In the absence of data dependencies (including state token threading),+    we reserve the right to re-order the following things arbitrarily:+      * Side effects+      * Imprecise exceptions+      * Divergent computations (infinite loops)+    This lets us safely float almost any primop *inwards*, but not+    inside a (multi-shot) lambda.  (See "Duplication" below.)++    However, the main reason to float-in a primop application would be+    to discard it (by floating it into some but not all branches of a+    case), so we actually only float-in NoEffect and CanFail operations.+    See also Note [Floating primops] in GHC.Core.Opt.FloatIn.++    (This automatically side-steps the question of precise exceptions, which+    mustn't be re-ordered arbitrarily but need at least ThrowsException.)++* Speculation (strict float-out):+    You must not float a CanFail primop *outwards* lest it escape the+    dynamic scope of a run-time validity test.  Example:       case d ># 0# of         True  -> case x /# d of r -> r +# 1         False -> 0-  Here we must not float the case outwards to give+    Here we must not float the case outwards to give       case x/# d of r ->       case d ># 0# of         True  -> r +# 1         False -> 0+    Otherwise, if this block is reached when d is zero, it will crash.+    Exactly the same reasoning applies to ThrowsException primops. -  Nor can you float out a has_side_effects primop.  For example:+    Nor can you float out a ReadWriteEffect primop.  For example:        if blah then case writeMutVar# v True s0 of (# s1 #) -> s1                else s0-  Notice that s0 is mentioned in both branches of the 'if', but-  only one of these two will actually be consumed.  But if we-  float out to+    Notice that s0 is mentioned in both branches of the 'if', but+    only one of these two will actually be consumed.  But if we+    float out to       case writeMutVar# v True s0 of (# s1 #) ->       if blah then s1 else s0-  the writeMutVar will be performed in both branches, which is-  utterly wrong.+    the writeMutVar will be performed in both branches, which is+    utterly wrong. -* Duplication.  You cannot duplicate a has_side_effect primop.  You-  might wonder how this can occur given the state token threading, but-  just look at Control.Monad.ST.Lazy.Imp.strictToLazy!  We get-  something like this+    What about a read-only operation that cannot fail, like+    readMutVar#?  In principle we could safely float these out.  But+    there are not very many such operations and it's not clear if+    there are real-world programs that would benefit from this.++* Duplication:+    You cannot duplicate a ReadWriteEffect primop.  You might wonder+    how this can occur given the state token threading, but just look+    at Control.Monad.ST.Lazy.Imp.strictToLazy!  We get something like this         p = case readMutVar# s v of               (# s', r #) -> (State# s', r)         s' = case p of (s', r) -> s'         r  = case p of (s', r) -> r -  (All these bindings are boxed.)  If we inline p at its two call-  sites, we get a catastrophe: because the read is performed once when-  s' is demanded, and once when 'r' is demanded, which may be much-  later.  Utterly wrong.  #3207 is real example of this happening.+    (All these bindings are boxed.)  If we inline p at its two call+    sites, we get a catastrophe: because the read is performed once when+    s' is demanded, and once when 'r' is demanded, which may be much+    later.  Utterly wrong.  #3207 is real example of this happening.+    Floating p into a multi-shot lambda would be wrong for the same reason. -  However, it's fine to duplicate a can_fail primop.  That is really-  the only difference between can_fail and has_side_effects.+    However, it's fine to duplicate a CanFail or ThrowsException primop. -Note [Implementation: how can_fail/has_side_effects affect transformations]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+++Note [Implementation: how PrimOpEffect affects transformations]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ How do we ensure that floating/duplication/discarding are done right in the simplifier? -Two main predicates on primops test these flags:-  primOpOkForSideEffects <=> not has_side_effects-  primOpOkForSpeculation <=> not (has_side_effects || can_fail)+Several predicates on primops test this flag:+  primOpOkToDiscard      <=> effect < ThrowsException+  primOpOkForSpeculation <=> effect == NoEffect && not (out_of_line)+  primOpIsCheap          <=> cheap  -- ...defaults to primOpOkForSpeculation+    [[But note that the raise# family and seq# are also considered cheap in+      GHC.Core.Utils.exprIsCheap by way of being work-free]] +  * The discarding mentioned above happens in+    GHC.Core.Opt.Simplify.Iteration, specifically in rebuildCase,+    where it is guarded by exprOkToDiscard, which in turn checks+    primOpOkToDiscard.+   * The "no-float-out" thing is achieved by ensuring that we never-    let-bind a can_fail or has_side_effects primop.  The RHS of a-    let-binding (which can float in and out freely) satisfies-    exprOkForSpeculation; this is the let-can-float invariant.  And-    exprOkForSpeculation is false of can_fail and has_side_effects.+    let-bind a saturated primop application unless it has NoEffect.+    The RHS of a let-binding (which can float in and out freely)+    satisfies exprOkForSpeculation; this is the let-can-float+    invariant.  And exprOkForSpeculation is false of a saturated+    primop application unless it has NoEffect. -  * So can_fail and has_side_effects primops will appear only as the+  * So primops that aren't NoEffect will appear only as the     scrutinees of cases, and that's why the FloatIn pass is capable     of floating case bindings inwards. -  * The no-duplicate thing is done via primOpIsCheap, by making-    has_side_effects things (very very very) not-cheap!+  * Duplication via inlining and float-in of (lifted) let-binders is+    controlled via primOpIsWorkFree and primOpIsCheap, by making+    ReadWriteEffect things (among others) not-cheap!  (The test+    PrimOpEffect_Sanity will complain if any ReadWriteEffect primop+    is considered either work-free or cheap.)  Additionally, a+    case binding is only floated inwards if its scrutinee is ok-to-discard. -} -primOpHasSideEffects :: PrimOp -> Bool-#include "primop-has-side-effects.hs-incl"+primOpEffect :: PrimOp -> PrimOpEffect+#include "primop-effects.hs-incl" -primOpCanFail :: PrimOp -> Bool-#include "primop-can-fail.hs-incl"+data PrimOpEffect+  -- See Note [Classifying primop effects]+  = NoEffect+  | CanFail+  | ThrowsException+  | ReadWriteEffect+  deriving (Eq, Ord)  primOpOkForSpeculation :: PrimOp -> Bool-  -- See Note [PrimOp can_fail and has_side_effects]+  -- See Note [Classifying primop effects]   -- See comments with GHC.Core.Utils.exprOkForSpeculation-  -- primOpOkForSpeculation => primOpOkForSideEffects+  -- primOpOkForSpeculation => primOpOkToDiscard primOpOkForSpeculation op-  =  primOpOkForSideEffects op-  && not (primOpOutOfLine op || primOpCanFail op)+  = primOpEffect op == NoEffect && not (primOpOutOfLine op)     -- I think the "out of line" test is because out of line things can     -- be expensive (eg sine, cosine), and so we may not want to speculate them -primOpOkForSideEffects :: PrimOp -> Bool-primOpOkForSideEffects op-  = not (primOpHasSideEffects op)--{--Note [primOpIsCheap]-~~~~~~~~~~~~~~~~~~~~+primOpOkToDiscard :: PrimOp -> Bool+primOpOkToDiscard op+  = primOpEffect op < ThrowsException -@primOpIsCheap@, as used in GHC.Core.Opt.Simplify.Utils.  For now (HACK-WARNING), we just borrow some other predicates for a-what-should-be-good-enough test.  "Cheap" means willing to call it more-than once, and/or push it inside a lambda.  The latter could change the-behaviour of 'seq' for primops that can fail, so we don't treat them as cheap.--}+primOpIsWorkFree :: PrimOp -> Bool+#include "primop-is-work-free.hs-incl"  primOpIsCheap :: PrimOp -> Bool--- See Note [PrimOp can_fail and has_side_effects]-primOpIsCheap op = primOpOkForSpeculation op+-- See Note [Classifying primop effects]+#include "primop-is-cheap.hs-incl" -- In March 2001, we changed this to --      primOpIsCheap op = False -- thereby making *no* primops seem cheap.  But this killed eta@@ -540,7 +638,7 @@ -- The problem that originally gave rise to the change was --      let x = a +# b *# c in x +# x -- were we don't want to inline x. But primopIsCheap doesn't control--- that (it's exprIsDupable that does) so the problem doesn't occur+-- that (it's primOpIsWorkFree that does) so the problem doesn't occur -- even if primOpIsCheap sometimes says 'True'.  @@ -759,8 +857,9 @@         GenPrimOp _occ tyvars arg_tys res_ty -> (tyvars, arg_tys, res_ty   )  data PrimOpResultInfo-  = ReturnsPrim     PrimRep-  | ReturnsAlg      TyCon+  = ReturnsVoid+  | ReturnsPrim     PrimRep+  | ReturnsTuple  -- Some PrimOps need not return a manifest primitive or algebraic value -- (i.e. they might return a polymorphic value).  These PrimOps *must*@@ -769,9 +868,13 @@ getPrimOpResultInfo :: PrimOp -> PrimOpResultInfo getPrimOpResultInfo op   = case (primOpInfo op) of-      Compare _ _                         -> ReturnsPrim (tyConPrimRep1 intPrimTyCon)-      GenPrimOp _ _ _ ty | isPrimTyCon tc -> ReturnsPrim (tyConPrimRep1 tc)-                         | otherwise      -> ReturnsAlg tc+      Compare _ _                         -> ReturnsPrim IntRep+      GenPrimOp _ _ _ ty | isPrimTyCon tc -> case tyConPrimRep tc of+                                               [] -> ReturnsVoid+                                               [rep] -> ReturnsPrim rep+                                               _ -> pprPanic "getPrimOpResultInfo" (ppr op)+                         | isUnboxedTupleTyCon tc -> ReturnsTuple+                         | otherwise      -> pprPanic "getPrimOpResultInfo" (ppr op)                          where                            tc = tyConAppTyCon ty                         -- All primops return a tycon-app result@@ -822,5 +925,6 @@ primOpIsReallyInline :: PrimOp -> Bool primOpIsReallyInline = \case   SeqOp       -> False-  DataToTagOp -> False+  DataToTagSmallOp -> False+  DataToTagLargeOp -> False   p           -> not (primOpOutOfLine p)
compiler/GHC/Builtin/PrimOps/Ids.hs view
@@ -1,3 +1,8 @@++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiWayIf #-}+ -- | PrimOp's Ids module GHC.Builtin.PrimOps.Ids   ( primOpId@@ -9,12 +14,14 @@  -- primop rules are attached to primop ids import {-# SOURCE #-} GHC.Core.Opt.ConstantFold (primOpRules)-import GHC.Core.Type (mkForAllTys, mkVisFunTysMany, argsHaveFixedRuntimeRep )+import GHC.Core.TyCo.Rep ( scaledThing )+import GHC.Core.Type import GHC.Core.FVs (mkRuleInfo)  import GHC.Builtin.PrimOps import GHC.Builtin.Uniques import GHC.Builtin.Names+import GHC.Builtin.Types.Prim  import GHC.Types.Basic import GHC.Types.Cpr@@ -23,11 +30,18 @@ import GHC.Types.Id.Info import GHC.Types.TyThing import GHC.Types.Name+import GHC.Types.Name.Env+import GHC.Types.Var+import GHC.Types.Var.Set +import GHC.Tc.Types.Origin+import GHC.Tc.Utils.TcType ( ConcreteTvOrigin(..), ConcreteTyVars, TcType )+ import GHC.Data.SmallArray-import Data.Maybe ( maybeToList ) +import Data.Maybe ( mapMaybe, listToMaybe, catMaybes, maybeToList ) + -- | Build a PrimOp Id mkPrimOpId :: PrimOp -> Id mkPrimOpId prim_op@@ -38,9 +52,10 @@     name = mkWiredInName gHC_PRIM (primOpOcc prim_op)                          (mkPrimOpIdUnique (primOpTag prim_op))                          (AnId id) UserSyntax-    id   = mkGlobalId (PrimOpId prim_op lev_poly) name ty info-    lev_poly = not (argsHaveFixedRuntimeRep ty)+    id   = mkGlobalId (PrimOpId prim_op conc_tvs) name ty info +    conc_tvs = computePrimOpConcTyVarsFromType name tyvars arg_tys res_ty+     -- PrimOps don't ever construct a product, but we want to preserve bottoms     cpr       | isDeadEndDiv (snd (splitDmdSig strict_sig)) = botCpr@@ -57,6 +72,85 @@                -- test) about a RULE conflicting with a possible inlining                -- cf #7287 +-- | Analyse the type of a primop to determine which of its outermost forall'd+-- type variables must be instantiated to concrete types when the primop is+-- instantiated.+--+-- These are the Levity and RuntimeRep kinded type-variables which appear in+-- negative position in the type of the primop.+computePrimOpConcTyVarsFromType :: Name -> [TyVarBinder] -> [Type] -> Type -> ConcreteTyVars+computePrimOpConcTyVarsFromType nm tyvars arg_tys _res_ty = mkNameEnv concs+  where+    concs = [ (tyVarName kind_tv, ConcreteFRR frr_orig)+            | Bndr tv _af <- tyvars+            , kind_tv    <- tyCoVarsOfTypeWellScoped $ tyVarKind tv+            , neg_pos    <- maybeToList $ frr_tyvar_maybe kind_tv+            , let frr_orig = FixedRuntimeRepOrigin+                           { frr_type    = mkTyVarTy tv+                           , frr_context = FRRRepPolyId nm RepPolyPrimOp neg_pos+                           }+            ]++    -- As per Note [Levity and representation polymorphic primops]+    -- in GHC.Builtin.Primops.txt.pp, we compute the ConcreteTyVars associated+    -- to a primop by inspecting the type variable names.+    frr_tyvar_maybe tv+      | tv `elem` [ runtimeRep1TyVar, runtimeRep2TyVar, runtimeRep3TyVar+                  , levity1TyVar, levity2TyVar ]+      = listToMaybe $+          mapMaybe (\ (i,arg) -> Argument i <$> positiveKindPos_maybe tv arg)+            (zip [1..] arg_tys)+      | otherwise+      = Nothing+      -- Compute whether the type variable occurs in the kind of a type variable+      -- in positive position in one of the argument types of the primop.++-- | Does this type variable appear in a kind in a negative position in the+-- type?+--+-- Returns the first such position if so.+--+-- NB: assumes the type is of a simple form, e.g. no foralls, no function+-- arrows nested in a TyCon other than a function arrow.+-- Just used to compute the set of ConcreteTyVars for a PrimOp by inspecting+-- its type, see 'computePrimOpConcTyVarsFromType'.+negativeKindPos_maybe :: TcTyVar -> TcType -> Maybe (Position Neg)+negativeKindPos_maybe tv ty+  | (args, res) <- splitFunTys ty+  = listToMaybe $ catMaybes $+      ( (if null args then Nothing else Result <$> negativeKindPos_maybe tv res)+      : map recur (zip [1..] args)+      )+  where+    recur (pos, scaled_ty)+      = Argument pos <$> positiveKindPos_maybe tv (scaledThing scaled_ty)+    -- (assumes we don't have any function types nested inside other types)++-- | Does this type variable appear in a kind in a positive position in the+-- type?+--+-- Returns the first such position if so.+--+-- NB: assumes the type is of a simple form, e.g. no foralls, no function+-- arrows nested in a TyCon other than a function arrow.+-- Just used to compute the set of ConcreteTyVars for a PrimOp by inspecting+-- its type, see 'computePrimOpConcTyVarsFromType'.+positiveKindPos_maybe :: TcTyVar -> TcType -> Maybe (Position Pos)+positiveKindPos_maybe tv ty+  | (args, res) <- splitFunTys ty+  = listToMaybe $ catMaybes $+      ( (if null args then finish res else Result <$> positiveKindPos_maybe tv res)+      : map recur (zip [1..] args)+      )+  where+    recur (pos, scaled_ty)+      = Argument pos <$> negativeKindPos_maybe tv (scaledThing scaled_ty)+    -- (assumes we don't have any function types nested inside other types)+    finish ty+      | tv `elemVarSet` tyCoVarsOfType (typeKind ty)+      = Just Top+      | otherwise+      = Nothing  ------------------------------------------------------------- -- Cache of PrimOp's Ids
compiler/GHC/Builtin/Types.hs view
@@ -5,6 +5,8 @@ -}  {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ParallelListComp #-}+{-# LANGUAGE MultiWayIf #-}  {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} @@ -18,7 +20,8 @@         mkWiredInIdName,    -- used in GHC.Types.Id.Make          -- * All wired in things-        wiredInTyCons, isBuiltInOcc_maybe, isTupleTyOcc_maybe, isPunOcc_maybe,+        wiredInTyCons, isBuiltInOcc_maybe, isTupleTyOcc_maybe, isSumTyOcc_maybe,+        isPunOcc_maybe,          -- * Bool         boolTy, boolTyCon, boolTyCon_RDR, boolTyConName,@@ -157,7 +160,9 @@         integerINDataCon, integerINDataConName,         naturalTy, naturalTyCon, naturalTyConName,         naturalNSDataCon, naturalNSDataConName,-        naturalNBDataCon, naturalNBDataConName+        naturalNBDataCon, naturalNBDataConName,++         pretendNameIsInScope,     ) where  import GHC.Prelude@@ -183,15 +188,19 @@  import GHC.Types.TyThing import GHC.Types.SourceText-import GHC.Types.Var ( VarBndr (Bndr) )+import GHC.Types.Var ( VarBndr (Bndr), tyVarName ) import GHC.Types.RepType import GHC.Types.Name.Reader import GHC.Types.Name as Name-import GHC.Types.Name.Env ( lookupNameEnv_NF )+import GHC.Types.Name.Env ( lookupNameEnv_NF, mkNameEnv ) import GHC.Types.Basic import GHC.Types.ForeignCall import GHC.Types.Unique.Set +import {-# SOURCE #-} GHC.Tc.Types.Origin+  ( FixedRuntimeRepOrigin(..), mkFRRUnboxedTuple, mkFRRUnboxedSum )+import {-# SOURCE #-} GHC.Tc.Utils.TcType+  ( ConcreteTvOrigin(..), ConcreteTyVars, noConcreteTyVars )  import GHC.Settings.Constants ( mAX_TUPLE_SIZE, mAX_CTUPLE_SIZE, mAX_SUM_SIZE ) import GHC.Unit.Module        ( Module )@@ -203,7 +212,6 @@ import GHC.Utils.Outputable import GHC.Utils.Misc import GHC.Utils.Panic-import GHC.Utils.Panic.Plain  import qualified Data.ByteString.Char8 as BS @@ -211,8 +219,8 @@ import Data.List        ( elemIndex, intersperse ) import Numeric          ( showInt ) -import Text.Read (readMaybe) import Data.Char (ord, isDigit)+import Control.Applicative ((<|>))  alpha_tyvar :: [TyVar] alpha_tyvar = [alphaTyVar]@@ -373,7 +381,7 @@ charTyConName, charDataConName, intTyConName, intDataConName, stringTyConName :: Name charTyConName     = mkWiredInTyConName   UserSyntax gHC_TYPES (fsLit "Char")   charTyConKey charTyCon charDataConName   = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "C#")     charDataConKey charDataCon-stringTyConName   = mkWiredInTyConName   UserSyntax gHC_BASE  (fsLit "String") stringTyConKey stringTyCon+stringTyConName   = mkWiredInTyConName   UserSyntax gHC_INTERNAL_BASE  (fsLit "String") stringTyConKey stringTyCon intTyConName      = mkWiredInTyConName   UserSyntax gHC_TYPES (fsLit "Int")    intTyConKey   intTyCon intDataConName    = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "I#")     intDataConKey  intDataCon @@ -388,17 +396,17 @@ consDataConName   = mkWiredInDataConName BuiltInSyntax gHC_TYPES (fsLit ":") consDataConKey consDataCon  maybeTyConName, nothingDataConName, justDataConName :: Name-maybeTyConName     = mkWiredInTyConName   UserSyntax gHC_MAYBE (fsLit "Maybe")+maybeTyConName     = mkWiredInTyConName   UserSyntax gHC_INTERNAL_MAYBE (fsLit "Maybe")                                           maybeTyConKey maybeTyCon-nothingDataConName = mkWiredInDataConName UserSyntax gHC_MAYBE (fsLit "Nothing")+nothingDataConName = mkWiredInDataConName UserSyntax gHC_INTERNAL_MAYBE (fsLit "Nothing")                                           nothingDataConKey nothingDataCon-justDataConName    = mkWiredInDataConName UserSyntax gHC_MAYBE (fsLit "Just")+justDataConName    = mkWiredInDataConName UserSyntax gHC_INTERNAL_MAYBE (fsLit "Just")                                           justDataConKey justDataCon  wordTyConName, wordDataConName, word8DataConName :: Name wordTyConName      = mkWiredInTyConName   UserSyntax gHC_TYPES (fsLit "Word")   wordTyConKey     wordTyCon wordDataConName    = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "W#")     wordDataConKey   wordDataCon-word8DataConName   = mkWiredInDataConName UserSyntax gHC_WORD  (fsLit "W8#")    word8DataConKey  word8DataCon+word8DataConName   = mkWiredInDataConName UserSyntax gHC_INTERNAL_WORD  (fsLit "W8#")    word8DataConKey  word8DataCon  floatTyConName, floatDataConName, doubleTyConName, doubleDataConName :: Name floatTyConName     = mkWiredInTyConName   UserSyntax gHC_TYPES (fsLit "Float")  floatTyConKey    floatTyCon@@ -459,9 +467,9 @@ application is required, but there is no constraint on the choice.  In this situation GHC uses 'Any', -> length (Any *) ([] (Any *))+> length @(Any @Type) ([] @(Any @Type)) -Above, we print kinds explicitly, as if with --fprint-explicit-kinds.+Above, we print kinds explicitly, as if with -fprint-explicit-kinds.  The Any tycon used to be quite magic, but we have since been able to implement it merely with an empty kind polymorphic type family. See #10886 for a@@ -552,33 +560,44 @@  pcDataCon :: Name -> [TyVar] -> [Type] -> TyCon -> DataCon pcDataCon n univs tys-  = pcDataConWithFixity False n univs-                      []    -- no ex_tvs-                      univs -- the univs are precisely the user-written tyvars-                      []    -- No theta-                      (map linear tys)+  = pcRepPolyDataCon n univs noConcreteTyVars tys +pcRepPolyDataCon :: Name -> [TyVar] -> ConcreteTyVars+                 -> [Type] -> TyCon -> DataCon+pcRepPolyDataCon n univs conc_tvs tys+  = pcDataConWithFixity False n+      univs+      []    -- no ex_tvs+      conc_tvs+      univs -- the univs are precisely the user-written tyvars+      []    -- No theta+      (map linear tys)+ pcDataConConstraint :: Name -> [TyVar] -> ThetaType -> TyCon -> DataCon -- Used for data constructors whose arguments are all constraints. -- Notably constraint tuples, Eq# etc. pcDataConConstraint n univs theta-  = pcDataConWithFixity False n univs-                      []    -- No ex_tvs-                      univs -- The univs are precisely the user-written tyvars-                      theta -- All constraint arguments-                      []    -- No value arguments+  = pcDataConWithFixity False n+      univs+      []           -- No ex_tvs+      noConcreteTyVars+      univs        -- The univs are precisely the user-written tyvars+      theta        -- All constraint arguments+      []           -- No value arguments  -- Used for RuntimeRep and friends; things with PromDataConInfo pcSpecialDataCon :: Name -> [Type] -> TyCon -> PromDataConInfo -> DataCon pcSpecialDataCon dc_name arg_tys tycon rri   = pcDataConWithFixity' False dc_name                          (dataConWorkerUnique (nameUnique dc_name)) rri-                         [] [] [] [] (map linear arg_tys) tycon+                         [] [] noConcreteTyVars [] [] (map linear arg_tys) tycon  pcDataConWithFixity :: Bool      -- ^ declared infix?                     -> Name      -- ^ datacon name                     -> [TyVar]   -- ^ univ tyvars                     -> [TyCoVar] -- ^ ex tycovars+                    -> ConcreteTyVars+                                 -- ^ concrete tyvars                     -> [TyCoVar] -- ^ user-written tycovars                     -> ThetaType                     -> [Scaled Type]    -- ^ args@@ -594,7 +613,9 @@ -- one DataCon unique per pair of Ints.  pcDataConWithFixity' :: Bool -> Name -> Unique -> PromDataConInfo-                     -> [TyVar] -> [TyCoVar] -> [TyCoVar]+                     -> [TyVar] -> [TyCoVar]+                     -> ConcreteTyVars+                     -> [TyCoVar]                      -> ThetaType -> [Scaled Type] -> TyCon -> DataCon -- The Name should be in the DataName name space; it's the name -- of the DataCon itself.@@ -607,7 +628,7 @@ --    to regret doing so (we do).  pcDataConWithFixity' declared_infix dc_name wrk_key rri-                     tyvars ex_tyvars user_tyvars theta arg_tys tycon+                     tyvars ex_tyvars conc_tyvars user_tyvars theta arg_tys tycon   = data_con   where     tag_map = mkTyConTagMap tycon@@ -621,6 +642,7 @@                 (map (const no_bang) arg_tys)                 []      -- No labelled fields                 tyvars ex_tyvars+                conc_tyvars                 (mkTyVarBinders SpecifiedSpec user_tyvars)                 []      -- No equality spec                 theta@@ -688,27 +710,27 @@  * UnboxedTuples     - A wired-in type-    - Have a pretend DataCon, defined in GHC.Prim,+    - Data type declarations in GHC.Types       but no actual declaration and no info table  * ConstraintTuples     - A wired-in type.     - Declared as classes in GHC.Classes, e.g.-         class (c1,c2) => (c1,c2)+         class (c1,c2) => CTuple2 c1 c2     - Given constraints: the superclasses automatically become available     - Wanted constraints: there is a built-in instance-         instance (c1,c2) => (c1,c2)+         instance (c1,c2) => CTuple2 c1 c2       See GHC.Tc.Instance.Class.matchCTuple     - Currently just go up to 64; beyond that       you have to use manual nesting-    - Their OccNames look like (%,,,%), so they can easily be-      distinguished from term tuples.  But (following Haskell) we-      pretty-print saturated constraint tuples with round parens;-      see BasicTypes.tupleParens.     - Unlike BoxedTuples and UnboxedTuples, which only wire       in type constructors and data constructors, ConstraintTuples also wire in-      superclass selector functions. For instance, $p1(%,%) and $p2(%,%) are+      superclass selector functions. For instance, $p1CTuple2 and $p2CTuple2 are       the selectors for the binary constraint tuple.+    - The parenthesis syntax for grouping constraints in contexts is not treated+      as a constraint tuple. The parser starts with a tuple type, then a+      postprocessing action extracts the individual constraints as a list and+      stores them in the context field of types like HsQualTy.  * In quite a lot of places things are restricted just to   BoxedTuple/UnboxedTuple, and then we used BasicTypes.Boxity to distinguish@@ -773,7 +795,7 @@ defined in GHC.Tuple, will be used when one-tuples are spliced in through Template Haskell. This program (from #18097) crucially relies on this: -  case $( tupE [ [| "ok" |] ] ) of Solo x -> putStrLn x+  case $( tupE [ [| "ok" |] ] ) of MkSolo x -> putStrLn x  Unless Solo has a known key, the type of `$( tupE [ [| "ok" |] ] )` (an ExplicitTuple of length 1) will not match the type of Solo (an ordinary@@ -794,7 +816,7 @@ -- with BuiltInSyntax. However, this should only be necessary while resolving -- names produced by Template Haskell splices since we take care to encode -- built-in syntax names specially in interface files. See--- Note [Symbol table representation of names].+-- Note [Symbol table representation of names] in GHC.Iface.Binary. -- -- Moreover, there is no need to include names of things that the user can't -- write (e.g. type representation bindings like $tc(,,,)).@@ -808,7 +830,7 @@       "FUN"  -> Just fUNTyConName       "->"  -> Just unrestrictedFunTyConName -      -- boxed tuple data/tycon+      -- tuple data/tycon       -- We deliberately exclude Solo (the boxed 1-tuple).       -- See Note [One-tuples] (Wrinkle: Make boxed one-tuple names have known keys)       "()"    -> Just $ tup_name Boxed 0@@ -819,7 +841,7 @@        -- unboxed tuple data/tycon       "(##)"  -> Just $ tup_name Unboxed 0-      "Solo#" -> Just $ tup_name Unboxed 1+      "(# #)" -> Just $ tup_name Unboxed 1       _ | Just rest <- "(#" `BS.stripPrefix` name         , (commas, rest') <- BS.span (==',') rest         , "#)" <- rest'@@ -840,6 +862,7 @@              -> let arity = nb_pipes1 + nb_pipes2 + 1                     alt = nb_pipes1 + 1                 in Just $ dataConName $ sumDataCon alt arity+       _ -> Nothing   where     name = bytesFS $ occNameFS occ@@ -865,31 +888,70 @@  isTupleTyOcc_maybe :: Module -> OccName -> Maybe Name isTupleTyOcc_maybe mod occ-  | mod == gHC_TUPLE_PRIM+  | mod == gHC_INTERNAL_TUPLE || mod == gHC_TYPES   = match_occ   where     match_occ       | occ == occName unitTyConName = Just unitTyConName       | occ == occName soloTyConName = Just soloTyConName+      | occ == occName unboxedUnitTyConName = Just unboxedUnitTyConName+      | occ == occName unboxedSoloTyConName = Just unboxedSoloTyConName       | otherwise = isTupleNTyOcc_maybe occ isTupleTyOcc_maybe _ _ = Nothing +isCTupleOcc_maybe :: Module -> OccName -> Maybe Name+isCTupleOcc_maybe mod occ+  | mod == gHC_CLASSES+  = match_occ+  where+    match_occ+      | occ == occName (cTupleTyConName 0) = Just (cTupleTyConName 0)+      | occ == occName (cTupleTyConName 1) = Just (cTupleTyConName 1)+      | 'C':'T':'u':'p':'l':'e' : rest <- occNameString occ+      , Just (BoxedTuple, num) <- arity_and_boxity rest+      , num >= 2 && num <= 64+           = Just $ cTupleTyConName num+      | otherwise = Nothing +isCTupleOcc_maybe _ _ = Nothing+ -- | This is only for Tuple<n>, not for Unit or Solo isTupleNTyOcc_maybe :: OccName -> Maybe Name isTupleNTyOcc_maybe occ =   case occNameString occ of-    'T':'u':'p':'l':'e':str | Just n <- readInt str, n > 1-      -> Just (tupleTyConName BoxedTuple n)+    'T':'u':'p':'l':'e':str | Just (sort, n) <- arity_and_boxity str, n > 1+      -> Just (tupleTyConName sort n)     _ -> Nothing +isSumTyOcc_maybe :: Module -> OccName -> Maybe Name+isSumTyOcc_maybe mod occ | mod == gHC_TYPES =+  isSumNTyOcc_maybe occ+isSumTyOcc_maybe _ _ = Nothing++isSumNTyOcc_maybe :: OccName -> Maybe Name+isSumNTyOcc_maybe occ =+  case occNameString occ of+    'S':'u':'m':str | Just (UnboxedTuple, n) <- arity_and_boxity str, n > 1+      -> Just (tyConName (sumTyCon n))+    _ -> Nothing+ -- | See Note [Small Ints parsing]-readInt :: String -> Maybe Int-readInt s = case s of-  [c] | isDigit c -> Just (digit_to_int c)-  [c1, c2] | isDigit c1, isDigit c2-    -> Just (digit_to_int c1 * 10 + digit_to_int c2)-  _ -> readMaybe s+--+-- Analyze a string as the suffix of an OccName of a tuple or sum tycon to+-- determine its arity and boxity (based on the presence of a @#@).+arity_and_boxity :: String -> Maybe (TupleSort, Int)+arity_and_boxity s = case s of+  c1 : t1 | isDigit c1 -> case t1 of+    [] -> Just (BoxedTuple, digit_to_int c1)+    ['#'] -> Just (UnboxedTuple, digit_to_int c1)+    c2 : t2 | isDigit c2 ->+      let ar = digit_to_int c1 * 10 + digit_to_int c2+      in case t2 of+        [] -> Just (BoxedTuple, ar)+        ['#'] -> Just (UnboxedTuple, ar)+        _ -> Nothing+    _ -> Nothing+  _ -> Nothing   where     digit_to_int :: Char -> Int     digit_to_int c = ord c - ord '0'@@ -917,23 +979,24 @@ isPunOcc_maybe mod occ   | mod == gHC_TYPES, occ == occName listTyConName   = Just listTyConName-  | mod == gHC_TUPLE_PRIM, occ == occName unitTyConName-  = Just unitTyConName-  | mod == gHC_TUPLE_PRIM-  = isTupleNTyOcc_maybe occ-isPunOcc_maybe _ _ = Nothing+  | mod == gHC_TYPES, occ == occName unboxedSoloDataConName+  = Just unboxedSoloDataConName+  | otherwise+  = isTupleTyOcc_maybe mod occ <|>+    isCTupleOcc_maybe  mod occ <|>+    isSumTyOcc_maybe   mod occ  mkTupleOcc :: NameSpace -> Boxity -> Arity -> OccName -- No need to cache these, the caching is done in mk_tuple mkTupleOcc ns Boxed   ar = mkOccName ns (mkBoxedTupleStr ns ar)-mkTupleOcc ns Unboxed ar = mkOccName ns (mkUnboxedTupleStr ar)+mkTupleOcc ns Unboxed ar = mkOccName ns (mkUnboxedTupleStr ns ar)  mkCTupleOcc :: NameSpace -> Arity -> OccName mkCTupleOcc ns ar = mkOccName ns (mkConstraintTupleStr ar)  mkTupleStr :: Boxity -> NameSpace -> Arity -> String mkTupleStr Boxed   = mkBoxedTupleStr-mkTupleStr Unboxed = const mkUnboxedTupleStr+mkTupleStr Unboxed = mkUnboxedTupleStr  mkBoxedTupleStr :: NameSpace -> Arity -> String mkBoxedTupleStr ns 0@@ -946,15 +1009,22 @@   | isDataConNameSpace ns = '(' : commas ar ++ ")"   | otherwise             = "Tuple" ++ showInt ar "" -mkUnboxedTupleStr :: Arity -> String-mkUnboxedTupleStr 0  = "(##)"-mkUnboxedTupleStr 1  = "Solo#"  -- See Note [One-tuples]-mkUnboxedTupleStr ar = "(#" ++ commas ar ++ "#)" +mkUnboxedTupleStr :: NameSpace -> Arity -> String+mkUnboxedTupleStr ns 0+  | isDataConNameSpace ns = "(##)"+  | otherwise             = "Unit#"+mkUnboxedTupleStr ns 1+  | isDataConNameSpace ns = "(# #)"  -- See Note [One-tuples]+  | otherwise             = "Solo#"+mkUnboxedTupleStr ns ar+  | isDataConNameSpace ns = "(#" ++ commas ar ++ "#)"+  | otherwise             = "Tuple" ++ show ar ++ "#"+ mkConstraintTupleStr :: Arity -> String-mkConstraintTupleStr 0  = "(%%)"-mkConstraintTupleStr 1  = "Solo%"   -- See Note [One-tuples]-mkConstraintTupleStr ar = "(%" ++ commas ar ++ "%)"+mkConstraintTupleStr 0 = "CUnit"+mkConstraintTupleStr 1 = "CSolo"+mkConstraintTupleStr ar = "CTuple" ++ show ar  commas :: Arity -> String commas ar = replicate (ar-1) ','@@ -1012,8 +1082,8 @@            ++ "(superclass position: " ++ show sc_pos            ++ ", arity: " ++ show arity ++ ")") -  | arity < 2-  = panic ("cTupleSelId: Arity starts from 2. "+  | arity < 1+  = panic ("cTupleSelId: Arity starts from 1. "            ++ "(superclass position: " ++ show sc_pos            ++ ", arity: " ++ show arity ++ ")") @@ -1104,7 +1174,7 @@     tuple_con  = pcDataCon dc_name dc_tvs dc_arg_tys tycon      boxity  = Boxed-    modu    = gHC_TUPLE_PRIM+    modu    = gHC_INTERNAL_TUPLE     tc_name = mkWiredInName modu (mkTupleOcc tcName boxity arity) tc_uniq                          (ATyCon tycon) UserSyntax     dc_name = mkWiredInName modu (mkTupleOcc dataName boxity arity) dc_uniq@@ -1126,13 +1196,21 @@     flavour     = VanillaAlgTyCon (mkPrelTyConRepName tc_name)      dc_tvs               = binderVars tc_binders-    (rr_tys, dc_arg_tys) = splitAt arity (mkTyVarTys dc_tvs)-    tuple_con            = pcDataCon dc_name dc_tvs dc_arg_tys tycon+    (rr_tvs, dc_arg_tvs) = splitAt arity dc_tvs+    rr_tys               = mkTyVarTys rr_tvs+    dc_arg_tys           = mkTyVarTys dc_arg_tvs+    tuple_con            = pcRepPolyDataCon dc_name dc_tvs conc_tvs dc_arg_tys tycon+    conc_tvs =+      mkNameEnv+        [ (tyVarName rr_tv, ConcreteFRR $ FixedRuntimeRepOrigin ty $ mkFRRUnboxedTuple pos)+        | rr_tv <- rr_tvs+        | ty <- dc_arg_tys+        | pos <- [1..arity] ]      boxity  = Unboxed-    modu    = gHC_PRIM+    modu    = gHC_TYPES     tc_name = mkWiredInName modu (mkTupleOcc tcName boxity arity) tc_uniq-                         (ATyCon tycon) BuiltInSyntax+                         (ATyCon tycon) UserSyntax     dc_name = mkWiredInName modu (mkTupleOcc dataName boxity arity) dc_uniq                             (AConLike (RealDataCon tuple_con)) BuiltInSyntax     tc_uniq = mkTupleTyConUnique   boxity arity@@ -1154,7 +1232,7 @@      modu    = gHC_CLASSES     tc_name = mkWiredInName modu (mkCTupleOcc tcName arity) tc_uniq-                         (ATyCon tycon) BuiltInSyntax+                         (ATyCon tycon) UserSyntax     dc_name = mkWiredInName modu (mkCTupleOcc dataName arity) dc_uniq                             (AConLike (RealDataCon tuple_con)) BuiltInSyntax     tc_uniq = mkCTupleTyConUnique   arity@@ -1207,9 +1285,21 @@ unboxedUnitTyCon :: TyCon unboxedUnitTyCon = tupleTyCon Unboxed 0 +unboxedUnitTyConName :: Name+unboxedUnitTyConName = tyConName unboxedUnitTyCon+ unboxedUnitDataCon :: DataCon unboxedUnitDataCon = tupleDataCon Unboxed 0 +unboxedSoloTyCon :: TyCon+unboxedSoloTyCon = tupleTyCon Unboxed 1++unboxedSoloTyConName :: Name+unboxedSoloTyConName = tyConName unboxedSoloTyCon++unboxedSoloDataConName :: Name+unboxedSoloDataConName = tupleDataConName Unboxed 1+ {- ********************************************************************* *                                                                      *       Unboxed sums@@ -1221,8 +1311,7 @@ mkSumTyConOcc n = mkOccName tcName str   where     -- No need to cache these, the caching is done in mk_sum-    str = '(' : '#' : ' ' : bars ++ " #)"-    bars = intersperse ' ' $ replicate (n-1) '|'+    str = "Sum" ++ show n ++ "#"  -- | OccName for i-th alternative of n-ary unboxed sum data constructor. mkSumDataConOcc :: ConTag -> Arity -> OccName@@ -1291,23 +1380,34 @@      tc_res_kind = unboxedSumKind rr_tys -    (rr_tys, tyvar_tys) = splitAt arity (mkTyVarTys tyvars)+    (rr_tvs, dc_arg_tvs) = splitAt arity tyvars+    rr_tys               = mkTyVarTys rr_tvs+    dc_arg_tys           = mkTyVarTys dc_arg_tvs -    tc_name = mkWiredInName gHC_PRIM (mkSumTyConOcc arity) tc_uniq-                            (ATyCon tycon) BuiltInSyntax+    conc_tvs =+      mkNameEnv+        [ (tyVarName rr_tv, ConcreteFRR $ FixedRuntimeRepOrigin ty $ mkFRRUnboxedSum (Just pos))+        | rr_tv <- rr_tvs+        | ty <- dc_arg_tys+        | pos <- [1..arity] ] +    tc_name = mkWiredInName gHC_TYPES (mkSumTyConOcc arity) tc_uniq+                            (ATyCon tycon) UserSyntax+     sum_cons = listArray (0,arity-1) [sum_con i | i <- [0..arity-1]]-    sum_con i = let dc = pcDataCon dc_name-                                   tyvars -- univ tyvars-                                   [tyvar_tys !! i] -- arg types-                                   tycon+    sum_con i =+      let dc = pcRepPolyDataCon dc_name+                  tyvars -- univ tyvars+                  conc_tvs+                  [dc_arg_tys !! i] -- arg types+                  tycon -                    dc_name = mkWiredInName gHC_PRIM-                                            (mkSumDataConOcc i arity)-                                            (dc_uniq i)-                                            (AConLike (RealDataCon dc))-                                            BuiltInSyntax-                in dc+          dc_name = mkWiredInName gHC_TYPES+                                  (mkSumDataConOcc i arity)+                                  (dc_uniq i)+                                  (AConLike (RealDataCon dc))+                                  BuiltInSyntax+      in dc      tc_uniq   = mkSumTyConUnique   arity     dc_uniq i = mkSumDataConUnique i arity@@ -2184,7 +2284,7 @@ consDataCon :: DataCon consDataCon = pcDataConWithFixity True {- Declared infix -}                consDataConName-               alpha_tyvar [] alpha_tyvar []+               alpha_tyvar [] noConcreteTyVars alpha_tyvar []                (map linear [alphaTy, mkTyConApp listTyCon alpha_ty])                listTyCon @@ -2385,28 +2485,28 @@ integerTyConName    = mkWiredInTyConName       UserSyntax-      gHC_NUM_INTEGER+      gHC_INTERNAL_NUM_INTEGER       (fsLit "Integer")       integerTyConKey       integerTyCon integerISDataConName    = mkWiredInDataConName       UserSyntax-      gHC_NUM_INTEGER+      gHC_INTERNAL_NUM_INTEGER       (fsLit "IS")       integerISDataConKey       integerISDataCon integerIPDataConName    = mkWiredInDataConName       UserSyntax-      gHC_NUM_INTEGER+      gHC_INTERNAL_NUM_INTEGER       (fsLit "IP")       integerIPDataConKey       integerIPDataCon integerINDataConName    = mkWiredInDataConName       UserSyntax-      gHC_NUM_INTEGER+      gHC_INTERNAL_NUM_INTEGER       (fsLit "IN")       integerINDataConKey       integerINDataCon@@ -2434,21 +2534,21 @@ naturalTyConName    = mkWiredInTyConName       UserSyntax-      gHC_NUM_NATURAL+      gHC_INTERNAL_NUM_NATURAL       (fsLit "Natural")       naturalTyConKey       naturalTyCon naturalNSDataConName    = mkWiredInDataConName       UserSyntax-      gHC_NUM_NATURAL+      gHC_INTERNAL_NUM_NATURAL       (fsLit "NS")       naturalNSDataConKey       naturalNSDataCon naturalNBDataConName    = mkWiredInDataConName       UserSyntax-      gHC_NUM_NATURAL+      gHC_INTERNAL_NUM_NATURAL       (fsLit "NB")       naturalNBDataConKey       naturalNBDataCon@@ -2473,3 +2573,59 @@   | Just arity <- cTupleTyConNameArity_maybe n   = Exact $ tupleTyConName BoxedTuple arity filterCTuple rdr = rdr++{-+************************************************************************+*                                                                      *+   Semi-builtin names+*                                                                      *+************************************************************************++Note [pretendNameIsInScope]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+In general, we filter out instances that mention types whose names are+not in scope. However, in the situations listed below, we make an exception+for some commonly used names, such as Data.Kind.Type, which may not actually+be in scope but should be treated as though they were in scope.+This includes built-in names, as well as a few extra names such as+'Type', 'TYPE', 'BoxedRep', etc.++Situations in which we apply this special logic:++  - GHCi's :info command, see GHC.Runtime.Eval.getInfo.+    This fixes #1581.++  - When reporting instance overlap errors. Not doing so could mean+    that we would omit instances for typeclasses like++      type Cls :: k -> Constraint+      class Cls a++    because BoxedRep/Lifted were not in scope.+    See GHC.Tc.Errors.potentialInstancesErrMsg.+    This fixes one of the issues reported in #20465.+-}++-- | Should this name be considered in-scope, even though it technically isn't?+--+-- This ensures that we don't filter out information because, e.g.,+-- Data.Kind.Type isn't imported.+--+-- See Note [pretendNameIsInScope].+pretendNameIsInScope :: Name -> Bool+pretendNameIsInScope n+  = isBuiltInSyntax n+  || isTupleTyConName n+  || isSumTyConName n+  || isCTupleTyConName n+  || any (n `hasKey`)+    [ liftedTypeKindTyConKey, unliftedTypeKindTyConKey+    , liftedDataConKey, unliftedDataConKey+    , tYPETyConKey+    , cONSTRAINTTyConKey+    , runtimeRepTyConKey, boxedRepDataConKey+    , eqTyConKey+    , listTyConKey+    , oneDataConKey+    , manyDataConKey+    , fUNTyConKey, unrestrictedFunTyConKey ]
compiler/GHC/Builtin/Types.hs-boot view
@@ -15,6 +15,7 @@ coercibleTyCon, heqTyCon :: TyCon  unitTy :: Type+unitTyCon :: TyCon  liftedTypeKindTyConName :: Name constraintKindTyConName :: Name
compiler/GHC/Builtin/Types/Prim.hs view
@@ -420,8 +420,8 @@                              -- Result is anon arg kinds [ak1, .., akm]     -> [TyVar]   -- [kv1:k1, ..., kvn:kn, av1:ak1, ..., avm:akm] -- Example: if you want the tyvars for---   forall (r:RuntimeRep) (a:TYPE r) (b:*). blah--- call mkTemplateKiTyVars [RuntimeRep] (\[r] -> [TYPE r, *])+--   forall (r::RuntimeRep) (a::TYPE r) (b::Type). blah+-- call mkTemplateKiTyVars [RuntimeRep] (\[r] -> [TYPE r, Type]) mkTemplateKiTyVars kind_var_kinds mk_arg_kinds   = kv_bndrs ++ tv_bndrs   where@@ -435,8 +435,8 @@                              -- Result is anon arg kinds [ak1, .., akm]     -> [TyVar]   -- [kv1:k1, ..., kvn:kn, av1:ak1, ..., avm:akm] -- Example: if you want the tyvars for---   forall (r:RuntimeRep) (a:TYPE r) (b:*). blah--- call mkTemplateKiTyVar RuntimeRep (\r -> [TYPE r, *])+--   forall (r::RuntimeRep) (a::TYPE r) (b::Type). blah+-- call mkTemplateKiTyVar RuntimeRep (\r -> [TYPE r, Type]) mkTemplateKiTyVar kind mk_arg_kinds   = kv_bndr : tv_bndrs   where@@ -758,8 +758,10 @@      are not /apart/: see Note [Type and Constraint are not apart]  (W2) We need two absent-error Ids, aBSENT_ERROR_ID for types of kind Type, and-     aBSENT_CONSTRAINT_ERROR_ID for vaues of kind Constraint.  Ditto noInlineId-     vs noInlineConstraintId in GHC.Types.Id.Make; see Note [inlineId magic].+     aBSENT_CONSTRAINT_ERROR_ID for types of kind Constraint.+     See Note [Type vs Constraint for error ids] in GHC.Core.Make.+     Ditto noInlineId vs noInlineConstraintId in GHC.Types.Id.Make;+     see Note [inlineId magic].  (W3) We need a TypeOrConstraint flag in LitRubbish. @@ -824,7 +826,7 @@      are not Apart. See the FunTy/FunTy case in GHC.Core.Unify.unify_ty.  (W3) Are (TYPE IntRep) and (CONSTRAINT WordRep) apart?  In truth yes,-     they are.  But it's easier to say that htey are not apart, by+     they are.  But it's easier to say that they are not apart, by      reporting "maybeApart" (which is always safe), rather than      recurse into the arguments (whose kinds may be utterly different)      to look for apartness inside them.  Again this is in@@ -844,8 +846,8 @@ Note [RuntimeRep polymorphism] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Generally speaking, you can't be polymorphic in `RuntimeRep`.  E.g-   f :: forall (rr:RuntimeRep) (a:TYPE rr). a -> [a]-   f = /\(rr:RuntimeRep) (a:rr) \(a:rr). ...+   f :: forall (rr::RuntimeRep) (a::TYPE rr). a -> [a]+   f = /\(rr::RuntimeRep) (a::rr) \(a::rr). ... This is no good: we could not generate code for 'f', because the calling convention for 'f' varies depending on whether the argument is a a Int, Int#, or Float#.  (You could imagine generating specialised@@ -854,7 +856,7 @@ Certain functions CAN be runtime-rep-polymorphic, because the code generator never has to manipulate a value of type 'a :: TYPE rr'. -* error :: forall (rr:RuntimeRep) (a:TYPE rr). String -> a+* error :: forall (rr::RuntimeRep) (a::TYPE rr). String -> a   Code generator never has to manipulate the return value.  * unsafeCoerce#, defined in Desugar.mkUnsafeCoercePair:
compiler/GHC/Builtin/Uniques.hs view
@@ -14,12 +14,14 @@       -- * Getting the 'Unique's of 'Name's       -- ** Anonymous sums     , mkSumTyConUnique, mkSumDataConUnique+    , isSumTyConUnique        -- ** Tuples       -- *** Vanilla     , mkTupleTyConUnique     , mkTupleDataConUnique     , isTupleTyConUnique+    , isTupleDataConLikeUnique       -- *** Constraint     , mkCTupleTyConUnique     , mkCTupleDataConUnique@@ -66,7 +68,6 @@  import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Utils.Panic.Plain (assert)  import Data.Maybe import GHC.Utils.Word64 (word64ToInt)@@ -121,6 +122,14 @@               -- alternative     mkUniqueInt 'z' (arity `shiftL` 8 .|. 0xfc) +isSumTyConUnique :: Unique -> Maybe Arity+isSumTyConUnique u =+  case (tag, n .&. 0xfc) of+    ('z', 0xfc) -> Just (word64ToInt n `shiftR` 8)+    _ -> Nothing+  where+    (tag, n) = unpkUnique u+ mkSumDataConUnique :: ConTagZ -> Arity -> Unique mkSumDataConUnique alt arity   | alt >= arity@@ -283,6 +292,18 @@   where     (tag,   n) = unpkUnique u     (arity', i) = quotRem n 2+    arity = word64ToInt arity'++-- | This function is an inverse of `mkTupleTyDataUnique` that also matches the worker and promoted tycon.+isTupleDataConLikeUnique :: Unique -> Maybe (Boxity, Arity)+isTupleDataConLikeUnique u =+  case tag of+    '7' -> Just (Boxed,   arity)+    '8' -> Just (Unboxed, arity)+    _ -> Nothing+  where+    (tag,   n) = unpkUnique u+    (arity', _) = quotRem n 3     arity = word64ToInt arity'  getTupleTyConName :: Boxity -> Int -> Name
compiler/GHC/ByteCode/Types.hs view
@@ -167,7 +167,8 @@   = BCOPtrName   !Name   | BCOPtrPrimOp !PrimOp   | BCOPtrBCO    !UnlinkedBCO-  | BCOPtrBreakArray  -- a pointer to this module's BreakArray+  | BCOPtrBreakArray (ForeignRef BreakArray)+    -- ^ a pointer to a breakpoint's module's BreakArray in GHCi's memory  instance NFData BCOPtr where   rnf (BCOPtrBCO bco) = rnf bco
compiler/GHC/Cmm.hs view
@@ -50,7 +50,6 @@ import GHC.Runtime.Heap.Layout import GHC.Cmm.Expr import GHC.Cmm.Dataflow.Block-import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Graph import GHC.Cmm.Dataflow.Label import GHC.Utils.Outputable
compiler/GHC/Cmm/CLabel.hs view
@@ -6,11 +6,6 @@ -- ----------------------------------------------------------------------------- -{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}-- module GHC.Cmm.CLabel (         CLabel, -- abstract type         NeedExternDecl (..),@@ -53,6 +48,7 @@         mkDirty_MUT_VAR_Label,         mkMUT_VAR_CLEAN_infoLabel,         mkNonmovingWriteBarrierEnabledLabel,+        mkOrigThunkInfoLabel,         mkUpdInfoLabel,         mkBHUpdInfoLabel,         mkIndStaticInfoLabel,@@ -153,7 +149,6 @@ import GHC.Types.CostCentre import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Utils.Panic.Plain import GHC.Data.FastString import GHC.Platform import GHC.Types.Unique.Set@@ -641,7 +636,7 @@ -- Constructing Cmm Labels mkDirty_MUT_VAR_Label,     mkNonmovingWriteBarrierEnabledLabel,-    mkUpdInfoLabel,+    mkOrigThunkInfoLabel, mkUpdInfoLabel,     mkBHUpdInfoLabel, mkIndStaticInfoLabel, mkMainCapabilityLabel,     mkMAP_FROZEN_CLEAN_infoLabel, mkMAP_FROZEN_DIRTY_infoLabel,     mkMAP_DIRTY_infoLabel,@@ -655,6 +650,7 @@ mkDirty_MUT_VAR_Label           = mkForeignLabel (fsLit "dirty_MUT_VAR") Nothing ForeignLabelInExternalPackage IsFunction mkNonmovingWriteBarrierEnabledLabel                                 = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "nonmoving_write_barrier_enabled") CmmData+mkOrigThunkInfoLabel            = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_orig_thunk_info_frame") CmmInfo mkUpdInfoLabel                  = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_upd_frame")         CmmInfo mkBHUpdInfoLabel                = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_bh_upd_frame" )     CmmInfo mkIndStaticInfoLabel            = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_IND_STATIC")        CmmInfo@@ -797,6 +793,7 @@ isSomeRODataLabel (IdLabel _ _ BlockInfoTable) = True -- info table defined in cmm (.cmm) isSomeRODataLabel (CmmLabel _ _ _ CmmInfo) = True+isSomeRODataLabel (CmmLabel _ _ _ CmmRetInfo) = True isSomeRODataLabel _lbl = False  -- | Whether label is points to some kind of info table
− compiler/GHC/Cmm/Dataflow/Collections.hs 
@@ -1,179 +0,0 @@-{-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE TypeFamilies #-}--module GHC.Cmm.Dataflow.Collections-    ( IsSet(..)-    , setInsertList, setDeleteList, setUnions-    , IsMap(..)-    , mapInsertList, mapDeleteList, mapUnions-    , UniqueMap, UniqueSet-    ) where--import GHC.Prelude--import qualified GHC.Data.Word64Map.Strict as M-import qualified GHC.Data.Word64Set as S--import Data.List (foldl1')-import Data.Word (Word64)--class IsSet set where-  type ElemOf set--  setNull :: set -> Bool-  setSize :: set -> Int-  setMember :: ElemOf set -> set -> Bool--  setEmpty :: set-  setSingleton :: ElemOf set -> set-  setInsert :: ElemOf set -> set -> set-  setDelete :: ElemOf set -> set -> set--  setUnion :: set -> set -> set-  setDifference :: set -> set -> set-  setIntersection :: set -> set -> set-  setIsSubsetOf :: set -> set -> Bool-  setFilter :: (ElemOf set -> Bool) -> set -> set--  setFoldl :: (b -> ElemOf set -> b) -> b -> set -> b-  setFoldr :: (ElemOf set -> b -> b) -> b -> set -> b--  setElems :: set -> [ElemOf set]-  setFromList :: [ElemOf set] -> set---- Helper functions for IsSet class-setInsertList :: IsSet set => [ElemOf set] -> set -> set-setInsertList keys set = foldl' (flip setInsert) set keys--setDeleteList :: IsSet set => [ElemOf set] -> set -> set-setDeleteList keys set = foldl' (flip setDelete) set keys--setUnions :: IsSet set => [set] -> set-setUnions [] = setEmpty-setUnions sets = foldl1' setUnion sets---class IsMap map where-  type KeyOf map--  mapNull :: map a -> Bool-  mapSize :: map a -> Int-  mapMember :: KeyOf map -> map a -> Bool-  mapLookup :: KeyOf map -> map a -> Maybe a-  mapFindWithDefault :: a -> KeyOf map -> map a -> a--  mapEmpty :: map a-  mapSingleton :: KeyOf map -> a -> map a-  mapInsert :: KeyOf map -> a -> map a -> map a-  mapInsertWith :: (a -> a -> a) -> KeyOf map -> a -> map a -> map a-  mapDelete :: KeyOf map -> map a -> map a-  mapAlter :: (Maybe a -> Maybe a) -> KeyOf map -> map a -> map a-  mapAdjust :: (a -> a) -> KeyOf map -> map a -> map a--  mapUnion :: map a -> map a -> map a-  mapUnionWithKey :: (KeyOf map -> a -> a -> a) -> map a -> map a -> map a-  mapDifference :: map a -> map a -> map a-  mapIntersection :: map a -> map a -> map a-  mapIsSubmapOf :: Eq a => map a -> map a -> Bool--  mapMap :: (a -> b) -> map a -> map b-  mapMapWithKey :: (KeyOf map -> a -> b) -> map a -> map b-  mapFoldl :: (b -> a -> b) -> b -> map a -> b-  mapFoldr :: (a -> b -> b) -> b -> map a -> b-  mapFoldlWithKey :: (b -> KeyOf map -> a -> b) -> b -> map a -> b-  mapFoldMapWithKey :: Monoid m => (KeyOf map -> a -> m) -> map a -> m-  mapFilter :: (a -> Bool) -> map a -> map a-  mapFilterWithKey :: (KeyOf map -> a -> Bool) -> map a -> map a---  mapElems :: map a -> [a]-  mapKeys :: map a -> [KeyOf map]-  mapToList :: map a -> [(KeyOf map, a)]-  mapFromList :: [(KeyOf map, a)] -> map a-  mapFromListWith :: (a -> a -> a) -> [(KeyOf map,a)] -> map a---- Helper functions for IsMap class-mapInsertList :: IsMap map => [(KeyOf map, a)] -> map a -> map a-mapInsertList assocs map = foldl' (flip (uncurry mapInsert)) map assocs--mapDeleteList :: IsMap map => [KeyOf map] -> map a -> map a-mapDeleteList keys map = foldl' (flip mapDelete) map keys--mapUnions :: IsMap map => [map a] -> map a-mapUnions [] = mapEmpty-mapUnions maps = foldl1' mapUnion maps---------------------------------------------------------------------------------- Basic instances--------------------------------------------------------------------------------newtype UniqueSet = US S.Word64Set deriving (Eq, Ord, Show, Semigroup, Monoid)--instance IsSet UniqueSet where-  type ElemOf UniqueSet = Word64--  setNull (US s) = S.null s-  setSize (US s) = S.size s-  setMember k (US s) = S.member k s--  setEmpty = US S.empty-  setSingleton k = US (S.singleton k)-  setInsert k (US s) = US (S.insert k s)-  setDelete k (US s) = US (S.delete k s)--  setUnion (US x) (US y) = US (S.union x y)-  setDifference (US x) (US y) = US (S.difference x y)-  setIntersection (US x) (US y) = US (S.intersection x y)-  setIsSubsetOf (US x) (US y) = S.isSubsetOf x y-  setFilter f (US s) = US (S.filter f s)--  setFoldl k z (US s) = S.foldl' k z s-  setFoldr k z (US s) = S.foldr k z s--  setElems (US s) = S.elems s-  setFromList ks = US (S.fromList ks)--newtype UniqueMap v = UM (M.Word64Map v)-  deriving (Eq, Ord, Show, Functor, Foldable, Traversable)--instance IsMap UniqueMap where-  type KeyOf UniqueMap = Word64--  mapNull (UM m) = M.null m-  mapSize (UM m) = M.size m-  mapMember k (UM m) = M.member k m-  mapLookup k (UM m) = M.lookup k m-  mapFindWithDefault def k (UM m) = M.findWithDefault def k m--  mapEmpty = UM M.empty-  mapSingleton k v = UM (M.singleton k v)-  mapInsert k v (UM m) = UM (M.insert k v m)-  mapInsertWith f k v (UM m) = UM (M.insertWith f k v m)-  mapDelete k (UM m) = UM (M.delete k m)-  mapAlter f k (UM m) = UM (M.alter f k m)-  mapAdjust f k (UM m) = UM (M.adjust f k m)--  mapUnion (UM x) (UM y) = UM (M.union x y)-  mapUnionWithKey f (UM x) (UM y) = UM (M.unionWithKey f x y)-  mapDifference (UM x) (UM y) = UM (M.difference x y)-  mapIntersection (UM x) (UM y) = UM (M.intersection x y)-  mapIsSubmapOf (UM x) (UM y) = M.isSubmapOf x y--  mapMap f (UM m) = UM (M.map f m)-  mapMapWithKey f (UM m) = UM (M.mapWithKey f m)-  mapFoldl k z (UM m) = M.foldl' k z m-  mapFoldr k z (UM m) = M.foldr k z m-  mapFoldlWithKey k z (UM m) = M.foldlWithKey' k z m-  mapFoldMapWithKey f (UM m) = M.foldMapWithKey f m-  {-# INLINEABLE mapFilter #-}-  mapFilter f (UM m) = UM (M.filter f m)-  {-# INLINEABLE mapFilterWithKey #-}-  mapFilterWithKey f (UM m) = UM (M.filterWithKey f m)--  mapElems (UM m) = M.elems m-  mapKeys (UM m) = M.keys m-  {-# INLINEABLE mapToList #-}-  mapToList (UM m) = M.toList m-  mapFromList assocs = UM (M.fromList assocs)-  mapFromListWith f assocs = UM (M.fromListWith f assocs)
compiler/GHC/Cmm/Dataflow/Graph.hs view
@@ -1,9 +1,5 @@-{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} module GHC.Cmm.Dataflow.Graph     ( Body@@ -26,7 +22,6 @@  import GHC.Cmm.Dataflow.Label import GHC.Cmm.Dataflow.Block-import GHC.Cmm.Dataflow.Collections  import Data.Kind @@ -120,7 +115,7 @@ labelsDefined GNil      = setEmpty labelsDefined (GUnit{}) = setEmpty labelsDefined (GMany _ body x) = mapFoldlWithKey addEntry (exitLabel x) body-  where addEntry :: forall a. LabelSet -> ElemOf LabelSet -> a -> LabelSet+  where addEntry :: forall a. LabelSet -> Label -> a -> LabelSet         addEntry labels label _ = setInsert label labels         exitLabel :: MaybeO x (block n C O) -> LabelSet         exitLabel NothingO  = setEmpty
compiler/GHC/Cmm/Dataflow/Label.hs view
@@ -1,8 +1,10 @@-{-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DeriveTraversable  #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleInstances  #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-}+{-# OPTIONS_GHC -Wno-unused-top-binds #-}  module GHC.Cmm.Dataflow.Label     ( Label@@ -11,18 +13,76 @@     , FactBase     , lookupFact     , mkHooplLabel+    -- * Set+    , setEmpty+    , setNull+    , setSize+    , setMember+    , setSingleton+    , setInsert+    , setDelete+    , setUnion+    , setUnions+    , setDifference+    , setIntersection+    , setIsSubsetOf+    , setFilter+    , setFoldl+    , setFoldr+    , setFromList+    , setElems+    -- * Map+    , mapNull+    , mapSize+    , mapMember+    , mapLookup+    , mapFindWithDefault+    , mapEmpty+    , mapSingleton+    , mapInsert+    , mapInsertWith+    , mapDelete+    , mapAlter+    , mapAdjust+    , mapUnion+    , mapUnions+    , mapUnionWithKey+    , mapDifference+    , mapIntersection+    , mapIsSubmapOf+    , mapMap+    , mapMapWithKey+    , mapFoldl+    , mapFoldr+    , mapFoldlWithKey+    , mapFoldMapWithKey+    , mapFilter+    , mapFilterWithKey+    , mapElems+    , mapKeys+    , mapToList+    , mapFromList+    , mapFromListWith     ) where  import GHC.Prelude  import GHC.Utils.Outputable --- TODO: This should really just use GHC's Unique and Uniq{Set,FM}-import GHC.Cmm.Dataflow.Collections- import GHC.Types.Unique (Uniquable(..), mkUniqueGrimily)++-- The code generator will eventually be using all the labels stored in a+-- LabelSet and LabelMap. For these reasons we use the strict variants of these+-- data structures. We inline selectively to enable the RULES in Word64Map/Set+-- to fire.+import GHC.Data.Word64Set (Word64Set)+import qualified GHC.Data.Word64Set as S+import GHC.Data.Word64Map.Strict (Word64Map)+import qualified GHC.Data.Word64Map.Strict as M import GHC.Data.TrieMap+ import Data.Word (Word64)+import Data.List (foldl1')   -----------------------------------------------------------------------------@@ -30,7 +90,7 @@ -----------------------------------------------------------------------------  newtype Label = Label { lblToUnique :: Word64 }-  deriving (Eq, Ord)+  deriving newtype (Eq, Ord)  mkHooplLabel :: Word64 -> Label mkHooplLabel = Label@@ -50,79 +110,178 @@ ----------------------------------------------------------------------------- -- LabelSet -newtype LabelSet = LS UniqueSet deriving (Eq, Ord, Show, Monoid, Semigroup)+newtype LabelSet = LS Word64Set+  deriving newtype (Eq, Ord, Show, Monoid, Semigroup) -instance IsSet LabelSet where-  type ElemOf LabelSet = Label+setNull :: LabelSet -> Bool+setNull (LS s) = S.null s -  setNull (LS s) = setNull s-  setSize (LS s) = setSize s-  setMember (Label k) (LS s) = setMember k s+setSize :: LabelSet -> Int+setSize (LS s) = S.size s -  setEmpty = LS setEmpty-  setSingleton (Label k) = LS (setSingleton k)-  setInsert (Label k) (LS s) = LS (setInsert k s)-  setDelete (Label k) (LS s) = LS (setDelete k s)+setMember :: Label -> LabelSet -> Bool+setMember (Label k) (LS s) = S.member k s -  setUnion (LS x) (LS y) = LS (setUnion x y)-  setDifference (LS x) (LS y) = LS (setDifference x y)-  setIntersection (LS x) (LS y) = LS (setIntersection x y)-  setIsSubsetOf (LS x) (LS y) = setIsSubsetOf x y-  setFilter f (LS s) = LS (setFilter (f . mkHooplLabel) s)-  setFoldl k z (LS s) = setFoldl (\a v -> k a (mkHooplLabel v)) z s-  setFoldr k z (LS s) = setFoldr (\v a -> k (mkHooplLabel v) a) z s+setEmpty :: LabelSet+setEmpty = LS S.empty -  setElems (LS s) = map mkHooplLabel (setElems s)-  setFromList ks = LS (setFromList (map lblToUnique ks))+setSingleton :: Label -> LabelSet+setSingleton (Label k) = LS (S.singleton k) +setInsert :: Label -> LabelSet -> LabelSet+setInsert (Label k) (LS s) = LS (S.insert k s)++setDelete :: Label -> LabelSet -> LabelSet+setDelete (Label k) (LS s) = LS (S.delete k s)++setUnion :: LabelSet -> LabelSet -> LabelSet+setUnion (LS x) (LS y) = LS (S.union x y)++{-# INLINE setUnions #-}+setUnions :: [LabelSet] -> LabelSet+setUnions [] = setEmpty+setUnions sets = foldl1' setUnion sets++setDifference :: LabelSet -> LabelSet -> LabelSet+setDifference (LS x) (LS y) = LS (S.difference x y)++setIntersection :: LabelSet -> LabelSet -> LabelSet+setIntersection (LS x) (LS y) = LS (S.intersection x y)++setIsSubsetOf :: LabelSet -> LabelSet -> Bool+setIsSubsetOf (LS x) (LS y) = S.isSubsetOf x y++setFilter :: (Label -> Bool) -> LabelSet -> LabelSet+setFilter f (LS s) = LS (S.filter (f . mkHooplLabel) s)++{-# INLINE setFoldl #-}+setFoldl :: (t -> Label -> t) -> t -> LabelSet -> t+setFoldl k z (LS s) = S.foldl (\a v -> k a (mkHooplLabel v)) z s++{-# INLINE setFoldr #-}+setFoldr :: (Label -> t -> t) -> t -> LabelSet -> t+setFoldr k z (LS s) = S.foldr (\v a -> k (mkHooplLabel v) a) z s++{-# INLINE setElems #-}+setElems :: LabelSet -> [Label]+setElems (LS s) = map mkHooplLabel (S.elems s)++{-# INLINE setFromList #-}+setFromList :: [Label] -> LabelSet+setFromList ks  = LS (S.fromList (map lblToUnique ks))+ ----------------------------------------------------------------------------- -- LabelMap -newtype LabelMap v = LM (UniqueMap v)-  deriving (Eq, Ord, Show, Functor, Foldable, Traversable)+newtype LabelMap v = LM (Word64Map v)+  deriving newtype (Eq, Ord, Show, Functor, Foldable)+  deriving stock   Traversable -instance IsMap LabelMap where-  type KeyOf LabelMap = Label+mapNull :: LabelMap a -> Bool+mapNull (LM m) = M.null m -  mapNull (LM m) = mapNull m-  mapSize (LM m) = mapSize m-  mapMember (Label k) (LM m) = mapMember k m-  mapLookup (Label k) (LM m) = mapLookup k m-  mapFindWithDefault def (Label k) (LM m) = mapFindWithDefault def k m+{-# INLINE mapSize #-}+mapSize :: LabelMap a -> Int+mapSize (LM m) = M.size m -  mapEmpty = LM mapEmpty-  mapSingleton (Label k) v = LM (mapSingleton k v)-  mapInsert (Label k) v (LM m) = LM (mapInsert k v m)-  mapInsertWith f (Label k) v (LM m) = LM (mapInsertWith f k v m)-  mapDelete (Label k) (LM m) = LM (mapDelete k m)-  mapAlter f (Label k) (LM m) = LM (mapAlter f k m)-  mapAdjust f (Label k) (LM m) = LM (mapAdjust f k m)+mapMember :: Label -> LabelMap a -> Bool+mapMember (Label k) (LM m) = M.member k m -  mapUnion (LM x) (LM y) = LM (mapUnion x y)-  mapUnionWithKey f (LM x) (LM y) = LM (mapUnionWithKey (f . mkHooplLabel) x y)-  mapDifference (LM x) (LM y) = LM (mapDifference x y)-  mapIntersection (LM x) (LM y) = LM (mapIntersection x y)-  mapIsSubmapOf (LM x) (LM y) = mapIsSubmapOf x y+mapLookup :: Label -> LabelMap a -> Maybe a+mapLookup (Label k) (LM m) = M.lookup k m -  mapMap f (LM m) = LM (mapMap f m)-  mapMapWithKey f (LM m) = LM (mapMapWithKey (f . mkHooplLabel) m)-  mapFoldl k z (LM m) = mapFoldl k z m-  mapFoldr k z (LM m) = mapFoldr k z m-  mapFoldlWithKey k z (LM m) =-      mapFoldlWithKey (\a v -> k a (mkHooplLabel v)) z m-  mapFoldMapWithKey f (LM m) = mapFoldMapWithKey (\k v -> f (mkHooplLabel k) v) m-  {-# INLINEABLE mapFilter #-}-  mapFilter f (LM m) = LM (mapFilter f m)-  {-# INLINEABLE mapFilterWithKey #-}-  mapFilterWithKey f (LM m) = LM (mapFilterWithKey (f . mkHooplLabel) m)+mapFindWithDefault :: a -> Label -> LabelMap a -> a+mapFindWithDefault def (Label k) (LM m) = M.findWithDefault def k m -  mapElems (LM m) = mapElems m-  mapKeys (LM m) = map mkHooplLabel (mapKeys m)-  {-# INLINEABLE mapToList #-}-  mapToList (LM m) = [(mkHooplLabel k, v) | (k, v) <- mapToList m]-  mapFromList assocs = LM (mapFromList [(lblToUnique k, v) | (k, v) <- assocs])-  mapFromListWith f assocs = LM (mapFromListWith f [(lblToUnique k, v) | (k, v) <- assocs])+mapEmpty :: LabelMap v+mapEmpty = LM M.empty +mapSingleton :: Label -> v -> LabelMap v+mapSingleton (Label k) v = LM (M.singleton k v)++mapInsert :: Label -> v -> LabelMap v -> LabelMap v+mapInsert (Label k) v (LM m) = LM (M.insert k v m)++mapInsertWith :: (v -> v -> v) -> Label -> v -> LabelMap v -> LabelMap v+mapInsertWith f (Label k) v (LM m) = LM (M.insertWith f k v m)++mapDelete :: Label -> LabelMap v -> LabelMap v+mapDelete (Label k) (LM m) = LM (M.delete k m)++mapAlter :: (Maybe v -> Maybe v) -> Label -> LabelMap v -> LabelMap v+mapAlter f (Label k) (LM m) = LM (M.alter f k m)++mapAdjust :: (v -> v) -> Label -> LabelMap v -> LabelMap v+mapAdjust f (Label k) (LM m) = LM (M.adjust f k m)++mapUnion :: LabelMap v -> LabelMap v -> LabelMap v+mapUnion (LM x) (LM y) = LM (M.union x y)++{-# INLINE mapUnions #-}+mapUnions :: [LabelMap a] -> LabelMap a+mapUnions [] = mapEmpty+mapUnions maps = foldl1' mapUnion maps++mapUnionWithKey :: (Label -> v -> v -> v) -> LabelMap v -> LabelMap v -> LabelMap v+mapUnionWithKey f (LM x) (LM y) = LM (M.unionWithKey (f . mkHooplLabel) x y)++mapDifference :: LabelMap v -> LabelMap b -> LabelMap v+mapDifference (LM x) (LM y) = LM (M.difference x y)++mapIntersection :: LabelMap v -> LabelMap b -> LabelMap v+mapIntersection (LM x) (LM y) = LM (M.intersection x y)++mapIsSubmapOf :: Eq a => LabelMap a -> LabelMap a -> Bool+mapIsSubmapOf (LM x) (LM y) = M.isSubmapOf x y++mapMap :: (a -> v) -> LabelMap a -> LabelMap v+mapMap f (LM m) = LM (M.map f m)++mapMapWithKey :: (Label -> a -> v) -> LabelMap a -> LabelMap v+mapMapWithKey f (LM m) = LM (M.mapWithKey (f . mkHooplLabel) m)++{-# INLINE mapFoldl #-}+mapFoldl :: (a -> b -> a) -> a -> LabelMap b -> a+mapFoldl k z (LM m) = M.foldl k z m++{-# INLINE mapFoldr #-}+mapFoldr :: (a -> b -> b) -> b -> LabelMap a -> b+mapFoldr k z (LM m) = M.foldr k z m++{-# INLINE mapFoldlWithKey #-}+mapFoldlWithKey :: (t -> Label -> b -> t) -> t -> LabelMap b -> t+mapFoldlWithKey k z (LM m) = M.foldlWithKey (\a v -> k a (mkHooplLabel v)) z m++mapFoldMapWithKey :: Monoid m => (Label -> t -> m) -> LabelMap t -> m+mapFoldMapWithKey f (LM m) = M.foldMapWithKey (\k v -> f (mkHooplLabel k) v) m++{-# INLINEABLE mapFilter #-}+mapFilter :: (v -> Bool) -> LabelMap v -> LabelMap v+mapFilter f (LM m) = LM (M.filter f m)++{-# INLINEABLE mapFilterWithKey #-}+mapFilterWithKey :: (Label -> v -> Bool) -> LabelMap v -> LabelMap v+mapFilterWithKey f (LM m)  = LM (M.filterWithKey (f . mkHooplLabel) m)++{-# INLINE mapElems #-}+mapElems :: LabelMap a -> [a]+mapElems (LM m) = M.elems m++{-# INLINE mapKeys #-}+mapKeys :: LabelMap a -> [Label]+mapKeys (LM m) = map (mkHooplLabel . fst) (M.toList m)++{-# INLINE mapToList #-}+mapToList :: LabelMap b -> [(Label, b)]+mapToList (LM m) = [(mkHooplLabel k, v) | (k, v) <- M.toList m]++{-# INLINE mapFromList #-}+mapFromList :: [(Label, v)] -> LabelMap v+mapFromList assocs = LM (M.fromList [(lblToUnique k, v) | (k, v) <- assocs])++mapFromListWith :: (v -> v -> v) -> [(Label, v)] -> LabelMap v+mapFromListWith f assocs = LM (M.fromListWith f [(lblToUnique k, v) | (k, v) <- assocs])+ ----------------------------------------------------------------------------- -- Instances @@ -137,11 +296,11 @@  instance TrieMap LabelMap where   type Key LabelMap = Label-  emptyTM = mapEmpty-  lookupTM k m = mapLookup k m+  emptyTM       = mapEmpty+  lookupTM k m  = mapLookup k m   alterTM k f m = mapAlter f k m-  foldTM k m z = mapFoldr k z m-  filterTM f m = mapFilter f m+  foldTM k m z  = mapFoldr k z m+  filterTM f m  = mapFilter f m  ----------------------------------------------------------------------------- -- FactBase
compiler/GHC/Cmm/Expr.hs view
@@ -1,8 +1,4 @@-{-# LANGUAGE BangPatterns #-} {-# LANGUAGE LambdaCase #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE UndecidableInstances #-}  module GHC.Cmm.Expr@@ -510,6 +506,8 @@         CmmMachOp mop args  -> genMachOp platform mop args  genMachOp :: Platform -> MachOp -> [CmmExpr] -> SDoc+genMachOp platform (MO_RelaxedRead w) [x] =+    ppr (cmmBits w) <> text "!" <> brackets (pdoc platform x) genMachOp platform mop args    | Just doc <- infixMachOp mop = case args of         -- dyadic
compiler/GHC/Cmm/MachOp.hs view
@@ -73,7 +73,7 @@ -- -- (1) has the benefit that its interpretation is completely independent of the -- architecture. So, the mid-term plan is to migrate to this--- interpretation/sematics.+-- interpretation/semantics.  data MachOp   -- Integer operations (insensitive to signed/unsigned)@@ -182,6 +182,10 @@   | MO_VF_Mul  Length Width   | MO_VF_Quot Length Width +  -- | An atomic read with no memory ordering. Address msut+  -- be naturally aligned.+  | MO_RelaxedRead Width+   -- Alignment check (for -falignment-sanitisation)   | MO_AlignmentCheck Int Width   deriving (Eq, Show)@@ -498,6 +502,7 @@     MO_VF_Quot l w      -> cmmVec l (cmmFloat w)     MO_VF_Neg  l w      -> cmmVec l (cmmFloat w) +    MO_RelaxedRead r    -> cmmBits r     MO_AlignmentCheck _ _ -> ty1   where     (ty1:_) = tys@@ -592,6 +597,7 @@     MO_VF_Quot _ r      -> [r,r]     MO_VF_Neg  _ r      -> [r] +    MO_RelaxedRead _    -> [wordWidth platform]     MO_AlignmentCheck _ r -> [r]  -----------------------------------------------------------------------------@@ -690,8 +696,6 @@   | MO_SubIntC   Width   | MO_U_Mul2    Width -  | MO_ReadBarrier-  | MO_WriteBarrier   | MO_Touch         -- Keep variables live (when using interior pointers)    -- Prefetch@@ -720,6 +724,10 @@    | MO_BSwap Width   | MO_BRev Width++  | MO_AcquireFence+  | MO_ReleaseFence+  | MO_SeqCstFence    -- | Atomic read-modify-write. Arguments are @[dest, n]@.   | MO_AtomicRMW Width AtomicMachOp
compiler/GHC/Cmm/Node.hs view
@@ -1,11 +1,5 @@-{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE LambdaCase #-} @@ -41,7 +35,6 @@ import GHC.Platform import GHC.Cmm.Dataflow.Block import GHC.Cmm.Dataflow.Graph-import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Label import Data.Foldable (toList) import Data.Functor.Classes (liftCompare)
compiler/GHC/CmmToLlvm/Config.hs view
@@ -1,34 +1,20 @@-{-# LANGUAGE CPP #-}- -- | Llvm code generator configuration module GHC.CmmToLlvm.Config   ( LlvmCgConfig(..)   , LlvmConfig(..)   , LlvmTarget(..)   , initLlvmConfig-  -- * LLVM version-  , LlvmVersion(..)-  , supportedLlvmVersionLowerBound-  , supportedLlvmVersionUpperBound-  , parseLlvmVersion-  , llvmVersionSupported-  , llvmVersionStr-  , llvmVersionList   ) where -#include "ghc-llvm-version.h"- import GHC.Prelude import GHC.Platform  import GHC.Utils.Outputable import GHC.Settings.Utils import GHC.Utils.Panic+import GHC.CmmToLlvm.Version.Type (LlvmVersion) -import Data.Char (isDigit)-import Data.List (intercalate)-import qualified Data.List.NonEmpty as NE import System.FilePath  data LlvmCgConfig = LlvmCgConfig@@ -36,6 +22,7 @@   , llvmCgContext           :: !SDocContext  -- ^ Context for LLVM code generation   , llvmCgFillUndefWithGarbage :: !Bool      -- ^ Fill undefined literals with garbage values   , llvmCgSplitSection      :: !Bool         -- ^ Split sections+  , llvmCgAvxEnabled        :: !Bool   , llvmCgBmiVersion        :: Maybe BmiVersion  -- ^ (x86) BMI instructions   , llvmCgLlvmVersion       :: Maybe LlvmVersion -- ^ version of Llvm we're using   , llvmCgDoWarn            :: !Bool         -- ^ True ==> warn unsupported Llvm version@@ -93,43 +80,3 @@   { llvmTargets :: [(String, LlvmTarget)]   , llvmPasses  :: [(Int, String)]   }--------------------------------------------------------------- LLVM version------------------------------------------------------------newtype LlvmVersion = LlvmVersion { llvmVersionNE :: NE.NonEmpty Int }-  deriving (Eq, Ord)--parseLlvmVersion :: String -> Maybe LlvmVersion-parseLlvmVersion =-    fmap LlvmVersion . NE.nonEmpty . go [] . dropWhile (not . isDigit)-  where-    go vs s-      | null ver_str-      = reverse vs-      | '.' : rest' <- rest-      = go (read ver_str : vs) rest'-      | otherwise-      = reverse (read ver_str : vs)-      where-        (ver_str, rest) = span isDigit s---- | The (inclusive) lower bound on the LLVM Version that is currently supported.-supportedLlvmVersionLowerBound :: LlvmVersion-supportedLlvmVersionLowerBound = LlvmVersion (sUPPORTED_LLVM_VERSION_MIN NE.:| [])---- | The (not-inclusive) upper bound  bound on the LLVM Version that is currently supported.-supportedLlvmVersionUpperBound :: LlvmVersion-supportedLlvmVersionUpperBound = LlvmVersion (sUPPORTED_LLVM_VERSION_MAX NE.:| [])--llvmVersionSupported :: LlvmVersion -> Bool-llvmVersionSupported v =-  v >= supportedLlvmVersionLowerBound && v < supportedLlvmVersionUpperBound--llvmVersionStr :: LlvmVersion -> String-llvmVersionStr = intercalate "." . map show . llvmVersionList--llvmVersionList :: LlvmVersion -> [Int]-llvmVersionList = NE.toList . llvmVersionNE
+ compiler/GHC/CmmToLlvm/Version/Type.hs view
@@ -0,0 +1,11 @@+module GHC.CmmToLlvm.Version.Type+  ( LlvmVersion(..)+  )+where++import GHC.Prelude++import qualified Data.List.NonEmpty as NE++newtype LlvmVersion = LlvmVersion { llvmVersionNE :: NE.NonEmpty Int }+  deriving (Eq, Ord)
compiler/GHC/Core.hs view
@@ -3,9 +3,7 @@ (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -} -{-# LANGUAGE DeriveDataTypeable, FlexibleContexts #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE NoPolyKinds #-}  -- | GHC.Core holds all the main data types for use by for the Glasgow Haskell Compiler midsection module GHC.Core (@@ -27,7 +25,7 @@         mkIntLit, mkIntLitWrap,         mkWordLit, mkWordLitWrap,         mkWord8Lit,-        mkWord64LitWord64, mkInt64LitInt64,+        mkWord32LitWord32, mkWord64LitWord64, mkInt64LitInt64,         mkCharLit, mkStringLit,         mkFloatLit, mkFloatLitFloat,         mkDoubleLit, mkDoubleLitDouble,@@ -35,6 +33,8 @@         mkConApp, mkConApp2, mkTyBind, mkCoBind,         varToCoreExpr, varsToCoreExprs, +        mkBinds,+         isId, cmpAltCon, cmpAlt, ltAlt,          -- ** Simple 'Expr' access functions and predicates@@ -112,7 +112,6 @@ import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Utils.Panic.Plain  import Data.Data hiding (TyCon) import Data.Int@@ -312,6 +311,17 @@             | Rec [(b, (Expr b))]   deriving Data +-- | Helper function. You can use the result of 'mkBinds' with 'mkLets' for+-- instance.+--+--   * @'mkBinds' 'Recursive' binds@ makes a single mutually-recursive+--     bindings with all the rhs/lhs pairs in @binds@+--   * @'mkBinds' 'NonRecursive' binds@ makes one non-recursive binding+--     for each rhs/lhs pairs in @binds@+mkBinds :: RecFlag -> [(b, (Expr b))] -> [Bind b]+mkBinds Recursive binds = [Rec binds]+mkBinds NonRecursive binds = map (uncurry NonRec) binds+ {- Note [Literal alternatives] ~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -404,7 +414,7 @@       (This binding looks recursive, but isn't; it defines a top-level, curried       function whose body just allocates and returns the data constructor.) -      But if (a) the data contructor is nullary and (b) the data type is unlifted,+      But if (a) the data constructor is nullary and (b) the data type is unlifted,       this binding is unlifted.       e.g.   data S :: UnliftedType where { S1 :: S, S2 :: S -> S }       we generate@@ -440,9 +450,6 @@  The let-can-float invariant is initially enforced by mkCoreLet in GHC.Core.Make. -For discussion of some implications of the let-can-float invariant primops see-Note [Checking versus non-checking primops] in GHC.Builtin.PrimOps.- Historical Note [The let/app invariant] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Before 2022 GHC used the "let/app invariant", which applied the let-can-float rules@@ -464,7 +471,7 @@ Note [Core top-level string literals] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ As an exception to the usual rule that top-level binders must be lifted,-we allow binding primitive string literals (of type Addr#) of type Addr# at the+we allow binding primitive string literals (of type Addr#) at the top level. This allows us to share string literals earlier in the pipeline and crucially allows other optimizations in the Core2Core pipeline to fire. Consider,@@ -642,7 +649,7 @@ GHC allows us to abstract over calling conventions using **representation polymorphism**. For example, we have: -  ($) :: forall (r :: RuntimeRep) (a :: Type) (b :: TYPE r). a -> b -> b+  ($) :: forall (r :: RuntimeRep) (a :: Type) (b :: TYPE r). (a -> b) -> a -> b  In this example, the type `b` is representation-polymorphic: it has kind `TYPE r`, where the type variable `r :: RuntimeRep` abstracts over the runtime representation@@ -657,13 +664,6 @@       (except for join points: See Note [Invariants on join points])   I2. The type of a function argument must have a fixed runtime representation. -On top of these two invariants, GHC's internal eta-expansion mechanism also requires:--  I3. In any partial application `f e_1 .. e_n`, where `f` is `hasNoBinding`,-      it must be the case that the application can be eta-expanded to match-      the arity of `f`.-      See Note [checkCanEtaExpand] in GHC.Core.Lint for more details.- Example of I1:    \(r::RuntimeRep). \(a::TYPE r). \(x::a). e@@ -678,26 +678,26 @@     This contravenes I2: we are applying the function `f` to a value     with an unknown runtime representation. -Examples of I3:+Note that these two invariants require us to check other types than just the+types of bound variables and types of function arguments, due to transformations+that GHC performs. For example, the definition -  myUnsafeCoerce# :: forall {r1} (a :: TYPE r1) {r2} (b :: TYPE r2). a -> b-  myUnsafeCoerce# = unsafeCoerce#+  myCoerce :: forall {r} (a :: TYPE r) (b :: TYPE r). Coercible a b => a -> b+  myCoerce = coerce -    This contravenes I3: we are instantiating `unsafeCoerce#` without any-    value arguments, and with a remaining argument type, `a`, which does not-    have a fixed runtime representation.-    But `unsafeCorce#` has no binding (see Note [Wiring in unsafeCoerce#]-    in GHC.HsToCore).  So before code-generation we must saturate it-    by eta-expansion (see GHC.CoreToStg.Prep.maybeSaturate), thus-       myUnsafeCoerce# = \x. unsafeCoerce# x-    But we can't do that because now the \x binding would violate I1.+is invalid, because `coerce` has no binding (see GHC.Types.Id.Make.coerceId).+So, before code-generation, GHC saturates the RHS of 'myCoerce' by performing+an eta-expansion (see GHC.CoreToStg.Prep.maybeSaturate): -  bar :: forall (a :: TYPE) r (b :: TYPE r). a -> b-  bar = unsafeCoerce#+  myCoerce = \ (x :: TYPE r) -> coerce x -    OK: eta expand to `\ (x :: Type) -> unsafeCoerce# x`,-    and `x` has a fixed RuntimeRep.+However, this transformation would be invalid, because now the binding of x+in the lambda abstraction would violate I1. +See Note [Representation-polymorphism checking built-ins] in GHC.Tc.Gen.Head+and Note [Linting representation-polymorphic builtins] in GHC.Core.Lint for+more details.+ Note that we currently require something slightly stronger than a fixed runtime representation: we check whether bound variables and function arguments have a /fixed RuntimeRep/ in the sense of Note [Fixed RuntimeRep] in GHC.Tc.Utils.Concrete.@@ -748,10 +748,14 @@   its scrutinee is (see GHC.Core.Utils.exprIsTrivial).  This is actually   important; see Note [Empty case is trivial] in GHC.Core.Utils -* An empty case is replaced by its scrutinee during the CoreToStg-  conversion; remember STG is un-typed, so there is no need for-  the empty case to do the type conversion.+* We lower empty cases in GHC.CoreToStg.coreToStgExpr to an eval on the+  scrutinee. +Historical Note: We used to lower EmptyCase in CorePrep by way of an+unsafeCoercion on the scrutinee, but that yielded panics in CodeGen when+we were beginning to eta expand in arguments, plus required to mess with+heterogenously-kinded coercions. It's simpler to stick to it just a bit longer.+ Note [Join points] ~~~~~~~~~~~~~~~~~~ In Core, a *join point* is a specially tagged function whose only occurrences@@ -1896,6 +1900,9 @@  mkWord8Lit :: Integer -> Expr b mkWord8Lit    w = Lit (mkLitWord8 w)++mkWord32LitWord32 :: Word32 -> Expr b+mkWord32LitWord32 w = Lit (mkLitWord32 (toInteger w))  mkWord64LitWord64 :: Word64 -> Expr b mkWord64LitWord64 w = Lit (mkLitWord64 (toInteger w))
compiler/GHC/Core.hs-boot view
@@ -1,3 +1,4 @@+{-# LANGUAGE NoPolyKinds #-} module GHC.Core where import {-# SOURCE #-} GHC.Types.Var
compiler/GHC/Core/Class.hs view
@@ -32,7 +32,6 @@ import GHC.Types.Unique import GHC.Utils.Misc import GHC.Utils.Panic-import GHC.Utils.Panic.Plain import GHC.Types.SrcLoc import GHC.Types.Var.Set import GHC.Utils.Outputable
compiler/GHC/Core/Coercion.hs view
@@ -41,7 +41,7 @@         mkInstCo, mkAppCo, mkAppCos, mkTyConAppCo,         mkFunCo, mkFunCo2, mkFunCoNoFTF, mkFunResCo,         mkNakedFunCo,-        mkForAllCo, mkForAllCos, mkHomoForAllCos,+        mkNakedForAllCo, mkForAllCo, mkHomoForAllCos,         mkPhantomCo,         mkHoleCo, mkUnivCo, mkSubCo,         mkAxiomInstCo, mkProofIrrelCo,@@ -74,7 +74,7 @@         mkCoherenceRightMCo,          coToMCo, mkTransMCo, mkTransMCoL, mkTransMCoR, mkCastTyMCo, mkSymMCo,-        mkHomoForAllMCo, mkFunResMCo, mkPiMCos,+        mkFunResMCo, mkPiMCos,         isReflMCo, checkReflexiveMCo,          -- ** Coercion variables@@ -95,10 +95,10 @@         -- ** Lifting         liftCoSubst, liftCoSubstTyVar, liftCoSubstWith, liftCoSubstWithEx,         emptyLiftingContext, extendLiftingContext, extendLiftingContextAndInScope,-        liftCoSubstVarBndrUsing, isMappedByLC,+        liftCoSubstVarBndrUsing, isMappedByLC, extendLiftingContextCvSubst,          mkSubstLiftingContext, zapLiftingContext,-        substForAllCoBndrUsingLC, lcSubst, lcInScopeSet,+        substForAllCoBndrUsingLC, lcLookupCoVar, lcInScopeSet,          LiftCoEnv, LiftingContext(..), liftEnvSubstLeft, liftEnvSubstRight,         substRightCo, substLeftCo, swapLiftCoEnv, lcSubstLeft, lcSubstRight,@@ -138,7 +138,7 @@ import GHC.Core.TyCo.Ppr import GHC.Core.TyCo.Subst import GHC.Core.TyCo.Tidy-import GHC.Core.TyCo.Compare( eqType, eqTypeX )+import GHC.Core.TyCo.Compare import GHC.Core.Type import GHC.Core.TyCon import GHC.Core.TyCon.RecWalk@@ -163,12 +163,12 @@ import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Utils.Panic.Plain  import Control.Monad (foldM, zipWithM) import Data.Function ( on ) import Data.Char( isDigit ) import qualified Data.Monoid as Monoid+import Control.DeepSeq  {- %************************************************************************@@ -361,10 +361,6 @@ mkCastTyMCo ty MRefl    = ty mkCastTyMCo ty (MCo co) = ty `mkCastTy` co -mkHomoForAllMCo :: TyCoVar -> MCoercion -> MCoercion-mkHomoForAllMCo _   MRefl    = MRefl-mkHomoForAllMCo tcv (MCo co) = MCo (mkHomoForAllCos [tcv] co)- mkPiMCos :: [Var] -> MCoercion -> MCoercion mkPiMCos _ MRefl = MRefl mkPiMCos vs (MCo co) = MCo (mkPiCos Representational vs co)@@ -555,22 +551,29 @@ splitFunCo_maybe (FunCo { fco_arg = arg, fco_res = res }) = Just (arg, res) splitFunCo_maybe _ = Nothing -splitForAllCo_maybe :: Coercion -> Maybe (TyCoVar, Coercion, Coercion)-splitForAllCo_maybe (ForAllCo tv k_co co) = Just (tv, k_co, co)-splitForAllCo_maybe _                     = Nothing+splitForAllCo_maybe :: Coercion -> Maybe (TyCoVar, ForAllTyFlag, ForAllTyFlag, Coercion, Coercion)+splitForAllCo_maybe (ForAllCo { fco_tcv = tv, fco_visL = vL, fco_visR = vR+                              , fco_kind = k_co, fco_body = co })+  = Just (tv, vL, vR, k_co, co)+splitForAllCo_maybe _ = Nothing  -- | Like 'splitForAllCo_maybe', but only returns Just for tyvar binder-splitForAllCo_ty_maybe :: Coercion -> Maybe (TyVar, Coercion, Coercion)-splitForAllCo_ty_maybe (ForAllCo tv k_co co)-  | isTyVar tv = Just (tv, k_co, co)+splitForAllCo_ty_maybe :: Coercion -> Maybe (TyVar, ForAllTyFlag, ForAllTyFlag, Coercion, Coercion)+splitForAllCo_ty_maybe co+  | Just stuff@(tv, _, _, _, _) <- splitForAllCo_maybe co+  , isTyVar tv+  = Just stuff splitForAllCo_ty_maybe _ = Nothing  -- | Like 'splitForAllCo_maybe', but only returns Just for covar binder-splitForAllCo_co_maybe :: Coercion -> Maybe (CoVar, Coercion, Coercion)-splitForAllCo_co_maybe (ForAllCo cv k_co co)-  | isCoVar cv = Just (cv, k_co, co)+splitForAllCo_co_maybe :: Coercion -> Maybe (CoVar, ForAllTyFlag, ForAllTyFlag, Coercion, Coercion)+splitForAllCo_co_maybe co+  | Just stuff@(cv, _, _, _, _) <- splitForAllCo_maybe co+  , isCoVar cv+  = Just stuff splitForAllCo_co_maybe _ = Nothing + ------------------------------------------------------- -- and some coercion kind stuff @@ -919,101 +922,86 @@          -> Coercion mkAppCos co1 cos = foldl' mkAppCo co1 cos -{- Note [Unused coercion variable in ForAllCo]-   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-See Note [Unused coercion variable in ForAllTy] in GHC.Core.TyCo.Rep for the-motivation for checking coercion variable in types.-To lift the design choice to (ForAllCo cv kind_co body_co), we have two options: -(1) In mkForAllCo, we check whether cv is a coercion variable-    and whether it is not used in body_co. If so we construct a FunCo.-(2) We don't do this check in mkForAllCo.-    In coercionKind, we use mkTyCoForAllTy to perform the check and construct-    a FunTy when necessary.--We chose (2) for two reasons:+-- | Make a Coercion from a tycovar, a kind coercion, and a body coercion.+mkForAllCo :: HasDebugCallStack => TyCoVar -> ForAllTyFlag -> ForAllTyFlag -> CoercionN -> Coercion -> Coercion+mkForAllCo v visL visR kind_co co+  | Just (ty, r) <- isReflCo_maybe co+  , isReflCo kind_co+  , visL `eqForAllVis` visR+  = mkReflCo r (mkTyCoForAllTy v visL ty) -* for a coercion, all that matters is its kind, So ForAllCo or FunCo does not-  make a difference.-* even if cv occurs in body_co, it is possible that cv does not occur in the kind-  of body_co. Therefore the check in coercionKind is inevitable.+  | otherwise+  = mkForAllCo_NoRefl v visL visR kind_co co -The last wrinkle is that there are restrictions around the use of the cv in the-coercion, as described in Section 5.8.5.2 of Richard's thesis. The idea is that-we cannot prove that the type system is consistent with unrestricted use of this-cv; the consistency proof uses an untyped rewrite relation that works over types-with all coercions and casts removed. So, we can allow the cv to appear only in-positions that are erased. As an approximation of this (and keeping close to the-published theory), we currently allow the cv only within the type in a Refl node-and under a GRefl node (including in the Coercion stored in a GRefl). It's-possible other places are OK, too, but this is a safe approximation.+-- | Make a Coercion quantified over a type/coercion variable;+-- the variable has the same kind and visibility in both sides of the coercion+mkHomoForAllCos :: [ForAllTyBinder] -> Coercion -> Coercion+mkHomoForAllCos vs orig_co+  | Just (ty, r) <- isReflCo_maybe orig_co+  = mkReflCo r (mkTyCoForAllTys vs ty)+  | otherwise+  = foldr go orig_co vs+  where+    go (Bndr var vis) co+      = mkForAllCo_NoRefl var vis vis (mkNomReflCo (varType var)) co -Sadly, with heterogeneous equality, this restriction might be able to be violated;-Richard's thesis is unable to prove that it isn't. Specifically, the liftCoSubst-function might create an invalid coercion. Because a violation of the-restriction might lead to a program that "goes wrong", it is checked all the time,-even in a production compiler and without -dcore-lint. We *have* proved that the-problem does not occur with homogeneous equality, so this check can be dropped-once ~# is made to be homogeneous.--}+-- | Like 'mkForAllCo', but there is no need to check that the inner coercion isn't Refl;+--   the caller has done that. (For example, it is guaranteed in 'mkHomoForAllCos'.)+-- The kind of the tycovar should be the left-hand kind of the kind coercion.+mkForAllCo_NoRefl :: TyCoVar -> ForAllTyFlag -> ForAllTyFlag -> CoercionN -> Coercion -> Coercion+mkForAllCo_NoRefl tcv visL visR kind_co co+  = assertGoodForAllCo tcv visL visR kind_co co $+    assertPpr (not (isReflCo co && isReflCo kind_co && visL == visR)) (ppr co) $+    ForAllCo { fco_tcv = tcv, fco_visL = visL, fco_visR = visR+             , fco_kind = kind_co, fco_body = co } +assertGoodForAllCo :: HasDebugCallStack+                   =>  TyCoVar -> ForAllTyFlag -> ForAllTyFlag+                   -> CoercionN -> Coercion -> a -> a+-- Check ForAllCo invariants; see Note [ForAllCo] in GHC.Core.TyCo.Rep+assertGoodForAllCo tcv visL visR kind_co co+  | isTyVar tcv+  = assertPpr (tcv_type `eqType` kind_co_lkind) doc --- | Make a Coercion from a tycovar, a kind coercion, and a body coercion.--- The kind of the tycovar should be the left-hand kind of the kind coercion.--- See Note [Unused coercion variable in ForAllCo]-mkForAllCo :: TyCoVar -> CoercionN -> Coercion -> Coercion-mkForAllCo v kind_co co-  | assert (varType v `eqType` (coercionLKind kind_co)) True-  , assert (isTyVar v || almostDevoidCoVarOfCo v co) True-  , Just (ty, r) <- isReflCo_maybe co-  , isGReflCo kind_co-  = mkReflCo r (mkTyCoInvForAllTy v ty)   | otherwise-  = ForAllCo v kind_co co+  = assertPpr (tcv_type `eqType` kind_co_lkind) doc+        -- The kind of the tycovar should be the left-hand kind of the kind coercion.+  . assertPpr (almostDevoidCoVarOfCo tcv co) doc+        -- See (FC6) in Note [ForAllCo] in GHC.Core.TyCo.Rep+  . assertPpr (visL == coreTyLamForAllTyFlag+            && visR == coreTyLamForAllTyFlag) doc+        -- See (FC7) in Note [ForAllCo] in GHC.Core.TyCo.Rep+  where+    tcv_type      = varType tcv+    kind_co_lkind = coercionLKind kind_co --- | Like 'mkForAllCo', but the inner coercion shouldn't be an obvious--- reflexive coercion. For example, it is guaranteed in 'mkForAllCos'.--- The kind of the tycovar should be the left-hand kind of the kind coercion.-mkForAllCo_NoRefl :: TyCoVar -> CoercionN -> Coercion -> Coercion-mkForAllCo_NoRefl v kind_co co-  | assert (varType v `eqType` (coercionLKind kind_co)) True-  , assert (not (isReflCo co)) True-  , isCoVar v-  , assert (almostDevoidCoVarOfCo v co) True-  , not (v `elemVarSet` tyCoVarsOfCo co)-  = mkFunCoNoFTF (coercionRole co) (multToCo ManyTy) kind_co co-      -- Functions from coercions are always unrestricted-  | otherwise-  = ForAllCo v kind_co co+    doc = vcat [ text "Var:" <+> ppr tcv <+> dcolon <+> ppr tcv_type+               , text "Vis:" <+> ppr visL <+> ppr visR+               , text "kind_co:" <+> ppr kind_co+               , text "kind_co_lkind" <+> ppr kind_co_lkind+               , text "body_co" <+> ppr co ] --- | Make nested ForAllCos-mkForAllCos :: [(TyCoVar, CoercionN)] -> Coercion -> Coercion-mkForAllCos bndrs co-  | Just (ty, r ) <- isReflCo_maybe co-  = let (refls_rev'd, non_refls_rev'd) = span (isReflCo . snd) (reverse bndrs) in-    foldl' (flip $ uncurry mkForAllCo_NoRefl)-           (mkReflCo r (mkTyCoInvForAllTys (reverse (map fst refls_rev'd)) ty))-           non_refls_rev'd-  | otherwise-  = foldr (uncurry mkForAllCo_NoRefl) co bndrs --- | Make a Coercion quantified over a type/coercion variable;--- the variable has the same type in both sides of the coercion-mkHomoForAllCos :: [TyCoVar] -> Coercion -> Coercion-mkHomoForAllCos vs co-  | Just (ty, r) <- isReflCo_maybe co-  = mkReflCo r (mkTyCoInvForAllTys vs ty)+mkNakedForAllCo :: TyVar    -- Never a CoVar+                -> ForAllTyFlag -> ForAllTyFlag+                -> CoercionN -> Coercion -> Coercion+-- This version lacks the assertion checks.+-- Used during type checking when the arguments may (legitimately) not be zonked+-- and so the assertions might (bogusly) fail+-- NB: since the coercions are un-zonked, we can't really deal with+--     (FC6) and (FC7) in Note [ForAllCo] in GHC.Core.TyCo.Rep.+--     Fortunately we don't have to: this function is needed only for /type/ variables.+mkNakedForAllCo tv visL visR kind_co co+  | assertPpr (isTyVar tv) (ppr tv) True+  , Just (ty, r) <- isReflCo_maybe co+  , isReflCo kind_co+  , visL `eqForAllVis` visR+  = mkReflCo r (mkForAllTy (Bndr tv visL) ty)   | otherwise-  = mkHomoForAllCos_NoRefl vs co+  = ForAllCo { fco_tcv = tv, fco_visL = visL, fco_visR = visR+             , fco_kind = kind_co, fco_body = co } --- | Like 'mkHomoForAllCos', but the inner coercion shouldn't be an obvious--- reflexive coercion. For example, it is guaranteed in 'mkHomoForAllCos'.-mkHomoForAllCos_NoRefl :: [TyCoVar] -> Coercion -> Coercion-mkHomoForAllCos_NoRefl vs orig_co-  = assert (not (isReflCo orig_co))-    foldr go orig_co vs-  where-    go v co = mkForAllCo_NoRefl v (mkNomReflCo (varType v)) co  mkCoVarCo :: CoVar -> Coercion -- cv :: s ~# t@@ -1167,7 +1155,7 @@         -- be equal to _co_role, the role of co, per Note [SelCo].         -- This was revealed by #23938. -    go SelForAll (ForAllCo _ kind_co _)+    go SelForAll (ForAllCo { fco_kind = kind_co })       = Just kind_co       -- If co :: (forall a1:k1. t1) ~ (forall a2:k2. t2)       -- then (nth SelForAll co :: k1 ~N k2)@@ -1235,7 +1223,7 @@  -- | Instantiates a 'Coercion'. mkInstCo :: Coercion -> CoercionN -> Coercion-mkInstCo (ForAllCo tcv _kind_co body_co) co+mkInstCo (ForAllCo { fco_tcv = tcv, fco_body = body_co }) co   | Just (arg, _) <- isReflCo_maybe co       -- works for both tyvar and covar   = substCoUnchecked (zipTCvSubst [tcv] [arg]) body_co@@ -1387,8 +1375,10 @@       = TransCo <$> setNominalRole_maybe_helper co1 <*> setNominalRole_maybe_helper co2     setNominalRole_maybe_helper (AppCo co1 co2)       = AppCo <$> setNominalRole_maybe_helper co1 <*> pure co2-    setNominalRole_maybe_helper (ForAllCo tv kind_co co)-      = ForAllCo tv kind_co <$> setNominalRole_maybe_helper co+    setNominalRole_maybe_helper co@(ForAllCo { fco_visL = visL, fco_visR = visR, fco_body = body_co })+      | visL `eqForAllVis` visR -- See (FC3) in Note [ForAllCo] in GHC.Core.TyCo.Rep+      = do { body_co' <- setNominalRole_maybe_helper body_co+           ; return (co { fco_body = body_co' }) }     setNominalRole_maybe_helper (SelCo cs co) =       -- NB, this case recurses via setNominalRole_maybe, not       -- setNominalRole_maybe_helper!@@ -1408,7 +1398,6 @@       | case prov of PhantomProv _    -> False  -- should always be phantom                      ProofIrrelProv _ -> True   -- it's always safe                      PluginProv _     -> False  -- who knows? This choice is conservative.-                     CorePrepProv _   -> True       = Just $ UnivCo prov Nominal co1 co2     setNominalRole_maybe_helper _ = Nothing @@ -1478,7 +1467,7 @@  -- | like mkKindCo, but aggressively & recursively optimizes to avoid using -- a KindCo constructor. The output role is nominal.-promoteCoercion :: Coercion -> CoercionN+promoteCoercion :: HasDebugCallStack => Coercion -> CoercionN  -- First cases handles anything that should yield refl. promoteCoercion co = case co of@@ -1508,7 +1497,7 @@       | otherwise       -> mkKindCo co -    ForAllCo tv _ g+    ForAllCo { fco_tcv = tv, fco_body = g }       | isTyVar tv       -> promoteCoercion g @@ -1519,7 +1508,7 @@             -- a coercion variable. So both sides have kind Type             -- (Note [Weird typing rule for ForAllTy] in GHC.Core.TyCo.Rep).             -- So the result is Refl, and that should have been caught by-            -- the first equation above+            -- the first equation above.  Hence `assert False`          mkNomReflCo liftedTypeKind      FunCo {} -> mkKindCo co@@ -1534,7 +1523,6 @@     UnivCo (PhantomProv kco)    _ _ _ -> kco     UnivCo (ProofIrrelProv kco) _ _ _ -> kco     UnivCo (PluginProv _)       _ _ _ -> mkKindCo co-    UnivCo (CorePrepProv _)     _ _ _ -> mkKindCo co      SymCo g       -> mkSymCo (promoteCoercion g)@@ -1663,7 +1651,7 @@ -- | Make a forall 'Coercion', where both types related by the coercion -- are quantified over the same variable. mkPiCo  :: Role -> Var -> Coercion -> Coercion-mkPiCo r v co | isTyVar v = mkHomoForAllCos [v] co+mkPiCo r v co | isTyVar v = mkHomoForAllCos [Bndr v coreTyLamForAllTyFlag] co               | isCoVar v = assert (not (v `elemVarSet` tyCoVarsOfCo co)) $                   -- We didn't call mkForAllCo here because if v does not appear                   -- in co, the argument coercion will be nominal. But here we@@ -2003,6 +1991,15 @@   | otherwise   = LC subst (extendVarEnv env tv arg) +-- | Extend the substitution component of a lifting context with+-- a new binding for a coercion variable. Used during coercion optimisation.+extendLiftingContextCvSubst :: LiftingContext+                            -> CoVar+                            -> Coercion+                            -> LiftingContext+extendLiftingContextCvSubst (LC subst env) cv co+  = LC (extendCvSubst subst cv co) env+ -- | Extend a lifting context with a new mapping, and extend the in-scope set extendLiftingContextAndInScope :: LiftingContext  -- ^ Original LC                                -> TyCoVar         -- ^ new variable to map...@@ -2087,17 +2084,17 @@     go r (AppTy ty1 ty2)    = mkAppCo (go r ty1) (go Nominal ty2)     go r (TyConApp tc tys)  = mkTyConAppCo r tc (zipWith go (tyConRoleListX r tc) tys)     go r (FunTy af w t1 t2) = mkFunCo r af (go Nominal w) (go r t1) (go r t2)-    go r t@(ForAllTy (Bndr v _) ty)+    go r t@(ForAllTy (Bndr v vis) ty)        = let (lc', v', h) = liftCoSubstVarBndr lc v              body_co = ty_co_subst lc' r ty in          if isTyVar v' || almostDevoidCoVarOfCo v' body_co            -- Lifting a ForAllTy over a coercion variable could fail as ForAllCo-           -- imposes an extra restriction on where a covar can appear. See last-           -- wrinkle in Note [Unused coercion variable in ForAllCo].-           -- We specifically check for this and panic because we know that-           -- there's a hole in the type system here, and we'd rather panic than-           -- fall into it.-         then mkForAllCo v' h body_co+           -- imposes an extra restriction on where a covar can appear. See+           -- (FC6) of Note [ForAllCo] in GHC.Tc.TyCo.Rep+            -- We specifically check for this and panic because we know that+           -- there's a hole in the type system here (see (FC6), and we'd rather+           -- panic than fall into it.+         then mkForAllCo v' vis vis h body_co          else pprPanic "ty_co_subst: covar is not almost devoid" (ppr t)     go r ty@(LitTy {})     = assert (r == Nominal) $                              mkNomReflCo ty@@ -2310,9 +2307,9 @@       where         equality_ty = selector (coercionKind co) --- | Extract the underlying substitution from the LiftingContext-lcSubst :: LiftingContext -> Subst-lcSubst (LC subst _) = subst+-- | Lookup a 'CoVar' in the substitution in a 'LiftingContext'+lcLookupCoVar :: LiftingContext -> CoVar -> Maybe Coercion+lcLookupCoVar (LC subst _) cv = lookupCoVar subst cv  -- | Get the 'InScopeSet' from a 'LiftingContext' lcInScopeSet :: LiftingContext -> InScopeSet@@ -2335,8 +2332,9 @@ seqCo (GRefl r ty mco)          = r `seq` seqType ty `seq` seqMCo mco seqCo (TyConAppCo r tc cos)     = r `seq` tc `seq` seqCos cos seqCo (AppCo co1 co2)           = seqCo co1 `seq` seqCo co2-seqCo (ForAllCo tv k co)        = seqType (varType tv) `seq` seqCo k-                                                       `seq` seqCo co+seqCo (ForAllCo tv visL visR k co) = seqType (varType tv) `seq`+                                      rnf visL `seq` rnf visR `seq`+                                      seqCo k `seq` seqCo co seqCo (FunCo r af1 af2 w co1 co2) = r `seq` af1 `seq` af2 `seq`                                     seqCo w `seq` seqCo co1 `seq` seqCo co2 seqCo (CoVarCo cv)              = cv `seq` ()@@ -2357,7 +2355,6 @@ seqProv (PhantomProv co)    = seqCo co seqProv (ProofIrrelProv co) = seqCo co seqProv (PluginProv _)      = ()-seqProv (CorePrepProv _)    = ()  seqCos :: [Coercion] -> () seqCos []       = ()@@ -2401,7 +2398,8 @@     go (GRefl _ ty _)            = ty     go (TyConAppCo _ tc cos)     = mkTyConApp tc (map go cos)     go (AppCo co1 co2)           = mkAppTy (go co1) (go co2)-    go (ForAllCo tv1 _ co1)      = mkTyCoInvForAllTy tv1 (go co1)+    go (ForAllCo { fco_tcv = tv1, fco_visL = visL, fco_body = co1 })+                                 = mkTyCoForAllTy tv1 visL (go co1)     go (FunCo { fco_afl = af, fco_mult = mult, fco_arg = arg, fco_res = res})        {- See Note [FunCo] -}    = FunTy { ft_af = af, ft_mult = go mult                                          , ft_arg = go arg, ft_res = go res }@@ -2480,8 +2478,9 @@     go (AxiomRuleCo ax cos)      = pSnd $ expectJust "coercionKind" $                                    coaxrProves ax $ map coercionKind cos -    go co@(ForAllCo tv1 k_co co1) -- works for both tyvar and covar-       | isGReflCo k_co           = mkTyCoInvForAllTy tv1 (go co1)+    go co@(ForAllCo { fco_tcv = tv1, fco_visR = visR+                    , fco_kind = k_co, fco_body = co1 }) -- works for both tyvar and covar+       | isGReflCo k_co           = mkTyCoForAllTy tv1 visR (go co1)          -- kind_co always has kind @Type@, thus @isGReflCo@        | otherwise                = go_forall empty_subst co        where@@ -2504,10 +2503,11 @@     go_app (InstCo co arg) args = go_app co (go arg:args)     go_app co              args = piResultTys (go co) args -    go_forall subst (ForAllCo tv1 k_co co)+    go_forall subst (ForAllCo { fco_tcv = tv1, fco_visR = visR+                              , fco_kind = k_co, fco_body = co })       -- See Note [Nested ForAllCos]       | isTyVar tv1-      = mkInfForAllTy tv2 (go_forall subst' co)+      = mkForAllTy (Bndr tv2 visR) (go_forall subst' co)       where         k2  = coercionRKind k_co         tv2 = setTyVarKind tv1 (substTy subst k2)@@ -2516,9 +2516,10 @@                | otherwise      = extendTvSubst (extendSubstInScope subst tv2) tv1 $                                   TyVarTy tv2 `mkCastTy` mkSymCo k_co -    go_forall subst (ForAllCo cv1 k_co co)+    go_forall subst (ForAllCo { fco_tcv = cv1, fco_visR = visR+                              , fco_kind = k_co, fco_body = co })       | isCoVar cv1-      = mkTyCoInvForAllTy cv2 (go_forall subst' co)+      = mkTyCoForAllTy cv2 visR (go_forall subst' co)       where         k2    = coercionRKind k_co         r     = coVarRole cv1@@ -2566,26 +2567,26 @@ coercionRole :: Coercion -> Role coercionRole = go   where-    go (Refl _) = Nominal-    go (GRefl r _ _) = r-    go (TyConAppCo r _ _) = r-    go (AppCo co1 _) = go co1-    go (ForAllCo _ _ co) = go co-    go (FunCo { fco_role = r }) = r-    go (CoVarCo cv) = coVarRole cv-    go (HoleCo h)   = coVarRole (coHoleCoVar h)-    go (AxiomInstCo ax _ _) = coAxiomRole ax-    go (UnivCo _ r _ _)  = r-    go (SymCo co) = go co-    go (TransCo co1 _co2) = go co1-    go (SelCo SelForAll      _co) = Nominal-    go (SelCo (SelTyCon _ r) _co) = r-    go (SelCo (SelFun fs)     co) = funRole (coercionRole co) fs-    go (LRCo {}) = Nominal-    go (InstCo co _) = go co-    go (KindCo {}) = Nominal-    go (SubCo _) = Representational-    go (AxiomRuleCo ax _) = coaxrRole ax+    go (Refl _)                     = Nominal+    go (GRefl r _ _)                = r+    go (TyConAppCo r _ _)           = r+    go (AppCo co1 _)                = go co1+    go (ForAllCo { fco_body = co }) = go co+    go (FunCo { fco_role = r })     = r+    go (CoVarCo cv)                 = coVarRole cv+    go (HoleCo h)                   = coVarRole (coHoleCoVar h)+    go (AxiomInstCo ax _ _)         = coAxiomRole ax+    go (UnivCo _ r _ _)             = r+    go (SymCo co)                   = go co+    go (TransCo co1 _co2)           = go co1+    go (SelCo SelForAll      _co)   = Nominal+    go (SelCo (SelTyCon _ r) _co)   = r+    go (SelCo (SelFun fs)     co)   = funRole (coercionRole co) fs+    go (LRCo {})                    = Nominal+    go (InstCo co _)                = go co+    go (KindCo {})                  = Nominal+    go (SubCo _)                    = Representational+    go (AxiomRuleCo ax _)           = coaxrRole ax  {- Note [Nested InstCos]@@ -2690,19 +2691,19 @@       | Just (ty1a, ty1b) <- splitAppTyNoView_maybe ty1       = mkAppCo (go ty1a ty2a) (go ty1b ty2b) -    go (ForAllTy (Bndr tv1 _flag1) ty1) (ForAllTy (Bndr tv2 _flag2) ty2)+    go (ForAllTy (Bndr tv1 flag1) ty1) (ForAllTy (Bndr tv2 flag2) ty2)       | isTyVar tv1       = assert (isTyVar tv2) $-        mkForAllCo tv1 kind_co (go ty1 ty2')+        mkForAllCo tv1 flag1 flag2 kind_co (go ty1 ty2')       where kind_co  = go (tyVarKind tv1) (tyVarKind tv2)             in_scope = mkInScopeSet $ tyCoVarsOfType ty2 `unionVarSet` tyCoVarsOfCo kind_co             ty2'     = substTyWithInScope in_scope [tv2]                          [mkTyVarTy tv1 `mkCastTy` kind_co]                          ty2 -    go (ForAllTy (Bndr cv1 _flag1) ty1) (ForAllTy (Bndr cv2 _flag2) ty2)+    go (ForAllTy (Bndr cv1 flag1) ty1) (ForAllTy (Bndr cv2 flag2) ty2)       = assert (isCoVar cv1 && isCoVar cv2) $-        mkForAllCo cv1 kind_co (go ty1 ty2')+        mkForAllCo cv1 flag1 flag2 kind_co (go ty1 ty2')       where s1 = varType cv1             s2 = varType cv2             kind_co = go s1 s2
compiler/GHC/Core/Coercion.hs-boot view
@@ -16,7 +16,7 @@ mkReflCo :: Role -> Type -> Coercion mkTyConAppCo :: HasDebugCallStack => Role -> TyCon -> [Coercion] -> Coercion mkAppCo :: Coercion -> Coercion -> Coercion-mkForAllCo :: TyCoVar -> Coercion -> Coercion -> Coercion+mkForAllCo :: HasDebugCallStack => TyCoVar -> ForAllTyFlag -> ForAllTyFlag -> Coercion -> Coercion -> Coercion mkFunCo      :: Role -> FunTyFlag -> CoercionN -> Coercion -> Coercion -> Coercion mkNakedFunCo :: Role -> FunTyFlag -> CoercionN -> Coercion -> Coercion -> Coercion mkFunCo2     :: Role -> FunTyFlag -> FunTyFlag -> CoercionN -> Coercion -> Coercion -> Coercion
compiler/GHC/Core/Coercion/Axiom.hs view
@@ -49,7 +49,6 @@ import GHC.Utils.Misc import GHC.Utils.Binary import GHC.Utils.Panic-import GHC.Utils.Panic.Plain import GHC.Data.Pair import GHC.Types.Basic import Data.Typeable ( Typeable )
compiler/GHC/Core/Coercion/Opt.hs view
@@ -14,13 +14,14 @@  import GHC.Core.TyCo.Rep import GHC.Core.TyCo.Subst-import GHC.Core.TyCo.Compare( eqType )+import GHC.Core.TyCo.Compare( eqType, eqForAllVis ) import GHC.Core.Coercion import GHC.Core.Type as Type hiding( substTyVarBndr, substTy ) import GHC.Core.TyCon import GHC.Core.Coercion.Axiom import GHC.Core.Unify +import GHC.Types.Var import GHC.Types.Var.Set import GHC.Types.Var.Env import GHC.Types.Unique.Set@@ -32,7 +33,6 @@ import GHC.Utils.Constants (debugIsOn) import GHC.Utils.Misc import GHC.Utils.Panic-import GHC.Utils.Panic.Plain  import Control.Monad   ( zipWithM ) @@ -289,11 +289,14 @@   = mkAppCo (opt_co4_wrap env sym rep r co1)             (opt_co4_wrap env sym False Nominal co2) -opt_co4 env sym rep r (ForAllCo tv k_co co)+opt_co4 env sym rep r (ForAllCo { fco_tcv = tv, fco_visL = visL, fco_visR = visR+                                , fco_kind = k_co, fco_body = co })   = case optForAllCoBndr env sym tv k_co of-      (env', tv', k_co') -> mkForAllCo tv' k_co' $+      (env', tv', k_co') -> mkForAllCo tv' visL' visR' k_co' $                             opt_co4_wrap env' sym rep r co      -- Use the "mk" functions to check for nested Refls+  where+    !(visL', visR') = swapSym sym (visL, visR)  opt_co4 env sym rep r (FunCo _r afl afr cow co1 co2)   = assert (r == _r) $@@ -304,18 +307,18 @@     cow' = opt_co1 env sym cow     !r' | rep       = Representational         | otherwise = r-    !(afl', afr') | sym       = (afr,afl)-                  | otherwise = (afl,afr)+    !(afl', afr') = swapSym sym (afl, afr)  opt_co4 env sym rep r (CoVarCo cv)-  | Just co <- lookupCoVar (lcSubst env) cv+  | Just co <- lcLookupCoVar env cv   -- see Note [Forall over coercion] for why+                                      -- this is the right thing here   = opt_co4_wrap (zapLiftingContext env) sym rep r co    | ty1 `eqType` ty2   -- See Note [Optimise CoVarCo to Refl]   = mkReflCo (chooseRole rep r) ty1    | otherwise-  = assert (isCoVar cv1 )+  = assert (isCoVar cv1) $     wrapRole rep r $ wrapSym sym $     CoVarCo cv1 @@ -375,7 +378,7 @@ opt_co4 env sym rep r (SelCo (SelFun fs) (FunCo _r2 _afl _afr w co1 co2))   = opt_co4_wrap env sym rep r (getNthFun fs w co1 co2) -opt_co4 env sym rep _ (SelCo SelForAll (ForAllCo _ eta _))+opt_co4 env sym rep _ (SelCo SelForAll (ForAllCo { fco_kind = eta }))       -- works for both tyvar and covar   = opt_co4_wrap env sym rep Nominal eta @@ -383,7 +386,7 @@   | Just nth_co <- case (co', n) of       (TyConAppCo _ _ cos, SelTyCon n _) -> Just (cos `getNth` n)       (FunCo _ _ _ w co1 co2, SelFun fs) -> Just (getNthFun fs w co1 co2)-      (ForAllCo _ eta _, SelForAll)      -> Just eta+      (ForAllCo { fco_kind = eta }, SelForAll) -> Just eta       _                  -> Nothing   = if rep && (r == Nominal)       -- keep propagating the SubCo@@ -412,10 +415,44 @@     pick_lr CLeft  (l, _) = l     pick_lr CRight (_, r) = r +{-+Note [Forall over coercion]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Example:+  type (:~:) :: forall k. k -> k -> Type+  Refl :: forall k (a :: k) (b :: k). forall (cv :: (~#) k k a b). (:~:) k a b+  k1,k2,k3,k4 :: Type+  eta :: (k1 ~# k2) ~# (k3 ~# k4)    ==    ((~#) Type Type k1 k2) ~# ((~#) Type Type k3 k4)+  co1_3 :: k1 ~# k3+  co2_4 :: k2 ~# k4+  nth 2 eta :: k1 ~# k3+  nth 3 eta :: k2 ~# k4+  co11_31 :: <k1> ~# (sym co1_3)+  co22_24 :: <k2> ~# co2_4+  (forall (cv :: eta). Refl <Type> co1_3 co2_4 (co11_31 ;; cv ;; co22_24)) ::+    (forall (cv :: k1 ~# k2). Refl Type k1 k2 (<k1> ;; cv ;; <k2>) ~#+    (forall (cv :: k3 ~# k4). Refl Type k3 k4+       (sym co1_3 ;; nth 2 eta ;; cv ;; sym (nth 3 eta) ;; co2_4))+  co1_2 :: k1 ~# k2+  co3_4 :: k3 ~# k4+  co5 :: co1_2 ~# co3_4+  InstCo (forall (cv :: eta). Refl <Type> co1_3 co2_4 (co11_31 ;; cv ;; co22_24)) co5 ::+   (Refl Type k1 k2 (<k1> ;; cv ;; <k2>))[cv |-> co1_2] ~#+   (Refl Type k3 k4 (sym co1_3 ;; nth 2 eta ;; cv ;; sym (nth 3 eta) ;; co2_4))[cv |-> co3_4]+      ==+   (Refl Type k1 k2 (<k1> ;; co1_2 ;; <k2>)) ~#+    (Refl Type k3 k4 (sym co1_3 ;; nth 2 eta ;; co3_4 ;; sym (nth 3 eta) ;; co2_4))+      ==>+   Refl <Type> co1_3 co2_4 (co11_31 ;; co1_2 ;; co22_24)+Conclusion: Because of the way this all works, we want to put in the *left-hand*+coercion in co5's type. (In the code, co5 is called `arg`.)+So we extend the environment binding cv to arg's left-hand type.+-}+ -- See Note [Optimising InstCo] opt_co4 env sym rep r (InstCo co1 arg)     -- forall over type...-  | Just (tv, kind_co, co_body) <- splitForAllCo_ty_maybe co1+  | Just (tv, _visL, _visR, kind_co, co_body) <- splitForAllCo_ty_maybe co1   = opt_co4_wrap (extendLiftingContext env tv                     (mkCoherenceRightCo Nominal t2 (mkSymCo kind_co) sym_arg))                    -- mkSymCo kind_co :: k1 ~ k2@@ -423,28 +460,24 @@                    -- tv |-> (t1 :: k1) ~ (((t2 :: k2) |> (sym kind_co)) :: k1)                  sym rep r co_body -    -- forall over coercion...-  | Just (cv, kind_co, co_body) <- splitForAllCo_co_maybe co1+    -- See Note [Forall over coercion]+  | Just (cv, _visL, _visR, _kind_co, co_body) <- splitForAllCo_co_maybe co1   , CoercionTy h1 <- t1-  , CoercionTy h2 <- t2-  = let new_co = mk_new_co cv (opt_co4_wrap env sym False Nominal kind_co) h1 h2-    in opt_co4_wrap (extendLiftingContext env cv new_co) sym rep r co_body+  = opt_co4_wrap (extendLiftingContextCvSubst env cv h1) sym rep r co_body      -- See if it is a forall after optimization     -- If so, do an inefficient one-variable substitution, then re-optimize      -- forall over type...-  | Just (tv', kind_co', co_body') <- splitForAllCo_ty_maybe co1'+  | Just (tv', _visL, _visR, kind_co', co_body') <- splitForAllCo_ty_maybe co1'   = opt_co4_wrap (extendLiftingContext (zapLiftingContext env) tv'                     (mkCoherenceRightCo Nominal t2' (mkSymCo kind_co') arg'))             False False r' co_body' -    -- forall over coercion...-  | Just (cv', kind_co', co_body') <- splitForAllCo_co_maybe co1'+    -- See Note [Forall over coercion]+  | Just (cv', _visL, _visR, _kind_co', co_body') <- splitForAllCo_co_maybe co1'   , CoercionTy h1' <- t1'-  , CoercionTy h2' <- t2'-  = let new_co = mk_new_co cv' kind_co' h1' h2'-    in opt_co4_wrap (extendLiftingContext (zapLiftingContext env) cv' new_co)+  = opt_co4_wrap (extendLiftingContextCvSubst (zapLiftingContext env) cv' h1')                     False False r' co_body'    | otherwise = InstCo co1' arg'@@ -465,20 +498,6 @@     Pair t1  t2  = coercionKind sym_arg     Pair t1' t2' = coercionKind arg' -    mk_new_co cv kind_co h1 h2-      = let -- h1 :: (t1 ~ t2)-            -- h2 :: (t3 ~ t4)-            -- kind_co :: (t1 ~ t2) ~ (t3 ~ t4)-            -- n1 :: t1 ~ t3-            -- n2 :: t2 ~ t4-            -- new_co = (h1 :: t1 ~ t2) ~ ((n1;h2;sym n2) :: t1 ~ t2)-            r2  = coVarRole cv-            kind_co' = downgradeRole r2 Nominal kind_co-            n1 = mkSelCo (SelTyCon 2 r2) kind_co'-            n2 = mkSelCo (SelTyCon 3 r2) kind_co'-         in mkProofIrrelCo Nominal (Refl (coercionType h1)) h1-                           (n1 `mkTransCo` h2 `mkTransCo` (mkSymCo n2))- opt_co4 env sym _rep r (KindCo co)   = assert (r == Nominal) $     let kco' = promoteCoercion co in@@ -525,8 +544,8 @@    Any :: forall k. k -  Any * Int                      :: *-  Any (*->*) Maybe Int  :: *+  Any @Type Int                :: Type+  Any @(Type->Type) Maybe Int  :: Type  Hence the need to compare argument lengths; see #13658 @@ -574,8 +593,10 @@    -- can't optimize the AppTy case because we can't build the kind coercions. -  | Just (tv1, ty1) <- splitForAllTyVar_maybe oty1-  , Just (tv2, ty2) <- splitForAllTyVar_maybe oty2+  | Just (Bndr tv1 vis1, ty1) <- splitForAllForAllTyBinder_maybe oty1+  , isTyVar tv1+  , Just (Bndr tv2 vis2, ty2) <- splitForAllForAllTyBinder_maybe oty2+  , isTyVar tv2       -- NB: prov isn't interesting here either   = let k1   = tyVarKind tv1         k2   = tyVarKind tv2@@ -584,11 +605,14 @@         ty2' = substTyWith [tv2] [TyVarTy tv1 `mkCastTy` eta] ty2          (env', tv1', eta') = optForAllCoBndr env sym tv1 eta+        !(vis1', vis2') = swapSym sym (vis1, vis2)     in-    mkForAllCo tv1' eta' (opt_univ env' sym prov' role ty1 ty2')+    mkForAllCo tv1' vis1' vis2' eta' (opt_univ env' sym prov' role ty1 ty2') -  | Just (cv1, ty1) <- splitForAllCoVar_maybe oty1-  , Just (cv2, ty2) <- splitForAllCoVar_maybe oty2+  | Just (Bndr cv1 vis1, ty1) <- splitForAllForAllTyBinder_maybe oty1+  , isCoVar cv1+  , Just (Bndr cv2 vis2, ty2) <- splitForAllForAllTyBinder_maybe oty2+  , isCoVar cv2       -- NB: prov isn't interesting here either   = let k1    = varType cv1         k2    = varType cv2@@ -602,8 +626,9 @@         ty2'  = substTyWithCoVars [cv2] [n_co] ty2          (env', cv1', eta') = optForAllCoBndr env sym cv1 eta+        !(vis1', vis2') = swapSym sym (vis1, vis2)     in-    mkForAllCo cv1' eta' (opt_univ env' sym prov' role ty1 ty2')+    mkForAllCo cv1' vis1' vis2' eta' (opt_univ env' sym prov' role ty1 ty2')    | otherwise   = let ty1 = substTyUnchecked (lcSubstLeft  env) oty1@@ -615,13 +640,8 @@    where     prov' = case prov of-#if __GLASGOW_HASKELL__ < 901--- This alt is redundant with the first match of the FunDef-      PhantomProv kco    -> PhantomProv $ opt_co4_wrap env sym False Nominal kco-#endif       ProofIrrelProv kco -> ProofIrrelProv $ opt_co4_wrap env sym False Nominal kco       PluginProv _       -> prov-      CorePrepProv _     -> prov  ------------- opt_transList :: HasDebugCallStack => InScopeSet -> [NormalCo] -> [NormalCo] -> [NormalCo]@@ -747,23 +767,23 @@ -- Push transitivity inside forall -- forall over types. opt_trans_rule is co1 co2-  | Just (tv1, eta1, r1) <- splitForAllCo_ty_maybe co1-  , Just (tv2, eta2, r2) <- etaForAllCo_ty_maybe co2-  = push_trans tv1 eta1 r1 tv2 eta2 r2+  | Just (tv1, visL1, _visR1, eta1, r1) <- splitForAllCo_ty_maybe co1+  , Just (tv2, _visL2, visR2, eta2, r2) <- etaForAllCo_ty_maybe co2+  = push_trans tv1 eta1 r1 tv2 eta2 r2 visL1 visR2 -  | Just (tv2, eta2, r2) <- splitForAllCo_ty_maybe co2-  , Just (tv1, eta1, r1) <- etaForAllCo_ty_maybe co1-  = push_trans tv1 eta1 r1 tv2 eta2 r2+  | Just (tv2, _visL2, visR2, eta2, r2) <- splitForAllCo_ty_maybe co2+  , Just (tv1, visL1, _visR1, eta1, r1) <- etaForAllCo_ty_maybe co1+  = push_trans tv1 eta1 r1 tv2 eta2 r2 visL1 visR2    where-  push_trans tv1 eta1 r1 tv2 eta2 r2+  push_trans tv1 eta1 r1 tv2 eta2 r2 visL visR     -- Given:-    --   co1 = /\ tv1 : eta1. r1-    --   co2 = /\ tv2 : eta2. r2+    --   co1 = /\ tv1 : eta1 <visL, visM>. r1+    --   co2 = /\ tv2 : eta2 <visM, visR>. r2     -- Wanted:-    --   /\tv1 : (eta1;eta2).  (r1; r2[tv2 |-> tv1 |> eta1])+    --   /\tv1 : (eta1;eta2) <visL, visR>.  (r1; r2[tv2 |-> tv1 |> eta1])     = fireTransRule "EtaAllTy_ty" co1 co2 $-      mkForAllCo tv1 (opt_trans is eta1 eta2) (opt_trans is' r1 r2')+      mkForAllCo tv1 visL visR (opt_trans is eta1 eta2) (opt_trans is' r1 r2')     where       is' = is `extendInScopeSet` tv1       r2' = substCoWithUnchecked [tv2] [mkCastTy (TyVarTy tv1) eta1] r2@@ -771,25 +791,25 @@ -- Push transitivity inside forall -- forall over coercions. opt_trans_rule is co1 co2-  | Just (cv1, eta1, r1) <- splitForAllCo_co_maybe co1-  , Just (cv2, eta2, r2) <- etaForAllCo_co_maybe co2-  = push_trans cv1 eta1 r1 cv2 eta2 r2+  | Just (cv1, visL1, _visR1, eta1, r1) <- splitForAllCo_co_maybe co1+  , Just (cv2, _visL2, visR2, eta2, r2) <- etaForAllCo_co_maybe co2+  = push_trans cv1 eta1 r1 cv2 eta2 r2 visL1 visR2 -  | Just (cv2, eta2, r2) <- splitForAllCo_co_maybe co2-  , Just (cv1, eta1, r1) <- etaForAllCo_co_maybe co1-  = push_trans cv1 eta1 r1 cv2 eta2 r2+  | Just (cv2, _visL2, visR2, eta2, r2) <- splitForAllCo_co_maybe co2+  , Just (cv1, visL1, _visR1, eta1, r1) <- etaForAllCo_co_maybe co1+  = push_trans cv1 eta1 r1 cv2 eta2 r2 visL1 visR2    where-  push_trans cv1 eta1 r1 cv2 eta2 r2+  push_trans cv1 eta1 r1 cv2 eta2 r2 visL visR     -- Given:-    --   co1 = /\ cv1 : eta1. r1-    --   co2 = /\ cv2 : eta2. r2+    --   co1 = /\ (cv1 : eta1) <visL, visM>. r1+    --   co2 = /\ (cv2 : eta2) <visM, visR>. r2     -- Wanted:     --   n1 = nth 2 eta1     --   n2 = nth 3 eta1     --   nco = /\ cv1 : (eta1;eta2). (r1; r2[cv2 |-> (sym n1);cv1;n2])     = fireTransRule "EtaAllTy_co" co1 co2 $-      mkForAllCo cv1 (opt_trans is eta1 eta2) (opt_trans is' r1 r2')+      mkForAllCo cv1 visL visR (opt_trans is eta1 eta2) (opt_trans is' r1 r2')     where       is'  = is `extendInScopeSet` cv1       role = coVarRole cv1@@ -1087,6 +1107,10 @@ -}  -----------+swapSym :: SymFlag -> (a,a) -> (a,a)+swapSym sym (x,y) | sym       = (y,x)+                  | otherwise = (x,y)+ wrapSym :: SymFlag -> Coercion -> Coercion wrapSym sym co | sym       = mkSymCo co                | otherwise = co@@ -1186,31 +1210,39 @@   eta2 = mkSelCo (SelTyCon 3 r) h1 :: (s2 ~ s4)   h2   = mkInstCo g (cv1 ~ (sym eta1;c1;eta2)) -}-etaForAllCo_ty_maybe :: Coercion -> Maybe (TyVar, Coercion, Coercion)+etaForAllCo_ty_maybe :: Coercion -> Maybe (TyVar, ForAllTyFlag, ForAllTyFlag, Coercion, Coercion) -- Try to make the coercion be of form (forall tv:kind_co. co) etaForAllCo_ty_maybe co-  | Just (tv, kind_co, r) <- splitForAllCo_ty_maybe co-  = Just (tv, kind_co, r)+  | Just (tv, visL, visR, kind_co, r) <- splitForAllCo_ty_maybe co+  = Just (tv, visL, visR, kind_co, r) -  | Pair ty1 ty2  <- coercionKind co-  , Just (tv1, _) <- splitForAllTyVar_maybe ty1-  , isForAllTy_ty ty2+  | (Pair ty1 ty2, role)  <- coercionKindRole co+  , Just (Bndr tv1 vis1, _) <- splitForAllForAllTyBinder_maybe ty1+  , isTyVar tv1+  , Just (Bndr tv2 vis2, _) <- splitForAllForAllTyBinder_maybe ty2+  , isTyVar tv2+  -- can't eta-expand at nominal role unless visibilities match+  , (role /= Nominal) || (vis1 `eqForAllVis` vis2)   , let kind_co = mkSelCo SelForAll co-  = Just ( tv1, kind_co+  = Just ( tv1, vis1, vis2, kind_co          , mkInstCo co (mkGReflRightCo Nominal (TyVarTy tv1) kind_co))    | otherwise   = Nothing -etaForAllCo_co_maybe :: Coercion -> Maybe (CoVar, Coercion, Coercion)+etaForAllCo_co_maybe :: Coercion -> Maybe (CoVar, ForAllTyFlag, ForAllTyFlag, Coercion, Coercion) -- Try to make the coercion be of form (forall cv:kind_co. co) etaForAllCo_co_maybe co-  | Just (cv, kind_co, r) <- splitForAllCo_co_maybe co-  = Just (cv, kind_co, r)+  | Just (cv, visL, visR, kind_co, r) <- splitForAllCo_co_maybe co+  = Just (cv, visL, visR, kind_co, r) -  | Pair ty1 ty2  <- coercionKind co-  , Just (cv1, _) <- splitForAllCoVar_maybe ty1-  , isForAllTy_co ty2+  | (Pair ty1 ty2, role)  <- coercionKindRole co+  , Just (Bndr cv1 vis1, _) <- splitForAllForAllTyBinder_maybe ty1+  , isCoVar cv1+  , Just (Bndr cv2 vis2, _) <- splitForAllForAllTyBinder_maybe ty2+  , isCoVar cv2+  -- can't eta-expand at nominal role unless visibilities match+  , (role /= Nominal)   = let kind_co  = mkSelCo SelForAll co         r        = coVarRole cv1         l_co     = mkCoVarCo cv1@@ -1218,7 +1250,7 @@         r_co     = mkSymCo (mkSelCo (SelTyCon 2 r) kind_co')                    `mkTransCo` l_co                    `mkTransCo` mkSelCo (SelTyCon 3 r) kind_co'-    in Just ( cv1, kind_co+    in Just ( cv1, vis1, vis2, kind_co             , mkInstCo co (mkProofIrrelCo Nominal kind_co l_co r_co))    | otherwise
compiler/GHC/Core/ConLike.hs view
@@ -47,6 +47,7 @@  import Data.Maybe( isJust ) import qualified Data.Data as Data+import qualified Data.List as List  {- ************************************************************************@@ -224,8 +225,10 @@   -- | The ConLikes that have *all* the given fields-conLikesWithFields :: [ConLike] -> [FieldLabelString] -> [ConLike]-conLikesWithFields con_likes lbls = filter has_flds con_likes+conLikesWithFields :: [ConLike] -> [FieldLabelString]+                   -> ( [ConLike]   -- ConLikes containing the fields+                      , [ConLike] ) -- ConLikes not containing the fields+conLikesWithFields con_likes lbls = List.partition has_flds con_likes   where has_flds dc = all (has_fld dc) lbls         has_fld dc lbl = any (\ fl -> flLabel fl == lbl) (conLikeFieldLabels dc)
compiler/GHC/Core/DataCon.hs view
@@ -35,6 +35,7 @@         dataConNonlinearType,         dataConDisplayType,         dataConUnivTyVars, dataConExTyCoVars, dataConUnivAndExTyCoVars,+        dataConConcreteTyVars,         dataConUserTyVars, dataConUserTyVarBinders,         dataConTheta,         dataConStupidTheta,@@ -69,6 +70,7 @@ import GHC.Prelude  import Language.Haskell.Syntax.Basic+import Language.Haskell.Syntax.Module.Name  import {-# SOURCE #-} GHC.Types.Id.Make ( DataConBoxer ) import GHC.Core.Type as Type@@ -96,10 +98,11 @@ import GHC.Builtin.Uniques( mkAlphaTyVarUnique ) import GHC.Data.Graph.UnVar  -- UnVarSet and operations +import {-# SOURCE #-} GHC.Tc.Utils.TcType ( ConcreteTyVars )+ import GHC.Utils.Outputable import GHC.Utils.Misc import GHC.Utils.Panic-import GHC.Utils.Panic.Plain  import Data.ByteString (ByteString) import qualified Data.ByteString.Builder as BSB@@ -108,8 +111,6 @@ import Data.Char import Data.List( find ) -import Language.Haskell.Syntax.Module.Name- {- Note [Data constructor representation] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -450,6 +451,14 @@         -- INVARIANT: the UnivTyVars and ExTyCoVars all have distinct OccNames         -- Reason: less confusing, and easier to generate Iface syntax +        -- The type variables of this data constructor that must be+        -- instantiated to concrete types. For example: the RuntimeRep+        -- variables of unboxed tuples and unboxed sums.+        --+        -- See Note [Representation-polymorphism checking built-ins]+        -- in GHC.Tc.Gen.Head.+        dcConcreteTyVars :: ConcreteTyVars,+         -- The type/coercion vars in the order the user wrote them [c,y,x,b]         -- INVARIANT(dataConTyVars): the set of tyvars in dcUserTyVarBinders is         --    exactly the set of tyvars (*not* covars) of dcExTyCoVars unioned@@ -562,12 +571,10 @@   {- Note [TyVarBinders in DataCons]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-For the TyVarBinders in a DataCon and PatSyn:-- * Each argument flag is Inferred or Specified.-   None are Required. (A DataCon is a term-level function; see-   Note [No Required PiTyBinder in terms] in GHC.Core.TyCo.Rep.)+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For the TyVarBinders in a DataCon and PatSyn,+each argument flag is either Inferred or Specified, never Required.+Lifting this restriction is tracked at #18389 (DataCon) and #23704 (PatSyn).  Why do we need the TyVarBinders, rather than just the TyVars?  So that we can construct the right type for the DataCon with its foralls@@ -1135,6 +1142,9 @@                             -- if it is a record, otherwise empty           -> [TyVar]        -- ^ Universals.           -> [TyCoVar]      -- ^ Existentials.+          -> ConcreteTyVars+                                -- ^ TyVars which must be instantiated with+                                -- concrete types           -> [InvisTVBinder]    -- ^ User-written 'TyVarBinder's.                                 --   These must be Inferred/Specified.                                 --   See @Note [TyVarBinders in DataCons]@@@ -1155,7 +1165,7 @@ mkDataCon name declared_infix prom_info           arg_stricts   -- Must match orig_arg_tys 1-1           fields-          univ_tvs ex_tvs user_tvbs+          univ_tvs ex_tvs conc_tvs user_tvbs           eq_spec theta           orig_arg_tys orig_res_ty rep_info rep_tycon tag           stupid_theta work_id rep@@ -1175,6 +1185,7 @@                   dcVanilla = is_vanilla, dcInfix = declared_infix,                   dcUnivTyVars = univ_tvs,                   dcExTyCoVars = ex_tvs,+                  dcConcreteTyVars = conc_tvs,                   dcUserTyVarBinders = user_tvbs,                   dcEqSpec = eq_spec,                   dcOtherTheta = theta,@@ -1292,6 +1303,15 @@ dataConUnivAndExTyCoVars :: DataCon -> [TyCoVar] dataConUnivAndExTyCoVars (MkData { dcUnivTyVars = univ_tvs, dcExTyCoVars = ex_tvs })   = univ_tvs ++ ex_tvs++-- | Which type variables of this data constructor that must be+-- instantiated to concrete types?+-- For example: the RuntimeRep variables of unboxed tuples and unboxed sums.+--+-- See Note [Representation-polymorphism checking built-ins]+-- in GHC.Tc.Gen.Head.+dataConConcreteTyVars :: DataCon -> ConcreteTyVars+dataConConcreteTyVars (MkData { dcConcreteTyVars = concs }) = concs  -- See Note [DataCon user type variable binders] -- | The type variables of the constructor, in the order the user wrote them
compiler/GHC/Core/FVs.hs view
@@ -288,7 +288,7 @@ exprs_fvs exprs = mapUnionFV expr_fvs exprs  tickish_fvs :: CoreTickish -> FV-tickish_fvs (Breakpoint _ _ ids) = FV.mkFVs ids+tickish_fvs (Breakpoint _ _ ids _) = FV.mkFVs ids tickish_fvs _ = emptyFV  {-@@ -386,8 +386,9 @@ orphNamesOfCo (GRefl _ ty mco)      = orphNamesOfType ty `unionNameSet` orphNamesOfMCo mco orphNamesOfCo (TyConAppCo _ tc cos) = unitNameSet (getName tc) `unionNameSet` orphNamesOfCos cos orphNamesOfCo (AppCo co1 co2)       = orphNamesOfCo co1 `unionNameSet` orphNamesOfCo co2-orphNamesOfCo (ForAllCo _ kind_co co)     = orphNamesOfCo kind_co-                                            `unionNameSet` orphNamesOfCo co+orphNamesOfCo (ForAllCo { fco_kind = kind_co, fco_body = co })+                                    = orphNamesOfCo kind_co+                                      `unionNameSet` orphNamesOfCo co orphNamesOfCo (FunCo { fco_mult = co_mult, fco_arg = co1, fco_res = co2 })                                     = orphNamesOfCo co_mult                                       `unionNameSet` orphNamesOfCo co1@@ -410,7 +411,6 @@ orphNamesOfProv (PhantomProv co)    = orphNamesOfCo co orphNamesOfProv (ProofIrrelProv co) = orphNamesOfCo co orphNamesOfProv (PluginProv _)      = emptyNameSet-orphNamesOfProv (CorePrepProv _)    = emptyNameSet  orphNamesOfCos :: [Coercion] -> NameSet orphNamesOfCos = orphNamesOfThings orphNamesOfCo@@ -793,9 +793,8 @@         , AnnTick tickish expr2 )       where         expr2 = go expr-        tickishFVs (Breakpoint _ _ ids) = mkDVarSet ids-        tickishFVs _                    = emptyDVarSet+        tickishFVs (Breakpoint _ _ ids _) = mkDVarSet ids+        tickishFVs _                      = emptyDVarSet      go (Type ty)     = (tyCoVarsOfTypeDSet ty, AnnType ty)     go (Coercion co) = (tyCoVarsOfCoDSet co, AnnCoercion co)-
compiler/GHC/Core/FamInstEnv.hs view
@@ -63,7 +63,6 @@ import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Utils.Panic.Plain  import GHC.Types.Name.Set import GHC.Data.Bag@@ -370,7 +369,7 @@  - For finding overlaps and conflicts   - For finding the representation type...see FamInstEnv.topNormaliseType-   and its call site in GHC.Core.Opt.Simplify+   and its call site in GHC.Core.Opt.Simplify.Iteration   - In standalone deriving instance Eq (T [Int]) we need to find the    representation type for T [Int]
compiler/GHC/Core/InstEnv.hs view
@@ -13,8 +13,8 @@         DFunId, InstMatch, ClsInstLookupResult,         Canonical, PotentialUnifiers(..), getPotentialUnifiers, nullUnifiers,         OverlapFlag(..), OverlapMode(..), setOverlapModeMaybe,-        ClsInst(..), DFunInstType, pprInstance, pprInstanceHdr, pprInstances,-        instanceHead, instanceSig, mkLocalClsInst, mkImportedClsInst,+        ClsInst(..), DFunInstType, pprInstance, pprInstanceHdr, pprDFunId, pprInstances,+        instanceWarning, instanceHead, instanceSig, mkLocalClsInst, mkImportedClsInst,         instanceDFunId, updateClsInstDFuns, updateClsInstDFun,         fuzzyClsInstCmp, orphNamesOfClsInst, @@ -42,8 +42,10 @@ import GHC.Core.Class import GHC.Core.Unify import GHC.Core.FVs( orphNamesOfTypes, orphNamesOfType )+import GHC.Hs.Extension  import GHC.Unit.Module.Env+import GHC.Unit.Module.Warnings import GHC.Unit.Types import GHC.Types.Var import GHC.Types.Unique.DSet@@ -60,7 +62,6 @@  import GHC.Utils.Outputable hiding ((<>)) import GHC.Utils.Panic-import GHC.Utils.Panic.Plain import Data.Semigroup  {-@@ -108,6 +109,10 @@              , is_flag :: OverlapFlag   -- See detailed comments with                                         -- the decl of BasicTypes.OverlapFlag              , is_orphan :: IsOrphan+             , is_warn :: Maybe (WarningTxt GhcRn)+                -- Warning emitted when the instance is used+                -- See Note [Implementation of deprecated instances]+                -- in GHC.Tc.Solver.Dict     }   deriving Data @@ -218,6 +223,16 @@ instance Outputable ClsInst where    ppr = pprInstance +pprDFunId :: DFunId -> SDoc+-- Prints the analogous information to `pprInstance`+-- but with just the DFunId+pprDFunId dfun+  = hang dfun_header+       2 (vcat [ text "--" <+> pprDefinedAt (getName dfun)+               , whenPprDebug (ppr dfun) ])+  where+    dfun_header = ppr_overlap_dfun_hdr empty dfun+ pprInstance :: ClsInst -> SDoc -- Prints the ClsInst as an instance declaration pprInstance ispec@@ -229,11 +244,18 @@ pprInstanceHdr :: ClsInst -> SDoc -- Prints the ClsInst as an instance declaration pprInstanceHdr (ClsInst { is_flag = flag, is_dfun = dfun })-  = text "instance" <+> ppr flag <+> pprSigmaType (idType dfun)+  = ppr_overlap_dfun_hdr (ppr flag) dfun +ppr_overlap_dfun_hdr :: SDoc -> DFunId -> SDoc+ppr_overlap_dfun_hdr flag_sdoc dfun+  = text "instance" <+> flag_sdoc <+> pprSigmaType (idType dfun)+ pprInstances :: [ClsInst] -> SDoc pprInstances ispecs = vcat (map pprInstance ispecs) +instanceWarning :: ClsInst -> Maybe (WarningTxt GhcRn)+instanceWarning = is_warn+ instanceHead :: ClsInst -> ([TyVar], Class, [Type]) -- Returns the head, using the fresh tyvars from the ClsInst instanceHead (ClsInst { is_tvs = tvs, is_cls = cls, is_tys = tys })@@ -261,17 +283,18 @@  mkLocalClsInst :: DFunId -> OverlapFlag                -> [TyVar] -> Class -> [Type]+               -> Maybe (WarningTxt GhcRn)                -> ClsInst -- Used for local instances, where we can safely pull on the DFunId. -- Consider using newClsInst instead; this will also warn if -- the instance is an orphan.-mkLocalClsInst dfun oflag tvs cls tys+mkLocalClsInst dfun oflag tvs cls tys warn   = ClsInst { is_flag = oflag, is_dfun = dfun             , is_tvs = tvs             , is_dfun_name = dfun_name             , is_cls = cls, is_cls_nm = cls_name             , is_tys = tys, is_tcs = RM_KnownTc cls_name : roughMatchTcs tys-            , is_orphan = orph+            , is_orphan = orph, is_warn = warn             }   where     cls_name = className cls@@ -302,24 +325,26 @@      choose_one nss = chooseOrphanAnchor (unionNameSets nss) -mkImportedClsInst :: Name           -- ^ the name of the class-                  -> [RoughMatchTc] -- ^ the rough match signature of the instance-                  -> Name           -- ^ the 'Name' of the dictionary binding-                  -> DFunId         -- ^ the 'Id' of the dictionary.-                  -> OverlapFlag    -- ^ may this instance overlap?-                  -> IsOrphan       -- ^ is this instance an orphan?+mkImportedClsInst :: Name                     -- ^ the name of the class+                  -> [RoughMatchTc]           -- ^ the rough match signature of the instance+                  -> Name                     -- ^ the 'Name' of the dictionary binding+                  -> DFunId                   -- ^ the 'Id' of the dictionary.+                  -> OverlapFlag              -- ^ may this instance overlap?+                  -> IsOrphan                 -- ^ is this instance an orphan?+                  -> Maybe (WarningTxt GhcRn) -- ^ warning emitted when solved                   -> ClsInst -- Used for imported instances, where we get the rough-match stuff -- from the interface file -- The bound tyvars of the dfun are guaranteed fresh, because -- the dfun has been typechecked out of the same interface file-mkImportedClsInst cls_nm mb_tcs dfun_name dfun oflag orphan+mkImportedClsInst cls_nm mb_tcs dfun_name dfun oflag orphan warn   = ClsInst { is_flag = oflag, is_dfun = dfun             , is_tvs = tvs, is_tys = tys             , is_dfun_name = dfun_name             , is_cls_nm = cls_nm, is_cls = cls             , is_tcs = RM_KnownTc cls_nm : mb_tcs-            , is_orphan = orphan }+            , is_orphan = orphan+            , is_warn = warn }   where     (tvs, _, cls, tys) = tcSplitDFunTy (idType dfun)
compiler/GHC/Core/Lint.hs view
@@ -33,7 +33,11 @@  import GHC.Driver.DynFlags -import GHC.Tc.Utils.TcType ( isFloatingPrimTy, isTyFamFree )+import GHC.Tc.Utils.TcType+  ( ConcreteTvOrigin(..), ConcreteTyVars+  , isFloatingPrimTy, isTyFamFree )+import GHC.Tc.Types.Origin+  ( FixedRuntimeRepOrigin(..) ) import GHC.Unit.Module.ModGuts import GHC.Platform @@ -48,7 +52,7 @@ import GHC.Core.Multiplicity import GHC.Core.UsageEnv import GHC.Core.TyCo.Rep   -- checks validity of types/coercions-import GHC.Core.TyCo.Compare( eqType )+import GHC.Core.TyCo.Compare ( eqType, eqForAllVis ) import GHC.Core.TyCo.Subst import GHC.Core.TyCo.FVs import GHC.Core.TyCo.Ppr@@ -70,6 +74,7 @@ import GHC.Types.Id.Info import GHC.Types.SrcLoc import GHC.Types.Tickish+import GHC.Types.Unique.FM ( isNullUFM, sizeUFM ) import GHC.Types.RepType import GHC.Types.Basic import GHC.Types.Demand      ( splitDmdSig, isDeadEndDiv )@@ -95,6 +100,8 @@ import Data.List.NonEmpty ( NonEmpty(..), groupWith ) import Data.List          ( partition ) import Data.Maybe+import Data.IntMap.Strict ( IntMap )+import qualified Data.IntMap.Strict as IntMap ( lookup, keys, empty, fromList ) import GHC.Data.Pair import GHC.Base (oneShot) import GHC.Data.Unboxed@@ -558,9 +565,9 @@            ; lintLetBind top_lvl Recursive bndr' rhs rhs_ty            ; return ue } -lintLetBody :: [LintedId] -> CoreExpr -> LintM (LintedType, UsageEnv)-lintLetBody bndrs body-  = do { (body_ty, body_ue) <- addLoc (BodyOfLetRec bndrs) (lintCoreExpr body)+lintLetBody :: LintLocInfo -> [LintedId] -> CoreExpr -> LintM (LintedType, UsageEnv)+lintLetBody loc bndrs body+  = do { (body_ty, body_ue) <- addLoc loc (lintCoreExpr body)        ; mapM_ (lintJoinBndrType body_ty) bndrs        ; return (body_ty, body_ue) } @@ -597,10 +604,10 @@           -- Check that a join-point binder has a valid type          -- NB: lintIdBinder has checked that it is not top-level bound-       ; case isJoinId_maybe binder of-            Nothing    -> return ()-            Just arity ->  checkL (isValidJoinPointType arity binder_ty)-                                  (mkInvalidJoinPointMsg binder binder_ty)+       ; case idJoinPointHood binder of+            NotJoinPoint    -> return ()+            JoinPoint arity ->  checkL (isValidJoinPointType arity binder_ty)+                                       (mkInvalidJoinPointMsg binder binder_ty)         ; when (lf_check_inline_loop_breakers flags                && isStableUnfolding (realIdUnfolding binder)@@ -655,7 +662,7 @@ -- NB: the Id can be Linted or not -- it's only used for --     its OccInfo and join-pointer-hood lintRhs bndr rhs-    | Just arity <- isJoinId_maybe bndr+    | JoinPoint arity <- idJoinPointHood bndr     = lintJoinLams arity (Just bndr) rhs     | AlwaysTailCalled arity <- tailCallInfo (idOccInfo bndr)     = lintJoinLams arity Nothing rhs@@ -777,7 +784,7 @@   Note [Checking for representation polymorphism]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We ordinarily want to check for bad representation polymorphism. See Note [Representation polymorphism invariants] in GHC.Core. However, we do *not* want to do this in a compulsory unfolding. Compulsory unfoldings arise@@ -815,8 +822,28 @@     join j = ...     in runRW# @r @ty (jump j) +Note [Coercions in terms]+~~~~~~~~~~~~~~~~~~~~~~~~~+The expression (Type ty) can occur only as the argument of an application,+or the RHS of a non-recursive Let.  But what about (Coercion co)? +Currently it appears in ghc-prim:GHC.Types.coercible_sel, a WiredInId whose+definition is:+   coercible_sel :: Coercible a b => (a ~R# b)+   coercible_sel d = case d of+                         MkCoercibleDict (co :: a ~# b) -> Coercion co +So this function has a (Coercion co) in the alternative of a case.++Richard says (!11908): it shouldn't appear outside of arguments, but we've been+loose about this. coercible_sel is some thin ice. Really we should be unpacking+Coercible using case, not a selector. I recall looking into this a few years+back and coming to the conclusion that the fix was worse than the disease. Don't+remember the details, but could probably recover it if we want to revisit.++So Lint current accepts (Coercion co) in arbitrary places.  There is no harm in+that: it really is a value, albeit a zero-bit value.+ ************************************************************************ *                                                                      * \subsection[lintCoreExpr]{lintCoreExpr}@@ -856,7 +883,9 @@ lintCoreExpr (Var var)   = do       var_pair@(var_ty, _) <- lintIdOcc var 0-      checkCanEtaExpand (Var var) [] var_ty+      -- See Note [Linting representation-polymorphic builtins]+      checkRepPolyBuiltin (Var var) [] var_ty+      --checkDataToTagPrimOpTyCon (Var var) []       return var_pair  lintCoreExpr (Lit lit)@@ -870,10 +899,10 @@  lintCoreExpr (Tick tickish expr)   = do case tickish of-         Breakpoint _ _ ids -> forM_ ids $ \id -> do-                                 checkDeadIdOcc id-                                 lookupIdInScope id-         _                  -> return ()+         Breakpoint _ _ ids _ -> forM_ ids $ \id -> do+                                   checkDeadIdOcc id+                                   lookupIdInScope id+         _                    -> return ()        markAllJoinsBadIf block_joins $ lintCoreExpr expr   where     block_joins = not (tickish `tickishScopesLike` SoftScope)@@ -892,7 +921,7 @@                 -- Now extend the substitution so we                 -- take advantage of it in the body         ; extendTvSubstL tv ty'        $-          addLoc (BodyOfLetRec [tv]) $+          addLoc (BodyOfLet tv) $           lintCoreExpr body } }  lintCoreExpr (Let (NonRec bndr rhs) body)@@ -904,7 +933,7 @@          -- Now lint the binder        ; lintBinder LetBind bndr $ \bndr' ->     do { lintLetBind NotTopLevel NonRecursive bndr' rhs rhs_ty-       ; addAliasUE bndr let_ue (lintLetBody [bndr'] body) } }+       ; addAliasUE bndr let_ue (lintLetBody (BodyOfLet bndr') [bndr'] body) } }    | otherwise   = failWithL (mkLetErr bndr rhs)       -- Not quite accurate@@ -924,7 +953,7 @@           -- See Note [Multiplicity of let binders] in Var         ; ((body_type, body_ue), ues) <-             lintRecBindings NotTopLevel pairs $ \ bndrs' ->-            lintLetBody bndrs' body+            lintLetBody (BodyOfLetRec bndrs') bndrs' body         ; return (body_type, body_ue  `addUE` scaleUE ManyTy (foldr1 addUE ues)) }   where     bndrs = map fst pairs@@ -950,7 +979,11 @@   | otherwise   = do { fun_pair <- lintCoreFun fun (length args)        ; app_pair@(app_ty, _) <- lintCoreArgs fun_pair args-       ; checkCanEtaExpand fun args app_ty++       -- See Note [Linting representation-polymorphic builtins]+       ; checkRepPolyBuiltin fun args app_ty+       ; --checkDataToTagPrimOpTyCon fun args+        ; return app_pair}   where     skipTick t = case collectFunSimple e of@@ -983,13 +1016,14 @@   = failWithL (text "Type found as expression" <+> ppr ty)  lintCoreExpr (Coercion co)+  -- See Note [Coercions in terms]   = do { co' <- addLoc (InCo co) $                 lintCoercion co        ; return (coercionType co', zeroUE) }  ---------------------- lintIdOcc :: Var -> Int -- Number of arguments (type or value) being passed-           -> LintM (LintedType, UsageEnv) -- returns type of the *variable*+          -> LintM (LintedType, UsageEnv) -- returns type of the *variable* lintIdOcc var nargs   = addLoc (OccOf var) $     do  { checkL (isNonCoVarId var)@@ -1074,7 +1108,7 @@ -- E.g. join j x = rhs in body --      The type of 'rhs' must be the same as the type of 'body' lintJoinBndrType body_ty bndr-  | Just arity <- isJoinId_maybe bndr+  | JoinPoint arity <- idJoinPointHood bndr   , let bndr_ty = idType bndr   , (bndrs, res) <- splitPiTys bndr_ty   = checkL (length bndrs >= arity@@ -1090,15 +1124,14 @@ -- Check that if the occurrence is a JoinId, then so is the -- binding site, and it's a valid join Id checkJoinOcc var n_args-  | Just join_arity_occ <- isJoinId_maybe var+  | JoinPoint join_arity_occ <- idJoinPointHood var   = do { mb_join_arity_bndr <- lookupJoinId var        ; case mb_join_arity_bndr of {-           Nothing -> -- Binder is not a join point-                      do { join_set <- getValidJoins-                         ; addErrL (text "join set " <+> ppr join_set $$-                                    invalidJoinOcc var) } ;+           NotJoinPoint -> do { join_set <- getValidJoins+                              ; addErrL (text "join set " <+> ppr join_set $$+                                invalidJoinOcc var) } ; -           Just join_arity_bndr ->+           JoinPoint join_arity_bndr ->      do { checkL (join_arity_bndr == join_arity_occ) $            -- Arity differs at binding site and occurrence@@ -1118,79 +1151,180 @@   = checkL (not (isTypeDataTyCon (dataConTyCon dc))) $     (text "type data constructor found in a" <+> text what <> colon <+> ppr dc) --- | This function checks that we are able to perform eta expansion for--- functions with no binding, in order to satisfy invariant I3--- from Note [Representation polymorphism invariants] in GHC.Core.-checkCanEtaExpand :: CoreExpr   -- ^ the function (head of the application) we are checking-                  -> [CoreArg]  -- ^ the arguments to the application-                  -> LintedType -- ^ the instantiated type of the overall application-                  -> LintM ()-checkCanEtaExpand (Var fun_id) args app_ty+{-+-- | Check that a use of a dataToTag# primop satisfies conditions DTT2+-- and DTT3 from Note [DataToTag overview] in GHC.Tc.Instance.Class+--+-- Ignores applications not headed by dataToTag# primops.++-- Commented out because GHC.PrimopWrappers doesn't respect this condition yet.+-- See wrinkle DTW7 in Note [DataToTag overview].+checkDataToTagPrimOpTyCon+  :: CoreExpr   -- ^ the function (head of the application) we are checking+  -> [CoreArg]  -- ^ The arguments to the application+  -> LintM ()+checkDataToTagPrimOpTyCon (Var fun_id) args+  | Just op <- isPrimOpId_maybe fun_id+  , op == DataToTagSmallOp || op == DataToTagLargeOp+  = case args of+      Type _levity : Type dty : _rest+        | Just (tc, _) <- splitTyConApp_maybe dty+        , isValidDTT2TyCon tc+          -> do  platform <- getPlatform+                 let  numConstrs = tyConFamilySize tc+                      isSmallOp = op == DataToTagSmallOp+                 checkL (isSmallFamily platform numConstrs == isSmallOp) $+                   text "dataToTag# primop-size/tycon-family-size mismatch"+        | otherwise -> failWithL $ text "dataToTagLarge# used at non-ADT type:"+                                   <+> ppr dty+      _ -> failWithL $ text "dataToTagLarge# needs two type arguments but has args:"+                       <+> ppr (take 2 args)++checkDataToTagPrimOpTyCon _ _ = pure ()+-}++-- | Check representation-polymorphic invariants in an application of a+-- built-in function or newtype constructor.+--+-- See Note [Linting representation-polymorphic builtins].+checkRepPolyBuiltin :: CoreExpr   -- ^ the function (head of the application) we are checking+                    -> [CoreArg]  -- ^ the arguments to the application+                    -> LintedType -- ^ the instantiated type of the overall application+                    -> LintM ()+checkRepPolyBuiltin (Var fun_id) args app_ty   = do { do_rep_poly_checks <- lf_check_fixed_rep <$> getLintFlags        ; when (do_rep_poly_checks && hasNoBinding fun_id) $-           checkL (null bad_arg_tys) err_msg }-    where-      arity :: Arity-      arity = idArity fun_id+           if+             -- (2) representation-polymorphic unlifted newtypes+             | Just dc <- isDataConId_maybe fun_id+             , isNewDataCon dc+             -> if tcHasFixedRuntimeRep $ dataConTyCon dc+                then return ()+                else checkRepPolyNewtypeApp dc args app_ty -      nb_val_args :: Int-      nb_val_args = count isValArg args+             -- (1) representation-polymorphic builtins+             | otherwise+             -> checkRepPolyBuiltinApp fun_id args+       }+checkRepPolyBuiltin _ _ _ = return () -      -- Check the remaining argument types, past the-      -- given arguments and up to the arity of the 'Id'.-      -- Returns the types that couldn't be determined to have-      -- a fixed RuntimeRep.-      check_args :: [Type] -> [Type]-      check_args = go (nb_val_args + 1)-        where-          go :: Int    -- index of the argument (starting from 1)-             -> [Type] -- arguments-             -> [Type] -- value argument types that could not be-                       -- determined to have a fixed runtime representation-          go i _-            | i > arity-            = []-          go _ []-            -- The Arity of an Id should never exceed the number of value arguments-            -- that can be read off from the Id's type.-            -- See Note [Arity and function types] in GHC.Types.Id.Info.-            = pprPanic "checkCanEtaExpand: arity larger than number of value arguments apparent in type"-                $ vcat-                  [ text "fun_id =" <+> ppr fun_id-                  , text "arity =" <+> ppr arity-                  , text "app_ty =" <+> ppr app_ty-                  , text "args = " <+> ppr args-                  , text "nb_val_args =" <+> ppr nb_val_args ]-          go i (ty : bndrs)-            | typeHasFixedRuntimeRep ty-            = go (i+1) bndrs-            | otherwise-            = ty : go (i+1) bndrs+checkRepPolyNewtypeApp :: DataCon -> [CoreArg] -> LintedType -> LintM ()+checkRepPolyNewtypeApp nt args app_ty+  -- If the newtype is saturated, we're OK.+  | any isValArg args+  = return ()+  -- Otherwise, check we can eta-expand.+  | otherwise+  = case getRuntimeArgTys app_ty of+      (Scaled _ first_val_arg_ty, _):_+        | not $ typeHasFixedRuntimeRep first_val_arg_ty+        -> failWithL (err_msg first_val_arg_ty)+      _ -> return () -      bad_arg_tys :: [Type]-      bad_arg_tys = check_args . map (scaledThing . fst) $ getRuntimeArgTys app_ty-        -- We use 'getRuntimeArgTys' to find all the argument types,-        -- including those hidden under newtypes. For example,-        -- if `FunNT a b` is a newtype around `a -> b`, then-        -- when checking-        ---        -- foo :: forall r (a :: TYPE r) (b :: TYPE r) c. a -> FunNT b c-        ---        -- we should check that the instantiations of BOTH `a` AND `b`-        -- have a fixed runtime representation.+  where -      err_msg :: SDoc-      err_msg-        = vcat [ text "Cannot eta expand" <+> quotes (ppr fun_id)-               , text "The following type" <> plural bad_arg_tys-                 <+> doOrDoes bad_arg_tys <+> text "not have a fixed runtime representation:"-               , nest 2 $ vcat $ map ppr_ty_ki bad_arg_tys ]+      err_msg :: Type -> SDoc+      err_msg bad_arg_ty+        = vcat [ text "Cannot eta expand unlifted newtype constructor" <+> quotes (ppr nt) <> dot+               , text "Its argument type does not have a fixed runtime representation:"+               , nest 2 $ ppr_ty_ki bad_arg_ty ]        ppr_ty_ki :: Type -> SDoc       ppr_ty_ki ty = bullet <+> ppr ty <+> dcolon <+> ppr (typeKind ty)-checkCanEtaExpand _ _ _-  = return () +checkRepPolyBuiltinApp :: Id -> [CoreArg] -> LintM ()+checkRepPolyBuiltinApp fun_id args = checkL (null not_concs) err_msg+  where++    conc_binder_positions :: IntMap ConcreteTvOrigin+    conc_binder_positions+      = concreteTyVarPositions fun_id+      $ idDetailsConcreteTvs+      $ idDetails fun_id++    max_pos :: Int+    max_pos =+      case IntMap.keys conc_binder_positions of+        [] -> 0+        positions -> maximum positions++    not_concs :: [(SDoc, ConcreteTvOrigin)]+    not_concs =+      mapMaybe is_bad (zip [1..max_pos] (map Just args ++ repeat Nothing))+        -- NB: 1-indexed++    is_bad :: (Int, Maybe CoreArg) -> Maybe (SDoc, ConcreteTvOrigin)+    is_bad (pos, mb_arg)+      | Just conc_reason <- IntMap.lookup pos conc_binder_positions+      , Just bad_ty <- case mb_arg of+          Just (Type ki)+            | isConcreteType ki+            -> Nothing+            | otherwise+            -- Here we handle the situation in which a "must be concrete" TyVar+            -- has been instantiated with a type that is not concrete.+            -> Just $ quotes (ppr ki) <+> text "is not concrete."+          -- We expected a type argument in this position, and got something else: panic!+          Just arg ->+            pprPanic "checkRepPolyBuiltinApp: expected a type in this position" $+              vcat [ text "fun_id:" <+> ppr fun_id <+> dcolon <+> ppr (idType fun_id)+                   , text "pos:" <+> ppr pos+                   , text "arg:" <+> ppr arg ]+          Nothing ->+            -- Here we handle the situation in which a "must be concrete" TyVar+            -- has not been instantiated at all.+            case conc_reason of+              ConcreteFRR frr_orig ->+                let ty = frr_type frr_orig+                in  Just $ ppr ty <+> dcolon <+> ppr (typeKind ty)+      = Just (bad_ty, conc_reason)+      | otherwise+      = Nothing++    err_msg :: SDoc+    err_msg+      = vcat $ map ((bullet <+>) . ppr_not_conc) not_concs++    ppr_not_conc :: (SDoc, ConcreteTvOrigin) -> SDoc+    ppr_not_conc (bad_ty, conc) =+      vcat+       [ ppr_conc_orig conc+       , nest 2 bad_ty ]++    ppr_conc_orig :: ConcreteTvOrigin -> SDoc+    ppr_conc_orig (ConcreteFRR frr_orig) =+      case frr_orig of+        FixedRuntimeRepOrigin { frr_context = ctxt } ->+          hsep [ ppr ctxt, text "does not have a fixed runtime representation:" ]++-- | Compute the 1-indexed positions in the outer forall'd quantified type variables+-- of the type in which the concrete type variables occur.+--+-- See Note [Representation-polymorphism checking built-ins] in GHC.Tc.Gen.Head.+concreteTyVarPositions :: Id -> ConcreteTyVars -> IntMap ConcreteTvOrigin+concreteTyVarPositions fun_id conc_tvs+  | isNullUFM conc_tvs+  = IntMap.empty+  | otherwise+  = case splitForAllTyCoVars (idType fun_id) of+    ([], _)  -> IntMap.empty+    (tvs, _) ->+      let positions =+            IntMap.fromList+              [ (pos, conc_orig)+              | (tv, pos) <- zip tvs [1..]+              , conc_orig <- maybeToList $ lookupNameEnv conc_tvs (tyVarName tv)+              ]+         -- Assert that we have as many positions as concrete type variables,+         -- i.e. we are not missing any concreteness information.+      in assertPpr (sizeUFM conc_tvs == length positions)+           (vcat [ text "concreteTyVarPositions: missing concreteness information"+                 , text "fun_id:" <+> ppr fun_id+                 , text "tvs:" <+> ppr tvs+                 , text "Expected # of concrete tvs:" <+> ppr (sizeUFM conc_tvs)+                 , text "  Actual # of concrete tvs:" <+> ppr (length positions) ])+           positions+ -- Check that the usage of var is consistent with var itself, and pop the var -- from the usage environment (this is important because of shadowing). checkLinearity :: UsageEnv -> Var -> LintM UsageEnv@@ -1325,6 +1459,8 @@ lintCoreArgs (fun_ty, fun_ue) args = foldM lintCoreArg (fun_ty, fun_ue) args  lintCoreArg  :: (LintedType, UsageEnv) -> CoreArg -> LintM (LintedType, UsageEnv)++-- Type argument lintCoreArg (fun_ty, ue) (Type arg_ty)   = do { checkL (not (isCoercionTy arg_ty))                 (text "Unnecessary coercion-to-type injection:"@@ -1333,6 +1469,14 @@        ; res <- lintTyApp fun_ty arg_ty'        ; return (res, ue) } +-- Coercion argument+lintCoreArg (fun_ty, ue) (Coercion co)+  = do { co' <- addLoc (InCo co) $+                lintCoercion co+       ; res <- lintCoApp fun_ty co'+       ; return (res, ue) }++-- Other value argument lintCoreArg (fun_ty, fun_ue) arg   = do { (arg_ty, arg_ue) <- markAllJoinsBad $ lintCoreExpr arg            -- See Note [Representation polymorphism invariants] in GHC.Core@@ -1397,7 +1541,7 @@ ----------------- lintTyApp :: LintedType -> LintedType -> LintM LintedType lintTyApp fun_ty arg_ty-  | Just (tv,body_ty) <- splitForAllTyCoVar_maybe fun_ty+  | Just (tv,body_ty) <- splitForAllTyVar_maybe fun_ty   = do  { lintTyKind tv arg_ty         ; in_scope <- getInScope         -- substTy needs the set of tyvars in scope to avoid generating@@ -1409,11 +1553,34 @@   = failWithL (mkTyAppMsg fun_ty arg_ty)  -----------------+lintCoApp :: LintedType -> LintedCoercion -> LintM LintedType+lintCoApp fun_ty co+  | Just (cv,body_ty) <- splitForAllCoVar_maybe fun_ty+  , let co_ty = coercionType co+        cv_ty = idType cv+  , cv_ty `eqType` co_ty+  = do { in_scope <- getInScope+       ; let init_subst = mkEmptySubst in_scope+             subst = extendCvSubst init_subst cv co+       ; return (substTy subst body_ty) } +  | Just (_, _, arg_ty', res_ty') <- splitFunTy_maybe fun_ty+  , co_ty `eqType` arg_ty'+  = return (res_ty')++  | otherwise+  = failWithL (mkCoAppMsg fun_ty co)++  where+    co_ty = coercionType co++-----------------+ -- | @lintValApp arg fun_ty arg_ty@ lints an application of @fun arg@ -- where @fun :: fun_ty@ and @arg :: arg_ty@, returning the type of the -- application.-lintValApp :: CoreExpr -> LintedType -> LintedType -> UsageEnv -> UsageEnv -> LintM (LintedType, UsageEnv)+lintValApp :: CoreExpr -> LintedType -> LintedType -> UsageEnv -> UsageEnv+           -> LintM (LintedType, UsageEnv) lintValApp arg fun_ty arg_ty fun_ue arg_ue   | Just (_, w, arg_ty', res_ty') <- splitFunTy_maybe fun_ty   = do { ensureEqTys arg_ty' arg_ty (mkAppMsg arg_ty' arg_ty arg)@@ -1842,7 +2009,6 @@          lintL (tcv `elemVarSet` tyCoVarsOfType body_ty) $          text "Covar does not occur in the body:" <+> (ppr tcv $$ ppr body_ty)          -- See GHC.Core.TyCo.Rep Note [Unused coercion variable in ForAllTy]-         -- and cf GHC.Core.Coercion Note [Unused coercion variable in ForAllCo]         ; return (ForAllTy (Bndr tcv' vis) body_ty') } @@ -2030,8 +2196,8 @@                                    , ru_args = args, ru_rhs = rhs })   = lintBinders LambdaBind bndrs $ \ _ ->     do { (lhs_ty, _) <- lintCoreArgs (fun_ty, zeroUE) args-       ; (rhs_ty, _) <- case isJoinId_maybe fun of-                     Just join_arity+       ; (rhs_ty, _) <- case idJoinPointHood fun of+                     JoinPoint join_arity                        -> do { checkL (args `lengthIs` join_arity) $                                 mkBadJoinPointRuleMsg fun join_arity rule                                -- See Note [Rules for join points]@@ -2230,9 +2396,14 @@        ; return (AppCo co1' co2') }  -----------lintCoercion co@(ForAllCo tcv kind_co body_co)+lintCoercion co@(ForAllCo { fco_tcv = tcv, fco_visL = visL, fco_visR = visR+                          , fco_kind = kind_co, fco_body = body_co })+-- See Note [ForAllCo] in GHC.Core.TyCo.Rep,+-- including the typing rule for ForAllCo+   | not (isTyCoVar tcv)   = failWithL (text "Non tyco binder in ForAllCo:" <+> ppr co)+   | otherwise   = do { kind_co' <- lintStarCoercion kind_co        ; lintTyCoBndr tcv $ \tcv' ->@@ -2246,19 +2417,25 @@        --    (forall (tcv:k2). rty[(tcv:k2) |> sym kind_co/tcv])        -- are both well formed.  Easiest way is to call lintForAllBody        -- for each; there is actually no need to do the funky substitution-       ; let Pair lty rty = coercionKind body_co'+       ; let (Pair lty rty, body_role) = coercionKindRole body_co'        ; lintForAllBody tcv' lty        ; lintForAllBody tcv' rty         ; when (isCoVar tcv) $-         lintL (almostDevoidCoVarOfCo tcv body_co) $-         text "Covar can only appear in Refl and GRefl: " <+> ppr co-         -- See "last wrinkle" in GHC.Core.Coercion-         -- Note [Unused coercion variable in ForAllCo]-         -- and c.f. GHC.Core.TyCo.Rep Note [Unused coercion variable in ForAllTy]+         do { lintL (visL == coreTyLamForAllTyFlag && visR == coreTyLamForAllTyFlag) $+              text "Invalid visibility flags in CoVar ForAllCo" <+> ppr co+              -- See (FC7) in Note [ForAllCo] in GHC.Core.TyCo.Rep+            ; lintL (almostDevoidCoVarOfCo tcv body_co) $+              text "Covar can only appear in Refl and GRefl: " <+> ppr co+              -- See (FC6) in Note [ForAllCo] in GHC.Core.TyCo.Rep+         } -       ; return (ForAllCo tcv' kind_co' body_co') } }+       ; when (body_role == Nominal) $+         lintL (visL `eqForAllVis` visR) $+         text "Nominal ForAllCo has mismatched visibilities: " <+> ppr co +       ; return (co { fco_tcv = tcv', fco_kind = kind_co', fco_body = body_co' }) } }+ lintCoercion co@(FunCo { fco_role = r, fco_afl = afl, fco_afr = afr                        , fco_mult = cow, fco_arg = co1, fco_res = co2 })   = do { co1' <- lintCoercion co1@@ -2309,9 +2486,6 @@         -- see #9122 for discussion of these checks      checkTypes t1 t2-       | allow_ill_kinded_univ_co prov-       = return ()  -- Skip kind checks-       | otherwise        = do { checkWarnL fixed_rep_1                          (report "left-hand type does not have a fixed runtime representation")             ; checkWarnL fixed_rep_2@@ -2329,13 +2503,6 @@          reps1 = typePrimRep t1          reps2 = typePrimRep t2 -     -- CorePrep deliberately makes ill-kinded casts-     --  e.g (case error @Int "blah" of {}) :: Int#-     --     ==> (error @Int "blah") |> Unsafe Int Int#-     -- See Note [Unsafe coercions] in GHC.Core.CoreToStg.Prep-     allow_ill_kinded_univ_co (CorePrepProv homo_kind) = not homo_kind-     allow_ill_kinded_univ_co _                        = False-      validateCoercion :: PrimRep -> PrimRep -> LintM ()      validateCoercion rep1 rep2        = do { platform <- getPlatform@@ -2365,8 +2532,7 @@             ; check_kinds kco k1 k2             ; return (ProofIrrelProv kco') } -     lint_prov _ _ prov@(PluginProv _)   = return prov-     lint_prov _ _ prov@(CorePrepProv _) = return prov+     lint_prov _ _ prov@(PluginProv _) = return prov       check_kinds kco k1 k2        = do { let Pair k1' k2' = coercionKind kco@@ -3006,43 +3172,56 @@  There is a useful discussion at https://gitlab.haskell.org/ghc/ghc/-/issues/22123 -Note [checkCanEtaExpand]-~~~~~~~~~~~~~~~~~~~~~~~~-The checkCanEtaExpand function is responsible for enforcing invariant I3-from Note [Representation polymorphism invariants] in GHC.Core: in any-partial application `f e_1 .. e_n`, if `f` has no binding, we must be able to-eta expand `f` to match the declared arity of `f`.+Note [Linting representation-polymorphic builtins]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+As described in Note [Representation-polymorphism checking built-ins], on+top of the two main representation-polymorphism invariants described in the+Note [Representation polymorphism invariants], we must perform additional+representation-polymorphism checks on builtin functions which don't have a+binding, for example to ensure that we don't run afoul of the+representation-polymorphism invariants when eta-expanding. -Wrinkle 1: eta-expansion and newtypes+There are two situations: -  Most of the time, when we have a partial application `f e_1 .. e_n`-  in which `f` is `hasNoBinding`, we eta-expand it up to its arity-  as follows:+  1. Builtins which have skolem type variables which must be instantiated to+     concrete types, such as the RuntimeRep type argument r to the catch# primop. -    \ x_{n+1} ... x_arity -> f e_1 .. e_n x_{n+1} ... x_arity+  2. Representation-polymorphic unlifted newtypes, which must always be instantiated+     at a fixed runtime representation. -  However, we might need to insert casts if some of the arguments-  that `f` takes are under a newtype.-  For example, suppose `f` `hasNoBinding`, has arity 1 and type+For 1, consider for example 'coerce': -    f :: forall r (a :: TYPE r). Identity (a -> a)+  coerce :: forall {r} (a :: TYPE r) (b :: TYPE r). Coercible a b => a -> b -  then we eta-expand the nullary application `f` to+We store in the IdDetails of the coerce Id that the first binder, r, must always+be instantiated to a concrete type. We thus check this in Core Lint: whenever we+see an application of the form -    ( \ x -> f x ) |> co+  coerce @{rep1} ... -  where+we ensure that 'rep1' is concrete. This is done in the function "checkRepPolyBuiltinApp".+Moreover, not instantiating these type variables at all is also an error, as+we would again not be able to perform eta-expansion. (This is a bit more theoretical,+as in user programs the typechecker will insert these type applications when+instantiating, but it can still arise when constructing Core expressions). -    co :: ( forall r (a :: TYPE r). a -> a ) ~# ( forall r (a :: TYPE r). Identity (a -> a) )+For 2, whenever we have an unlifted newtype such as -  In this case we would have to perform a representation-polymorphism check on the instantiation-  of `a`.+  type RR :: Type -> RuntimeRep+  type family RR a -Wrinkle 2: 'hasNoBinding' and laziness+  type F :: forall (a :: Type) -> TYPE (RR a)+  type family F a -  It's important that we able to compute 'hasNoBinding' for an 'Id' without ever forcing-  the unfolding of the 'Id'. Otherwise, we could end up with a loop, as outlined in-    Note [Lazily checking Unfoldings] in GHC.IfaceToCore.+  type N :: forall (a :: Type) -> TYPE (RR a)+  newtype N a = MkN (F a)++and an unsaturated occurrence++  MkN @ty -- NB: no value argument!++we check that the (instantiated) argument type has a fixed runtime representation.+This is done in the function "checkRepPolyNewtypeApp". -}  instance Applicative LintM where@@ -3074,7 +3253,8 @@   | LambdaBodyOf Id     -- The lambda-binder   | RuleOf Id           -- Rules attached to a binder   | UnfoldingOf Id      -- Unfolding of a binder-  | BodyOfLetRec [Id]   -- One of the binders+  | BodyOfLet Id        -- The let-bound variable+  | BodyOfLetRec [Id]   -- The binders of the let   | CaseAlt CoreAlt     -- Case alternative   | CasePat CoreAlt     -- The *pattern* of the case alternative   | CaseTy CoreExpr     -- The type field of a case expression@@ -3269,14 +3449,14 @@        --     wired-in Ids after worker/wrapper        --     So we simply disable the test in this case -lookupJoinId :: Id -> LintM (Maybe JoinArity)+lookupJoinId :: Id -> LintM JoinPointHood -- Look up an Id which should be a join point, valid here -- If so, return its arity, if not return Nothing lookupJoinId id   = do { join_set <- getValidJoins        ; case lookupVarSet join_set id of-            Just id' -> return (isJoinId_maybe id')-            Nothing  -> return Nothing }+            Just id' -> return (idJoinPointHood id')+            Nothing  -> return NotJoinPoint }  addAliasUE :: Id -> UsageEnv -> LintM a -> LintM a addAliasUE id ue thing_inside = LintM $ \ env errs ->@@ -3364,11 +3544,14 @@ dumpLoc (UnfoldingOf b)   = (getSrcLoc b, text "In the unfolding of" <+> pp_binder b) +dumpLoc (BodyOfLet b)+  = (noSrcLoc, text "In the body of a let with binder" <+> pp_binder b)+ dumpLoc (BodyOfLetRec [])   = (noSrcLoc, text "In body of a letrec with no binders")  dumpLoc (BodyOfLetRec bs@(b:_))-  = ( getSrcLoc b, text "In the body of letrec with binders" <+> pp_binders bs)+  = ( getSrcLoc b, text "In the body of a letrec with binders" <+> pp_binders bs)  dumpLoc (AnExpr e)   = (noSrcLoc, text "In the expression:" <+> ppr e)@@ -3498,10 +3681,18 @@ mkTyAppMsg :: Type -> Type -> SDoc mkTyAppMsg ty arg_ty   = vcat [text "Illegal type application:",-              hang (text "Exp type:")+              hang (text "Function type:")                  4 (ppr ty <+> dcolon <+> ppr (typeKind ty)),-              hang (text "Arg type:")+              hang (text "Type argument:")                  4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]++mkCoAppMsg :: Type -> Coercion -> SDoc+mkCoAppMsg fun_ty co+  = vcat [ text "Illegal coercion application:"+         , hang (text "Function type:")+              4 (ppr fun_ty)+         , hang (text "Coercion argument:")+              4 (ppr co <+> dcolon <+> ppr (coercionType co))]  emptyRec :: CoreExpr -> SDoc emptyRec e = hang (text "Empty Rec binding:") 2 (ppr e)
compiler/GHC/Core/Make.hs view
@@ -79,7 +79,6 @@ import GHC.Utils.Outputable import GHC.Utils.Misc import GHC.Utils.Panic-import GHC.Utils.Panic.Plain  import GHC.Settings.Constants( mAX_TUPLE_SIZE ) import GHC.Data.FastString@@ -469,12 +468,12 @@  -- | Build the type of a big tuple that holds the specified variables -- One-tuples are flattened; see Note [Flattening one-tuples]-mkBigCoreVarTupTy :: [Id] -> Type+mkBigCoreVarTupTy :: HasDebugCallStack => [Id] -> Type mkBigCoreVarTupTy ids = mkBigCoreTupTy (map idType ids)  -- | Build the type of a big tuple that holds the specified type of thing -- One-tuples are flattened; see Note [Flattening one-tuples]-mkBigCoreTupTy :: [Type] -> Type+mkBigCoreTupTy :: HasDebugCallStack => [Type] -> Type mkBigCoreTupTy tys = mkChunkified mkBoxedTupleTy $                      map boxTy tys @@ -499,7 +498,7 @@   where     e_ty = exprType e -boxTy :: Type -> Type+boxTy :: HasDebugCallStack => Type -> Type -- ^ `boxTy ty` is the boxed version of `ty`. That is, -- if `e :: ty`, then `wrapBox e :: boxTy ty`. -- Note that if `ty :: Type`, `boxTy ty` just returns `ty`.@@ -908,7 +907,7 @@                                   nonExhaustiveGuardsErrorIdKey nON_EXHAUSTIVE_GUARDS_ERROR_ID  err_nm :: String -> Unique -> Id -> Name-err_nm str uniq id = mkWiredInIdName cONTROL_EXCEPTION_BASE (fsLit str) uniq id+err_nm str uniq id = mkWiredInIdName gHC_INTERNAL_CONTROL_EXCEPTION_BASE (fsLit str) uniq id  rEC_SEL_ERROR_ID, rEC_CON_ERROR_ID :: Id pAT_ERROR_ID, nO_METHOD_BINDING_ERROR_ID, nON_EXHAUSTIVE_GUARDS_ERROR_ID :: Id@@ -1251,7 +1250,7 @@  mkRuntimeErrorId :: TypeOrConstraint -> Name -> Id -- Error function---   with type:  forall (r:RuntimeRep) (a:TYPE r). Addr# -> a+--   with type:  forall (r::RuntimeRep) (a::TYPE r). Addr# -> a --   with arity: 1 -- which diverges after being given one argument -- The Addr# is expected to be the address of
compiler/GHC/Core/Map/Expr.hs view
@@ -194,10 +194,11 @@  eqDeBruijnTickish :: DeBruijn CoreTickish -> DeBruijn CoreTickish -> Bool eqDeBruijnTickish (D env1 t1) (D env2 t2) = go t1 t2 where-    go (Breakpoint lext lid lids) (Breakpoint rext rid rids)+    go (Breakpoint lext lid lids lmod) (Breakpoint rext rid rids rmod)         =  lid == rid         && D env1 lids == D env2 rids         && lext == rext+        && lmod == rmod     go l r = l == r  -- Compares for equality, modulo alpha
compiler/GHC/Core/Opt/Arity.hs view
@@ -68,6 +68,7 @@ import GHC.Types.Demand import GHC.Types.Cpr( CprSig, mkCprSig, botCpr ) import GHC.Types.Id+import GHC.Types.Var import GHC.Types.Var.Env import GHC.Types.Var.Set import GHC.Types.Basic@@ -84,7 +85,6 @@ import GHC.Utils.Constants (debugIsOn) import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Utils.Panic.Plain import GHC.Utils.Misc  import Data.Maybe( isJust )@@ -198,8 +198,10 @@   = go initRecTc ty   where     go rec_nts ty-      | Just (_, ty')  <- splitForAllTyCoVar_maybe ty-      = go rec_nts ty'+      | Just (tcv, ty')  <- splitForAllTyCoVar_maybe ty+      = if isCoVar tcv+        then idOneShotInfo tcv : go rec_nts ty'+        else go rec_nts ty'        | Just (_,_,arg,res) <- splitFunTy_maybe ty       = typeOneShot arg : go rec_nts res@@ -513,8 +515,11 @@  Of course both (1) and (2) are readily defeated by disguising the bottoms. -4. Note [Newtype arity]-~~~~~~~~~~~~~~~~~~~~~~~~+There also is an interaction with Note [Combining arity type with demand info],+outlined in Wrinkle (CAD1).++Note [Newtype arity]+~~~~~~~~~~~~~~~~~~~~ Non-recursive newtypes are transparent, and should not get in the way. We do (currently) eta-expand recursive newtypes too.  So if we have, say @@ -716,7 +721,7 @@ now reflects the (cost-free) arity of the expression  Why do we ever need an "unsafe" ArityType, such as the example above?-Because its (cost-free) arity may increased by combineWithDemandOneShots+Because its (cost-free) arity may increased by combineWithCallCards in findRhsArity. See Note [Combining arity type with demand info].  Thus the function `arityType` returns a regular "unsafe" ArityType, that@@ -855,7 +860,7 @@  -- | The Arity returned is the number of value args the -- expression can be applied to without doing much work-exprEtaExpandArity :: HasDebugCallStack => ArityOpts -> CoreExpr -> Maybe SafeArityType+exprEtaExpandArity :: ArityOpts -> CoreExpr -> Maybe SafeArityType -- exprEtaExpandArity is used when eta expanding --      e  ==>  \xy -> e x y -- Nothing if the expression has arity 0@@ -918,14 +923,14 @@                          NonRecursive -> trimArityType ty_arity (cheapArityType rhs)      ty_arity     = typeArity (idType bndr)-    id_one_shots = idDemandOneShots bndr+    use_call_cards = useSiteCallCards bndr      step :: ArityEnv -> SafeArityType     step env = trimArityType ty_arity $                safeArityType $ -- See Note [Arity invariants for bindings], item (3)-               arityType env rhs `combineWithDemandOneShots` id_one_shots+               combineWithCallCards env (arityType env rhs) use_call_cards        -- trimArityType: see Note [Trim arity inside the loop]-       -- combineWithDemandOneShots: take account of the demand on the+       -- combineWithCallCards: take account of the demand on the        -- binder.  Perhaps it is always called with 2 args        --   let f = \x. blah in (f 3 4, f 1 9)        -- f's demand-info says how many args it is called with@@ -950,14 +955,24 @@       where         next_at = step (extendSigEnv init_env bndr cur_at) -infixl 2 `combineWithDemandOneShots`--combineWithDemandOneShots :: ArityType -> [OneShotInfo] -> ArityType+combineWithCallCards :: ArityEnv -> ArityType -> [Card] -> ArityType -- See Note [Combining arity type with demand info]-combineWithDemandOneShots at@(AT lams div) oss+combineWithCallCards env at@(AT lams div) cards   | null lams = at   | otherwise = AT (zip_lams lams oss) div   where+    oss = map card_to_oneshot cards+    card_to_oneshot n+      | isAtMostOnce n, not (pedanticBottoms env)+         -- Take care for -fpedantic-bottoms;+         -- see Note [Combining arity type with demand info], Wrinkle (CAD1)+      = OneShotLam+      | n == C_11+         -- Safe to eta-expand even in the presence of -fpedantic-bottoms+         -- see Note [Combining arity type with demand info], Wrinkle (CAD1)+      = OneShotLam+      | otherwise+      = NoOneShotInfo     zip_lams :: [ATLamInfo] -> [OneShotInfo] -> [ATLamInfo]     zip_lams lams []  = lams     zip_lams []   oss | isDeadEndDiv div = []@@ -966,29 +981,33 @@     zip_lams ((ch,os1):lams) (os2:oss)       = (ch, os1 `bestOneShot` os2) : zip_lams lams oss -idDemandOneShots :: Id -> [OneShotInfo]-idDemandOneShots bndr-  = call_arity_one_shots `zip_lams` dmd_one_shots+useSiteCallCards :: Id -> [Card]+useSiteCallCards bndr+  = call_arity_one_shots `zip_cards` dmd_one_shots   where-    call_arity_one_shots :: [OneShotInfo]+    call_arity_one_shots :: [Card]     call_arity_one_shots       | call_arity == 0 = []-      | otherwise       = NoOneShotInfo : replicate (call_arity-1) OneShotLam-    -- Call Arity analysis says the function is always called-    -- applied to this many arguments.  The first NoOneShotInfo is because-    -- if Call Arity says "always applied to 3 args" then the one-shot info-    -- we get is [NoOneShotInfo, OneShotLam, OneShotLam]+      | otherwise       = C_0N : replicate (call_arity-1) C_01+    -- Call Arity analysis says /however often the function is called/, it is+    -- always applied to this many arguments.+    -- The first C_0N is because of the "however often it is called" part.+    -- Thus if Call Arity says "always applied to 3 args" then the one-shot info+    -- we get is [C_0N, C_01, C_01]     call_arity = idCallArity bndr -    dmd_one_shots :: [OneShotInfo]+    dmd_one_shots :: [Card]     -- If the demand info is C(x,C(1,C(1,.))) then we know that an     -- application to one arg is also an application to three-    dmd_one_shots = argOneShots (idDemandInfo bndr)+    dmd_one_shots = case idDemandInfo bndr of+      AbsDmd  -> [] -- There is no use in eta expanding+      BotDmd  -> [] -- when the binding could be dropped instead+      _ :* sd -> callCards sd      -- Take the *longer* list-    zip_lams (lam1:lams1) (lam2:lams2) = (lam1 `bestOneShot` lam2) : zip_lams lams1 lams2-    zip_lams []           lams2        = lams2-    zip_lams lams1        []           = lams1+    zip_cards (n1:ns1) (n2:ns2) = (n1 `glbCard` n2) : zip_cards ns1 ns2+    zip_cards []       ns2      = ns2+    zip_cards ns1      []       = ns1  {- Note [Arity analysis] ~~~~~~~~~~~~~~~~~~~~~~~~@@ -1084,7 +1103,7 @@ result: arity=3, which is better than we could do from either source alone. -The "combining" part is done by combineWithDemandOneShots.  It+The "combining" part is done by combineWithCallCards.  It uses info from both Call Arity and demand analysis.  We may have /more/ call demands from the calls than we have lambdas@@ -1103,6 +1122,22 @@ Nor, in the case of f2, do we want to push that error call under a lambda.  Hence the takeWhile in combineWithDemandDoneShots. +Wrinkles:++(CAD1) #24296 exposed a subtle interaction with -fpedantic-bottoms+  (See Note [Dealing with bottom]). Consider++    let f = \x y. error "blah" in+    f 2 1 `seq` Just (f 3 2 1)+      -- Demand on f is C(x,C(1,C(M,L)))++  Usually, it is OK to consider a lambda that is called *at most* once (so call+  cardinality C_01, abbreviated M) a one-shot lambda and eta-expand over it.+  But with -fpedantic-bottoms that is no longer true: If we were to eta-expand+  f to arity 3, we'd discard the error raised when evaluating `f 2 1`.+  Hence in the presence of -fpedantic-bottoms, we must have C_11 for+  eta-expansion.+ Note [Do not eta-expand join points] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Similarly to CPR (see Note [Don't w/w join points for CPR] in@@ -1235,8 +1270,14 @@ floatIn :: Cost -> ArityType -> ArityType -- We have something like (let x = E in b), -- where b has the given arity type.-floatIn IsCheap     at = at-floatIn IsExpensive at = addWork at+-- NB: be as lazy as possible in the Cost-of-E argument;+--     we can often get away without ever looking at it+--     See Note [Care with nested expressions]+floatIn ch at@(AT lams div)+  = case lams of+      []                 -> at+      (IsExpensive,_):_  -> at+      (_,os):lams        -> AT ((ch,os):lams) div  addWork :: ArityType -> ArityType -- Add work to the outermost level of the arity type@@ -1319,6 +1360,25 @@ first bullet).  So 'go2' gets an arityType of \(C?)(C1).T, which is what we want. +Note [Care with nested expressions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+    arityType (Just <big-expressions>)+We will take+    arityType Just = AT [(IsCheap,os)] topDiv+and then do+    arityApp (AT [(IsCheap os)] topDiv) (exprCost <big-expression>)+The result will be AT [] topDiv.  It doesn't matter what <big-expresison>+is!  The same is true of+    arityType (let x = <rhs> in <body>)+where the cost of <rhs> doesn't matter unless <body> has a useful+arityType.++TL;DR in `floatIn`, do not to look at the Cost argument until you have to.++I found this when looking at #24471, although I don't think it was really+the main culprit.+ Note [Combining case branches: andWithTail] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When combining the ArityTypes for two case branches (with andArityType)@@ -1541,7 +1601,7 @@   = alts_type    | otherwise            -- In the remaining cases we may not push-  = addWork alts_type -- evaluation of the scrutinee in+  = addWork alts_type    -- evaluation of the scrutinee in   where     env' = delInScope env bndr     arity_type_alt (Alt _con bndrs rhs) = arityType (delInScopeList env' bndrs) rhs@@ -1882,9 +1942,8 @@ has an unfolding we have to push it into there too.  AND j might be recursive... -So for now I'm abandoning the no-crap rule in this case. I think-that for the use in CorePrep it really doesn't matter; and if-it does, then CoreToStg.myCollectArgs will fall over.+So for now I'm abandoning the no-crap rule in this case, conscious that this+causes the ugly Wrinkle (EA1) of Note [Eta expansion of arguments in CorePrep].  (Moreover, I think that casts can make the no-crap rule fail too.) @@ -2039,8 +2098,8 @@     Note that the /same/ EtaInfo drives both etaInfoAbs and etaInfoApp -To a first approximation EtaInfo is just [Var].  But-casts complicate the question.  If we have+To a first approximation EtaInfo is just [Var].  But casts complicate+the question.  If we have    newtype N a = MkN (S -> a)      axN :: N a  ~  S -> a and@@ -2056,6 +2115,20 @@     data EtaInfo = EI [Var] MCoercionR +Precisely, here is the (EtaInfo Invariant):++  EI bs co :: EtaInfo++describes a particular eta-expansion, thus:++  Abstraction:  (\b1 b2 .. bn. []) |> sym co+  Application:  ([] |> co) b1 b2 .. bn++  e  :: T+  co :: T ~R (t1 -> t2 -> .. -> tn -> tr)+  e = (\b1 b2 ... bn. (e |> co) b1 b2 .. bn) |> sym co++ Note [Check for reflexive casts in eta expansion] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ It turns out that the casts created by the above mechanism are often Refl.@@ -2111,13 +2184,7 @@  -------------- data EtaInfo = EI [Var] MCoercionR---- (EI bs co) describes a particular eta-expansion, as follows:---  Abstraction:  (\b1 b2 .. bn. []) |> sym co---  Application:  ([] |> co) b1 b2 .. bn------    e :: T    co :: T ~ (t1 -> t2 -> .. -> tn -> tr)---    e = (\b1 b2 ... bn. (e |> co) b1 b2 .. bn) |> sym co+     -- See Note [The EtaInfo mechanism]  instance Outputable EtaInfo where   ppr (EI vs mco) = text "EI" <+> ppr vs <+> parens (ppr mco)@@ -2231,14 +2298,14 @@      go n oss@(one_shot:oss1) subst ty        ----------- Forall types  (forall a. ty)-       | Just (tcv,ty') <- splitForAllTyCoVar_maybe ty+       | Just (Bndr tcv vis, ty') <- splitForAllForAllTyBinder_maybe ty        , (subst', tcv') <- Type.substVarBndr subst tcv        , let oss' | isTyVar tcv = oss                   | otherwise   = oss1          -- A forall can bind a CoVar, in which case          -- we consume one of the [OneShotInfo]        , (in_scope, EI bs mco) <- go n oss' subst' ty'-       = (in_scope, EI (tcv' : bs) (mkHomoForAllMCo tcv' mco))+       = (in_scope, EI (tcv' : bs) (mkEtaForAllMCo (Bndr tcv' vis) ty' mco))         ----------- Function types  (t1 -> t2)        | Just (_af, mult, arg_ty, res_ty) <- splitFunTy_maybe ty@@ -2281,6 +2348,19 @@         -- So we simply decline to eta-expand.  Otherwise we'd end up         -- with an explicit lambda having a non-function type +mkEtaForAllMCo :: ForAllTyBinder -> Type -> MCoercion -> MCoercion+mkEtaForAllMCo (Bndr tcv vis) ty mco+  = case mco of+      MRefl | vis == coreTyLamForAllTyFlag -> MRefl+            | otherwise                    -> mk_fco (mkRepReflCo ty)+      MCo co                               -> mk_fco co+  where+    mk_fco co = MCo (mkForAllCo tcv vis coreTyLamForAllTyFlag+                                (mkNomReflCo (varType tcv)) co)+    -- coreTyLamForAllTyFlag: See Note [The EtaInfo mechanism], particularly+    -- the (EtaInfo Invariant).  (sym co) wraps a lambda that always has+    -- a ForAllTyFlag of coreTyLamForAllTyFlag; see wrinkle (FC4) in+    -- Note [ForAllCo] in GHC.Core.TyCo.Rep  {- ************************************************************************@@ -2720,9 +2800,19 @@                                --   (and similarly for tyvars, coercion args)                     , [CoreTickish])     -- See Note [Eta reduction with casted arguments]-    ok_arg bndr (Type ty) co _-       | Just tv <- getTyVar_maybe ty-       , bndr == tv  = Just (mkHomoForAllCos [tv] co, [])+    ok_arg bndr (Type arg_ty) co fun_ty+       | Just tv <- getTyVar_maybe arg_ty+       , bndr == tv  = case splitForAllForAllTyBinder_maybe fun_ty of+           Just (Bndr _ vis, _) -> Just (fco, [])+             where !fco = mkForAllCo tv vis coreTyLamForAllTyFlag kco co+                   -- The lambda we are eta-reducing always has visibility+                   -- 'coreTyLamForAllTyFlag' which may or may not match+                   -- the visibility on the inner function (#24014)+                   kco = mkNomReflCo (tyVarKind tv)+           Nothing -> pprPanic "tryEtaReduce: type arg to non-forall type"+                               (text "fun:" <+> ppr bndr+                                $$ text "arg:" <+> ppr arg_ty+                                $$ text "fun_ty:" <+> ppr fun_ty)     ok_arg bndr (Var v) co fun_ty        | bndr == v        , let mult = idMult bndr
compiler/GHC/Core/Opt/ConstantFold.hs view
@@ -34,6 +34,7 @@ import GHC.Prelude  import GHC.Platform+import GHC.Float  import GHC.Types.Id.Make ( unboxedUnitExpr ) import GHC.Types.Id@@ -54,9 +55,8 @@ import GHC.Core.Type import GHC.Core.TyCo.Compare( eqType ) import GHC.Core.TyCon-   ( tyConDataCons_maybe, isAlgTyCon, isEnumerationTyCon-   , isNewTyCon, tyConDataCons-   , tyConFamilySize, isTypeDataTyCon )+   ( TyCon, tyConDataCons_maybe, tyConDataCons, tyConFamilySize+   , isEnumerationTyCon, isValidDTT2TyCon, isNewTyCon ) import GHC.Core.Map.Expr ( eqCoreExpr )  import GHC.Builtin.PrimOps ( PrimOp(..), tagToEnumKey )@@ -74,7 +74,6 @@ import GHC.Utils.Outputable import GHC.Utils.Misc import GHC.Utils.Panic-import GHC.Utils.Panic.Plain  import Control.Applicative ( Alternative(..) ) import Control.Monad@@ -104,7 +103,8 @@ primOpRules ::  Name -> PrimOp -> Maybe CoreRule primOpRules nm = \case    TagToEnumOp -> mkPrimOpRule nm 2 [ tagToEnumRule ]-   DataToTagOp -> mkPrimOpRule nm 2 [ dataToTagRule ]+   DataToTagSmallOp -> mkPrimOpRule nm 3 [ dataToTagRule ]+   DataToTagLargeOp -> mkPrimOpRule nm 3 [ dataToTagRule ]     -- Int8 operations    Int8AddOp   -> mkPrimOpRule nm 2 [ binaryLit (int8Op2 (+))@@ -658,6 +658,38 @@                                        , removeOp32                                        , narrowSubsumesAnd WordAndOp Narrow32WordOp 32 ] +   CastWord64ToDoubleOp -> mkPrimOpRule nm 1+      [ unaryLit $ \_env -> \case+         LitNumber _ n+             | v <- castWord64ToDouble (fromInteger n)+             -- we can't represent those float literals in Core until #18897 is fixed+             , not (isNaN v || isInfinite v || isNegativeZero v)+             -> Just (mkDoubleLitDouble v)+         _   -> Nothing+      ]++   CastWord32ToFloatOp -> mkPrimOpRule nm 1+      [ unaryLit $ \_env -> \case+          LitNumber _ n+              | v <- castWord32ToFloat (fromInteger n)+              -- we can't represent those float literals in Core until #18897 is fixed+              , not (isNaN v || isInfinite v || isNegativeZero v)+              -> Just (mkFloatLitFloat v)+          _   -> Nothing+      ]++   CastDoubleToWord64Op -> mkPrimOpRule nm 1+      [ unaryLit $ \_env -> \case+         LitDouble n -> Just (mkWord64LitWord64 (castDoubleToWord64 (fromRational n)))+         _           -> Nothing+      ]++   CastFloatToWord32Op -> mkPrimOpRule nm 1+      [ unaryLit $ \_env -> \case+          LitFloat n -> Just (mkWord32LitWord32 (castFloatToWord32 (fromRational n)))+          _          -> Nothing+      ]+    OrdOp          -> mkPrimOpRule nm 1 [ liftLit charToIntLit                                        , semiInversePrimOp ChrOp ]    ChrOp          -> mkPrimOpRule nm 1 [ do [Lit lit] <- getArgs@@ -1099,7 +1131,7 @@     _ | shift_len == 0 -> pure e1        -- See Note [Guarding against silly shifts]-    _ | shift_len < 0 || shift_len > bit_size+    _ | shift_len < 0 || shift_len >= bit_size       -> pure $ Lit $ mkLitNumberWrap platform lit_num_ty 0            -- Be sure to use lit_num_ty here, so we get a correctly typed zero.            -- See #18589@@ -1581,15 +1613,15 @@     let x = I# (error "invalid shift")     in ... -This was originally done in the fix to #16449 but this breaks the let-can-float-invariant (see Note [Core let-can-float invariant] in GHC.Core) as noted in #16742.-For the reasons discussed in Note [Checking versus non-checking-primops] (in the PrimOp module) there is no safe way to rewrite the argument of I#-such that it bottoms.+This was originally done in the fix to #16449 but this breaks the+let-can-float invariant (see Note [Core let-can-float invariant] in+GHC.Core) as noted in #16742.  For the reasons discussed under+"NoEffect" in Note [Classifying primop effects] (in GHC.Builtin.PrimOps)+there is no safe way to rewrite the argument of I# such that it bottoms. -Consequently we instead take advantage of the fact that large shifts are-undefined behavior (see associated documentation in primops.txt.pp) and-transform the invalid shift into an "obviously incorrect" value.+Consequently we instead take advantage of the fact that the result of a+large shift is unspecified (see associated documentation in primops.txt.pp)+and transform the invalid shift into an "obviously incorrect" value.  There are two cases: @@ -1987,12 +2019,14 @@  ------------------------------ dataToTagRule :: RuleM CoreExpr--- See Note [dataToTag# magic].+-- Used for both dataToTagSmall# and dataToTagLarge#.+-- See Note [DataToTag overview] in GHC.Tc.Instance.Class,+-- particularly wrinkle DTW5. dataToTagRule = a `mplus` b   where     -- dataToTag (tagToEnum x)   ==>   x     a = do-      [Type ty1, Var tag_to_enum `App` Type ty2 `App` tag] <- getArgs+      [Type _lev, Type ty1, Var tag_to_enum `App` Type ty2 `App` tag] <- getArgs       guard $ tag_to_enum `hasKey` tagToEnumKey       guard $ ty1 `eqType` ty2       return tag@@ -2003,42 +2037,13 @@     -- where x's unfolding is a constructor application     b = do       platform <- getPlatform-      [_, val_arg] <- getArgs+      [_lev, _ty, val_arg] <- getArgs       in_scope <- getInScopeEnv       (_,floats, dc,_,_) <- liftMaybe $ exprIsConApp_maybe in_scope val_arg       massert (not (isNewTyCon (dataConTyCon dc)))       return $ wrapFloats floats (mkIntVal platform (toInteger (dataConTagZ dc))) -{- Note [dataToTag# magic]-~~~~~~~~~~~~~~~~~~~~~~~~~~-The primop dataToTag# is unusual because it evaluates its argument.-Only `SeqOp` shares that property.  (Other primops do not do anything-as fancy as argument evaluation.)  The special handling for dataToTag#-is: -* GHC.Core.Utils.exprOkForSpeculation has a special case for DataToTagOp,-  (actually in app_ok).  Most primops with lifted arguments do not-  evaluate those arguments, but DataToTagOp and SeqOp are two-  exceptions.  We say that they are /never/ ok-for-speculation,-  regardless of the evaluated-ness of their argument.-  See GHC.Core.Utils Note [exprOkForSpeculation and SeqOp/DataToTagOp]--* There is a special case for DataToTagOp in GHC.StgToCmm.Expr.cgExpr,-  that evaluates its argument and then extracts the tag from-  the returned value.--* An application like (dataToTag# (Just x)) is optimised by-  dataToTagRule in GHC.Core.Opt.ConstantFold.--* A case expression like-     case (dataToTag# e) of <alts>-  gets transformed t-     case e of <transformed alts>-  by GHC.Core.Opt.ConstantFold.caseRules; see Note [caseRules for dataToTag]--See #15696 for a long saga.--}- {- ********************************************************************* *                                                                      *              unsafeEqualityProof@@ -2088,7 +2093,7 @@ * Why do we need a primop at all?  That is, instead of       case seq# x s of (# x, s #) -> blah   why not instead say this?-      case x of { DEFAULT -> blah)+      case x of { DEFAULT -> blah }    Reason (see #5129): if we saw     catch# (\s -> case x of { DEFAULT -> raiseIO# exn s }) handler@@ -2113,12 +2118,12 @@  - GHC.StgToCmm.Expr.cgExpr, and cgCase: special case for seq# -- GHC.Core.Utils.exprOkForSpeculation;-  see Note [exprOkForSpeculation and SeqOp/DataToTagOp] in GHC.Core.Utils- - Simplify.addEvals records evaluated-ness for the result; see   Note [Adding evaluatedness info to pattern-bound variables]-  in GHC.Core.Opt.Simplify+  in GHC.Core.Opt.Simplify.Iteration++- Likewise, GHC.Stg.InferTags.inferTagExpr knows that seq# returns a+  properly-tagged pointer inside of its unboxed-tuple result. -}  seqRule :: RuleM CoreExpr@@ -3404,21 +3409,29 @@            , \v -> (App (App (Var f) type_arg) (Var v)))  -- See Note [caseRules for dataToTag]-caseRules _ (App (App (Var f) (Type ty)) v)       -- dataToTag x-  | Just DataToTagOp <- isPrimOpId_maybe f-  , Just (tc, _) <- tcSplitTyConApp_maybe ty-  , isAlgTyCon tc-  , not (isTypeDataTyCon tc) -- See wrinkle (W2c) in GHC.Rename.Module-                             -- Note [Type data declarations]-  = Just (v, tx_con_dtt ty-           , \v -> App (App (Var f) (Type ty)) (Var v))+caseRules _ (Var f `App` Type lev `App` Type ty `App` v) -- dataToTag x+  | Just op <- isPrimOpId_maybe f+  , op == DataToTagSmallOp || op == DataToTagLargeOp+  = case splitTyConApp_maybe ty of+      Just (tc, _) | isValidDTT2TyCon tc+        -> Just (v, tx_con_dtt tc+                , \v' -> Var f `App` Type lev `App` Type ty `App` Var v')+      _ -> pprTraceUserWarning warnMsg Nothing+  where+    warnMsg = vcat $ map text+      [ "Found dataToTag primop applied to a non-ADT type. This could"+      , "be a future bug in GHC, or it may be caused by an unsupported"+      , "use of the ghc-internal primops dataToTagSmall# and dataToTagLarge#."+      , "In either case, the GHC developers would like to know about it!"+      , "Please report this as a GHC bug:  http://www.haskell.org/ghc/reportabug"+      ]  caseRules _ _ = Nothing   -- | Case rules ----- It's important that occurence info are present, hence the use of In* types.+-- It's important that occurrence info are present, hence the use of In* types. caseRules2    :: InExpr  -- ^ Scutinee    -> InId    -- ^ Case-binder@@ -3519,9 +3532,9 @@ tx_con_tte platform (DataAlt dc)  -- See Note [caseRules for tagToEnum]   = Just $ LitAlt $ mkLitInt platform $ toInteger $ dataConTagZ dc -tx_con_dtt :: Type -> AltCon -> Maybe AltCon+tx_con_dtt :: TyCon -> AltCon -> Maybe AltCon tx_con_dtt _  DEFAULT = Just DEFAULT-tx_con_dtt ty (LitAlt (LitNumber LitNumInt i))+tx_con_dtt tc (LitAlt (LitNumber LitNumInt i))    | tag >= 0    , tag < n_data_cons    = Just (DataAlt (data_cons !! tag))   -- tag is zero-indexed, as is (!!)@@ -3529,17 +3542,16 @@    = Nothing    where      tag         = fromInteger i :: ConTagZ-     tc          = tyConAppTyCon ty      n_data_cons = tyConFamilySize tc      data_cons   = tyConDataCons tc -tx_con_dtt _ alt = pprPanic "caseRules" (ppr alt)+tx_con_dtt _ alt = pprPanic "caseRules/dataToTag: bad alt" (ppr alt)   {- Note [caseRules for tagToEnum] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We want to transform-   case tagToEnum x of+   case tagToEnum# x of      False -> e1      True  -> e2 into@@ -3547,13 +3559,13 @@      0# -> e1      1# -> e2 -This rule eliminates a lot of boilerplate. For+See #8317.   This rule eliminates a lot of boilerplate. For   if (x>y) then e2 else e1 we generate-  case tagToEnum (x ># y) of+  case tagToEnum# (x ># y) of     False -> e1     True  -> e2-and it is nice to then get rid of the tagToEnum.+and it is nice to then get rid of the tagToEnum#.  Beware (#14768): avoid the temptation to map constructor 0 to DEFAULT, in the hope of getting this@@ -3571,15 +3583,16 @@       DEFAULT -> e1       DEFAULT -> e2 -Instead, we deal with turning one branch into DEFAULT in GHC.Core.Opt.Simplify.Utils-(add_default in mkCase3).+Instead, when possible, we turn one branch into DEFAULT in+GHC.Core.Opt.Simplify.Utils.mkCase2; see Note [Literal cases]+in that module.  Note [caseRules for dataToTag] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-See also Note [dataToTag# magic].+See also Note [DataToTag overview] in GHC.Tc.Instance.Class.  We want to transform-  case dataToTag x of+  case dataToTagSmall# x of     DEFAULT -> e1     1# -> e2 into@@ -3587,14 +3600,23 @@     DEFAULT -> e1     (:) _ _ -> e2 -Note the need for some wildcard binders in-the 'cons' case.+(Note the need for some wildcard binders in the 'cons' case.) -For the time, we only apply this transformation when the type of `x` is a type-headed by a normal tycon. In particular, we do not apply this in the case of a-data family tycon, since that would require carefully applying coercion(s)-between the data family and the data family instance's representation type,-which caseRules isn't currently engineered to handle (#14680).+This transformation often enables further optimisation via+case-flattening and case-of-known-constructor and can be very+important for code using derived Eq instances.++We can apply this transformation only when we can easily get the+constructors from the type at which dataToTagSmall# is used.  And we+cannot apply this transformation at "type data"-related types without+breaking invariant I1 from Note [Type data declarations] in+GHC.Rename.Module.  That leaves exactly the types satisfying condition+DTT2 from Note [DataToTag overview] in GHC.Tc.Instance.Class.++All of the above applies identically for `dataToTagLarge#`.  And+thanks to wrinkle DTW5, there is no need to worry about large-tag+arguments for `dataToTagSmall#`; those cause undefined behavior anyway.+  Note [Unreachable caseRules alternatives] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
compiler/GHC/Core/Opt/OccurAnal.hs view
@@ -1,3589 +1,3992 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE ViewPatterns #-}--{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}--{--(c) The GRASP/AQUA Project, Glasgow University, 1992-1998--************************************************************************-*                                                                      *-\section[OccurAnal]{Occurrence analysis pass}-*                                                                      *-************************************************************************--The occurrence analyser re-typechecks a core expression, returning a new-core expression with (hopefully) improved usage information.--}--module GHC.Core.Opt.OccurAnal (-    occurAnalysePgm,-    occurAnalyseExpr,-    zapLambdaBndrs, scrutBinderSwap_maybe-  ) where--import GHC.Prelude hiding ( head, init, last, tail )--import GHC.Core-import GHC.Core.FVs-import GHC.Core.Utils   ( exprIsTrivial, isDefaultAlt, isExpandableApp,-                          mkCastMCo, mkTicks )-import GHC.Core.Opt.Arity   ( joinRhsArity, isOneShotBndr )-import GHC.Core.Coercion-import GHC.Core.Predicate   ( isDictId )-import GHC.Core.Type-import GHC.Core.TyCo.FVs    ( tyCoVarsOfMCo )--import GHC.Data.Maybe( isJust, orElse )-import GHC.Data.Graph.Directed ( SCC(..), Node(..)-                               , stronglyConnCompFromEdgedVerticesUniq-                               , stronglyConnCompFromEdgedVerticesUniqR )-import GHC.Types.Unique-import GHC.Types.Unique.FM-import GHC.Types.Unique.Set-import GHC.Types.Id-import GHC.Types.Id.Info-import GHC.Types.Basic-import GHC.Types.Tickish-import GHC.Types.Var.Set-import GHC.Types.Var.Env-import GHC.Types.Var-import GHC.Types.Demand ( argOneShots, argsOneShots )--import GHC.Utils.Outputable-import GHC.Utils.Panic-import GHC.Utils.Panic.Plain-import GHC.Utils.Misc--import GHC.Builtin.Names( runRWKey )-import GHC.Unit.Module( Module )--import Data.List (mapAccumL, mapAccumR)-import Data.List.NonEmpty (NonEmpty (..))-import qualified Data.List.NonEmpty as NE--{--************************************************************************-*                                                                      *-    occurAnalysePgm, occurAnalyseExpr-*                                                                      *-************************************************************************--Here's the externally-callable interface:--}---- | Do occurrence analysis, and discard occurrence info returned-occurAnalyseExpr :: CoreExpr -> CoreExpr-occurAnalyseExpr expr = expr'-  where-    (WithUsageDetails _ expr') = occAnal initOccEnv expr--occurAnalysePgm :: Module         -- Used only in debug output-                -> (Id -> Bool)         -- Active unfoldings-                -> (Activation -> Bool) -- Active rules-                -> [CoreRule]           -- Local rules for imported Ids-                -> CoreProgram -> CoreProgram-occurAnalysePgm this_mod active_unf active_rule imp_rules binds-  | isEmptyDetails final_usage-  = occ_anald_binds--  | otherwise   -- See Note [Glomming]-  = warnPprTrace True "Glomming in" (hang (ppr this_mod <> colon) 2 (ppr final_usage))-    occ_anald_glommed_binds-  where-    init_env = initOccEnv { occ_rule_act = active_rule-                          , occ_unf_act  = active_unf }--    (WithUsageDetails final_usage occ_anald_binds) = go init_env binds-    (WithUsageDetails _ occ_anald_glommed_binds) = occAnalRecBind init_env TopLevel-                                                    imp_rule_edges-                                                    (flattenBinds binds)-                                                    initial_uds-          -- It's crucial to re-analyse the glommed-together bindings-          -- so that we establish the right loop breakers. Otherwise-          -- we can easily create an infinite loop (#9583 is an example)-          ---          -- Also crucial to re-analyse the /original/ bindings-          -- in case the first pass accidentally discarded as dead code-          -- a binding that was actually needed (albeit before its-          -- definition site).  #17724 threw this up.--    initial_uds = addManyOccs emptyDetails (rulesFreeVars imp_rules)-    -- The RULES declarations keep things alive!--    -- imp_rule_edges maps a top-level local binder 'f' to the-    -- RHS free vars of any IMP-RULE, a local RULE for an imported function,-    -- where 'f' appears on the LHS-    --   e.g.  RULE foldr f = blah-    --         imp_rule_edges contains f :-> fvs(blah)-    -- We treat such RULES as extra rules for 'f'-    -- See Note [Preventing loops due to imported functions rules]-    imp_rule_edges :: ImpRuleEdges-    imp_rule_edges = foldr (plusVarEnv_C (++)) emptyVarEnv-                           [ mapVarEnv (const [(act,rhs_fvs)]) $ getUniqSet $-                             exprsFreeIds args `delVarSetList` bndrs-                           | Rule { ru_act = act, ru_bndrs = bndrs-                                   , ru_args = args, ru_rhs = rhs } <- imp_rules-                                   -- Not BuiltinRules; see Note [Plugin rules]-                           , let rhs_fvs = exprFreeIds rhs `delVarSetList` bndrs ]--    go :: OccEnv -> [CoreBind] -> WithUsageDetails [CoreBind]-    go !_ []-        = WithUsageDetails initial_uds []-    go env (bind:binds)-        = WithUsageDetails final_usage (bind' ++ binds')-        where-           (WithUsageDetails bs_usage binds')   = go env binds-           (WithUsageDetails final_usage bind') = occAnalBind env TopLevel imp_rule_edges bind bs_usage--{- *********************************************************************-*                                                                      *-                IMP-RULES-         Local rules for imported functions-*                                                                      *-********************************************************************* -}--type ImpRuleEdges = IdEnv [(Activation, VarSet)]-    -- Mapping from a local Id 'f' to info about its IMP-RULES,-    -- i.e. /local/ rules for an imported Id that mention 'f' on the LHS-    -- We record (a) its Activation and (b) the RHS free vars-    -- See Note [IMP-RULES: local rules for imported functions]--noImpRuleEdges :: ImpRuleEdges-noImpRuleEdges = emptyVarEnv--lookupImpRules :: ImpRuleEdges -> Id -> [(Activation,VarSet)]-lookupImpRules imp_rule_edges bndr-  = case lookupVarEnv imp_rule_edges bndr of-      Nothing -> []-      Just vs -> vs--impRulesScopeUsage :: [(Activation,VarSet)] -> UsageDetails--- Variable mentioned in RHS of an IMP-RULE for the bndr,--- whether active or not-impRulesScopeUsage imp_rules_info-  = foldr add emptyDetails imp_rules_info-  where-    add (_,vs) usage = addManyOccs usage vs--impRulesActiveFvs :: (Activation -> Bool) -> VarSet-                  -> [(Activation,VarSet)] -> VarSet-impRulesActiveFvs is_active bndr_set vs-  = foldr add emptyVarSet vs `intersectVarSet` bndr_set-  where-    add (act,vs) acc | is_active act = vs `unionVarSet` acc-                     | otherwise     = acc--{- Note [IMP-RULES: local rules for imported functions]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We quite often have-  * A /local/ rule-  * for an /imported/ function-like this:-  foo x = blah-  {-# RULE "map/foo" forall xs. map foo xs = xs #-}-We call them IMP-RULES.  They are important in practice, and occur a-lot in the libraries.--IMP-RULES are held in mg_rules of ModGuts, and passed in to-occurAnalysePgm.--Main Invariant:--* Throughout, we treat an IMP-RULE that mentions 'f' on its LHS-  just like a RULE for f.--Note [IMP-RULES: unavoidable loops]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider this-   f = /\a. B.g a-   RULE B.g Int = 1 + f Int-Note that-  * The RULE is for an imported function.-  * f is non-recursive-Now we-can get-   f Int --> B.g Int      Inlining f-         --> 1 + f Int    Firing RULE-and so the simplifier goes into an infinite loop. This-would not happen if the RULE was for a local function,-because we keep track of dependencies through rules.  But-that is pretty much impossible to do for imported Ids.  Suppose-f's definition had been-   f = /\a. C.h a-where (by some long and devious process), C.h eventually inlines to-B.g.  We could only spot such loops by exhaustively following-unfoldings of C.h etc, in case we reach B.g, and hence (via the RULE)-f.--We regard this potential infinite loop as a *programmer* error.-It's up the programmer not to write silly rules like-     RULE f x = f x-and the example above is just a more complicated version.--Note [Specialising imported functions] (referred to from Specialise)-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-For *automatically-generated* rules, the programmer can't be-responsible for the "programmer error" in Note [IMP-RULES: unavoidable-loops].  In particular, consider specialising a recursive function-defined in another module.  If we specialise a recursive function B.g,-we get-  g_spec = .....(B.g Int).....-  RULE B.g Int = g_spec-Here, g_spec doesn't look recursive, but when the rule fires, it-becomes so.  And if B.g was mutually recursive, the loop might not be-as obvious as it is here.--To avoid this,- * When specialising a function that is a loop breaker,-   give a NOINLINE pragma to the specialised function--Note [Preventing loops due to imported functions rules]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider:-  import GHC.Base (foldr)--  {-# RULES "filterList" forall p. foldr (filterFB (:) p) [] = filter p #-}-  filter p xs = build (\c n -> foldr (filterFB c p) n xs)-  filterFB c p = ...--  f = filter p xs--Note that filter is not a loop-breaker, so what happens is:-  f =          filter p xs-    = {inline} build (\c n -> foldr (filterFB c p) n xs)-    = {inline} foldr (filterFB (:) p) [] xs-    = {RULE}   filter p xs--We are in an infinite loop.--A more elaborate example (that I actually saw in practice when I went to-mark GHC.List.filter as INLINABLE) is as follows. Say I have this module:-  {-# LANGUAGE RankNTypes #-}-  module GHCList where--  import Prelude hiding (filter)-  import GHC.Base (build)--  {-# INLINABLE filter #-}-  filter :: (a -> Bool) -> [a] -> [a]-  filter p [] = []-  filter p (x:xs) = if p x then x : filter p xs else filter p xs--  {-# NOINLINE [0] filterFB #-}-  filterFB :: (a -> b -> b) -> (a -> Bool) -> a -> b -> b-  filterFB c p x r | p x       = x `c` r-                   | otherwise = r--  {-# RULES-  "filter"     [~1] forall p xs.  filter p xs = build (\c n -> foldr-  (filterFB c p) n xs)-  "filterList" [1]  forall p.     foldr (filterFB (:) p) [] = filter p-   #-}--Then (because RULES are applied inside INLINABLE unfoldings, but inlinings-are not), the unfolding given to "filter" in the interface file will be:-  filter p []     = []-  filter p (x:xs) = if p x then x : build (\c n -> foldr (filterFB c p) n xs)-                           else     build (\c n -> foldr (filterFB c p) n xs--Note that because this unfolding does not mention "filter", filter is not-marked as a strong loop breaker. Therefore at a use site in another module:-  filter p xs-    = {inline}-      case xs of []     -> []-                 (x:xs) -> if p x then x : build (\c n -> foldr (filterFB c p) n xs)-                                  else     build (\c n -> foldr (filterFB c p) n xs)--  build (\c n -> foldr (filterFB c p) n xs)-    = {inline} foldr (filterFB (:) p) [] xs-    = {RULE}   filter p xs--And we are in an infinite loop again, except that this time the loop is producing an-infinitely large *term* (an unrolling of filter) and so the simplifier finally-dies with "ticks exhausted"--SOLUTION: we treat the rule "filterList" as an extra rule for 'filterFB'-because it mentions 'filterFB' on the LHS.  This is the Main Invariant-in Note [IMP-RULES: local rules for imported functions].--So, during loop-breaker analysis:--- for each active RULE for a local function 'f' we add an edge between-  'f' and the local FVs of the rule RHS--- for each active RULE for an *imported* function we add dependency-  edges between the *local* FVS of the rule LHS and the *local* FVS of-  the rule RHS.--Even with this extra hack we aren't always going to get things-right. For example, it might be that the rule LHS mentions an imported-Id, and another module has a RULE that can rewrite that imported Id to-one of our local Ids.--Note [Plugin rules]-~~~~~~~~~~~~~~~~~~~-Conal Elliott (#11651) built a GHC plugin that added some-BuiltinRules (for imported Ids) to the mg_rules field of ModGuts, to-do some domain-specific transformations that could not be expressed-with an ordinary pattern-matching CoreRule.  But then we can't extract-the dependencies (in imp_rule_edges) from ru_rhs etc, because a-BuiltinRule doesn't have any of that stuff.--So we simply assume that BuiltinRules have no dependencies, and filter-them out from the imp_rule_edges comprehension.--Note [Glomming]-~~~~~~~~~~~~~~~-RULES for imported Ids can make something at the top refer to-something at the bottom:--        foo = ...(B.f @Int)...-        $sf = blah-        RULE:  B.f @Int = $sf--Applying this rule makes foo refer to $sf, although foo doesn't appear to-depend on $sf.  (And, as in Note [IMP-RULES: local rules for imported functions], the-dependency might be more indirect. For example, foo might mention C.t-rather than B.f, where C.t eventually inlines to B.f.)--NOTICE that this cannot happen for rules whose head is a-locally-defined function, because we accurately track dependencies-through RULES.  It only happens for rules whose head is an imported-function (B.f in the example above).--Solution:-  - When simplifying, bring all top level identifiers into-    scope at the start, ignoring the Rec/NonRec structure, so-    that when 'h' pops up in f's rhs, we find it in the in-scope set-    (as the simplifier generally expects). This happens in simplTopBinds.--  - In the occurrence analyser, if there are any out-of-scope-    occurrences that pop out of the top, which will happen after-    firing the rule:      f = \x -> h x-                          h = \y -> 3-    then just glom all the bindings into a single Rec, so that-    the *next* iteration of the occurrence analyser will sort-    them all out.   This part happens in occurAnalysePgm.--This is a legitimate situation where the need for glomming doesn't-point to any problems. However, when GHC is compiled with -DDEBUG, we-produce a warning addressed to the GHC developers just in case we-require glomming due to an out-of-order reference that is caused by-some earlier transformation stage misbehaving.--}--{--************************************************************************-*                                                                      *-                Bindings-*                                                                      *-************************************************************************--Note [Recursive bindings: the grand plan]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Loop breaking is surprisingly subtle.  First read the section 4 of-"Secrets of the GHC inliner".  This describes our basic plan.  We-avoid infinite inlinings by choosing loop breakers, and ensuring that-a loop breaker cuts each loop.--See also Note [Inlining and hs-boot files] in GHC.Core.ToIface, which-deals with a closely related source of infinite loops.--When we come across a binding group-  Rec { x1 = r1; ...; xn = rn }-we treat it like this (occAnalRecBind):--1. Note [Forming Rec groups]-   Occurrence-analyse each right hand side, and build a-   "Details" for each binding to capture the results.-   Wrap the details in a LetrecNode, ready for SCC analysis.-   All this is done by makeNode.--   The edges of this graph are the "scope edges".--2. Do SCC-analysis on these Nodes:-   - Each CyclicSCC will become a new Rec-   - Each AcyclicSCC will become a new NonRec--   The key property is that every free variable of a binding is-   accounted for by the scope edges, so that when we are done-   everything is still in scope.--3. For each AcyclicSCC, just make a NonRec binding.--4. For each CyclicSCC of the scope-edge SCC-analysis in (2), we-   identify suitable loop-breakers to ensure that inlining terminates.-   This is done by occAnalRec.--   To do so, form the loop-breaker graph, do SCC analysis. For each-   CyclicSCC we choose a loop breaker, delete all edges to that node,-   re-analyse the SCC, and iterate. See Note [Choosing loop breakers]-   for the details---Note [Dead code]-~~~~~~~~~~~~~~~~-Dropping dead code for a cyclic Strongly Connected Component is done-in a very simple way:--        the entire SCC is dropped if none of its binders are mentioned-        in the body; otherwise the whole thing is kept.--The key observation is that dead code elimination happens after-dependency analysis: so 'occAnalBind' processes SCCs instead of the-original term's binding groups.--Thus 'occAnalBind' does indeed drop 'f' in an example like--        letrec f = ...g...-               g = ...(...g...)...-        in-           ...g...--when 'g' no longer uses 'f' at all (eg 'f' does not occur in a RULE in-'g'). 'occAnalBind' first consumes 'CyclicSCC g' and then it consumes-'AcyclicSCC f', where 'body_usage' won't contain 'f'.--Note [Forming Rec groups]-~~~~~~~~~~~~~~~~~~~~~~~~~-The key point about the "Forming Rec groups" step is that it /preserves-scoping/.  If 'x' is mentioned, it had better be bound somewhere.  So if-we start with-  Rec { f = ...h...-      ; g = ...f...-      ; h = ...f... }-we can split into SCCs-  Rec { f = ...h...-      ; h = ..f... }-  NonRec { g = ...f... }--We put bindings {f = ef; g = eg } in a Rec group if "f uses g" and "g-uses f", no matter how indirectly.  We do a SCC analysis with an edge-f -> g if "f mentions g". That is, g is free in:-  a) the rhs 'ef'-  b) or the RHS of a rule for f, whether active or inactive-       Note [Rules are extra RHSs]-  c) or the LHS or a rule for f, whether active or inactive-       Note [Rule dependency info]-  d) the RHS of an /active/ local IMP-RULE-       Note [IMP-RULES: local rules for imported functions]--(b) and (c) apply regardless of the activation of the RULE, because even if-the rule is inactive its free variables must be bound.  But (d) doesn't need-to worry about this because IMP-RULES are always notionally at the bottom-of the file.--  * Note [Rules are extra RHSs]-    ~~~~~~~~~~~~~~~~~~~~~~~~~~~-    A RULE for 'f' is like an extra RHS for 'f'. That way the "parent"-    keeps the specialised "children" alive.  If the parent dies-    (because it isn't referenced any more), then the children will die-    too (unless they are already referenced directly).--    So in Example [eftInt], eftInt and eftIntFB will be put in the-    same Rec, even though their 'main' RHSs are both non-recursive.--    We must also include inactive rules, so that their free vars-    remain in scope.--  * Note [Rule dependency info]-    ~~~~~~~~~~~~~~~~~~~~~~~~~~~-    The VarSet in a RuleInfo is used for dependency analysis in the-    occurrence analyser.  We must track free vars in *both* lhs and rhs.-    Hence use of idRuleVars, rather than idRuleRhsVars in occAnalBind.-    Why both? Consider-        x = y-        RULE f x = v+4-    Then if we substitute y for x, we'd better do so in the-    rule's LHS too, so we'd better ensure the RULE appears to mention 'x'-    as well as 'v'--  * Note [Rules are visible in their own rec group]-    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-    We want the rules for 'f' to be visible in f's right-hand side.-    And we'd like them to be visible in other functions in f's Rec-    group.  E.g. in Note [Specialisation rules] we want f' rule-    to be visible in both f's RHS, and fs's RHS.--    This means that we must simplify the RULEs first, before looking-    at any of the definitions.  This is done by Simplify.simplRecBind,-    when it calls addLetIdInfo.--Note [TailUsageDetails when forming Rec groups]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The `TailUsageDetails` stored in the `nd_uds` field of a `NodeDetails` is-computed by `occAnalLamTail` applied to the RHS, not `occAnalExpr`.-That is because the binding might still become a *non-recursive join point* in-the AcyclicSCC case of dependency analysis!-Hence we do the delayed `adjustTailUsage` in `occAnalRec`/`tagRecBinders` to get-a regular, adjusted UsageDetails.-See Note [Join points and unfoldings/rules] for more details on the contract.--Note [Stable unfoldings]-~~~~~~~~~~~~~~~~~~~~~~~~-None of the above stuff about RULES applies to a stable unfolding-stored in a CoreUnfolding.  The unfolding, if any, is simplified-at the same time as the regular RHS of the function (ie *not* like-Note [Rules are visible in their own rec group]), so it should be-treated *exactly* like an extra RHS.--Or, rather, when computing loop-breaker edges,-  * If f has an INLINE pragma, and it is active, we treat the-    INLINE rhs as f's rhs-  * If it's inactive, we treat f as having no rhs-  * If it has no INLINE pragma, we look at f's actual rhs---There is a danger that we'll be sub-optimal if we see this-     f = ...f...-     [INLINE f = ..no f...]-where f is recursive, but the INLINE is not. This can just about-happen with a sufficiently odd set of rules; eg--        foo :: Int -> Int-        {-# INLINE [1] foo #-}-        foo x = x+1--        bar :: Int -> Int-        {-# INLINE [1] bar #-}-        bar x = foo x + 1--        {-# RULES "foo" [~1] forall x. foo x = bar x #-}--Here the RULE makes bar recursive; but it's INLINE pragma remains-non-recursive. It's tempting to then say that 'bar' should not be-a loop breaker, but an attempt to do so goes wrong in two ways:-   a) We may get-         $df = ...$cfoo...-         $cfoo = ...$df....-         [INLINE $cfoo = ...no-$df...]-      But we want $cfoo to depend on $df explicitly so that we-      put the bindings in the right order to inline $df in $cfoo-      and perhaps break the loop altogether.  (Maybe this-   b)---Example [eftInt]-~~~~~~~~~~~~~~~-Example (from GHC.Enum):--  eftInt :: Int# -> Int# -> [Int]-  eftInt x y = ...(non-recursive)...--  {-# INLINE [0] eftIntFB #-}-  eftIntFB :: (Int -> r -> r) -> r -> Int# -> Int# -> r-  eftIntFB c n x y = ...(non-recursive)...--  {-# RULES-  "eftInt"  [~1] forall x y. eftInt x y = build (\ c n -> eftIntFB c n x y)-  "eftIntList"  [1] eftIntFB  (:) [] = eftInt-   #-}--Note [Specialisation rules]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider this group, which is typical of what SpecConstr builds:--   fs a = ....f (C a)....-   f  x = ....f (C a)....-   {-# RULE f (C a) = fs a #-}--So 'f' and 'fs' are in the same Rec group (since f refers to fs via its RULE).--But watch out!  If 'fs' is not chosen as a loop breaker, we may get an infinite loop:-  - the RULE is applied in f's RHS (see Note [Rules for recursive functions] in GHC.Core.Opt.Simplify-  - fs is inlined (say it's small)-  - now there's another opportunity to apply the RULE--This showed up when compiling Control.Concurrent.Chan.getChanContents.-Hence the transitive rule_fv_env stuff described in-Note [Rules and loop breakers].---------------------------------------------------------------Note [Finding join points]-~~~~~~~~~~~~~~~~~~~~~~~~~~-It's the occurrence analyser's job to find bindings that we can turn into join-points, but it doesn't perform that transformation right away. Rather, it marks-the eligible bindings as part of their occurrence data, leaving it to the-simplifier (or to simpleOptPgm) to actually change the binder's 'IdDetails'.-The simplifier then eta-expands the RHS if needed and then updates the-occurrence sites. Dividing the work this way means that the occurrence analyser-still only takes one pass, yet one can always tell the difference between a-function call and a jump by looking at the occurrence (because the same pass-changes the 'IdDetails' and propagates the binders to their occurrence sites).--To track potential join points, we use the 'occ_tail' field of OccInfo. A value-of `AlwaysTailCalled n` indicates that every occurrence of the variable is a-tail call with `n` arguments (counting both value and type arguments). Otherwise-'occ_tail' will be 'NoTailCallInfo'. The tail call info flows bottom-up with the-rest of 'OccInfo' until it goes on the binder.--Note [Join arity prediction based on joinRhsArity]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In general, the join arity from tail occurrences of a join point (O) may be-higher or lower than the manifest join arity of the join body (M). E.g.,--  -- M > O:-  let f x y = x + y              -- M = 2-  in if b then f 1 else f 2      -- O = 1-  ==> { Contify for join arity 1 }-  join f x = \y -> x + y-  in if b then jump f 1 else jump f 2--  -- M < O-  let f = id                     -- M = 0-  in if ... then f 12 else f 13  -- O = 1-  ==> { Contify for join arity 1, eta-expand f }-  join f x = id x-  in if b then jump f 12 else jump f 13--But for *recursive* let, it is crucial that both arities match up, consider--  letrec f x y = if ... then f x else True-  in f 42--Here, M=2 but O=1. If we settled for a joinrec arity of 1, the recursive jump-would not happen in a tail context! Contification is invalid here.-So indeed it is crucial to demand that M=O.--(Side note: Actually, we could be more specific: Let O1 be the join arity of-occurrences from the letrec RHS and O2 the join arity from the let body. Then-we need M=O1 and M<=O2 and could simply eta-expand the RHS to match O2 later.-M=O is the specific case where we don't want to eta-expand. Neither the join-points paper nor GHC does this at the moment.)--We can capitalise on this observation and conclude that *if* f could become a-joinrec (without eta-expansion), it will have join arity M.-Now, M is just the result of 'joinRhsArity', a rather simple, local analysis.-It is also the join arity inside the 'TailUsageDetails' returned by-'occAnalLamTail', so we can predict join arity without doing any fixed-point-iteration or really doing any deep traversal of let body or RHS at all.-We check for M in the 'adjustTailUsage' call inside 'tagRecBinders'.--All this is quite apparent if you look at the contification transformation in-Fig. 5 of "Compiling without Continuations" (which does not account for-eta-expansion at all, mind you). The letrec case looks like this--  letrec f = /\as.\xs. L[us] in L'[es]-    ... and a bunch of conditions establishing that f only occurs-        in app heads of join arity (len as + len xs) inside us and es ...--The syntactic form `/\as.\xs. L[us]` forces M=O iff `f` occurs in `us`. However,-for non-recursive functions, this is the definition of contification from the-paper:--  let f = /\as.\xs.u in L[es]     ... conditions ...--Note that u could be a lambda itself, as we have seen. No relationship between M-and O to exploit here.--Note [Join points and unfoldings/rules]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-   let j2 y = blah-   let j x = j2 (x+x)-       {-# INLINE [2] j #-}-   in case e of { A -> j 1; B -> ...; C -> j 2 }--Before j is inlined, we'll have occurrences of j2 in-both j's RHS and in its stable unfolding.  We want to discover-j2 as a join point. So 'occAnalUnfolding' returns an unadjusted-'TailUsageDetails', like 'occAnalLamTail'. We adjust the usage details of the-unfolding to the actual join arity using the same 'adjustTailArity' as for-the RHS, see Note [Adjusting right-hand sides].--Same with rules. Suppose we have:--  let j :: Int -> Int-      j y = 2 * y-  let k :: Int -> Int -> Int-      {-# RULES "SPEC k 0" k 0 y = j y #-}-      k x y = x + 2 * y-  in case e of { A -> k 1 2; B -> k 3 5; C -> blah }--We identify k as a join point, and we want j to be a join point too.-Without the RULE it would be, and we don't want the RULE to mess it-up.  So provided the join-point arity of k matches the args of the-rule we can allow the tail-call info from the RHS of the rule to-propagate.--* Note that the join arity of the RHS and that of the unfolding or RULE might-  mismatch:--    let j x y = j2 (x+x)-        {-# INLINE[2] j = \x. g #-}-        {-# RULE forall x y z. j x y z = h 17 #-}-    in j 1 2--  So it is crucial that we adjust each TailUsageDetails individually-  with the actual join arity 2 here before we combine with `andUDs`.-  Here, that means losing tail call info on `g` and `h`.--* Wrinkle for Rec case: We store one TailUsageDetails in the node Details for-  RHS, unfolding and RULE combined. Clearly, if they don't agree on their join-  arity, we have to do some adjusting. We choose to adjust to the join arity-  of the RHS, because that is likely the join arity that the join point will-  have; see Note [Join arity prediction based on joinRhsArity].--  If the guess is correct, then tail calls in the RHS are preserved; a necessary-  condition for the whole binding becoming a joinrec.-  The guess can only be incorrect in the 'AcyclicSCC' case when the binding-  becomes a non-recursive join point with a different join arity. But then the-  eventual call to 'adjustTailUsage' in 'tagRecBinders'/'occAnalRec' will-  be with a different join arity and destroy unsound tail call info with-  'markNonTail'.--* Wrinkle for RULES.  Suppose the example was a bit different:-      let j :: Int -> Int-          j y = 2 * y-          k :: Int -> Int -> Int-          {-# RULES "SPEC k 0" k 0 = j #-}-          k x y = x + 2 * y-      in ...-  If we eta-expanded the rule all would be well, but as it stands the-  one arg of the rule don't match the join-point arity of 2.--  Conceivably we could notice that a potential join point would have-  an "undersaturated" rule and account for it. This would mean we-  could make something that's been specialised a join point, for-  instance. But local bindings are rarely specialised, and being-  overly cautious about rules only costs us anything when, for some `j`:--  * Before specialisation, `j` has non-tail calls, so it can't be a join point.-  * During specialisation, `j` gets specialised and thus acquires rules.-  * Sometime afterward, the non-tail calls to `j` disappear (as dead code, say),-    and so now `j` *could* become a join point.--  This appears to be very rare in practice. TODO Perhaps we should gather-  statistics to be sure.---------------------------------------------------------------Note [Adjusting right-hand sides]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-There's a bit of a dance we need to do after analysing a lambda expression or-a right-hand side. In particular, we need to--  a) call 'markAllNonTail' *unless* the binding is for a join point, and-     the TailUsageDetails from the RHS has the right join arity; e.g.-        join j x y = case ... of-                       A -> j2 p-                       B -> j2 q-        in j a b-     Here we want the tail calls to j2 to be tail calls of the whole expression-  b) call 'markAllInsideLam' *unless* the binding is for a thunk, a one-shot-     lambda, or a non-recursive join point--Some examples, with how the free occurrences in e (assumed not to be a value-lambda) get marked:--                             inside lam    non-tail-called-  -------------------------------------------------------------  let x = e                  No            Yes-  let f = \x -> e            Yes           Yes-  let f = \x{OneShot} -> e   No            Yes-  \x -> e                    Yes           Yes-  join j x = e               No            No-  joinrec j x = e            Yes           No--There are a few other caveats; most importantly, if we're marking a binding as-'AlwaysTailCalled', it's *going* to be a join point, so we treat it as one so-that the effect cascades properly. Consequently, at the time the RHS is-analysed, we won't know what adjustments to make; thus 'occAnalLamTail' must-return the unadjusted 'TailUsageDetails', to be adjusted by 'adjustTailUsage'-once join-point-hood has been decided and eventual one-shot annotations have-been added through 'markNonRecJoinOneShots'.--It is not so simple to see that 'occAnalNonRecBind' and 'occAnalRecBind' indeed-perform a similar sequence of steps. Thus, here is an interleaving of events-of both functions, serving as a specification:--  1. Call 'occAnalLamTail' to find usage information for the RHS.-     Recursive case:     'makeNode'-     Non-recursive case: 'occAnalNonRecBind'-  2. (Analyse the binding's scope. Done in 'occAnalBind'/`occAnal Let{}`.-      Same whether recursive or not.)-  3. Call 'tagNonRecBinder' or 'tagRecBinders', which decides whether to make-     the binding a join point.-     Cyclic  Recursive case:  'mkLoopBreakerNodes'-     Acyclic Recursive case:  `occAnalRec AcyclicSCC{}`-     Non-recursive case:      'occAnalNonRecBind'-  4. Non-recursive join point: Call 'markNonRecJoinOneShots' so that e.g.,-     FloatOut sees one-shot annotations on lambdas-     Acyclic Recursive case:  `occAnalRec AcyclicSCC{}`  calls 'adjustNonRecRhs'-     Non-recursive case:      'occAnalNonRecBind'        calls 'adjustNonRecRhs'-  5. Call 'adjustTailUsage' accordingly.-     Cyclic Recursive case:   'tagRecBinders'-     Acyclic Recursive case:  'adjustNonRecRhs'-     Non-recursive case:      'adjustNonRecRhs'--}--data WithUsageDetails a = WithUsageDetails !UsageDetails !a--data WithTailUsageDetails a = WithTailUsageDetails !TailUsageDetails !a-----------------------------------------------------------------------                 occAnalBind---------------------------------------------------------------------occAnalBind :: OccEnv           -- The incoming OccEnv-            -> TopLevelFlag-            -> ImpRuleEdges-            -> CoreBind-            -> UsageDetails             -- Usage details of scope-            -> WithUsageDetails [CoreBind] -- Of the whole let(rec)--occAnalBind !env lvl top_env (NonRec binder rhs) body_usage-  = occAnalNonRecBind env lvl top_env binder rhs body_usage-occAnalBind env lvl top_env (Rec pairs) body_usage-  = occAnalRecBind env lvl top_env pairs body_usage--------------------occAnalNonRecBind :: OccEnv -> TopLevelFlag -> ImpRuleEdges -> Var -> CoreExpr-                  -> UsageDetails -> WithUsageDetails [CoreBind]-occAnalNonRecBind !env lvl imp_rule_edges bndr rhs body_usage-  | isTyVar bndr      -- A type let; we don't gather usage info-  = WithUsageDetails body_usage [NonRec bndr rhs]--  | not (bndr `usedIn` body_usage)-  = WithUsageDetails body_usage [] -- See Note [Dead code]--  | otherwise                   -- It's mentioned in the body-  = WithUsageDetails (body_usage' `andUDs` rhs_usage) [NonRec final_bndr final_rhs]-  where-    WithUsageDetails body_usage' tagged_bndr = tagNonRecBinder lvl body_usage bndr--    -- Get the join info from the *new* decision-    -- See Note [Join points and unfoldings/rules]-    -- => join arity O of Note [Join arity prediction based on joinRhsArity]-    mb_join_arity = willBeJoinId_maybe tagged_bndr-    is_join_point = isJust mb_join_arity--    --------- Right hand side ----------    env1 | is_join_point    = env  -- See Note [Join point RHSs]-         | certainly_inline = env  -- See Note [Cascading inlines]-         | otherwise        = rhsCtxt env--    -- See Note [Sources of one-shot information]-    rhs_env = env1 { occ_one_shots = argOneShots dmd }-    -- See Note [Join arity prediction based on joinRhsArity]-    -- Match join arity O from mb_join_arity with manifest join arity M as-    -- returned by of occAnalLamTail. It's totally OK for them to mismatch;-    -- hence adjust the UDs from the RHS-    WithUsageDetails adj_rhs_uds final_rhs-      = adjustNonRecRhs mb_join_arity $ occAnalLamTail rhs_env rhs-    rhs_usage = adj_rhs_uds `andUDs` adj_unf_uds `andUDs` adj_rule_uds-    final_bndr = tagged_bndr `setIdSpecialisation` mkRuleInfo rules'-                             `setIdUnfolding` unf2--    --------- Unfolding ----------    -- See Note [Join points and unfoldings/rules]-    unf | isId bndr = idUnfolding bndr-        | otherwise = NoUnfolding-    WithTailUsageDetails unf_uds unf1 = occAnalUnfolding rhs_env unf-    unf2 = markNonRecUnfoldingOneShots mb_join_arity unf1-    adj_unf_uds = adjustTailArity mb_join_arity unf_uds--    --------- Rules ----------    -- See Note [Rules are extra RHSs] and Note [Rule dependency info]-    -- and Note [Join points and unfoldings/rules]-    rules_w_uds  = occAnalRules rhs_env bndr-    rules'       = map fstOf3 rules_w_uds-    imp_rule_uds = impRulesScopeUsage (lookupImpRules imp_rule_edges bndr)-         -- imp_rule_uds: consider-         --     h = ...-         --     g = ...-         --     RULE map g = h-         -- Then we want to ensure that h is in scope everywhere-         -- that g is (since the RULE might turn g into h), so-         -- we make g mention h.--    adj_rule_uds = foldr add_rule_uds imp_rule_uds rules_w_uds-    add_rule_uds (_, l, r) uds-      = l `andUDs` adjustTailArity mb_join_arity r `andUDs` uds--    -----------    occ = idOccInfo tagged_bndr-    certainly_inline -- See Note [Cascading inlines]-      = case occ of-          OneOcc { occ_in_lam = NotInsideLam, occ_n_br = 1 }-            -> active && not_stable-          _ -> False--    dmd        = idDemandInfo bndr-    active     = isAlwaysActive (idInlineActivation bndr)-    not_stable = not (isStableUnfolding (idUnfolding bndr))--------------------occAnalRecBind :: OccEnv -> TopLevelFlag -> ImpRuleEdges -> [(Var,CoreExpr)]-               -> UsageDetails -> WithUsageDetails [CoreBind]--- For a recursive group, we---      * occ-analyse all the RHSs---      * compute strongly-connected components---      * feed those components to occAnalRec--- See Note [Recursive bindings: the grand plan]-occAnalRecBind !env lvl imp_rule_edges pairs body_usage-  = foldr (occAnalRec rhs_env lvl) (WithUsageDetails body_usage []) sccs-  where-    sccs :: [SCC NodeDetails]-    sccs = {-# SCC "occAnalBind.scc" #-}-           stronglyConnCompFromEdgedVerticesUniq nodes--    nodes :: [LetrecNode]-    nodes = {-# SCC "occAnalBind.assoc" #-}-            map (makeNode rhs_env imp_rule_edges bndr_set) pairs--    bndrs    = map fst pairs-    bndr_set = mkVarSet bndrs-    rhs_env  = env `addInScope` bndrs--adjustNonRecRhs :: Maybe JoinArity -> WithTailUsageDetails CoreExpr -> WithUsageDetails CoreExpr--- ^ This function concentrates shared logic between occAnalNonRecBind and the--- AcyclicSCC case of occAnalRec.---   * It applies 'markNonRecJoinOneShots' to the RHS---   * and returns the adjusted rhs UsageDetails combined with the body usage-adjustNonRecRhs mb_join_arity (WithTailUsageDetails rhs_tuds rhs)-  = WithUsageDetails rhs_uds' rhs'-  where-    --------- Marking (non-rec) join binders one-shot ----------    !rhs' | Just ja <- mb_join_arity = markNonRecJoinOneShots ja rhs-          | otherwise                = rhs-    --------- Adjusting right-hand side usage ----------    rhs_uds' = adjustTailUsage mb_join_arity rhs' rhs_tuds--bindersOfSCC :: SCC NodeDetails -> [Var]-bindersOfSCC (AcyclicSCC nd) = [nd_bndr nd]-bindersOfSCC (CyclicSCC ds)  = map nd_bndr ds--------------------------------occAnalRec :: OccEnv -> TopLevelFlag-           -> SCC NodeDetails-           -> WithUsageDetails [CoreBind]-           -> WithUsageDetails [CoreBind]---- Check for Note [Dead code]--- NB: Only look at body_uds, ignoring uses in the SCC-occAnalRec !_ _ scc (WithUsageDetails body_uds binds)-  | not (any (`usedIn` body_uds) (bindersOfSCC scc))-  = WithUsageDetails body_uds binds---- The NonRec case is just like a Let (NonRec ...) above-occAnalRec !_ lvl-           (AcyclicSCC (ND { nd_bndr = bndr, nd_rhs = wtuds }))-           (WithUsageDetails body_uds binds)-  = WithUsageDetails (body_uds' `andUDs` rhs_uds') (NonRec bndr' rhs' : binds)-  where-    WithUsageDetails body_uds' tagged_bndr = tagNonRecBinder lvl body_uds bndr-    mb_join_arity = willBeJoinId_maybe tagged_bndr-    WithUsageDetails rhs_uds' rhs' = adjustNonRecRhs mb_join_arity wtuds-    !unf'  = markNonRecUnfoldingOneShots mb_join_arity (idUnfolding tagged_bndr)-    !bndr' = tagged_bndr `setIdUnfolding` unf'---- The Rec case is the interesting one--- See Note [Recursive bindings: the grand plan]--- See Note [Loop breaking]-occAnalRec env lvl (CyclicSCC details_s) (WithUsageDetails body_uds binds)-  = -- pprTrace "occAnalRec" (ppr loop_breaker_nodes)-    WithUsageDetails final_uds (Rec pairs : binds)-  where-    all_simple = all nd_simple details_s--    -------------------------------    -- Make the nodes for the loop-breaker analysis-    -- See Note [Choosing loop breakers] for loop_breaker_nodes-    final_uds :: UsageDetails-    loop_breaker_nodes :: [LoopBreakerNode]-    (WithUsageDetails final_uds loop_breaker_nodes) = mkLoopBreakerNodes env lvl body_uds details_s--    -------------------------------    weak_fvs :: VarSet-    weak_fvs = mapUnionVarSet nd_weak_fvs details_s--    ----------------------------    -- Now reconstruct the cycle-    pairs :: [(Id,CoreExpr)]-    pairs | all_simple = reOrderNodes   0 weak_fvs loop_breaker_nodes []-          | otherwise  = loopBreakNodes 0 weak_fvs loop_breaker_nodes []-          -- In the common case when all are "simple" (no rules at all)-          -- the loop_breaker_nodes will include all the scope edges-          -- so a SCC computation would yield a single CyclicSCC result;-          -- and reOrderNodes deals with exactly that case.-          -- Saves a SCC analysis in a common case---{- *********************************************************************-*                                                                      *-                Loop breaking-*                                                                      *-********************************************************************* -}--{- Note [Choosing loop breakers]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In Step 4 in Note [Recursive bindings: the grand plan]), occAnalRec does-loop-breaking on each CyclicSCC of the original program:--* mkLoopBreakerNodes: Form the loop-breaker graph for that CyclicSCC--* loopBreakNodes: Do SCC analysis on it--* reOrderNodes: For each CyclicSCC, pick a loop breaker-    * Delete edges to that loop breaker-    * Do another SCC analysis on that reduced SCC-    * Repeat--To form the loop-breaker graph, we construct a new set of Nodes, the-"loop-breaker nodes", with the same details but different edges, the-"loop-breaker edges".  The loop-breaker nodes have both more and fewer-dependencies than the scope edges:--  More edges:-     If f calls g, and g has an active rule that mentions h then-     we add an edge from f -> h.  See Note [Rules and loop breakers].--  Fewer edges: we only include dependencies-     * only on /active/ rules,-     * on rule /RHSs/ (not LHSs)--The scope edges, by contrast, must be much more inclusive.--The nd_simple flag tracks the common case when a binding has no RULES-at all, in which case the loop-breaker edges will be identical to the-scope edges.--Note that in Example [eftInt], *neither* eftInt *nor* eftIntFB is-chosen as a loop breaker, because their RHSs don't mention each other.-And indeed both can be inlined safely.--Note [inl_fvs]-~~~~~~~~~~~~~~-Note that the loop-breaker graph includes edges for occurrences in-/both/ the RHS /and/ the stable unfolding.  Consider this, which actually-occurred when compiling BooleanFormula.hs in GHC:--  Rec { lvl1 = go-      ; lvl2[StableUnf = go] = lvl1-      ; go = ...go...lvl2... }--From the point of view of infinite inlining, we need only these edges:-   lvl1 :-> go-   lvl2 :-> go       -- The RHS lvl1 will never be used for inlining-   go   :-> go, lvl2--But the danger is that, lacking any edge to lvl1, we'll put it at the-end thus-  Rec { lvl2[ StableUnf = go] = lvl1-      ; go[LoopBreaker] = ...go...lvl2... }-      ; lvl1[Occ=Once]  = go }--And now the Simplifer will try to use PreInlineUnconditionally on lvl1-(which occurs just once), but because it is last we won't actually-substitute in lvl2.  Sigh.--To avoid this possibility, we include edges from lvl2 to /both/ its-stable unfolding /and/ its RHS.  Hence the defn of inl_fvs in-makeNode.  Maybe we could be more clever, but it's very much a corner-case.--Note [Weak loop breakers]-~~~~~~~~~~~~~~~~~~~~~~~~~-There is a last nasty wrinkle.  Suppose we have--    Rec { f = f_rhs-          RULE f [] = g--          h = h_rhs-          g = h-          ...more... }--Remember that we simplify the RULES before any RHS (see Note-[Rules are visible in their own rec group] above).--So we must *not* postInlineUnconditionally 'g', even though-its RHS turns out to be trivial.  (I'm assuming that 'g' is-not chosen as a loop breaker.)  Why not?  Because then we-drop the binding for 'g', which leaves it out of scope in the-RULE!--Here's a somewhat different example of the same thing-    Rec { q = r-        ; r = ...p...-        ; p = p_rhs-          RULE p [] = q }-Here the RULE is "below" q, but we *still* can't postInlineUnconditionally-q, because the RULE for p is active throughout.  So the RHS of r-might rewrite to     r = ...q...-So q must remain in scope in the output program!--We "solve" this by:--    Make q a "weak" loop breaker (OccInfo = IAmLoopBreaker True)-    iff q is a mentioned in the RHS of any RULE (active on not)-    in the Rec group--Note the "active or not" comment; even if a RULE is inactive, we-want its RHS free vars to stay alive (#20820)!--A normal "strong" loop breaker has IAmLoopBreaker False.  So:--                                Inline  postInlineUnconditionally-strong   IAmLoopBreaker False    no      no-weak     IAmLoopBreaker True     yes     no-         other                   yes     yes--The **sole** reason for this kind of loop breaker is so that-postInlineUnconditionally does not fire.  Ugh.--Annoyingly, since we simplify the rules *first* we'll never inline-q into p's RULE.  That trivial binding for q will hang around until-we discard the rule.  Yuk.  But it's rare.--Note [Rules and loop breakers]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-When we form the loop-breaker graph (Step 4 in Note [Recursive-bindings: the grand plan]), we must be careful about RULEs.--For a start, we want a loop breaker to cut every cycle, so inactive-rules play no part; we need only consider /active/ rules.-See Note [Finding rule RHS free vars]--The second point is more subtle.  A RULE is like an equation for-'f' that is *always* inlined if it is applicable.  We do *not* disable-rules for loop-breakers.  It's up to whoever makes the rules to make-sure that the rules themselves always terminate.  See Note [Rules for-recursive functions] in GHC.Core.Opt.Simplify--Hence, if-    f's RHS (or its stable unfolding if it has one) mentions g, and-    g has a RULE that mentions h, and-    h has a RULE that mentions f--then we *must* choose f to be a loop breaker.  Example: see Note-[Specialisation rules]. So our plan is this:--   Take the free variables of f's RHS, and augment it with all the-   variables reachable by a transitive sequence RULES from those-   starting points.--That is the whole reason for computing rule_fv_env in mkLoopBreakerNodes.-Wrinkles:--* We only consider /active/ rules. See Note [Finding rule RHS free vars]--* We need only consider free vars that are also binders in this Rec-  group.  See also Note [Finding rule RHS free vars]--* We only consider variables free in the *RHS* of the rule, in-  contrast to the way we build the Rec group in the first place (Note-  [Rule dependency info])--* Why "transitive sequence of rules"?  Because active rules apply-  unconditionally, without checking loop-breaker-ness.- See Note [Loop breaker dependencies].--Note [Finding rule RHS free vars]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider this real example from Data Parallel Haskell-     tagZero :: Array Int -> Array Tag-     {-# INLINE [1] tagZeroes #-}-     tagZero xs = pmap (\x -> fromBool (x==0)) xs--     {-# RULES "tagZero" [~1] forall xs n.-         pmap fromBool <blah blah> = tagZero xs #-}-So tagZero's RHS mentions pmap, and pmap's RULE mentions tagZero.-However, tagZero can only be inlined in phase 1 and later, while-the RULE is only active *before* phase 1.  So there's no problem.--To make this work, we look for the RHS free vars only for-*active* rules. That's the reason for the occ_rule_act field-of the OccEnv.--Note [loopBreakNodes]-~~~~~~~~~~~~~~~~~~~~~-loopBreakNodes is applied to the list of nodes for a cyclic strongly-connected component (there's guaranteed to be a cycle).  It returns-the same nodes, but-        a) in a better order,-        b) with some of the Ids having a IAmALoopBreaker pragma--The "loop-breaker" Ids are sufficient to break all cycles in the SCC.  This means-that the simplifier can guarantee not to loop provided it never records an inlining-for these no-inline guys.--Furthermore, the order of the binds is such that if we neglect dependencies-on the no-inline Ids then the binds are topologically sorted.  This means-that the simplifier will generally do a good job if it works from top bottom,-recording inlinings for any Ids which aren't marked as "no-inline" as it goes.--}--type Binding = (Id,CoreExpr)---- See Note [loopBreakNodes]-loopBreakNodes :: Int-               -> VarSet        -- Binders whose dependencies may be "missing"-                                -- See Note [Weak loop breakers]-               -> [LoopBreakerNode]-               -> [Binding]             -- Append these to the end-               -> [Binding]---- Return the bindings sorted into a plausible order, and marked with loop breakers.--- See Note [loopBreakNodes]-loopBreakNodes depth weak_fvs nodes binds-  = -- pprTrace "loopBreakNodes" (ppr nodes) $-    go (stronglyConnCompFromEdgedVerticesUniqR nodes)-  where-    go []         = binds-    go (scc:sccs) = loop_break_scc scc (go sccs)--    loop_break_scc scc binds-      = case scc of-          AcyclicSCC node  -> nodeBinding (mk_non_loop_breaker weak_fvs) node : binds-          CyclicSCC nodes  -> reOrderNodes depth weak_fvs nodes binds-------------------------------------reOrderNodes :: Int -> VarSet -> [LoopBreakerNode] -> [Binding] -> [Binding]-    -- Choose a loop breaker, mark it no-inline,-    -- and call loopBreakNodes on the rest-reOrderNodes _ _ []     _     = panic "reOrderNodes"-reOrderNodes _ _ [node] binds = nodeBinding mk_loop_breaker node : binds-reOrderNodes depth weak_fvs (node : nodes) binds-  = -- pprTrace "reOrderNodes" (vcat [ text "unchosen" <+> ppr unchosen-    --                               , text "chosen" <+> ppr chosen_nodes ]) $-    loopBreakNodes new_depth weak_fvs unchosen $-    (map (nodeBinding mk_loop_breaker) chosen_nodes ++ binds)-  where-    (chosen_nodes, unchosen) = chooseLoopBreaker approximate_lb-                                                 (snd_score (node_payload node))-                                                 [node] [] nodes--    approximate_lb = depth >= 2-    new_depth | approximate_lb = 0-              | otherwise      = depth+1-        -- After two iterations (d=0, d=1) give up-        -- and approximate, returning to d=0--nodeBinding :: (Id -> Id) -> LoopBreakerNode -> Binding-nodeBinding set_id_occ (node_payload -> SND { snd_bndr = bndr, snd_rhs = rhs})-  = (set_id_occ bndr, rhs)--mk_loop_breaker :: Id -> Id-mk_loop_breaker bndr-  = bndr `setIdOccInfo` occ'-  where-    occ'      = strongLoopBreaker { occ_tail = tail_info }-    tail_info = tailCallInfo (idOccInfo bndr)--mk_non_loop_breaker :: VarSet -> Id -> Id--- See Note [Weak loop breakers]-mk_non_loop_breaker weak_fvs bndr-  | bndr `elemVarSet` weak_fvs = setIdOccInfo bndr occ'-  | otherwise                  = bndr-  where-    occ'      = weakLoopBreaker { occ_tail = tail_info }-    tail_info = tailCallInfo (idOccInfo bndr)-------------------------------------chooseLoopBreaker :: Bool                -- True <=> Too many iterations,-                                         --          so approximate-                  -> NodeScore           -- Best score so far-                  -> [LoopBreakerNode]   -- Nodes with this score-                  -> [LoopBreakerNode]   -- Nodes with higher scores-                  -> [LoopBreakerNode]   -- Unprocessed nodes-                  -> ([LoopBreakerNode], [LoopBreakerNode])-    -- This loop looks for the bind with the lowest score-    -- to pick as the loop  breaker.  The rest accumulate in-chooseLoopBreaker _ _ loop_nodes acc []-  = (loop_nodes, acc)        -- Done--    -- If approximate_loop_breaker is True, we pick *all*-    -- nodes with lowest score, else just one-    -- See Note [Complexity of loop breaking]-chooseLoopBreaker approx_lb loop_sc loop_nodes acc (node : nodes)-  | approx_lb-  , rank sc == rank loop_sc-  = chooseLoopBreaker approx_lb loop_sc (node : loop_nodes) acc nodes--  | sc `betterLB` loop_sc  -- Better score so pick this new one-  = chooseLoopBreaker approx_lb sc [node] (loop_nodes ++ acc) nodes--  | otherwise              -- Worse score so don't pick it-  = chooseLoopBreaker approx_lb loop_sc loop_nodes (node : acc) nodes-  where-    sc = snd_score (node_payload node)--{--Note [Complexity of loop breaking]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The loop-breaking algorithm knocks out one binder at a time, and-performs a new SCC analysis on the remaining binders.  That can-behave very badly in tightly-coupled groups of bindings; in the-worst case it can be (N**2)*log N, because it does a full SCC-on N, then N-1, then N-2 and so on.--To avoid this, we switch plans after 2 (or whatever) attempts:-  Plan A: pick one binder with the lowest score, make it-          a loop breaker, and try again-  Plan B: pick *all* binders with the lowest score, make them-          all loop breakers, and try again-Since there are only a small finite number of scores, this will-terminate in a constant number of iterations, rather than O(N)-iterations.--You might thing that it's very unlikely, but RULES make it much-more likely.  Here's a real example from #1969:-  Rec { $dm = \d.\x. op d-        {-# RULES forall d. $dm Int d  = $s$dm1-                  forall d. $dm Bool d = $s$dm2 #-}--        dInt = MkD .... opInt ...-        dInt = MkD .... opBool ...-        opInt  = $dm dInt-        opBool = $dm dBool--        $s$dm1 = \x. op dInt-        $s$dm2 = \x. op dBool }-The RULES stuff means that we can't choose $dm as a loop breaker-(Note [Choosing loop breakers]), so we must choose at least (say)-opInt *and* opBool, and so on.  The number of loop breakers is-linear in the number of instance declarations.--Note [Loop breakers and INLINE/INLINABLE pragmas]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Avoid choosing a function with an INLINE pramga as the loop breaker!-If such a function is mutually-recursive with a non-INLINE thing,-then the latter should be the loop-breaker.--It's vital to distinguish between INLINE and INLINABLE (the-Bool returned by hasStableCoreUnfolding_maybe).  If we start with-   Rec { {-# INLINABLE f #-}-         f x = ...f... }-and then worker/wrapper it through strictness analysis, we'll get-   Rec { {-# INLINABLE $wf #-}-         $wf p q = let x = (p,q) in ...f...--         {-# INLINE f #-}-         f x = case x of (p,q) -> $wf p q }--Now it is vital that we choose $wf as the loop breaker, so we can-inline 'f' in '$wf'.--Note [DFuns should not be loop breakers]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-It's particularly bad to make a DFun into a loop breaker.  See-Note [How instance declarations are translated] in GHC.Tc.TyCl.Instance--We give DFuns a higher score than ordinary CONLIKE things because-if there's a choice we want the DFun to be the non-loop breaker. Eg--rec { sc = /\ a \$dC. $fBWrap (T a) ($fCT @ a $dC)--      $fCT :: forall a_afE. (Roman.C a_afE) => Roman.C (Roman.T a_afE)-      {-# DFUN #-}-      $fCT = /\a \$dC. MkD (T a) ((sc @ a $dC) |> blah) ($ctoF @ a $dC)-    }--Here 'sc' (the superclass) looks CONLIKE, but we'll never get to it-if we can't unravel the DFun first.--Note [Constructor applications]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-It's really really important to inline dictionaries.  Real-example (the Enum Ordering instance from GHC.Base):--     rec     f = \ x -> case d of (p,q,r) -> p x-             g = \ x -> case d of (p,q,r) -> q x-             d = (v, f, g)--Here, f and g occur just once; but we can't inline them into d.-On the other hand we *could* simplify those case expressions if-we didn't stupidly choose d as the loop breaker.-But we won't because constructor args are marked "Many".-Inlining dictionaries is really essential to unravelling-the loops in static numeric dictionaries, see GHC.Float.--Note [Closure conversion]-~~~~~~~~~~~~~~~~~~~~~~~~~-We treat (\x. C p q) as a high-score candidate in the letrec scoring algorithm.-The immediate motivation came from the result of a closure-conversion transformation-which generated code like this:--    data Clo a b = forall c. Clo (c -> a -> b) c--    ($:) :: Clo a b -> a -> b-    Clo f env $: x = f env x--    rec { plus = Clo plus1 ()--        ; plus1 _ n = Clo plus2 n--        ; plus2 Zero     n = n-        ; plus2 (Succ m) n = Succ (plus $: m $: n) }--If we inline 'plus' and 'plus1', everything unravels nicely.  But if-we choose 'plus1' as the loop breaker (which is entirely possible-otherwise), the loop does not unravel nicely.---@occAnalUnfolding@ deals with the question of bindings where the Id is marked-by an INLINE pragma.  For these we record that anything which occurs-in its RHS occurs many times.  This pessimistically assumes that this-inlined binder also occurs many times in its scope, but if it doesn't-we'll catch it next time round.  At worst this costs an extra simplifier pass.-ToDo: try using the occurrence info for the inline'd binder.--[March 97] We do the same for atomic RHSs.  Reason: see notes with loopBreakSCC.-[June 98, SLPJ]  I've undone this change; I don't understand it.  See notes with loopBreakSCC.---************************************************************************-*                                                                      *-                   Making nodes-*                                                                      *-************************************************************************--}---- | Digraph node as constructed by 'makeNode' and consumed by 'occAnalRec'.--- The Unique key is gotten from the Id.-type LetrecNode = Node Unique NodeDetails---- | Node details as consumed by 'occAnalRec'.-data NodeDetails-  = ND { nd_bndr :: Id          -- Binder--       , nd_rhs  :: !(WithTailUsageDetails CoreExpr)-         -- ^ RHS, already occ-analysed-         -- With TailUsageDetails from RHS, and RULES, and stable unfoldings,-         -- ignoring phase (ie assuming all are active).-         -- NB: Unadjusted TailUsageDetails, as if this Node becomes a-         -- non-recursive join point!-         -- See Note [TailUsageDetails when forming Rec groups]--       , nd_inl  :: IdSet       -- Free variables of the stable unfolding and the RHS-                                -- but excluding any RULES-                                -- This is the IdSet that may be used if the Id is inlined--       , nd_simple :: Bool      -- True iff this binding has no local RULES-                                -- If all nodes are simple we don't need a loop-breaker-                                -- dep-anal before reconstructing.--       , nd_weak_fvs :: IdSet    -- Variables bound in this Rec group that are free-                                 -- in the RHS of any rule (active or not) for this bndr-                                 -- See Note [Weak loop breakers]--       , nd_active_rule_fvs :: IdSet    -- Variables bound in this Rec group that are free-                                        -- in the RHS of an active rule for this bndr-                                        -- See Note [Rules and loop breakers]-  }--instance Outputable NodeDetails where-   ppr nd = text "ND" <> braces-             (sep [ text "bndr =" <+> ppr (nd_bndr nd)-                  , text "uds =" <+> ppr uds-                  , text "inl =" <+> ppr (nd_inl nd)-                  , text "simple =" <+> ppr (nd_simple nd)-                  , text "active_rule_fvs =" <+> ppr (nd_active_rule_fvs nd)-             ])-            where WithTailUsageDetails uds _ = nd_rhs nd---- | Digraph with simplified and completely occurrence analysed--- 'SimpleNodeDetails', retaining just the info we need for breaking loops.-type LoopBreakerNode = Node Unique SimpleNodeDetails---- | Condensed variant of 'NodeDetails' needed during loop breaking.-data SimpleNodeDetails-  = SND { snd_bndr  :: IdWithOccInfo  -- OccInfo accurate-        , snd_rhs   :: CoreExpr       -- properly occur-analysed-        , snd_score :: NodeScore-        }--instance Outputable SimpleNodeDetails where-   ppr nd = text "SND" <> braces-             (sep [ text "bndr =" <+> ppr (snd_bndr nd)-                  , text "score =" <+> ppr (snd_score nd)-             ])---- The NodeScore is compared lexicographically;---      e.g. lower rank wins regardless of size-type NodeScore = ( Int     -- Rank: lower => more likely to be picked as loop breaker-                 , Int     -- Size of rhs: higher => more likely to be picked as LB-                           -- Maxes out at maxExprSize; we just use it to prioritise-                           -- small functions-                 , Bool )  -- Was it a loop breaker before?-                           -- True => more likely to be picked-                           -- Note [Loop breakers, node scoring, and stability]--rank :: NodeScore -> Int-rank (r, _, _) = r--makeNode :: OccEnv -> ImpRuleEdges -> VarSet-         -> (Var, CoreExpr) -> LetrecNode--- See Note [Recursive bindings: the grand plan]-makeNode !env imp_rule_edges bndr_set (bndr, rhs)-  = DigraphNode { node_payload      = details-                , node_key          = varUnique bndr-                , node_dependencies = nonDetKeysUniqSet scope_fvs }-    -- It's OK to use nonDetKeysUniqSet here as stronglyConnCompFromEdgedVerticesR-    -- is still deterministic with edges in nondeterministic order as-    -- explained in Note [Deterministic SCC] in GHC.Data.Graph.Directed.-  where-    details = ND { nd_bndr            = bndr'-                 , nd_rhs             = WithTailUsageDetails scope_uds rhs'-                 , nd_inl             = inl_fvs-                 , nd_simple          = null rules_w_uds && null imp_rule_info-                 , nd_weak_fvs        = weak_fvs-                 , nd_active_rule_fvs = active_rule_fvs }--    bndr' = bndr `setIdUnfolding`      unf'-                 `setIdSpecialisation` mkRuleInfo rules'--    -- NB: Both adj_unf_uds and adj_rule_uds have been adjusted to match the-    --     JoinArity rhs_ja of unadj_rhs_uds.-    unadj_inl_uds   = unadj_rhs_uds `andUDs` adj_unf_uds-    unadj_scope_uds = unadj_inl_uds `andUDs` adj_rule_uds-    scope_uds       = TUD rhs_ja unadj_scope_uds-                   -- Note [Rules are extra RHSs]-                   -- Note [Rule dependency info]-    scope_fvs = udFreeVars bndr_set unadj_scope_uds-    -- scope_fvs: all occurrences from this binder: RHS, unfolding,-    --            and RULES, both LHS and RHS thereof, active or inactive--    inl_fvs  = udFreeVars bndr_set unadj_inl_uds-    -- inl_fvs: vars that would become free if the function was inlined.-    -- We conservatively approximate that by thefree vars from the RHS-    -- and the unfolding together.-    -- See Note [inl_fvs]---    --------- Right hand side ----------    -- Constructing the edges for the main Rec computation-    -- See Note [Forming Rec groups]-    -- and Note [TailUsageDetails when forming Rec groups]-    -- Compared to occAnalNonRecBind, we can't yet adjust the RHS because-    --   (a) we don't yet know the final joinpointhood. It might not become a-    --       join point after all!-    --   (b) we don't even know whether it stays a recursive RHS after the SCC-    --       analysis we are about to seed! So we can't markAllInsideLam in-    --       advance, because if it ends up as a non-recursive join point we'll-    --       consider it as one-shot and don't need to markAllInsideLam.-    -- Instead, do the occAnalLamTail call here and postpone adjustTailUsage-    -- until occAnalRec. In effect, we pretend that the RHS becomes a-    -- non-recursive join point and fix up later with adjustTailUsage.-    rhs_env = rhsCtxt env-    WithTailUsageDetails (TUD rhs_ja unadj_rhs_uds) rhs' = occAnalLamTail rhs_env rhs-      -- corresponding call to adjustTailUsage in occAnalRec and tagRecBinders--    --------- Unfolding ----------    -- See Note [Join points and unfoldings/rules]-    unf = realIdUnfolding bndr -- realIdUnfolding: Ignore loop-breaker-ness-                               -- here because that is what we are setting!-    WithTailUsageDetails unf_tuds unf' = occAnalUnfolding rhs_env unf-    adj_unf_uds = adjustTailArity (Just rhs_ja) unf_tuds-      -- `rhs_ja` is `joinRhsArity rhs` and is the prediction for source M-      -- of Note [Join arity prediction based on joinRhsArity]--    --------- IMP-RULES ---------    is_active     = occ_rule_act env :: Activation -> Bool-    imp_rule_info = lookupImpRules imp_rule_edges bndr-    imp_rule_uds  = impRulesScopeUsage imp_rule_info-    imp_rule_fvs  = impRulesActiveFvs is_active bndr_set imp_rule_info--    --------- All rules ---------    -- See Note [Join points and unfoldings/rules]-    -- `rhs_ja` is `joinRhsArity rhs'` and is the prediction for source M-    -- of Note [Join arity prediction based on joinRhsArity]-    rules_w_uds :: [(CoreRule, UsageDetails, UsageDetails)]-    rules_w_uds = [ (r,l,adjustTailArity (Just rhs_ja) rhs_tuds)-                  | (r,l,rhs_tuds) <- occAnalRules rhs_env bndr ]-    rules'      = map fstOf3 rules_w_uds--    adj_rule_uds = foldr add_rule_uds imp_rule_uds rules_w_uds-    add_rule_uds (_, l, r) uds = l `andUDs` r `andUDs` uds--    -------- active_rule_fvs -------------    active_rule_fvs = foldr add_active_rule imp_rule_fvs rules_w_uds-    add_active_rule (rule, _, rhs_uds) fvs-      | is_active (ruleActivation rule)-      = udFreeVars bndr_set rhs_uds `unionVarSet` fvs-      | otherwise-      = fvs--    -------- weak_fvs -------------    -- See Note [Weak loop breakers]-    weak_fvs = foldr add_rule emptyVarSet rules_w_uds-    add_rule (_, _, rhs_uds) fvs = udFreeVars bndr_set rhs_uds `unionVarSet` fvs--mkLoopBreakerNodes :: OccEnv -> TopLevelFlag-                   -> UsageDetails   -- for BODY of let-                   -> [NodeDetails]-                   -> WithUsageDetails [LoopBreakerNode] -- with OccInfo up-to-date--- See Note [Choosing loop breakers]--- This function primarily creates the Nodes for the--- loop-breaker SCC analysis.  More specifically:---   a) tag each binder with its occurrence info---   b) add a NodeScore to each node---   c) make a Node with the right dependency edges for---      the loop-breaker SCC analysis---   d) adjust each RHS's usage details according to---      the binder's (new) shotness and join-point-hood-mkLoopBreakerNodes !env lvl body_uds details_s-  = WithUsageDetails final_uds (zipWithEqual "mkLoopBreakerNodes" mk_lb_node details_s bndrs')-  where-    WithUsageDetails final_uds bndrs' = tagRecBinders lvl body_uds details_s--    mk_lb_node nd@(ND { nd_bndr = old_bndr, nd_inl = inl_fvs }) new_bndr-      = DigraphNode { node_payload      = simple_nd-                    , node_key          = varUnique old_bndr-                    , node_dependencies = nonDetKeysUniqSet lb_deps }-              -- It's OK to use nonDetKeysUniqSet here as-              -- stronglyConnCompFromEdgedVerticesR is still deterministic with edges-              -- in nondeterministic order as explained in-              -- Note [Deterministic SCC] in GHC.Data.Graph.Directed.-      where-        WithTailUsageDetails _ rhs = nd_rhs nd-        simple_nd = SND { snd_bndr = new_bndr, snd_rhs = rhs, snd_score = score }-        score  = nodeScore env new_bndr lb_deps nd-        lb_deps = extendFvs_ rule_fv_env inl_fvs-        -- See Note [Loop breaker dependencies]--    rule_fv_env :: IdEnv IdSet-    -- Maps a variable f to the variables from this group-    --      reachable by a sequence of RULES starting with f-    -- Domain is *subset* of bound vars (others have no rule fvs)-    -- See Note [Finding rule RHS free vars]-    -- Why transClosureFV?  See Note [Loop breaker dependencies]-    rule_fv_env = transClosureFV $ mkVarEnv $-                  [ (b, rule_fvs)-                  | ND { nd_bndr = b, nd_active_rule_fvs = rule_fvs } <- details_s-                  , not (isEmptyVarSet rule_fvs) ]--{- Note [Loop breaker dependencies]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The loop breaker dependencies of x in a recursive-group { f1 = e1; ...; fn = en } are:--- The "inline free variables" of f: the fi free in-  f's stable unfolding and RHS; see Note [inl_fvs]--- Any fi reachable from those inline free variables by a sequence-  of RULE rewrites.  Remember, rule rewriting is not affected-  by fi being a loop breaker, so we have to take the transitive-  closure in case f is the only possible loop breaker in the loop.--  Hence rule_fv_env.  We need only account for /active/ rules.--}---------------------------------------------nodeScore :: OccEnv-          -> Id        -- Binder with new occ-info-          -> VarSet    -- Loop-breaker dependencies-          -> NodeDetails-          -> NodeScore-nodeScore !env new_bndr lb_deps-          (ND { nd_bndr = old_bndr, nd_rhs = WithTailUsageDetails _ bind_rhs })--  | not (isId old_bndr)     -- A type or coercion variable is never a loop breaker-  = (100, 0, False)--  | old_bndr `elemVarSet` lb_deps  -- Self-recursive things are great loop breakers-  = (0, 0, True)                   -- See Note [Self-recursion and loop breakers]--  | not (occ_unf_act env old_bndr) -- A binder whose inlining is inactive (e.g. has-  = (0, 0, True)                   -- a NOINLINE pragma) makes a great loop breaker--  | exprIsTrivial rhs-  = mk_score 10  -- Practically certain to be inlined-    -- Used to have also: && not (isExportedId bndr)-    -- But I found this sometimes cost an extra iteration when we have-    --      rec { d = (a,b); a = ...df...; b = ...df...; df = d }-    -- where df is the exported dictionary. Then df makes a really-    -- bad choice for loop breaker--  | DFunUnfolding { df_args = args } <- old_unf-    -- Never choose a DFun as a loop breaker-    -- Note [DFuns should not be loop breakers]-  = (9, length args, is_lb)--    -- Data structures are more important than INLINE pragmas-    -- so that dictionary/method recursion unravels--  | CoreUnfolding { uf_guidance = UnfWhen {} } <- old_unf-  = mk_score 6--  | is_con_app rhs   -- Data types help with cases:-  = mk_score 5       -- Note [Constructor applications]--  | isStableUnfolding old_unf-  , can_unfold-  = mk_score 3--  | isOneOcc (idOccInfo new_bndr)-  = mk_score 2  -- Likely to be inlined--  | can_unfold  -- The Id has some kind of unfolding-  = mk_score 1--  | otherwise-  = (0, 0, is_lb)--  where-    mk_score :: Int -> NodeScore-    mk_score rank = (rank, rhs_size, is_lb)--    -- is_lb: see Note [Loop breakers, node scoring, and stability]-    is_lb = isStrongLoopBreaker (idOccInfo old_bndr)--    old_unf = realIdUnfolding old_bndr-    can_unfold = canUnfold old_unf-    rhs        = case old_unf of-                   CoreUnfolding { uf_src = src, uf_tmpl = unf_rhs }-                     | isStableSource src-                     -> unf_rhs-                   _ -> bind_rhs-       -- 'bind_rhs' is irrelevant for inlining things with a stable unfolding-    rhs_size = case old_unf of-                 CoreUnfolding { uf_guidance = guidance }-                    | UnfIfGoodArgs { ug_size = size } <- guidance-                    -> size-                 _  -> cheapExprSize rhs---        -- Checking for a constructor application-        -- Cheap and cheerful; the simplifier moves casts out of the way-        -- The lambda case is important to spot x = /\a. C (f a)-        -- which comes up when C is a dictionary constructor and-        -- f is a default method.-        -- Example: the instance for Show (ST s a) in GHC.ST-        ---        -- However we *also* treat (\x. C p q) as a con-app-like thing,-        --      Note [Closure conversion]-    is_con_app (Var v)    = isConLikeId v-    is_con_app (App f _)  = is_con_app f-    is_con_app (Lam _ e)  = is_con_app e-    is_con_app (Tick _ e) = is_con_app e-    is_con_app (Let _ e)  = is_con_app e  -- let x = let y = blah in (a,b)-    is_con_app _          = False         -- We will float the y out, so treat-                                          -- the x-binding as a con-app (#20941)--maxExprSize :: Int-maxExprSize = 20  -- Rather arbitrary--cheapExprSize :: CoreExpr -> Int--- Maxes out at maxExprSize-cheapExprSize e-  = go 0 e-  where-    go n e | n >= maxExprSize = n-           | otherwise        = go1 n e--    go1 n (Var {})        = n+1-    go1 n (Lit {})        = n+1-    go1 n (Type {})       = n-    go1 n (Coercion {})   = n-    go1 n (Tick _ e)      = go1 n e-    go1 n (Cast e _)      = go1 n e-    go1 n (App f a)       = go (go1 n f) a-    go1 n (Lam b e)-      | isTyVar b         = go1 n e-      | otherwise         = go (n+1) e-    go1 n (Let b e)       = gos (go1 n e) (rhssOfBind b)-    go1 n (Case e _ _ as) = gos (go1 n e) (rhssOfAlts as)--    gos n [] = n-    gos n (e:es) | n >= maxExprSize = n-                 | otherwise        = gos (go1 n e) es--betterLB :: NodeScore -> NodeScore -> Bool--- If  n1 `betterLB` n2  then choose n1 as the loop breaker-betterLB (rank1, size1, lb1) (rank2, size2, _)-  | rank1 < rank2 = True-  | rank1 > rank2 = False-  | size1 < size2 = False   -- Make the bigger n2 into the loop breaker-  | size1 > size2 = True-  | lb1           = True    -- Tie-break: if n1 was a loop breaker before, choose it-  | otherwise     = False   -- See Note [Loop breakers, node scoring, and stability]--{- Note [Self-recursion and loop breakers]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If we have-   rec { f = ...f...g...-       ; g = .....f...   }-then 'f' has to be a loop breaker anyway, so we may as well choose it-right away, so that g can inline freely.--This is really just a cheap hack. Consider-   rec { f = ...g...-       ; g = ..f..h...-      ;  h = ...f....}-Here f or g are better loop breakers than h; but we might accidentally-choose h.  Finding the minimal set of loop breakers is hard.--Note [Loop breakers, node scoring, and stability]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-To choose a loop breaker, we give a NodeScore to each node in the SCC,-and pick the one with the best score (according to 'betterLB').--We need to be jolly careful (#12425, #12234) about the stability-of this choice. Suppose we have--    let rec { f = ...g...g...-            ; g = ...f...f... }-    in-    case x of-      True  -> ...f..-      False -> ..f...--In each iteration of the simplifier the occurrence analyser OccAnal-chooses a loop breaker. Suppose in iteration 1 it choose g as the loop-breaker. That means it is free to inline f.--Suppose that GHC decides to inline f in the branches of the case, but-(for some reason; eg it is not saturated) in the rhs of g. So we get--    let rec { f = ...g...g...-            ; g = ...f...f... }-    in-    case x of-      True  -> ...g...g.....-      False -> ..g..g....--Now suppose that, for some reason, in the next iteration the occurrence-analyser chooses f as the loop breaker, so it can freely inline g. And-again for some reason the simplifier inlines g at its calls in the case-branches, but not in the RHS of f. Then we get--    let rec { f = ...g...g...-            ; g = ...f...f... }-    in-    case x of-      True  -> ...(...f...f...)...(...f..f..).....-      False -> ..(...f...f...)...(..f..f...)....--You can see where this is going! Each iteration of the simplifier-doubles the number of calls to f or g. No wonder GHC is slow!--(In the particular example in comment:3 of #12425, f and g are the two-mutually recursive fmap instances for CondT and Result. They are both-marked INLINE which, oddly, is why they don't inline in each other's-RHS, because the call there is not saturated.)--The root cause is that we flip-flop on our choice of loop breaker. I-always thought it didn't matter, and indeed for any single iteration-to terminate, it doesn't matter. But when we iterate, it matters a-lot!!--So The Plan is this:-   If there is a tie, choose the node that-   was a loop breaker last time round--Hence the is_lb field of NodeScore--}--{- *********************************************************************-*                                                                      *-                  Lambda groups-*                                                                      *-********************************************************************* -}--{- Note [Occurrence analysis for lambda binders]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-For value lambdas we do a special hack.  Consider-     (\x. \y. ...x...)-If we did nothing, x is used inside the \y, so would be marked-as dangerous to dup.  But in the common case where the abstraction-is applied to two arguments this is over-pessimistic, which delays-inlining x, which forces more simplifier iterations.--So the occurrence analyser collaborates with the simplifier to treat-a /lambda-group/ specially.   A lambda-group is a contiguous run of-lambda and casts, e.g.-    Lam x (Lam y (Cast (Lam z body) co))--* Occurrence analyser: we just mark each binder in the lambda-group-  (here: x,y,z) with its occurrence info in the *body* of the-  lambda-group.  See occAnalLamTail.--* Simplifier.  The simplifier is careful when partially applying-  lambda-groups. See the call to zapLambdaBndrs in-     GHC.Core.Opt.Simplify.simplExprF1-     GHC.Core.SimpleOpt.simple_app--* Why do we take care to account for intervening casts? Answer:-  currently we don't do eta-expansion and cast-swizzling in a stable-  unfolding (see Historical-note [Eta-expansion in stable unfoldings]).-  So we can get-    f = \x. ((\y. ...x...y...) |> co)-  Now, since the lambdas aren't together, the occurrence analyser will-  say that x is OnceInLam.  Now if we have a call-    (f e1 |> co) e2-  we'll end up with-    let x = e1 in ...x..e2...-  and it'll take an extra iteration of the Simplifier to substitute for x.--A thought: a lambda-group is pretty much what GHC.Core.Opt.Arity.manifestArity-recognises except that the latter looks through (some) ticks.  Maybe a lambda-group should also look through (some) ticks?--}--isOneShotFun :: CoreExpr -> Bool--- The top level lambdas, ignoring casts, of the expression--- are all one-shot.  If there aren't any lambdas at all, this is True-isOneShotFun (Lam b e)  = isOneShotBndr b && isOneShotFun e-isOneShotFun (Cast e _) = isOneShotFun e-isOneShotFun _          = True--zapLambdaBndrs :: CoreExpr -> FullArgCount -> CoreExpr--- If (\xyz. t) appears under-applied to only two arguments,--- we must zap the occ-info on x,y, because they appear under the \z--- See Note [Occurrence analysis for lambda binders] in GHc.Core.Opt.OccurAnal------ NB: `arg_count` includes both type and value args-zapLambdaBndrs fun arg_count-  = -- If the lambda is fully applied, leave it alone; if not-    -- zap the OccInfo on the lambdas that do have arguments,-    -- so they beta-reduce to use-many Lets rather than used-once ones.-    zap arg_count fun `orElse` fun-  where-    zap :: FullArgCount -> CoreExpr -> Maybe CoreExpr-    -- Nothing => No need to change the occ-info-    -- Just e  => Had to change-    zap 0 e | isOneShotFun e = Nothing  -- All remaining lambdas are one-shot-            | otherwise      = Just e   -- in which case no need to zap-    zap n (Cast e co) = do { e' <- zap n e; return (Cast e' co) }-    zap n (Lam b e)   = do { e' <- zap (n-1) e-                           ; return (Lam (zap_bndr b) e') }-    zap _ _           = Nothing  -- More arguments than lambdas--    zap_bndr b | isTyVar b = b-               | otherwise = zapLamIdInfo b--occAnalLamTail :: OccEnv -> CoreExpr -> WithTailUsageDetails CoreExpr--- ^ See Note [Occurrence analysis for lambda binders].--- It does the following:---   * Sets one-shot info on the lambda binder from the OccEnv, and---     removes that one-shot info from the OccEnv---   * Sets the OccEnv to OccVanilla when going under a value lambda---   * Tags each lambda with its occurrence information---   * Walks through casts---   * Package up the analysed lambda with its manifest join arity------ This function does /not/ do---   markAllInsideLam or---   markAllNonTail--- The caller does that, via adjustTailUsage (mostly calls go through--- adjustNonRecRhs). Every call to occAnalLamTail must ultimately call--- adjustTailUsage to discharge the assumed join arity.------ In effect, the analysis result is for a non-recursive join point with--- manifest arity and adjustTailUsage does the fixup.--- See Note [Adjusting right-hand sides]-occAnalLamTail env (Lam bndr expr)-  | isTyVar bndr-  , let env1 = addOneInScope env bndr-  , WithTailUsageDetails (TUD ja usage) expr' <- occAnalLamTail env1 expr-  = WithTailUsageDetails (TUD (ja+1) usage) (Lam bndr expr')-       -- Important: Keep the 'env' unchanged so that with a RHS like-       --   \(@ x) -> K @x (f @x)-       -- we'll see that (K @x (f @x)) is in a OccRhs, and hence refrain-       -- from inlining f. See the beginning of Note [Cascading inlines].--  | otherwise  -- So 'bndr' is an Id-  = let (env_one_shots', bndr1)-           = case occ_one_shots env of-               []         -> ([],  bndr)-               (os : oss) -> (oss, updOneShotInfo bndr os)-               -- Use updOneShotInfo, not setOneShotInfo, as pre-existing-               -- one-shot info might be better than what we can infer, e.g.-               -- due to explicit use of the magic 'oneShot' function.-               -- See Note [The oneShot function]--        env1 = env { occ_encl = OccVanilla, occ_one_shots = env_one_shots' }-        env2 = addOneInScope env1 bndr-        WithTailUsageDetails (TUD ja usage) expr' = occAnalLamTail env2 expr-        (usage', bndr2) = tagLamBinder usage bndr1-    in WithTailUsageDetails (TUD (ja+1) usage') (Lam bndr2 expr')---- For casts, keep going in the same lambda-group--- See Note [Occurrence analysis for lambda binders]-occAnalLamTail env (Cast expr co)-  = let  WithTailUsageDetails (TUD ja usage) expr' = occAnalLamTail env expr-         -- usage1: see Note [Gather occurrences of coercion variables]-         usage1 = addManyOccs usage (coVarsOfCo co)--         -- usage2: see Note [Occ-anal and cast worker/wrapper]-         usage2 = case expr of-                    Var {} | isRhsEnv env -> markAllMany usage1-                    _ -> usage1--         -- usage3: you might think this was not necessary, because of-         -- the markAllNonTail in adjustTailUsage; but not so!  For a-         -- join point, adjustTailUsage doesn't do this; yet if there is-         -- a cast, we must!  Also: why markAllNonTail?  See-         -- GHC.Core.Lint: Note Note [Join points and casts]-         usage3 = markAllNonTail usage2--    in WithTailUsageDetails (TUD ja usage3) (Cast expr' co)--occAnalLamTail env expr = case occAnal env expr of-  WithUsageDetails usage expr' -> WithTailUsageDetails (TUD 0 usage) expr'--{- Note [Occ-anal and cast worker/wrapper]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider   y = e; x = y |> co-If we mark y as used-once, we'll inline y into x, and the Cast-worker/wrapper transform will float it straight back out again.  See-Note [Cast worker/wrapper] in GHC.Core.Opt.Simplify.--So in this particular case we want to mark 'y' as Many.  It's very-ad-hoc, but it's also simple.  It's also what would happen if we gave-the binding for x a stable unfolding (as we usually do for wrappers, thus-      y = e-      {-# INLINE x #-}-      x = y |> co-Now y appears twice -- once in x's stable unfolding, and once in x's-RHS. So it'll get a Many occ-info.  (Maybe Cast w/w should create a stable-unfolding, which would obviate this Note; but that seems a bit of a-heavyweight solution.)--We only need to this in occAnalLamTail, not occAnal, because the top leve-of a right hand side is handled by occAnalLamTail.--}---{- *********************************************************************-*                                                                      *-                   Right hand sides-*                                                                      *-********************************************************************* -}--occAnalUnfolding :: OccEnv-                 -> Unfolding-                 -> WithTailUsageDetails Unfolding--- Occurrence-analyse a stable unfolding;--- discard a non-stable one altogether and return empty usage details.-occAnalUnfolding !env unf-  = case unf of-      unf@(CoreUnfolding { uf_tmpl = rhs, uf_src = src })-        | isStableSource src ->-            let-              WithTailUsageDetails (TUD rhs_ja usage) rhs' = occAnalLamTail env rhs--              unf' | noBinderSwaps env = unf -- Note [Unfoldings and rules]-                   | otherwise         = unf { uf_tmpl = rhs' }-            in WithTailUsageDetails (TUD rhs_ja (markAllMany usage)) unf'-              -- markAllMany: see Note [Occurrences in stable unfoldings]-        | otherwise          -> WithTailUsageDetails (TUD 0 emptyDetails) unf-              -- For non-Stable unfoldings we leave them undisturbed, but-              -- don't count their usage because the simplifier will discard them.-              -- We leave them undisturbed because nodeScore uses their size info-              -- to guide its decisions.  It's ok to leave un-substituted-              -- expressions in the tree because all the variables that were in-              -- scope remain in scope; there is no cloning etc.--      unf@(DFunUnfolding { df_bndrs = bndrs, df_args = args })-        -> WithTailUsageDetails (TUD 0 final_usage) (unf { df_args = args' })-        where-          env'            = env `addInScope` bndrs-          (WithUsageDetails usage args') = occAnalList env' args-          final_usage     = usage `addLamCoVarOccs` bndrs `delDetailsList` bndrs-              -- delDetailsList; no need to use tagLamBinders because we-              -- never inline DFuns so the occ-info on binders doesn't matter--      unf -> WithTailUsageDetails (TUD 0 emptyDetails) unf--occAnalRules :: OccEnv-             -> Id               -- Get rules from here-             -> [(CoreRule,      -- Each (non-built-in) rule-                  UsageDetails,  -- Usage details for LHS-                  TailUsageDetails)] -- Usage details for RHS-occAnalRules !env bndr-  = map occ_anal_rule (idCoreRules bndr)-  where-    occ_anal_rule rule@(Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs })-      = (rule', lhs_uds', TUD rhs_ja rhs_uds')-      where-        env' = env `addInScope` bndrs-        rule' | noBinderSwaps env = rule  -- Note [Unfoldings and rules]-              | otherwise         = rule { ru_args = args', ru_rhs = rhs' }--        (WithUsageDetails lhs_uds args') = occAnalList env' args-        lhs_uds'         = markAllManyNonTail (lhs_uds `delDetailsList` bndrs)-                           `addLamCoVarOccs` bndrs--        (WithUsageDetails rhs_uds rhs') = occAnal env' rhs-                            -- Note [Rules are extra RHSs]-                            -- Note [Rule dependency info]-        rhs_uds' = markAllMany $-                   rhs_uds `delDetailsList` bndrs-        rhs_ja = length args -- See Note [Join points and unfoldings/rules]--    occ_anal_rule other_rule = (other_rule, emptyDetails, TUD 0 emptyDetails)--{- Note [Join point RHSs]-~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-   x = e-   join j = Just x--We want to inline x into j right away, so we don't want to give-the join point a RhsCtxt (#14137).  It's not a huge deal, because-the FloatIn pass knows to float into join point RHSs; and the simplifier-does not float things out of join point RHSs.  But it's a simple, cheap-thing to do.  See #14137.--Note [Occurrences in stable unfoldings]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-    f p = BIG-    {-# INLINE g #-}-    g y = not (f y)-where this is the /only/ occurrence of 'f'.  So 'g' will get a stable-unfolding.  Now suppose that g's RHS gets optimised (perhaps by a rule-or inlining f) so that it doesn't mention 'f' any more.  Now the last-remaining call to f is in g's Stable unfolding. But, even though there-is only one syntactic occurrence of f, we do /not/ want to do-preinlineUnconditionally here!--The INLINE pragma says "inline exactly this RHS"; perhaps the-programmer wants to expose that 'not', say. If we inline f that will make-the Stable unfoldign big, and that wasn't what the programmer wanted.--Another way to think about it: if we inlined g as-is into multiple-call sites, now there's be multiple calls to f.--Bottom line: treat all occurrences in a stable unfolding as "Many".-We still leave tail call information intact, though, as to not spoil-potential join points.--Note [Unfoldings and rules]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-Generally unfoldings and rules are already occurrence-analysed, so we-don't want to reconstruct their trees; we just want to analyse them to-find how they use their free variables.--EXCEPT if there is a binder-swap going on, in which case we do want to-produce a new tree.--So we have a fast-path that keeps the old tree if the occ_bs_env is-empty.   This just saves a bit of allocation and reconstruction; not-a big deal.--This fast path exposes a tricky cornder, though (#22761). Supose we have-    Unfolding = \x. let y = foo in x+1-which includes a dead binding for `y`. In occAnalUnfolding we occ-anal-the unfolding and produce /no/ occurrences of `foo` (since `y` is-dead).  But if we discard the occ-analysed syntax tree (which we do on-our fast path), and use the old one, we still /have/ an occurrence of-`foo` -- and that can lead to out-of-scope variables (#22761).--Solution: always keep occ-analysed trees in unfoldings and rules, so they-have no dead code.  See Note [OccInfo in unfoldings and rules] in GHC.Core.--Note [Cascading inlines]-~~~~~~~~~~~~~~~~~~~~~~~~-By default we use an rhsCtxt for the RHS of a binding.  This tells the-occ anal n that it's looking at an RHS, which has an effect in-occAnalApp.  In particular, for constructor applications, it makes-the arguments appear to have NoOccInfo, so that we don't inline into-them. Thus    x = f y-              k = Just x-we do not want to inline x.--But there's a problem.  Consider-     x1 = a0 : []-     x2 = a1 : x1-     x3 = a2 : x2-     g  = f x3-First time round, it looks as if x1 and x2 occur as an arg of a-let-bound constructor ==> give them a many-occurrence.-But then x3 is inlined (unconditionally as it happens) and-next time round, x2 will be, and the next time round x1 will be-Result: multiple simplifier iterations.  Sigh.--So, when analysing the RHS of x3 we notice that x3 will itself-definitely inline the next time round, and so we analyse x3's rhs in-an ordinary context, not rhsCtxt.  Hence the "certainly_inline" stuff.--Annoyingly, we have to approximate GHC.Core.Opt.Simplify.Utils.preInlineUnconditionally.-If (a) the RHS is expandable (see isExpandableApp in occAnalApp), and-   (b) certainly_inline says "yes" when preInlineUnconditionally says "no"-then the simplifier iterates indefinitely:-        x = f y-        k = Just x   -- We decide that k is 'certainly_inline'-        v = ...k...  -- but preInlineUnconditionally doesn't inline it-inline ==>-        k = Just (f y)-        v = ...k...-float ==>-        x1 = f y-        k = Just x1-        v = ...k...--This is worse than the slow cascade, so we only want to say "certainly_inline"-if it really is certain.  Look at the note with preInlineUnconditionally-for the various clauses.---************************************************************************-*                                                                      *-                Expressions-*                                                                      *-************************************************************************--}--occAnalList :: OccEnv -> [CoreExpr] -> WithUsageDetails [CoreExpr]-occAnalList !_   []    = WithUsageDetails emptyDetails []-occAnalList env (e:es) = let-                          (WithUsageDetails uds1 e') = occAnal env e-                          (WithUsageDetails uds2 es') = occAnalList env es-                         in WithUsageDetails (uds1 `andUDs` uds2) (e' : es')--occAnal :: OccEnv-        -> CoreExpr-        -> WithUsageDetails CoreExpr       -- Gives info only about the "interesting" Ids--occAnal !_   expr@(Lit _)  = WithUsageDetails emptyDetails expr--occAnal env expr@(Var _) = occAnalApp env (expr, [], [])-    -- At one stage, I gathered the idRuleVars for the variable here too,-    -- which in a way is the right thing to do.-    -- But that went wrong right after specialisation, when-    -- the *occurrences* of the overloaded function didn't have any-    -- rules in them, so the *specialised* versions looked as if they-    -- weren't used at all.--occAnal _ expr@(Type ty)-  = WithUsageDetails (addManyOccs emptyDetails (coVarsOfType ty)) expr-occAnal _ expr@(Coercion co)-  = WithUsageDetails (addManyOccs emptyDetails (coVarsOfCo co)) expr-        -- See Note [Gather occurrences of coercion variables]--{- Note [Gather occurrences of coercion variables]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We need to gather info about what coercion variables appear, for two reasons:--1. So that we can sort them into the right place when doing dependency analysis.--2. So that we know when they are surely dead.--It is useful to know when they a coercion variable is surely dead,-when we want to discard a case-expression, in GHC.Core.Opt.Simplify.rebuildCase.-For example (#20143):--  case unsafeEqualityProof @blah of-     UnsafeRefl cv -> ...no use of cv...--Here we can discard the case, since unsafeEqualityProof always terminates.-But only if the coercion variable 'cv' is unused.--Another example from #15696: we had something like-  case eq_sel d of co -> ...(typeError @(...co...) "urk")...-Then 'd' was substituted by a dictionary, so the expression-simpified to-  case (Coercion <blah>) of cv -> ...(typeError @(...cv...) "urk")...--We can only  drop the case altogether if 'cv' is unused, which is not-the case here.--Conclusion: we need accurate dead-ness info for CoVars.-We gather CoVar occurrences from:--  * The (Type ty) and (Coercion co) cases of occAnal--  * The type 'ty' of a lambda-binder (\(x:ty). blah)-    See addLamCoVarOccs--But it is not necessary to gather CoVars from the types of other binders.--* For let-binders, if the type mentions a CoVar, so will the RHS (since-  it has the same type)--* For case-alt binders, if the type mentions a CoVar, so will the scrutinee-  (since it has the same type)--}--occAnal env (Tick tickish body)-  | SourceNote{} <- tickish-  = WithUsageDetails usage (Tick tickish body')-                  -- SourceNotes are best-effort; so we just proceed as usual.-                  -- If we drop a tick due to the issues described below it's-                  -- not the end of the world.--  | tickish `tickishScopesLike` SoftScope-  = WithUsageDetails (markAllNonTail usage) (Tick tickish body')--  | Breakpoint _ _ ids <- tickish-  = WithUsageDetails (usage_lam `andUDs` foldr addManyOcc emptyDetails ids) (Tick tickish body')-    -- never substitute for any of the Ids in a Breakpoint--  | otherwise-  = WithUsageDetails usage_lam (Tick tickish body')-  where-    (WithUsageDetails usage body') = occAnal env body-    -- for a non-soft tick scope, we can inline lambdas only-    usage_lam = markAllNonTail (markAllInsideLam usage)-                  -- TODO There may be ways to make ticks and join points play-                  -- nicer together, but right now there are problems:-                  --   let j x = ... in tick<t> (j 1)-                  -- Making j a join point may cause the simplifier to drop t-                  -- (if the tick is put into the continuation). So we don't-                  -- count j 1 as a tail call.-                  -- See #14242.--occAnal env (Cast expr co)-  = let  (WithUsageDetails usage expr') = occAnal env expr-         usage1 = addManyOccs usage (coVarsOfCo co)-             -- usage2: see Note [Gather occurrences of coercion variables]-         usage2 = markAllNonTail usage1-             -- usage3: calls inside expr aren't tail calls any more-    in WithUsageDetails usage2 (Cast expr' co)--occAnal env app@(App _ _)-  = occAnalApp env (collectArgsTicks tickishFloatable app)--occAnal env expr@(Lam {})-  = adjustNonRecRhs Nothing $ occAnalLamTail env expr -- mb_join_arity == Nothing <=> markAllManyNonTail--occAnal env (Case scrut bndr ty alts)-  = let-      (WithUsageDetails scrut_usage scrut') = occAnal (scrutCtxt env alts) scrut-      alt_env = addBndrSwap scrut' bndr $ env { occ_encl = OccVanilla } `addOneInScope` bndr-      (alts_usage_s, alts') = mapAndUnzip (do_alt alt_env) alts-      alts_usage  = foldr orUDs emptyDetails alts_usage_s-      (alts_usage1, tagged_bndr) = tagLamBinder alts_usage bndr-      total_usage = markAllNonTail scrut_usage `andUDs` alts_usage1-                    -- Alts can have tail calls, but the scrutinee can't-    in WithUsageDetails total_usage (Case scrut' tagged_bndr ty alts')-  where-    do_alt !env (Alt con bndrs rhs)-      = let-          (WithUsageDetails rhs_usage1 rhs1) = occAnal (env `addInScope` bndrs) rhs-          (alt_usg, tagged_bndrs) = tagLamBinders rhs_usage1 bndrs-        in                          -- See Note [Binders in case alternatives]-        (alt_usg, Alt con tagged_bndrs rhs1)--occAnal env (Let bind body)-  = let-      body_env = env { occ_encl = OccVanilla } `addInScope` bindersOf bind-      (WithUsageDetails body_usage  body')  = occAnal body_env body-      (WithUsageDetails final_usage binds') = occAnalBind env NotTopLevel-                                                    noImpRuleEdges bind body_usage-    in WithUsageDetails final_usage (mkLets binds' body')--occAnalArgs :: OccEnv -> CoreExpr -> [CoreExpr] -> [OneShots] -> WithUsageDetails CoreExpr--- The `fun` argument is just an accumulating parameter,--- the base for building the application we return-occAnalArgs !env fun args !one_shots-  = go emptyDetails fun args one_shots-  where-    go uds fun [] _ = WithUsageDetails uds fun-    go uds fun (arg:args) one_shots-      = go (uds `andUDs` arg_uds) (fun `App` arg') args one_shots'-      where-        !(WithUsageDetails arg_uds arg') = occAnal arg_env arg-        !(arg_env, one_shots')-            | isTypeArg arg = (env, one_shots)-            | otherwise     = valArgCtxt env one_shots--{--Applications are dealt with specially because we want-the "build hack" to work.--Note [Arguments of let-bound constructors]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-    f x = let y = expensive x in-          let z = (True,y) in-          (case z of {(p,q)->q}, case z of {(p,q)->q})-We feel free to duplicate the WHNF (True,y), but that means-that y may be duplicated thereby.--If we aren't careful we duplicate the (expensive x) call!-Constructors are rather like lambdas in this way.--}--occAnalApp :: OccEnv-           -> (Expr CoreBndr, [Arg CoreBndr], [CoreTickish])-           -> WithUsageDetails (Expr CoreBndr)--- Naked variables (not applied) end up here too-occAnalApp !env (Var fun, args, ticks)-  -- Account for join arity of runRW# continuation-  -- See Note [Simplification of runRW#]-  ---  -- NB: Do not be tempted to make the next (Var fun, args, tick)-  --     equation into an 'otherwise' clause for this equation-  --     The former has a bang-pattern to occ-anal the args, and-  --     we don't want to occ-anal them twice in the runRW# case!-  --     This caused #18296-  | fun `hasKey` runRWKey-  , [t1, t2, arg]  <- args-  , WithUsageDetails usage arg' <- adjustNonRecRhs (Just 1) $ occAnalLamTail env arg-  = WithUsageDetails usage (mkTicks ticks $ mkApps (Var fun) [t1, t2, arg'])--occAnalApp env (Var fun_id, args, ticks)-  = WithUsageDetails all_uds (mkTicks ticks app')-  where-    -- Lots of banged bindings: this is a very heavily bit of code,-    -- so it pays not to make lots of thunks here, all of which-    -- will ultimately be forced.-    !(fun', fun_id')  = lookupBndrSwap env fun_id-    !(WithUsageDetails args_uds app') = occAnalArgs env fun' args one_shots--    fun_uds = mkOneOcc fun_id' int_cxt n_args-       -- NB: fun_uds is computed for fun_id', not fun_id-       -- See (BS1) in Note [The binder-swap substitution]--    all_uds = fun_uds `andUDs` final_args_uds--    !final_args_uds = markAllNonTail                              $-                      markAllInsideLamIf (isRhsEnv env && is_exp) $-                      args_uds-       -- We mark the free vars of the argument of a constructor or PAP-       -- as "inside-lambda", if it is the RHS of a let(rec).-       -- This means that nothing gets inlined into a constructor or PAP-       -- argument position, which is what we want.  Typically those-       -- constructor arguments are just variables, or trivial expressions.-       -- We use inside-lam because it's like eta-expanding the PAP.-       ---       -- This is the *whole point* of the isRhsEnv predicate-       -- See Note [Arguments of let-bound constructors]--    !n_val_args = valArgCount args-    !n_args     = length args-    !int_cxt    = case occ_encl env of-                   OccScrut -> IsInteresting-                   _other   | n_val_args > 0 -> IsInteresting-                            | otherwise      -> NotInteresting--    !is_exp     = isExpandableApp fun_id n_val_args-        -- See Note [CONLIKE pragma] in GHC.Types.Basic-        -- The definition of is_exp should match that in GHC.Core.Opt.Simplify.prepareRhs--    one_shots  = argsOneShots (idDmdSig fun_id) guaranteed_val_args-    guaranteed_val_args = n_val_args + length (takeWhile isOneShotInfo-                                                         (occ_one_shots env))-        -- See Note [Sources of one-shot information], bullet point A']--occAnalApp env (fun, args, ticks)-  = WithUsageDetails (markAllNonTail (fun_uds `andUDs` args_uds))-                     (mkTicks ticks app')-  where-    !(WithUsageDetails args_uds app') = occAnalArgs env fun' args []-    !(WithUsageDetails fun_uds fun')  = occAnal (addAppCtxt env args) fun-        -- The addAppCtxt is a bit cunning.  One iteration of the simplifier-        -- often leaves behind beta redexs like-        --      (\x y -> e) a1 a2-        -- Here we would like to mark x,y as one-shot, and treat the whole-        -- thing much like a let.  We do this by pushing some OneShotLam items-        -- onto the context stack.--addAppCtxt :: OccEnv -> [Arg CoreBndr] -> OccEnv-addAppCtxt env@(OccEnv { occ_one_shots = ctxt }) args-  | n_val_args > 0-  = env { occ_one_shots = replicate n_val_args OneShotLam ++ ctxt-        , occ_encl      = OccVanilla }-          -- OccVanilla: the function part of the application-          -- is no longer on OccRhs or OccScrut-  | otherwise-  = env-  where-    n_val_args = valArgCount args---{--Note [Sources of one-shot information]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The occurrence analyser obtains one-shot-lambda information from two sources:--A:  Saturated applications:  eg   f e1 .. en--    In general, given a call (f e1 .. en) we can propagate one-shot info from-    f's strictness signature into e1 .. en, but /only/ if n is enough to-    saturate the strictness signature. A strictness signature like--          f :: C(1,C(1,L))LS--    means that *if f is applied to three arguments* then it will guarantee to-    call its first argument at most once, and to call the result of that at-    most once. But if f has fewer than three arguments, all bets are off; e.g.--          map (f (\x y. expensive) e2) xs--    Here the \x y abstraction may be called many times (once for each element of-    xs) so we should not mark x and y as one-shot. But if it was--          map (f (\x y. expensive) 3 2) xs--    then the first argument of f will be called at most once.--    The one-shot info, derived from f's strictness signature, is-    computed by 'argsOneShots', called in occAnalApp.--A': Non-obviously saturated applications: eg    build (f (\x y -> expensive))-    where f is as above.--    In this case, f is only manifestly applied to one argument, so it does not-    look saturated. So by the previous point, we should not use its strictness-    signature to learn about the one-shotness of \x y. But in this case we can:-    build is fully applied, so we may use its strictness signature; and from-    that we learn that build calls its argument with two arguments *at most once*.--    So there is really only one call to f, and it will have three arguments. In-    that sense, f is saturated, and we may proceed as described above.--    Hence the computation of 'guaranteed_val_args' in occAnalApp, using-    '(occ_one_shots env)'.  See also #13227, comment:9--B:  Let-bindings:  eg   let f = \c. let ... in \n -> blah-                        in (build f, build f)--    Propagate one-shot info from the demand-info on 'f' to the-    lambdas in its RHS (which may not be syntactically at the top)--    This information must have come from a previous run of the demand-    analyser.--Previously, the demand analyser would *also* set the one-shot information, but-that code was buggy (see #11770), so doing it only in on place, namely here, is-saner.--Note [OneShots]-~~~~~~~~~~~~~~~-When analysing an expression, the occ_one_shots argument contains information-about how the function is being used. The length of the list indicates-how many arguments will eventually be passed to the analysed expression,-and the OneShotInfo indicates whether this application is once or multiple times.--Example:-- Context of f                occ_one_shots when analysing f-- f 1 2                       [OneShot, OneShot]- map (f 1)                   [OneShot, NoOneShotInfo]- build f                     [OneShot, OneShot]- f 1 2 `seq` f 2 1           [NoOneShotInfo, OneShot]--Note [Binders in case alternatives]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-    case x of y { (a,b) -> f y }-We treat 'a', 'b' as dead, because they don't physically occur in the-case alternative.  (Indeed, a variable is dead iff it doesn't occur in-its scope in the output of OccAnal.)  It really helps to know when-binders are unused.  See esp the call to isDeadBinder in-Simplify.mkDupableAlt--In this example, though, the Simplifier will bring 'a' and 'b' back to-life, because it binds 'y' to (a,b) (imagine got inlined and-scrutinised y).--}--{--************************************************************************-*                                                                      *-                    OccEnv-*                                                                      *-************************************************************************--}--data OccEnv-  = OccEnv { occ_encl       :: !OccEncl      -- Enclosing context information-           , occ_one_shots  :: !OneShots     -- See Note [OneShots]-           , occ_unf_act    :: Id -> Bool          -- Which Id unfoldings are active-           , occ_rule_act   :: Activation -> Bool  -- Which rules are active-             -- See Note [Finding rule RHS free vars]--           -- See Note [The binder-swap substitution]-           -- If  x :-> (y, co)  is in the env,-           -- then please replace x by (y |> mco)-           -- Invariant of course: idType x = exprType (y |> mco)-           , occ_bs_env  :: !(IdEnv (OutId, MCoercion))-                   -- Domain is Global and Local Ids-                   -- Range is just Local Ids-           , occ_bs_rng  :: !VarSet-                   -- Vars (TyVars and Ids) free in the range of occ_bs_env-    }----------------------------------- OccEncl is used to control whether to inline into constructor arguments--- For example:---      x = (p,q)               -- Don't inline p or q---      y = /\a -> (p a, q a)   -- Still don't inline p or q---      z = f (p,q)             -- Do inline p,q; it may make a rule fire--- So OccEncl tells enough about the context to know what to do when--- we encounter a constructor application or PAP.------ OccScrut is used to set the "interesting context" field of OncOcc--data OccEncl-  = OccRhs         -- RHS of let(rec), albeit perhaps inside a type lambda-                   -- Don't inline into constructor args here--  | OccScrut       -- Scrutintee of a case-                   -- Can inline into constructor args--  | OccVanilla     -- Argument of function, body of lambda, etc-                   -- Do inline into constructor args here--instance Outputable OccEncl where-  ppr OccRhs     = text "occRhs"-  ppr OccScrut   = text "occScrut"-  ppr OccVanilla = text "occVanilla"---- See Note [OneShots]-type OneShots = [OneShotInfo]--initOccEnv :: OccEnv-initOccEnv-  = OccEnv { occ_encl      = OccVanilla-           , occ_one_shots = []--                 -- To be conservative, we say that all-                 -- inlines and rules are active-           , occ_unf_act   = \_ -> True-           , occ_rule_act  = \_ -> True--           , occ_bs_env = emptyVarEnv-           , occ_bs_rng = emptyVarSet }--noBinderSwaps :: OccEnv -> Bool-noBinderSwaps (OccEnv { occ_bs_env = bs_env }) = isEmptyVarEnv bs_env--scrutCtxt :: OccEnv -> [CoreAlt] -> OccEnv-scrutCtxt !env alts-  | interesting_alts =  env { occ_encl = OccScrut,   occ_one_shots = [] }-  | otherwise        =  env { occ_encl = OccVanilla, occ_one_shots = [] }-  where-    interesting_alts = case alts of-                         []    -> False-                         [alt] -> not (isDefaultAlt alt)-                         _     -> True-     -- 'interesting_alts' is True if the case has at least one-     -- non-default alternative.  That in turn influences-     -- pre/postInlineUnconditionally.  Grep for "occ_int_cxt"!--rhsCtxt :: OccEnv -> OccEnv-rhsCtxt !env = env { occ_encl = OccRhs, occ_one_shots = [] }--valArgCtxt :: OccEnv -> [OneShots] -> (OccEnv, [OneShots])-valArgCtxt !env []-  = (env { occ_encl = OccVanilla, occ_one_shots = [] }, [])-valArgCtxt env (one_shots:one_shots_s)-  = (env { occ_encl = OccVanilla, occ_one_shots = one_shots }, one_shots_s)--isRhsEnv :: OccEnv -> Bool-isRhsEnv (OccEnv { occ_encl = cxt }) = case cxt of-                                          OccRhs -> True-                                          _      -> False--addOneInScope :: OccEnv -> CoreBndr -> OccEnv--- Needed for all Vars not just Ids--- See Note [The binder-swap substitution] (BS3)-addOneInScope env@(OccEnv { occ_bs_env = swap_env, occ_bs_rng = rng_vars }) bndr-  | bndr `elemVarSet` rng_vars = env { occ_bs_env = emptyVarEnv, occ_bs_rng = emptyVarSet }-  | otherwise                  = env { occ_bs_env = swap_env `delVarEnv` bndr }--addInScope :: OccEnv -> [Var] -> OccEnv--- Needed for all Vars not just Ids--- See Note [The binder-swap substitution] (BS3)-addInScope env@(OccEnv { occ_bs_env = swap_env, occ_bs_rng = rng_vars }) bndrs-  | any (`elemVarSet` rng_vars) bndrs = env { occ_bs_env = emptyVarEnv, occ_bs_rng = emptyVarSet }-  | otherwise                         = env { occ_bs_env = swap_env `delVarEnvList` bndrs }------------------------transClosureFV :: VarEnv VarSet -> VarEnv VarSet--- If (f,g), (g,h) are in the input, then (f,h) is in the output---                                   as well as (f,g), (g,h)-transClosureFV env-  | no_change = env-  | otherwise = transClosureFV (listToUFM_Directly new_fv_list)-  where-    (no_change, new_fv_list) = mapAccumL bump True (nonDetUFMToList env)-      -- It's OK to use nonDetUFMToList here because we'll forget the-      -- ordering by creating a new set with listToUFM-    bump no_change (b,fvs)-      | no_change_here = (no_change, (b,fvs))-      | otherwise      = (False,     (b,new_fvs))-      where-        (new_fvs, no_change_here) = extendFvs env fvs----------------extendFvs_ :: VarEnv VarSet -> VarSet -> VarSet-extendFvs_ env s = fst (extendFvs env s)   -- Discard the Bool flag--extendFvs :: VarEnv VarSet -> VarSet -> (VarSet, Bool)--- (extendFVs env s) returns---     (s `union` env(s), env(s) `subset` s)-extendFvs env s-  | isNullUFM env-  = (s, True)-  | otherwise-  = (s `unionVarSet` extras, extras `subVarSet` s)-  where-    extras :: VarSet    -- env(s)-    extras = nonDetStrictFoldUFM unionVarSet emptyVarSet $-      -- It's OK to use nonDetStrictFoldUFM here because unionVarSet commutes-             intersectUFM_C (\x _ -> x) env (getUniqSet s)--{--************************************************************************-*                                                                      *-                    Binder swap-*                                                                      *-************************************************************************--Note [Binder swap]-~~~~~~~~~~~~~~~~~~-The "binder swap" transformation swaps occurrence of the-scrutinee of a case for occurrences of the case-binder:-- (1)  case x of b { pi -> ri }-         ==>-      case x of b { pi -> ri[b/x] }-- (2)  case (x |> co) of b { pi -> ri }-        ==>-      case (x |> co) of b { pi -> ri[b |> sym co/x] }--The substitution ri[b/x] etc is done by the occurrence analyser.-See Note [The binder-swap substitution].--There are two reasons for making this swap:--(A) It reduces the number of occurrences of the scrutinee, x.-    That in turn might reduce its occurrences to one, so we-    can inline it and save an allocation.  E.g.-      let x = factorial y in case x of b { I# v -> ...x... }-    If we replace 'x' by 'b' in the alternative we get-      let x = factorial y in case x of b { I# v -> ...b... }-    and now we can inline 'x', thus-      case (factorial y) of b { I# v -> ...b... }--(B) The case-binder b has unfolding information; in the-    example above we know that b = I# v. That in turn allows-    nested cases to simplify.  Consider-       case x of b { I# v ->-       ...(case x of b2 { I# v2 -> rhs })...-    If we replace 'x' by 'b' in the alternative we get-       case x of b { I# v ->-       ...(case b of b2 { I# v2 -> rhs })...-    and now it is trivial to simplify the inner case:-       case x of b { I# v ->-       ...(let b2 = b in rhs)...--    The same can happen even if the scrutinee is a variable-    with a cast: see Note [Case of cast]--The reason for doing these transformations /here in the occurrence-analyser/ is because it allows us to adjust the OccInfo for 'x' and-'b' as we go.--  * Suppose the only occurrences of 'x' are the scrutinee and in the-    ri; then this transformation makes it occur just once, and hence-    get inlined right away.--  * If instead the Simplifier replaces occurrences of x with-    occurrences of b, that will mess up b's occurrence info. That in-    turn might have consequences.--There is a danger though.  Consider-      let v = x +# y-      in case (f v) of w -> ...v...v...-And suppose that (f v) expands to just v.  Then we'd like to-use 'w' instead of 'v' in the alternative.  But it may be too-late; we may have substituted the (cheap) x+#y for v in the-same simplifier pass that reduced (f v) to v.--I think this is just too bad.  CSE will recover some of it.--Note [The binder-swap substitution]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The binder-swap is implemented by the occ_bs_env field of OccEnv.-There are two main pieces:--* Given    case x |> co of b { alts }-  we add [x :-> (b, sym co)] to the occ_bs_env environment; this is-  done by addBndrSwap.--* Then, at an occurrence of a variable, we look up in the occ_bs_env-  to perform the swap. This is done by lookupBndrSwap.--Some tricky corners:--(BS1) We do the substitution before gathering occurrence info. So in-      the above example, an occurrence of x turns into an occurrence-      of b, and that's what we gather in the UsageDetails.  It's as-      if the binder-swap occurred before occurrence analysis. See-      the computation of fun_uds in occAnalApp.--(BS2) When doing a lookup in occ_bs_env, we may need to iterate,-      as you can see implemented in lookupBndrSwap.  Why?-      Consider   case x of a { 1# -> e1; DEFAULT ->-                 case x of b { 2# -> e2; DEFAULT ->-                 case x of c { 3# -> e3; DEFAULT -> ..x..a..b.. }}}-      At the first case addBndrSwap will extend occ_bs_env with-          [x :-> a]-      At the second case we occ-anal the scrutinee 'x', which looks up-        'x in occ_bs_env, returning 'a', as it should.-      Then addBndrSwap will add [a :-> b] to occ_bs_env, yielding-         occ_bs_env = [x :-> a, a :-> b]-      At the third case we'll again look up 'x' which returns 'a'.-      But we don't want to stop the lookup there, else we'll end up with-                 case x of a { 1# -> e1; DEFAULT ->-                 case a of b { 2# -> e2; DEFAULT ->-                 case a of c { 3# -> e3; DEFAULT -> ..a..b..c.. }}}-      Instead, we want iterate the lookup in addBndrSwap, to give-                 case x of a { 1# -> e1; DEFAULT ->-                 case a of b { 2# -> e2; DEFAULT ->-                 case b of c { 3# -> e3; DEFAULT -> ..c..c..c.. }}}-      This makes a particular difference for case-merge, which works-      only if the scrutinee is the case-binder of the immediately enclosing-      case (Note [Merge Nested Cases] in GHC.Core.Opt.Simplify.Utils-      See #19581 for the bug report that showed this up.--(BS3) We need care when shadowing.  Suppose [x :-> b] is in occ_bs_env,-      and we encounter:-         (i) \x. blah-             Here we want to delete the x-binding from occ_bs_env--         (ii) \b. blah-              This is harder: we really want to delete all bindings that-              have 'b' free in the range.  That is a bit tiresome to implement,-              so we compromise.  We keep occ_bs_rng, which is the set of-              free vars of rng(occc_bs_env).  If a binder shadows any of these-              variables, we discard all of occ_bs_env.  Safe, if a bit-              brutal.  NB, however: the simplifer de-shadows the code, so the-              next time around this won't happen.--      These checks are implemented in addInScope.-      (i) is needed only for Ids, but (ii) is needed for tyvars too (#22623)-      because if occ_bs_env has [x :-> ...a...] where `a` is a tyvar, we-      must not replace `x` by `...a...` under /\a. ...x..., or similarly-      under a case pattern match that binds `a`.--      An alternative would be for the occurrence analyser to do cloning as-      it goes.  In principle it could do so, but it'd make it a bit more-      complicated and there is no great benefit. The simplifer uses-      cloning to get a no-shadowing situation, the care-when-shadowing-      behaviour above isn't needed for long.--(BS4) The domain of occ_bs_env can include GlobaIds.  Eg-         case M.foo of b { alts }-      We extend occ_bs_env with [M.foo :-> b].  That's fine.--(BS5) We have to apply the occ_bs_env substitution uniformly,-      including to (local) rules and unfoldings.--(BS6) We must be very careful with dictionaries.-      See Note [Care with binder-swap on dictionaries]--Note [Case of cast]-~~~~~~~~~~~~~~~~~~~-Consider        case (x `cast` co) of b { I# ->-                ... (case (x `cast` co) of {...}) ...-We'd like to eliminate the inner case.  That is the motivation for-equation (2) in Note [Binder swap].  When we get to the inner case, we-inline x, cancel the casts, and away we go.--Note [Care with binder-swap on dictionaries]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-This Note explains why we need isDictId in scrutBinderSwap_maybe.-Consider this tricky example (#21229, #21470):--  class Sing (b :: Bool) where sing :: Bool-  instance Sing 'True  where sing = True-  instance Sing 'False where sing = False--  f :: forall a. Sing a => blah--  h = \ @(a :: Bool) ($dSing :: Sing a)-      let the_co =  Main.N:Sing[0] <a> :: Sing a ~R# Bool-      case ($dSing |> the_co) of wild-        True  -> f @'True (True |> sym the_co)-        False -> f @a     dSing--Now do a binder-swap on the case-expression:--  h = \ @(a :: Bool) ($dSing :: Sing a)-      let the_co =  Main.N:Sing[0] <a> :: Sing a ~R# Bool-      case ($dSing |> the_co) of wild-        True  -> f @'True (True |> sym the_co)-        False -> f @a     (wild |> sym the_co)--And now substitute `False` for `wild` (since wild=False in the False branch):--  h = \ @(a :: Bool) ($dSing :: Sing a)-      let the_co =  Main.N:Sing[0] <a> :: Sing a ~R# Bool-      case ($dSing |> the_co) of wild-        True  -> f @'True (True  |> sym the_co)-        False -> f @a     (False |> sym the_co)--And now we have a problem.  The specialiser will specialise (f @a d)a (for all-vtypes a and dictionaries d!!) with the dictionary (False |> sym the_co), using-Note [Specialising polymorphic dictionaries] in GHC.Core.Opt.Specialise.--The real problem is the binder-swap.  It swaps a dictionary variable $dSing-(of kind Constraint) for a term variable wild (of kind Type).  And that is-dangerous: a dictionary is a /singleton/ type whereas a general term variable is-not.  In this particular example, Bool is most certainly not a singleton type!--Conclusion:-  for a /dictionary variable/ do not perform-  the clever cast version of the binder-swap--Hence the subtle isDictId in scrutBinderSwap_maybe.--Note [Zap case binders in proxy bindings]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-From the original-     case x of cb(dead) { p -> ...x... }-we will get-     case x of cb(live) { p -> ...cb... }--Core Lint never expects to find an *occurrence* of an Id marked-as Dead, so we must zap the OccInfo on cb before making the-binding x = cb.  See #5028.--NB: the OccInfo on /occurrences/ really doesn't matter much; the simplifier-doesn't use it. So this is only to satisfy the perhaps-over-picky Lint.---}--addBndrSwap :: OutExpr -> Id -> OccEnv -> OccEnv--- See Note [The binder-swap substitution]-addBndrSwap scrut case_bndr-            env@(OccEnv { occ_bs_env = swap_env, occ_bs_rng = rng_vars })-  | Just (scrut_var, mco) <- scrutBinderSwap_maybe scrut-  , scrut_var /= case_bndr-      -- Consider: case x of x { ... }-      -- Do not add [x :-> x] to occ_bs_env, else lookupBndrSwap will loop-  = env { occ_bs_env = extendVarEnv swap_env scrut_var (case_bndr', mco)-        , occ_bs_rng = rng_vars `extendVarSet` case_bndr'-                       `unionVarSet` tyCoVarsOfMCo mco }--  | otherwise-  = env-  where-    case_bndr' = zapIdOccInfo case_bndr-                 -- See Note [Zap case binders in proxy bindings]--scrutBinderSwap_maybe :: OutExpr -> Maybe (OutVar, MCoercion)--- If (scrutBinderSwap_maybe e = Just (v, mco), then---    v = e |> mco--- See Note [Case of cast]--- See Note [Care with binder-swap on dictionaries]------ We use this same function in SpecConstr, and Simplify.Iteration,--- when something binder-swap-like is happening-scrutBinderSwap_maybe (Var v)    = Just (v, MRefl)-scrutBinderSwap_maybe (Cast (Var v) co)-  | not (isDictId v)             = Just (v, MCo (mkSymCo co))-        -- Cast: see Note [Case of cast]-        -- isDictId: see Note [Care with binder-swap on dictionaries]-        -- The isDictId rejects a Constraint/Constraint binder-swap, perhaps-        -- over-conservatively. But I have never seen one, so I'm leaving-        -- the code as simple as possible. Losing the binder-swap in a-        -- rare case probably has very low impact.-scrutBinderSwap_maybe (Tick _ e) = scrutBinderSwap_maybe e  -- Drop ticks-scrutBinderSwap_maybe _          = Nothing--lookupBndrSwap :: OccEnv -> Id -> (CoreExpr, Id)--- See Note [The binder-swap substitution]--- Returns an expression of the same type as Id-lookupBndrSwap env@(OccEnv { occ_bs_env = bs_env })  bndr-  = case lookupVarEnv bs_env bndr of {-       Nothing           -> (Var bndr, bndr) ;-       Just (bndr1, mco) ->--    -- Why do we iterate here?-    -- See (BS2) in Note [The binder-swap substitution]-    case lookupBndrSwap env bndr1 of-      (fun, fun_id) -> (mkCastMCo fun mco, fun_id) }--{- Historical note [Proxy let-bindings]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We used to do the binder-swap transformation by introducing-a proxy let-binding, thus;--   case x of b { pi -> ri }-      ==>-   case x of b { pi -> let x = b in ri }--But that had two problems:--1. If 'x' is an imported GlobalId, we'd end up with a GlobalId-   on the LHS of a let-binding which isn't allowed.  We worked-   around this for a while by "localising" x, but it turned-   out to be very painful #16296,--2. In CorePrep we use the occurrence analyser to do dead-code-   elimination (see Note [Dead code in CorePrep]).  But that-   occasionally led to an unlifted let-binding-       case x of b { DEFAULT -> let x::Int# = b in ... }-   which disobeys one of CorePrep's output invariants (no unlifted-   let-bindings) -- see #5433.--Doing a substitution (via occ_bs_env) is much better.--Historical Note [no-case-of-case]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We *used* to suppress the binder-swap in case expressions when--fno-case-of-case is on.  Old remarks:-    "This happens in the first simplifier pass,-    and enhances full laziness.  Here's the bad case:-            f = \ y -> ...(case x of I# v -> ...(case x of ...) ... )-    If we eliminate the inner case, we trap it inside the I# v -> arm,-    which might prevent some full laziness happening.  I've seen this-    in action in spectral/cichelli/Prog.hs:-             [(m,n) | m <- [1..max], n <- [1..max]]-    Hence the check for NoCaseOfCase."-However, now the full-laziness pass itself reverses the binder-swap, so this-check is no longer necessary.--Historical Note [Suppressing the case binder-swap]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-This old note describes a problem that is also fixed by doing the-binder-swap in OccAnal:--    There is another situation when it might make sense to suppress the-    case-expression binde-swap. If we have--        case x of w1 { DEFAULT -> case x of w2 { A -> e1; B -> e2 }-                       ...other cases .... }--    We'll perform the binder-swap for the outer case, giving--        case x of w1 { DEFAULT -> case w1 of w2 { A -> e1; B -> e2 }-                       ...other cases .... }--    But there is no point in doing it for the inner case, because w1 can't-    be inlined anyway.  Furthermore, doing the case-swapping involves-    zapping w2's occurrence info (see paragraphs that follow), and that-    forces us to bind w2 when doing case merging.  So we get--        case x of w1 { A -> let w2 = w1 in e1-                       B -> let w2 = w1 in e2-                       ...other cases .... }--    This is plain silly in the common case where w2 is dead.--    Even so, I can't see a good way to implement this idea.  I tried-    not doing the binder-swap if the scrutinee was already evaluated-    but that failed big-time:--            data T = MkT !Int--            case v of w  { MkT x ->-            case x of x1 { I# y1 ->-            case x of x2 { I# y2 -> ...--    Notice that because MkT is strict, x is marked "evaluated".  But to-    eliminate the last case, we must either make sure that x (as well as-    x1) has unfolding MkT y1.  The straightforward thing to do is to do-    the binder-swap.  So this whole note is a no-op.--It's fixed by doing the binder-swap in OccAnal because we can do the-binder-swap unconditionally and still get occurrence analysis-information right.---************************************************************************-*                                                                      *-\subsection[OccurAnal-types]{OccEnv}-*                                                                      *-************************************************************************--Note [UsageDetails and zapping]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-On many occasions, we must modify all gathered occurrence data at once. For-instance, all occurrences underneath a (non-one-shot) lambda set the-'occ_in_lam' flag to become 'True'. We could use 'mapVarEnv' to do this, but-that takes O(n) time and we will do this often---in particular, there are many-places where tail calls are not allowed, and each of these causes all variables-to get marked with 'NoTailCallInfo'.--Instead of relying on `mapVarEnv`, then, we carry three 'IdEnv's around along-with the 'OccInfoEnv'. Each of these extra environments is a "zapped set"-recording which variables have been zapped in some way. Zapping all occurrence-info then simply means setting the corresponding zapped set to the whole-'OccInfoEnv', a fast O(1) operation.--}--type OccInfoEnv = IdEnv OccInfo -- A finite map from ids to their usage-                -- INVARIANT: never IAmDead-                -- (Deadness is signalled by not being in the map at all)--type ZappedSet = OccInfoEnv -- Values are ignored--data UsageDetails-  = UD { ud_env       :: !OccInfoEnv-       , ud_z_many    :: !ZappedSet   -- apply 'markMany' to these-       , ud_z_in_lam  :: !ZappedSet   -- apply 'markInsideLam' to these-       , ud_z_no_tail :: !ZappedSet } -- apply 'markNonTail' to these-  -- INVARIANT: All three zapped sets are subsets of the OccInfoEnv--instance Outputable UsageDetails where-  ppr ud = ppr (ud_env (flattenUsageDetails ud))---- | Captures the result of applying 'occAnalLamTail' to a function `\xyz.body`.--- The TailUsageDetails records---   * the number of lambdas (including type lambdas: a JoinArity)---   * UsageDetails for the `body`, unadjusted by `adjustTailUsage`.---     If the binding turns out to be a join point with the indicated join---     arity, this unadjusted usage details is just what we need; otherwise we---     need to discard tail calls. That's what `adjustTailUsage` does.-data TailUsageDetails = TUD !JoinArity !UsageDetails--instance Outputable TailUsageDetails where-  ppr (TUD ja uds) = lambda <> ppr ja <> ppr uds------------------------- UsageDetails API--andUDs, orUDs-        :: UsageDetails -> UsageDetails -> UsageDetails-andUDs = combineUsageDetailsWith addOccInfo-orUDs  = combineUsageDetailsWith orOccInfo--mkOneOcc :: Id -> InterestingCxt -> JoinArity -> UsageDetails-mkOneOcc id int_cxt arity-  | isLocalId id-  = emptyDetails { ud_env = unitVarEnv id occ_info }-  | otherwise-  = emptyDetails-  where-    occ_info = OneOcc { occ_in_lam  = NotInsideLam-                      , occ_n_br    = oneBranch-                      , occ_int_cxt = int_cxt-                      , occ_tail    = AlwaysTailCalled arity }--addManyOccId :: UsageDetails -> Id -> UsageDetails--- Add the non-committal (id :-> noOccInfo) to the usage details-addManyOccId ud id = ud { ud_env = extendVarEnv (ud_env ud) id noOccInfo }---- Add several occurrences, assumed not to be tail calls-addManyOcc :: Var -> UsageDetails -> UsageDetails-addManyOcc v u | isId v    = addManyOccId u v-               | otherwise = u-        -- Give a non-committal binder info (i.e noOccInfo) because-        --   a) Many copies of the specialised thing can appear-        --   b) We don't want to substitute a BIG expression inside a RULE-        --      even if that's the only occurrence of the thing-        --      (Same goes for INLINE.)--addManyOccs :: UsageDetails -> VarSet -> UsageDetails-addManyOccs usage id_set = nonDetStrictFoldUniqSet addManyOcc usage id_set-  -- It's OK to use nonDetStrictFoldUniqSet here because addManyOcc commutes--addLamCoVarOccs :: UsageDetails -> [Var] -> UsageDetails--- Add any CoVars free in the type of a lambda-binder--- See Note [Gather occurrences of coercion variables]-addLamCoVarOccs uds bndrs-  = uds `addManyOccs` coVarsOfTypes (map varType bndrs)--delDetails :: UsageDetails -> Id -> UsageDetails-delDetails ud bndr-  = ud `alterUsageDetails` (`delVarEnv` bndr)--delDetailsList :: UsageDetails -> [Id] -> UsageDetails-delDetailsList ud bndrs-  = ud `alterUsageDetails` (`delVarEnvList` bndrs)--emptyDetails :: UsageDetails-emptyDetails = UD { ud_env       = emptyVarEnv-                  , ud_z_many    = emptyVarEnv-                  , ud_z_in_lam  = emptyVarEnv-                  , ud_z_no_tail = emptyVarEnv }--isEmptyDetails :: UsageDetails -> Bool-isEmptyDetails = isEmptyVarEnv . ud_env--markAllMany, markAllInsideLam, markAllNonTail, markAllManyNonTail-  :: UsageDetails -> UsageDetails-markAllMany          ud = ud { ud_z_many    = ud_env ud }-markAllInsideLam     ud = ud { ud_z_in_lam  = ud_env ud }-markAllNonTail ud = ud { ud_z_no_tail = ud_env ud }--markAllInsideLamIf, markAllNonTailIf :: Bool -> UsageDetails -> UsageDetails--markAllInsideLamIf  True  ud = markAllInsideLam ud-markAllInsideLamIf  False ud = ud--markAllNonTailIf True  ud = markAllNonTail ud-markAllNonTailIf False ud = ud---markAllManyNonTail = markAllMany . markAllNonTail -- effectively sets to noOccInfo--lookupDetails :: UsageDetails -> Id -> OccInfo-lookupDetails ud id-  = case lookupVarEnv (ud_env ud) id of-      Just occ -> doZapping ud id occ-      Nothing  -> IAmDead--usedIn :: Id -> UsageDetails -> Bool-v `usedIn` ud = isExportedId v || v `elemVarEnv` ud_env ud--udFreeVars :: VarSet -> UsageDetails -> VarSet--- Find the subset of bndrs that are mentioned in uds-udFreeVars bndrs ud = restrictFreeVars bndrs (ud_env ud)--restrictFreeVars :: VarSet -> OccInfoEnv -> VarSet-restrictFreeVars bndrs fvs = restrictUniqSetToUFM bndrs fvs------------------------ Auxiliary functions for UsageDetails implementation--combineUsageDetailsWith :: (OccInfo -> OccInfo -> OccInfo)-                        -> UsageDetails -> UsageDetails -> UsageDetails-combineUsageDetailsWith plus_occ_info ud1 ud2-  | isEmptyDetails ud1 = ud2-  | isEmptyDetails ud2 = ud1-  | otherwise-  = UD { ud_env       = plusVarEnv_C plus_occ_info (ud_env ud1) (ud_env ud2)-       , ud_z_many    = plusVarEnv (ud_z_many    ud1) (ud_z_many    ud2)-       , ud_z_in_lam  = plusVarEnv (ud_z_in_lam  ud1) (ud_z_in_lam  ud2)-       , ud_z_no_tail = plusVarEnv (ud_z_no_tail ud1) (ud_z_no_tail ud2) }--doZapping :: UsageDetails -> Var -> OccInfo -> OccInfo-doZapping ud var occ-  = doZappingByUnique ud (varUnique var) occ--doZappingByUnique :: UsageDetails -> Unique -> OccInfo -> OccInfo-doZappingByUnique (UD { ud_z_many = many-                      , ud_z_in_lam = in_lam-                      , ud_z_no_tail = no_tail })-                  uniq occ-  = occ2-  where-    occ1 | uniq `elemVarEnvByKey` many    = markMany occ-         | uniq `elemVarEnvByKey` in_lam  = markInsideLam occ-         | otherwise                      = occ-    occ2 | uniq `elemVarEnvByKey` no_tail = markNonTail occ1-         | otherwise                      = occ1--alterUsageDetails :: UsageDetails -> (OccInfoEnv -> OccInfoEnv) -> UsageDetails-alterUsageDetails !ud f-  = UD { ud_env       = f (ud_env       ud)-       , ud_z_many    = f (ud_z_many    ud)-       , ud_z_in_lam  = f (ud_z_in_lam  ud)-       , ud_z_no_tail = f (ud_z_no_tail ud) }--flattenUsageDetails :: UsageDetails -> UsageDetails-flattenUsageDetails ud@(UD { ud_env = env })-  = UD { ud_env       = mapUFM_Directly (doZappingByUnique ud) env-       , ud_z_many    = emptyVarEnv-       , ud_z_in_lam  = emptyVarEnv-       , ud_z_no_tail = emptyVarEnv }------------------------ See Note [Adjusting right-hand sides]-adjustTailUsage :: Maybe JoinArity-               -> CoreExpr           -- Rhs, AFTER occAnalLamTail-               -> TailUsageDetails   -- From body of lambda-               -> UsageDetails-adjustTailUsage mb_join_arity rhs (TUD rhs_ja usage)-  = -- c.f. occAnal (Lam {})-    markAllInsideLamIf (not one_shot) $-    markAllNonTailIf (not exact_join) $-    usage-  where-    one_shot   = isOneShotFun rhs-    exact_join = mb_join_arity == Just rhs_ja--adjustTailArity :: Maybe JoinArity -> TailUsageDetails -> UsageDetails-adjustTailArity mb_rhs_ja (TUD ud_ja usage) =-  markAllNonTailIf (mb_rhs_ja /= Just ud_ja) usage--markNonRecJoinOneShots :: JoinArity -> CoreExpr -> CoreExpr--- For a /non-recursive/ join point we can mark all--- its join-lambda as one-shot; and it's a good idea to do so-markNonRecJoinOneShots join_arity rhs-  = go join_arity rhs-  where-    go 0 rhs         = rhs-    go n (Lam b rhs) = Lam (if isId b then setOneShotLambda b else b)-                           (go (n-1) rhs)-    go _ rhs         = rhs  -- Not enough lambdas.  This can legitimately happen.-                            -- e.g.    let j = case ... in j True-                            -- This will become an arity-1 join point after the-                            -- simplifier has eta-expanded it; but it may not have-                            -- enough lambdas /yet/. (Lint checks that JoinIds do-                            -- have enough lambdas.)--markNonRecUnfoldingOneShots :: Maybe JoinArity -> Unfolding -> Unfolding--- ^ Apply 'markNonRecJoinOneShots' to a stable unfolding-markNonRecUnfoldingOneShots mb_join_arity unf-  | Just ja <- mb_join_arity-  , CoreUnfolding{uf_src=src,uf_tmpl=tmpl} <- unf-  , isStableSource src-  , let !tmpl' = markNonRecJoinOneShots ja tmpl-  = unf{uf_tmpl=tmpl'}-  | otherwise-  = unf--type IdWithOccInfo = Id--tagLamBinders :: UsageDetails          -- Of scope-              -> [Id]                  -- Binders-              -> (UsageDetails,        -- Details with binders removed-                 [IdWithOccInfo])    -- Tagged binders-tagLamBinders usage binders-  = usage' `seq` (usage', bndrs')-  where-    (usage', bndrs') = mapAccumR tagLamBinder usage binders--tagLamBinder :: UsageDetails       -- Of scope-             -> Id                 -- Binder-             -> (UsageDetails,     -- Details with binder removed-                 IdWithOccInfo)    -- Tagged binders--- Used for lambda and case binders--- It copes with the fact that lambda bindings can have a--- stable unfolding, used for join points-tagLamBinder usage bndr-  = (usage2, bndr')-  where-        occ    = lookupDetails usage bndr-        bndr'  = setBinderOcc (markNonTail occ) bndr-                   -- Don't try to make an argument into a join point-        usage1 = usage `delDetails` bndr-        usage2 | isId bndr = addManyOccs usage1 (idUnfoldingVars bndr)-                               -- This is effectively the RHS of a-                               -- non-join-point binding, so it's okay to use-                               -- addManyOccsSet, which assumes no tail calls-               | otherwise = usage1--tagNonRecBinder :: TopLevelFlag           -- At top level?-                -> UsageDetails           -- Of scope-                -> CoreBndr               -- Binder-                -> WithUsageDetails       -- Details with binder removed-                    IdWithOccInfo         -- Tagged binder--tagNonRecBinder lvl usage binder- = let-     occ     = lookupDetails usage binder-     will_be_join = decideJoinPointHood lvl usage (NE.singleton binder)-     occ'    | will_be_join = -- must already be marked AlwaysTailCalled-                              assert (isAlwaysTailCalled occ) occ-             | otherwise    = markNonTail occ-     binder' = setBinderOcc occ' binder-     usage'  = usage `delDetails` binder-   in-   WithUsageDetails usage' binder'--tagRecBinders :: TopLevelFlag           -- At top level?-              -> UsageDetails           -- Of body of let ONLY-              -> [NodeDetails]-              -> WithUsageDetails       -- Adjusted details for whole scope,-                                        -- with binders removed-                  [IdWithOccInfo]       -- Tagged binders--- Substantially more complicated than non-recursive case. Need to adjust RHS--- details *before* tagging binders (because the tags depend on the RHSes).-tagRecBinders lvl body_uds details_s- = let-     bndrs    = map nd_bndr details_s--     -- 1. See Note [Join arity prediction based on joinRhsArity]-     --    Determine possible join-point-hood of whole group, by testing for-     --    manifest join arity M.-     --    This (re-)asserts that makeNode had made tuds for that same arity M!-     unadj_uds     = foldr (andUDs . test_manifest_arity) body_uds details_s-     test_manifest_arity ND{nd_rhs=WithTailUsageDetails tuds rhs}-       = adjustTailArity (Just (joinRhsArity rhs)) tuds--     bndr_ne = expectNonEmpty "List of binders is never empty" bndrs-     will_be_joins = decideJoinPointHood lvl unadj_uds bndr_ne--     mb_join_arity :: Id -> Maybe JoinArity-     -- mb_join_arity: See Note [Join arity prediction based on joinRhsArity]-     -- This is the source O-     mb_join_arity bndr-         -- Can't use willBeJoinId_maybe here because we haven't tagged-         -- the binder yet (the tag depends on these adjustments!)-       | will_be_joins-       , let occ = lookupDetails unadj_uds bndr-       , AlwaysTailCalled arity <- tailCallInfo occ-       = Just arity-       | otherwise-       = assert (not will_be_joins) -- Should be AlwaysTailCalled if-         Nothing                   -- we are making join points!--     -- 2. Adjust usage details of each RHS, taking into account the-     --    join-point-hood decision-     rhs_udss' = [ adjustTailUsage (mb_join_arity bndr) rhs rhs_tuds -- matching occAnalLamTail in makeNode-                 | ND { nd_bndr = bndr, nd_rhs = WithTailUsageDetails rhs_tuds rhs }-                     <- details_s ]--     -- 3. Compute final usage details from adjusted RHS details-     adj_uds   = foldr andUDs body_uds rhs_udss'--     -- 4. Tag each binder with its adjusted details-     bndrs'    = [ setBinderOcc (lookupDetails adj_uds bndr) bndr-                 | bndr <- bndrs ]--     -- 5. Drop the binders from the adjusted details and return-     usage'    = adj_uds `delDetailsList` bndrs-   in-   WithUsageDetails usage' bndrs'--setBinderOcc :: OccInfo -> CoreBndr -> CoreBndr-setBinderOcc occ_info bndr-  | isTyVar bndr      = bndr-  | isExportedId bndr = if isManyOccs (idOccInfo bndr)-                          then bndr-                          else setIdOccInfo bndr noOccInfo-            -- Don't use local usage info for visible-elsewhere things-            -- BUT *do* erase any IAmALoopBreaker annotation, because we're-            -- about to re-generate it and it shouldn't be "sticky"--  | otherwise = setIdOccInfo bndr occ_info---- | Decide whether some bindings should be made into join points or not, based--- on its occurrences. This is--- Returns `False` if they can't be join points. Note that it's an--- all-or-nothing decision, as if multiple binders are given, they're--- assumed to be mutually recursive.------ It must, however, be a final decision. If we say `True` for 'f',--- and then subsequently decide /not/ make 'f' into a join point, then--- the decision about another binding 'g' might be invalidated if (say)--- 'f' tail-calls 'g'.------ See Note [Invariants on join points] in "GHC.Core".-decideJoinPointHood :: TopLevelFlag -> UsageDetails-                    -> NonEmpty CoreBndr-                    -> Bool-decideJoinPointHood TopLevel _ _-  = False-decideJoinPointHood NotTopLevel usage bndrs-  | isJoinId (NE.head bndrs)-  = warnPprTrace (not all_ok)-                 "OccurAnal failed to rediscover join point(s)" (ppr bndrs)-                 all_ok-  | otherwise-  = all_ok-  where-    -- See Note [Invariants on join points]; invariants cited by number below.-    -- Invariant 2 is always satisfiable by the simplifier by eta expansion.-    all_ok = -- Invariant 3: Either all are join points or none are-             all ok bndrs--    ok bndr-      | -- Invariant 1: Only tail calls, all same join arity-        AlwaysTailCalled arity <- tailCallInfo (lookupDetails usage bndr)--      , -- Invariant 1 as applied to LHSes of rules-        all (ok_rule arity) (idCoreRules bndr)--        -- Invariant 2a: stable unfoldings-        -- See Note [Join points and INLINE pragmas]-      , ok_unfolding arity (realIdUnfolding bndr)--        -- Invariant 4: Satisfies polymorphism rule-      , isValidJoinPointType arity (idType bndr)-      = True--      | otherwise-      = False--    ok_rule _ BuiltinRule{} = False -- only possible with plugin shenanigans-    ok_rule join_arity (Rule { ru_args = args })-      = args `lengthIs` join_arity-        -- Invariant 1 as applied to LHSes of rules--    -- ok_unfolding returns False if we should /not/ convert a non-join-id-    -- into a join-id, even though it is AlwaysTailCalled-    ok_unfolding join_arity (CoreUnfolding { uf_src = src, uf_tmpl = rhs })-      = not (isStableSource src && join_arity > joinRhsArity rhs)-    ok_unfolding _ (DFunUnfolding {})-      = False-    ok_unfolding _ _-      = True--willBeJoinId_maybe :: CoreBndr -> Maybe JoinArity-willBeJoinId_maybe bndr-  | isId bndr-  , AlwaysTailCalled arity <- tailCallInfo (idOccInfo bndr)-  = Just arity-  | otherwise-  = isJoinId_maybe bndr---{- Note [Join points and INLINE pragmas]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider-   f x = let g = \x. not  -- Arity 1-             {-# INLINE g #-}-         in case x of-              A -> g True True-              B -> g True False-              C -> blah2--Here 'g' is always tail-called applied to 2 args, but the stable-unfolding captured by the INLINE pragma has arity 1.  If we try to-convert g to be a join point, its unfolding will still have arity 1-(since it is stable, and we don't meddle with stable unfoldings), and-Lint will complain (see Note [Invariants on join points], (2a), in-GHC.Core.  #13413.--Moreover, since g is going to be inlined anyway, there is no benefit-from making it a join point.--If it is recursive, and uselessly marked INLINE, this will stop us-making it a join point, which is annoying.  But occasionally-(notably in class methods; see Note [Instances and loop breakers] in-GHC.Tc.TyCl.Instance) we mark recursive things as INLINE but the recursion-unravels; so ignoring INLINE pragmas on recursive things isn't good-either.--See Invariant 2a of Note [Invariants on join points] in GHC.Core---************************************************************************-*                                                                      *-\subsection{Operations over OccInfo}-*                                                                      *-************************************************************************--}--markMany, markInsideLam, markNonTail :: OccInfo -> OccInfo--markMany IAmDead = IAmDead-markMany occ     = ManyOccs { occ_tail = occ_tail occ }--markInsideLam occ@(OneOcc {}) = occ { occ_in_lam = IsInsideLam }-markInsideLam occ             = occ--markNonTail IAmDead = IAmDead-markNonTail occ     = occ { occ_tail = NoTailCallInfo }--addOccInfo, orOccInfo :: OccInfo -> OccInfo -> OccInfo--addOccInfo a1 a2  = assert (not (isDeadOcc a1 || isDeadOcc a2)) $-                    ManyOccs { occ_tail = tailCallInfo a1 `andTailCallInfo`-                                          tailCallInfo a2 }-                                -- Both branches are at least One-                                -- (Argument is never IAmDead)---- (orOccInfo orig new) is used--- when combining occurrence info from branches of a case--orOccInfo (OneOcc { occ_in_lam  = in_lam1-                  , occ_n_br    = nbr1-                  , occ_int_cxt = int_cxt1-                  , occ_tail    = tail1 })-          (OneOcc { occ_in_lam  = in_lam2-                  , occ_n_br    = nbr2-                  , occ_int_cxt = int_cxt2-                  , occ_tail    = tail2 })-  = OneOcc { occ_n_br    = nbr1 + nbr2-           , occ_in_lam  = in_lam1 `mappend` in_lam2-           , occ_int_cxt = int_cxt1 `mappend` int_cxt2-           , occ_tail    = tail1 `andTailCallInfo` tail2 }--orOccInfo a1 a2 = assert (not (isDeadOcc a1 || isDeadOcc a2)) $-                  ManyOccs { occ_tail = tailCallInfo a1 `andTailCallInfo`-                                        tailCallInfo a2 }+{-# LANGUAGE ViewPatterns #-}++{-# OPTIONS_GHC -cpp -Wno-incomplete-record-updates #-}++{-# OPTIONS_GHC -fmax-worker-args=12 #-}+-- The -fmax-worker-args=12 is there because the main functions+-- are strict in the OccEnv, and it turned out that with the default settting+-- some functions would unbox the OccEnv ad some would not, depending on how+-- many /other/ arguments the function has.  Inconsistent unboxing is very+-- bad for performance, so I increased the limit to allow it to unbox+-- consistently.++{-+(c) The GRASP/AQUA Project, Glasgow University, 1992-1998++************************************************************************+*                                                                      *+\section[OccurAnal]{Occurrence analysis pass}+*                                                                      *+************************************************************************++The occurrence analyser re-typechecks a core expression, returning a new+core expression with (hopefully) improved usage information.+-}++module GHC.Core.Opt.OccurAnal (+    occurAnalysePgm,+    occurAnalyseExpr,+    zapLambdaBndrs, scrutBinderSwap_maybe+  ) where++import GHC.Prelude hiding ( head, init, last, tail )++import GHC.Core+import GHC.Core.FVs+import GHC.Core.Utils   ( exprIsTrivial, isDefaultAlt, isExpandableApp,+                          mkCastMCo, mkTicks )+import GHC.Core.Opt.Arity   ( joinRhsArity, isOneShotBndr )+import GHC.Core.Coercion+import GHC.Core.Predicate   ( isDictId )+import GHC.Core.Type+import GHC.Core.TyCo.FVs    ( tyCoVarsOfMCo )++import GHC.Data.Maybe( orElse )+import GHC.Data.Graph.Directed ( SCC(..), Node(..)+                               , stronglyConnCompFromEdgedVerticesUniq+                               , stronglyConnCompFromEdgedVerticesUniqR )+import GHC.Types.Unique+import GHC.Types.Unique.FM+import GHC.Types.Unique.Set+import GHC.Types.Id+import GHC.Types.Id.Info+import GHC.Types.Basic+import GHC.Types.Tickish+import GHC.Types.Var.Set+import GHC.Types.Var.Env+import GHC.Types.Var+import GHC.Types.Demand ( argOneShots, argsOneShots )++import GHC.Utils.Outputable+import GHC.Utils.Panic+import GHC.Utils.Misc++import GHC.Builtin.Names( runRWKey )+import GHC.Unit.Module( Module )++import Data.List (mapAccumL)++{-+************************************************************************+*                                                                      *+    occurAnalysePgm, occurAnalyseExpr+*                                                                      *+************************************************************************++Here's the externally-callable interface:+-}++-- | Do occurrence analysis, and discard occurrence info returned+occurAnalyseExpr :: CoreExpr -> CoreExpr+occurAnalyseExpr expr = expr'+  where+    WUD _ expr' = occAnal initOccEnv expr++occurAnalysePgm :: Module         -- Used only in debug output+                -> (Id -> Bool)         -- Active unfoldings+                -> (Activation -> Bool) -- Active rules+                -> [CoreRule]           -- Local rules for imported Ids+                -> CoreProgram -> CoreProgram+occurAnalysePgm this_mod active_unf active_rule imp_rules binds+  | isEmptyDetails final_usage+  = occ_anald_binds++  | otherwise   -- See Note [Glomming]+  = warnPprTrace True "Glomming in" (hang (ppr this_mod <> colon) 2 (ppr final_usage))+    occ_anald_glommed_binds+  where+    init_env = initOccEnv { occ_rule_act = active_rule+                          , occ_unf_act  = active_unf }++    WUD final_usage occ_anald_binds = go binds init_env+    WUD _ occ_anald_glommed_binds = occAnalRecBind init_env TopLevel+                                                    imp_rule_edges+                                                    (flattenBinds binds)+                                                    initial_uds+          -- It's crucial to re-analyse the glommed-together bindings+          -- so that we establish the right loop breakers. Otherwise+          -- we can easily create an infinite loop (#9583 is an example)+          --+          -- Also crucial to re-analyse the /original/ bindings+          -- in case the first pass accidentally discarded as dead code+          -- a binding that was actually needed (albeit before its+          -- definition site).  #17724 threw this up.++    initial_uds = addManyOccs emptyDetails (rulesFreeVars imp_rules)+    -- The RULES declarations keep things alive!++    -- imp_rule_edges maps a top-level local binder 'f' to the+    -- RHS free vars of any IMP-RULE, a local RULE for an imported function,+    -- where 'f' appears on the LHS+    --   e.g.  RULE foldr f = blah+    --         imp_rule_edges contains f :-> fvs(blah)+    -- We treat such RULES as extra rules for 'f'+    -- See Note [Preventing loops due to imported functions rules]+    imp_rule_edges :: ImpRuleEdges+    imp_rule_edges = foldr (plusVarEnv_C (++)) emptyVarEnv+                           [ mapVarEnv (const [(act,rhs_fvs)]) $ getUniqSet $+                             exprsFreeIds args `delVarSetList` bndrs+                           | Rule { ru_act = act, ru_bndrs = bndrs+                                   , ru_args = args, ru_rhs = rhs } <- imp_rules+                                   -- Not BuiltinRules; see Note [Plugin rules]+                           , let rhs_fvs = exprFreeIds rhs `delVarSetList` bndrs ]++    go :: [CoreBind] -> OccEnv -> WithUsageDetails [CoreBind]+    go []           _   = WUD initial_uds []+    go (bind:binds) env = occAnalBind env TopLevel+                           imp_rule_edges bind (go binds) (++)++{- *********************************************************************+*                                                                      *+                IMP-RULES+         Local rules for imported functions+*                                                                      *+********************************************************************* -}++type ImpRuleEdges = IdEnv [(Activation, VarSet)]+    -- Mapping from a local Id 'f' to info about its IMP-RULES,+    -- i.e. /local/ rules for an imported Id that mention 'f' on the LHS+    -- We record (a) its Activation and (b) the RHS free vars+    -- See Note [IMP-RULES: local rules for imported functions]++noImpRuleEdges :: ImpRuleEdges+noImpRuleEdges = emptyVarEnv++lookupImpRules :: ImpRuleEdges -> Id -> [(Activation,VarSet)]+lookupImpRules imp_rule_edges bndr+  = case lookupVarEnv imp_rule_edges bndr of+      Nothing -> []+      Just vs -> vs++impRulesScopeUsage :: [(Activation,VarSet)] -> UsageDetails+-- Variable mentioned in RHS of an IMP-RULE for the bndr,+-- whether active or not+impRulesScopeUsage imp_rules_info+  = foldr add emptyDetails imp_rules_info+  where+    add (_,vs) usage = addManyOccs usage vs++impRulesActiveFvs :: (Activation -> Bool) -> VarSet+                  -> [(Activation,VarSet)] -> VarSet+impRulesActiveFvs is_active bndr_set vs+  = foldr add emptyVarSet vs `intersectVarSet` bndr_set+  where+    add (act,vs) acc | is_active act = vs `unionVarSet` acc+                     | otherwise     = acc++{- Note [IMP-RULES: local rules for imported functions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We quite often have+  * A /local/ rule+  * for an /imported/ function+like this:+  foo x = blah+  {-# RULE "map/foo" forall xs. map foo xs = xs #-}+We call them IMP-RULES.  They are important in practice, and occur a+lot in the libraries.++IMP-RULES are held in mg_rules of ModGuts, and passed in to+occurAnalysePgm.++Main Invariant:++* Throughout, we treat an IMP-RULE that mentions 'f' on its LHS+  just like a RULE for f.++Note [IMP-RULES: unavoidable loops]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this+   f = /\a. B.g a+   RULE B.g Int = 1 + f Int+Note that+  * The RULE is for an imported function.+  * f is non-recursive+Now we+can get+   f Int --> B.g Int      Inlining f+         --> 1 + f Int    Firing RULE+and so the simplifier goes into an infinite loop. This+would not happen if the RULE was for a local function,+because we keep track of dependencies through rules.  But+that is pretty much impossible to do for imported Ids.  Suppose+f's definition had been+   f = /\a. C.h a+where (by some long and devious process), C.h eventually inlines to+B.g.  We could only spot such loops by exhaustively following+unfoldings of C.h etc, in case we reach B.g, and hence (via the RULE)+f.++We regard this potential infinite loop as a *programmer* error.+It's up the programmer not to write silly rules like+     RULE f x = f x+and the example above is just a more complicated version.++Note [Specialising imported functions] (referred to from Specialise)+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For *automatically-generated* rules, the programmer can't be+responsible for the "programmer error" in Note [IMP-RULES: unavoidable+loops].  In particular, consider specialising a recursive function+defined in another module.  If we specialise a recursive function B.g,+we get+  g_spec = .....(B.g Int).....+  RULE B.g Int = g_spec+Here, g_spec doesn't look recursive, but when the rule fires, it+becomes so.  And if B.g was mutually recursive, the loop might not be+as obvious as it is here.++To avoid this,+ * When specialising a function that is a loop breaker,+   give a NOINLINE pragma to the specialised function++Note [Preventing loops due to imported functions rules]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider:+  import GHC.Base (foldr)++  {-# RULES "filterList" forall p. foldr (filterFB (:) p) [] = filter p #-}+  filter p xs = build (\c n -> foldr (filterFB c p) n xs)+  filterFB c p = ...++  f = filter p xs++Note that filter is not a loop-breaker, so what happens is:+  f =          filter p xs+    = {inline} build (\c n -> foldr (filterFB c p) n xs)+    = {inline} foldr (filterFB (:) p) [] xs+    = {RULE}   filter p xs++We are in an infinite loop.++A more elaborate example (that I actually saw in practice when I went to+mark GHC.List.filter as INLINABLE) is as follows. Say I have this module:+  {-# LANGUAGE RankNTypes #-}+  module GHCList where++  import Prelude hiding (filter)+  import GHC.Base (build)++  {-# INLINABLE filter #-}+  filter :: (a -> Bool) -> [a] -> [a]+  filter p [] = []+  filter p (x:xs) = if p x then x : filter p xs else filter p xs++  {-# NOINLINE [0] filterFB #-}+  filterFB :: (a -> b -> b) -> (a -> Bool) -> a -> b -> b+  filterFB c p x r | p x       = x `c` r+                   | otherwise = r++  {-# RULES+  "filter"     [~1] forall p xs.  filter p xs = build (\c n -> foldr+  (filterFB c p) n xs)+  "filterList" [1]  forall p.     foldr (filterFB (:) p) [] = filter p+   #-}++Then (because RULES are applied inside INLINABLE unfoldings, but inlinings+are not), the unfolding given to "filter" in the interface file will be:+  filter p []     = []+  filter p (x:xs) = if p x then x : build (\c n -> foldr (filterFB c p) n xs)+                           else     build (\c n -> foldr (filterFB c p) n xs++Note that because this unfolding does not mention "filter", filter is not+marked as a strong loop breaker. Therefore at a use site in another module:+  filter p xs+    = {inline}+      case xs of []     -> []+                 (x:xs) -> if p x then x : build (\c n -> foldr (filterFB c p) n xs)+                                  else     build (\c n -> foldr (filterFB c p) n xs)++  build (\c n -> foldr (filterFB c p) n xs)+    = {inline} foldr (filterFB (:) p) [] xs+    = {RULE}   filter p xs++And we are in an infinite loop again, except that this time the loop is producing an+infinitely large *term* (an unrolling of filter) and so the simplifier finally+dies with "ticks exhausted"++SOLUTION: we treat the rule "filterList" as an extra rule for 'filterFB'+because it mentions 'filterFB' on the LHS.  This is the Main Invariant+in Note [IMP-RULES: local rules for imported functions].++So, during loop-breaker analysis:++- for each active RULE for a local function 'f' we add an edge between+  'f' and the local FVs of the rule RHS++- for each active RULE for an *imported* function we add dependency+  edges between the *local* FVS of the rule LHS and the *local* FVS of+  the rule RHS.++Even with this extra hack we aren't always going to get things+right. For example, it might be that the rule LHS mentions an imported+Id, and another module has a RULE that can rewrite that imported Id to+one of our local Ids.++Note [Plugin rules]+~~~~~~~~~~~~~~~~~~~+Conal Elliott (#11651) built a GHC plugin that added some+BuiltinRules (for imported Ids) to the mg_rules field of ModGuts, to+do some domain-specific transformations that could not be expressed+with an ordinary pattern-matching CoreRule.  But then we can't extract+the dependencies (in imp_rule_edges) from ru_rhs etc, because a+BuiltinRule doesn't have any of that stuff.++So we simply assume that BuiltinRules have no dependencies, and filter+them out from the imp_rule_edges comprehension.++Note [Glomming]+~~~~~~~~~~~~~~~+RULES for imported Ids can make something at the top refer to+something at the bottom:++        foo = ...(B.f @Int)...+        $sf = blah+        RULE:  B.f @Int = $sf++Applying this rule makes foo refer to $sf, although foo doesn't appear to+depend on $sf.  (And, as in Note [IMP-RULES: local rules for imported functions], the+dependency might be more indirect. For example, foo might mention C.t+rather than B.f, where C.t eventually inlines to B.f.)++NOTICE that this cannot happen for rules whose head is a+locally-defined function, because we accurately track dependencies+through RULES.  It only happens for rules whose head is an imported+function (B.f in the example above).++Solution:+  - When simplifying, bring all top level identifiers into+    scope at the start, ignoring the Rec/NonRec structure, so+    that when 'h' pops up in f's rhs, we find it in the in-scope set+    (as the simplifier generally expects). This happens in simplTopBinds.++  - In the occurrence analyser, if there are any out-of-scope+    occurrences that pop out of the top, which will happen after+    firing the rule:      f = \x -> h x+                          h = \y -> 3+    then just glom all the bindings into a single Rec, so that+    the *next* iteration of the occurrence analyser will sort+    them all out.   This part happens in occurAnalysePgm.++This is a legitimate situation where the need for glomming doesn't+point to any problems. However, when GHC is compiled with -DDEBUG, we+produce a warning addressed to the GHC developers just in case we+require glomming due to an out-of-order reference that is caused by+some earlier transformation stage misbehaving.+-}++{-+************************************************************************+*                                                                      *+                Bindings+*                                                                      *+************************************************************************++Note [Recursive bindings: the grand plan]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Loop breaking is surprisingly subtle.  First read the section 4 of+"Secrets of the GHC inliner".  This describes our basic plan.  We+avoid infinite inlinings by choosing loop breakers, and ensuring that+a loop breaker cuts each loop.++See also Note [Inlining and hs-boot files] in GHC.Core.ToIface, which+deals with a closely related source of infinite loops.++When we come across a binding group+  Rec { x1 = r1; ...; xn = rn }+we treat it like this (occAnalRecBind):++1. Note [Forming Rec groups]+   Occurrence-analyse each right hand side, and build a+   "Details" for each binding to capture the results.+   Wrap the details in a LetrecNode, ready for SCC analysis.+   All this is done by makeNode.++   The edges of this graph are the "scope edges".++2. Do SCC-analysis on these Nodes:+   - Each CyclicSCC will become a new Rec+   - Each AcyclicSCC will become a new NonRec++   The key property is that every free variable of a binding is+   accounted for by the scope edges, so that when we are done+   everything is still in scope.++3. For each AcyclicSCC, just make a NonRec binding.++4. For each CyclicSCC of the scope-edge SCC-analysis in (2), we+   identify suitable loop-breakers to ensure that inlining terminates.+   This is done by occAnalRec.++   To do so, form the loop-breaker graph, do SCC analysis. For each+   CyclicSCC we choose a loop breaker, delete all edges to that node,+   re-analyse the SCC, and iterate. See Note [Choosing loop breakers]+   for the details+++Note [Dead code]+~~~~~~~~~~~~~~~~+Dropping dead code for a cyclic Strongly Connected Component is done+in a very simple way:++        the entire SCC is dropped if none of its binders are mentioned+        in the body; otherwise the whole thing is kept.++The key observation is that dead code elimination happens after+dependency analysis: so 'occAnalBind' processes SCCs instead of the+original term's binding groups.++Thus 'occAnalBind' does indeed drop 'f' in an example like++        letrec f = ...g...+               g = ...(...g...)...+        in+           ...g...++when 'g' no longer uses 'f' at all (eg 'f' does not occur in a RULE in+'g'). 'occAnalBind' first consumes 'CyclicSCC g' and then it consumes+'AcyclicSCC f', where 'body_usage' won't contain 'f'.++Note [Forming Rec groups]+~~~~~~~~~~~~~~~~~~~~~~~~~+The key point about the "Forming Rec groups" step is that it /preserves+scoping/.  If 'x' is mentioned, it had better be bound somewhere.  So if+we start with+  Rec { f = ...h...+      ; g = ...f...+      ; h = ...f... }+we can split into SCCs+  Rec { f = ...h...+      ; h = ..f... }+  NonRec { g = ...f... }++We put bindings {f = ef; g = eg } in a Rec group if "f uses g" and "g+uses f", no matter how indirectly.  We do a SCC analysis with an edge+f -> g if "f mentions g". That is, g is free in:+  a) the rhs 'ef'+  b) or the RHS of a rule for f, whether active or inactive+       Note [Rules are extra RHSs]+  c) or the LHS or a rule for f, whether active or inactive+       Note [Rule dependency info]+  d) the RHS of an /active/ local IMP-RULE+       Note [IMP-RULES: local rules for imported functions]++(b) and (c) apply regardless of the activation of the RULE, because even if+the rule is inactive its free variables must be bound.  But (d) doesn't need+to worry about this because IMP-RULES are always notionally at the bottom+of the file.++  * Note [Rules are extra RHSs]+    ~~~~~~~~~~~~~~~~~~~~~~~~~~~+    A RULE for 'f' is like an extra RHS for 'f'. That way the "parent"+    keeps the specialised "children" alive.  If the parent dies+    (because it isn't referenced any more), then the children will die+    too (unless they are already referenced directly).++    So in Example [eftInt], eftInt and eftIntFB will be put in the+    same Rec, even though their 'main' RHSs are both non-recursive.++    We must also include inactive rules, so that their free vars+    remain in scope.++  * Note [Rule dependency info]+    ~~~~~~~~~~~~~~~~~~~~~~~~~~~+    The VarSet in a RuleInfo is used for dependency analysis in the+    occurrence analyser.  We must track free vars in *both* lhs and rhs.+    Hence use of idRuleVars, rather than idRuleRhsVars in occAnalBind.+    Why both? Consider+        x = y+        RULE f x = v+4+    Then if we substitute y for x, we'd better do so in the+    rule's LHS too, so we'd better ensure the RULE appears to mention 'x'+    as well as 'v'++  * Note [Rules are visible in their own rec group]+    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+    We want the rules for 'f' to be visible in f's right-hand side.+    And we'd like them to be visible in other functions in f's Rec+    group.  E.g. in Note [Specialisation rules] we want f' rule+    to be visible in both f's RHS, and fs's RHS.++    This means that we must simplify the RULEs first, before looking+    at any of the definitions.  This is done by Simplify.simplRecBind,+    when it calls addLetIdInfo.++Note [TailUsageDetails when forming Rec groups]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The `TailUsageDetails` stored in the `nd_uds` field of a `NodeDetails` is+computed by `occAnalLamTail` applied to the RHS, not `occAnalExpr`.+That is because the binding might still become a *non-recursive join point* in+the AcyclicSCC case of dependency analysis!+Hence we do the delayed `adjustTailUsage` in `occAnalRec`/`tagRecBinders` to get+a regular, adjusted UsageDetails.+See Note [Join points and unfoldings/rules] for more details on the contract.++Note [Stable unfoldings]+~~~~~~~~~~~~~~~~~~~~~~~~+None of the above stuff about RULES applies to a stable unfolding+stored in a CoreUnfolding.  The unfolding, if any, is simplified+at the same time as the regular RHS of the function (ie *not* like+Note [Rules are visible in their own rec group]), so it should be+treated *exactly* like an extra RHS.++Or, rather, when computing loop-breaker edges,+  * If f has an INLINE pragma, and it is active, we treat the+    INLINE rhs as f's rhs+  * If it's inactive, we treat f as having no rhs+  * If it has no INLINE pragma, we look at f's actual rhs+++There is a danger that we'll be sub-optimal if we see this+     f = ...f...+     [INLINE f = ..no f...]+where f is recursive, but the INLINE is not. This can just about+happen with a sufficiently odd set of rules; eg++        foo :: Int -> Int+        {-# INLINE [1] foo #-}+        foo x = x+1++        bar :: Int -> Int+        {-# INLINE [1] bar #-}+        bar x = foo x + 1++        {-# RULES "foo" [~1] forall x. foo x = bar x #-}++Here the RULE makes bar recursive; but it's INLINE pragma remains+non-recursive. It's tempting to then say that 'bar' should not be+a loop breaker, but an attempt to do so goes wrong in two ways:+   a) We may get+         $df = ...$cfoo...+         $cfoo = ...$df....+         [INLINE $cfoo = ...no-$df...]+      But we want $cfoo to depend on $df explicitly so that we+      put the bindings in the right order to inline $df in $cfoo+      and perhaps break the loop altogether.  (Maybe this+   b)+++Example [eftInt]+~~~~~~~~~~~~~~~+Example (from GHC.Enum):++  eftInt :: Int# -> Int# -> [Int]+  eftInt x y = ...(non-recursive)...++  {-# INLINE [0] eftIntFB #-}+  eftIntFB :: (Int -> r -> r) -> r -> Int# -> Int# -> r+  eftIntFB c n x y = ...(non-recursive)...++  {-# RULES+  "eftInt"  [~1] forall x y. eftInt x y = build (\ c n -> eftIntFB c n x y)+  "eftIntList"  [1] eftIntFB  (:) [] = eftInt+   #-}++Note [Specialisation rules]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this group, which is typical of what SpecConstr builds:++   fs a = ....f (C a)....+   f  x = ....f (C a)....+   {-# RULE f (C a) = fs a #-}++So 'f' and 'fs' are in the same Rec group (since f refers to fs via its RULE).++But watch out!  If 'fs' is not chosen as a loop breaker, we may get an infinite loop:+  - the RULE is applied in f's RHS (see Note [Rules for recursive functions] in GHC.Core.Opt.Simplify+  - fs is inlined (say it's small)+  - now there's another opportunity to apply the RULE++This showed up when compiling Control.Concurrent.Chan.getChanContents.+Hence the transitive rule_fv_env stuff described in+Note [Rules and loop breakers].++Note [Occurrence analysis for join points]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider these two somewhat artificial programs (#22404)++  Program (P1)                      Program (P2)+  ------------------------------    -------------------------------------+  let v = <small thunk> in          let v = <small thunk> in+                                    join j = case v of (a,b) -> a+  in case x of                      in case x of+        A -> case v of (a,b) -> a         A -> j+        B -> case v of (a,b) -> a         B -> j+        C -> case v of (a,b) -> b         C -> case v of (a,b) -> b+        D -> []                           D -> []++In (P1), `v` gets allocated, as a thunk, every time this code is executed.  But+notice that `v` occurs at most once in any case branch; the occurrence analyser+spots this and returns a OneOcc{ occ_n_br = 3 } for `v`.  Then the code in+GHC.Core.Opt.Simplify.Utils.postInlineUnconditionally inlines `v` at its three+use sites, and discards the let-binding.  That way, we avoid allocating `v` in+the A,B,C branches (though we still compute it of course), and branch D+doesn't involve <small thunk> at all.  This sometimes makes a Really Big+Difference.++In (P2) we have shared the common RHS of A, B, in a join point `j`.  We would+like to inline `v` in just the same way as in (P1).  But the usual strategy+for let bindings is conservative and uses `andUDs` to combine usage from j's+RHS to its body; as if `j` was called on every code path (once, albeit).  In+the case of (P2), we'll get ManyOccs for `v`.  Important optimisation lost!++Solving this problem makes the Simplifier less fragile.  For example,+the Simplifier might inline `j`, and convert (P2) into (P1)... or it might+not, depending in a perhaps-fragile way on the size of the join point.+I was motivated to implement this feature of the occurrence analyser+when trying to make optimisation join points simpler and more robust+(see e.g. #23627).++The occurrence analyser therefore has clever code that behaves just as+if you inlined `j` at all its call sites.  Here is a tricky variant+to keep in mind:++  Program (P3)+  -------------------------------+    join j = case v of (a,b) -> a+    in case f v of+          A -> j+          B -> j+          C -> []++If you mentally inline `j` you'll see that `v` is used twice on the path+through A, so it should have ManyOcc.  Bear this case in mind!++* We treat /non-recursive/ join points specially. Recursive join points are+  treated like any other letrec, as before.  Moreover, we only give this special+  treatment to /pre-existing/ non-recursive join points, not the ones that we+  discover for the first time in this sweep of the occurrence analyser.++* In occ_env, the new (occ_join_points :: IdEnv OccInfoEnv) maps+  each in-scope non-recursive join point, such as `j` above, to+  a "zeroed form" of its RHS's usage details. The "zeroed form"+    * deletes ManyOccs+    * maps a OneOcc to OneOcc{ occ_n_br = 0 }+  In our example, occ_join_points will be extended with+      [j :-> [v :-> OneOcc{occ_n_br=0}]]+  See addJoinPoint.++* At an occurrence of a join point, we do everything as normal, but add in the+  UsageDetails from the occ_join_points.  See mkOneOcc.++* Crucially, at the NonRec binding of the join point, in `occAnalBind`, we use+  `orUDs`, not `andUDs` to combine the usage from the RHS with the usage from+  the body.++Here are the consequences++* Because of the perhaps-surprising OneOcc{occ_n_br=0} idea of the zeroed+  form, the occ_n_br field of a OneOcc binder still counts the number of+  /actual lexical occurrences/ of the variable.  In Program P2, for example,+  `v` will end up with OneOcc{occ_n_br=2}, not occ_n_br=3.+  There are two lexical occurrences of `v`!+  (NB: `orUDs` adds occ_n_br together, so occ_n_br=1 is impossible, too.)++* In the tricky (P3) we'll get an `andUDs` of+    * OneOcc{occ_n_br=0} from the occurrences of `j`)+    * OneOcc{occ_n_br=1} from the (f v)+  These are `andUDs` together in `addOccInfo`, and hence+  `v` gets ManyOccs, just as it should.  Clever!++There are a couple of tricky wrinkles++(W1) Consider this example which shadows `j`:+          join j = rhs in+          in case x of { K j -> ..j..; ... }+     Clearly when we come to the pattern `K j` we must drop the `j`+     entry in occ_join_points.++     This is done by `drop_shadowed_joins` in `addInScope`.++(W2) Consider this example which shadows `v`:+          join j = ...v...+          in case x of { K v -> ..j..; ... }++     We can't make j's occurrences in the K alternative give rise to an+     occurrence of `v` (via occ_join_points), because it'll just be deleted by+     the `K v` pattern.  Yikes.  This is rare because shadowing is rare, but+     it definitely can happen.  Solution: when bringing `v` into scope at+     the `K v` pattern, chuck out of occ_join_points any elements whose+     UsageDetails mentions `v`.  Instead, just `andUDs` all that usage in+     right here.++     This requires work in two places.+     * In `preprocess_env`, we detect if the newly-bound variables intersect+       the free vars of occ_join_points.  (These free vars are conveniently+       simply the domain of the OccInfoEnv for that join point.) If so,+       we zap the entire occ_join_points.+     * In `postprcess_uds`, we add the chucked-out join points to the+       returned UsageDetails, with `andUDs`.++(W3) Consider this example, which shadows `j`, but this time in an argument+              join j = rhs+              in f (case x of { K j -> ...; ... })+     We can zap the entire occ_join_points when looking at the argument,+     because `j` can't posibly occur -- it's a join point!  And the smaller+     occ_join_points is, the better.  Smaller to look up in mkOneOcc, and+     more important, less looking-up when checking (W2).++     This is done in setNonTailCtxt.  It's important /not/ to do this for+     join-point RHS's because of course `j` can occur there!++     NB: this is just about efficiency: it is always safe /not/ to zap the+     occ_join_points.++(W4) What if the join point binding has a stable unfolding, or RULES?+     They are just alternative right-hand sides, and at each call site we+     will use only one of them. So again, we can use `orUDs` to combine+     usage info from all these alternatives RHSs.++Wrinkles (W1) and (W2) are very similar to Note [Binder swap] (BS3).++Note [Finding join points]+~~~~~~~~~~~~~~~~~~~~~~~~~~+It's the occurrence analyser's job to find bindings that we can turn into join+points, but it doesn't perform that transformation right away. Rather, it marks+the eligible bindings as part of their occurrence data, leaving it to the+simplifier (or to simpleOptPgm) to actually change the binder's 'IdDetails'.+The simplifier then eta-expands the RHS if needed and then updates the+occurrence sites. Dividing the work this way means that the occurrence analyser+still only takes one pass, yet one can always tell the difference between a+function call and a jump by looking at the occurrence (because the same pass+changes the 'IdDetails' and propagates the binders to their occurrence sites).++To track potential join points, we use the 'occ_tail' field of OccInfo. A value+of `AlwaysTailCalled n` indicates that every occurrence of the variable is a+tail call with `n` arguments (counting both value and type arguments). Otherwise+'occ_tail' will be 'NoTailCallInfo'. The tail call info flows bottom-up with the+rest of 'OccInfo' until it goes on the binder.++Note [Join arity prediction based on joinRhsArity]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In general, the join arity from tail occurrences of a join point (O) may be+higher or lower than the manifest join arity of the join body (M). E.g.,++  -- M > O:+  let f x y = x + y              -- M = 2+  in if b then f 1 else f 2      -- O = 1+  ==> { Contify for join arity 1 }+  join f x = \y -> x + y+  in if b then jump f 1 else jump f 2++  -- M < O+  let f = id                     -- M = 0+  in if ... then f 12 else f 13  -- O = 1+  ==> { Contify for join arity 1, eta-expand f }+  join f x = id x+  in if b then jump f 12 else jump f 13++But for *recursive* let, it is crucial that both arities match up, consider++  letrec f x y = if ... then f x else True+  in f 42++Here, M=2 but O=1. If we settled for a joinrec arity of 1, the recursive jump+would not happen in a tail context! Contification is invalid here.+So indeed it is crucial to demand that M=O.++(Side note: Actually, we could be more specific: Let O1 be the join arity of+occurrences from the letrec RHS and O2 the join arity from the let body. Then+we need M=O1 and M<=O2 and could simply eta-expand the RHS to match O2 later.+M=O is the specific case where we don't want to eta-expand. Neither the join+points paper nor GHC does this at the moment.)++We can capitalise on this observation and conclude that *if* f could become a+joinrec (without eta-expansion), it will have join arity M.+Now, M is just the result of 'joinRhsArity', a rather simple, local analysis.+It is also the join arity inside the 'TailUsageDetails' returned by+'occAnalLamTail', so we can predict join arity without doing any fixed-point+iteration or really doing any deep traversal of let body or RHS at all.+We check for M in the 'adjustTailUsage' call inside 'tagRecBinders'.++All this is quite apparent if you look at the contification transformation in+Fig. 5 of "Compiling without Continuations" (which does not account for+eta-expansion at all, mind you). The letrec case looks like this++  letrec f = /\as.\xs. L[us] in L'[es]+    ... and a bunch of conditions establishing that f only occurs+        in app heads of join arity (len as + len xs) inside us and es ...++The syntactic form `/\as.\xs. L[us]` forces M=O iff `f` occurs in `us`. However,+for non-recursive functions, this is the definition of contification from the+paper:++  let f = /\as.\xs.u in L[es]     ... conditions ...++Note that u could be a lambda itself, as we have seen. No relationship between M+and O to exploit here.++Note [Join points and unfoldings/rules]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+   let j2 y = blah+   let j x = j2 (x+x)+       {-# INLINE [2] j #-}+   in case e of { A -> j 1; B -> ...; C -> j 2 }++Before j is inlined, we'll have occurrences of j2 in+both j's RHS and in its stable unfolding.  We want to discover+j2 as a join point. So 'occAnalUnfolding' returns an unadjusted+'TailUsageDetails', like 'occAnalLamTail'. We adjust the usage details of the+unfolding to the actual join arity using the same 'adjustTailArity' as for+the RHS, see Note [Adjusting right-hand sides].++Same with rules. Suppose we have:++  let j :: Int -> Int+      j y = 2 * y+  let k :: Int -> Int -> Int+      {-# RULES "SPEC k 0" k 0 y = j y #-}+      k x y = x + 2 * y+  in case e of { A -> k 1 2; B -> k 3 5; C -> blah }++We identify k as a join point, and we want j to be a join point too.+Without the RULE it would be, and we don't want the RULE to mess it+up.  So provided the join-point arity of k matches the args of the+rule we can allow the tail-call info from the RHS of the rule to+propagate.++* Note that the join arity of the RHS and that of the unfolding or RULE might+  mismatch:++    let j x y = j2 (x+x)+        {-# INLINE[2] j = \x. g #-}+        {-# RULE forall x y z. j x y z = h 17 #-}+    in j 1 2++  So it is crucial that we adjust each TailUsageDetails individually+  with the actual join arity 2 here before we combine with `andUDs`.+  Here, that means losing tail call info on `g` and `h`.++* Wrinkle for Rec case: We store one TailUsageDetails in the node Details for+  RHS, unfolding and RULE combined. Clearly, if they don't agree on their join+  arity, we have to do some adjusting. We choose to adjust to the join arity+  of the RHS, because that is likely the join arity that the join point will+  have; see Note [Join arity prediction based on joinRhsArity].++  If the guess is correct, then tail calls in the RHS are preserved; a necessary+  condition for the whole binding becoming a joinrec.+  The guess can only be incorrect in the 'AcyclicSCC' case when the binding+  becomes a non-recursive join point with a different join arity. But then the+  eventual call to 'adjustTailUsage' in 'tagRecBinders'/'occAnalRec' will+  be with a different join arity and destroy unsound tail call info with+  'markNonTail'.++* Wrinkle for RULES.  Suppose the example was a bit different:+      let j :: Int -> Int+          j y = 2 * y+          k :: Int -> Int -> Int+          {-# RULES "SPEC k 0" k 0 = j #-}+          k x y = x + 2 * y+      in ...+  If we eta-expanded the rule all would be well, but as it stands the+  one arg of the rule don't match the join-point arity of 2.++  Conceivably we could notice that a potential join point would have+  an "undersaturated" rule and account for it. This would mean we+  could make something that's been specialised a join point, for+  instance. But local bindings are rarely specialised, and being+  overly cautious about rules only costs us anything when, for some `j`:++  * Before specialisation, `j` has non-tail calls, so it can't be a join point.+  * During specialisation, `j` gets specialised and thus acquires rules.+  * Sometime afterward, the non-tail calls to `j` disappear (as dead code, say),+    and so now `j` *could* become a join point.++  This appears to be very rare in practice. TODO Perhaps we should gather+  statistics to be sure.++------------------------------------------------------------+Note [Adjusting right-hand sides]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There's a bit of a dance we need to do after analysing a lambda expression or+a right-hand side. In particular, we need to++  a) call 'markAllNonTail' *unless* the binding is for a join point, and+     the TailUsageDetails from the RHS has the right join arity; e.g.+        join j x y = case ... of+                       A -> j2 p+                       B -> j2 q+        in j a b+     Here we want the tail calls to j2 to be tail calls of the whole expression+  b) call 'markAllInsideLam' *unless* the binding is for a thunk, a one-shot+     lambda, or a non-recursive join point++Some examples, with how the free occurrences in e (assumed not to be a value+lambda) get marked:++                             inside lam    non-tail-called+  ------------------------------------------------------------+  let x = e                  No            Yes+  let f = \x -> e            Yes           Yes+  let f = \x{OneShot} -> e   No            Yes+  \x -> e                    Yes           Yes+  join j x = e               No            No+  joinrec j x = e            Yes           No++There are a few other caveats; most importantly, if we're marking a binding as+'AlwaysTailCalled', it's *going* to be a join point, so we treat it as one so+that the effect cascades properly. Consequently, at the time the RHS is+analysed, we won't know what adjustments to make; thus 'occAnalLamTail' must+return the unadjusted 'TailUsageDetails', to be adjusted by 'adjustTailUsage'+once join-point-hood has been decided and eventual one-shot annotations have+been added through 'markNonRecJoinOneShots'.++It is not so simple to see that 'occAnalNonRecBind' and 'occAnalRecBind' indeed+perform a similar sequence of steps. Thus, here is an interleaving of events+of both functions, serving as a specification:++  1. Call 'occAnalLamTail' to find usage information for the RHS.+     Recursive case:     'makeNode'+     Non-recursive case: 'occAnalNonRecBind'+  2. (Analyse the binding's scope. Done in 'occAnalBind'/`occAnal Let{}`.+      Same whether recursive or not.)+  3. Call 'tagNonRecBinder' or 'tagRecBinders', which decides whether to make+     the binding a join point.+     Cyclic  Recursive case:  'mkLoopBreakerNodes'+     Acyclic Recursive case:  `occAnalRec AcyclicSCC{}`+     Non-recursive case:      'occAnalNonRecBind'+  4. Non-recursive join point: Call 'markNonRecJoinOneShots' so that e.g.,+     FloatOut sees one-shot annotations on lambdas+     Acyclic Recursive case:  `occAnalRec AcyclicSCC{}`  calls 'adjustNonRecRhs'+     Non-recursive case:      'occAnalNonRecBind'        calls 'adjustNonRecRhs'+  5. Call 'adjustTailUsage' accordingly.+     Cyclic Recursive case:   'tagRecBinders'+     Acyclic Recursive case:  'adjustNonRecRhs'+     Non-recursive case:      'adjustNonRecRhs'+-}++------------------------------------------------------------------+--                 occAnalBind+------------------------------------------------------------------++occAnalBind+  :: OccEnv+  -> TopLevelFlag+  -> ImpRuleEdges+  -> CoreBind+  -> (OccEnv -> WithUsageDetails r)  -- Scope of the bind+  -> ([CoreBind] -> r -> r)          -- How to combine the scope with new binds+  -> WithUsageDetails r              -- Of the whole let(rec)++occAnalBind env lvl ire (Rec pairs) thing_inside combine+  = addInScopeList env (map fst pairs) $ \env ->+    let WUD body_uds body'  = thing_inside env+        WUD bind_uds binds' = occAnalRecBind env lvl ire pairs body_uds+    in WUD bind_uds (combine binds' body')++occAnalBind !env lvl ire (NonRec bndr rhs) thing_inside combine+  | isTyVar bndr      -- A type let; we don't gather usage info+  = let !(WUD body_uds res) = addInScopeOne env bndr thing_inside+    in WUD body_uds (combine [NonRec bndr rhs] res)++  -- /Existing/ non-recursive join points+  -- See Note [Occurrence analysis for join points]+  | mb_join@(JoinPoint {}) <- idJoinPointHood bndr+  = -- Analyse the RHS and /then/ the body+    let -- Analyse the rhs first, generating rhs_uds+        !(rhs_uds_s, bndr', rhs') = occAnalNonRecRhs env ire mb_join bndr rhs+        rhs_uds = foldr1 orUDs rhs_uds_s   -- NB: orUDs.  See (W4) of+                                           -- Note [Occurrence analysis for join points]++        -- Now analyse the body, adding the join point+        -- into the environment with addJoinPoint+        !(WUD body_uds (occ, body)) = occAnalNonRecBody env bndr' $ \env ->+                                      thing_inside (addJoinPoint env bndr' rhs_uds)+    in+    if isDeadOcc occ     -- Drop dead code; see Note [Dead code]+    then WUD body_uds body+    else WUD (rhs_uds `orUDs` body_uds)    -- Note `orUDs`+             (combine [NonRec (fst (tagNonRecBinder lvl occ bndr')) rhs']+                      body)++  -- The normal case, including newly-discovered join points+  -- Analyse the body and /then/ the RHS+  | WUD body_uds (occ,body) <- occAnalNonRecBody env bndr thing_inside+  = if isDeadOcc occ   -- Drop dead code; see Note [Dead code]+    then WUD body_uds body+    else let+        -- Get the join info from the *new* decision; NB: bndr is not already a JoinId+        -- See Note [Join points and unfoldings/rules]+        -- => join arity O of Note [Join arity prediction based on joinRhsArity]+        (tagged_bndr, mb_join) = tagNonRecBinder lvl occ bndr++        !(rhs_uds_s, final_bndr, rhs') = occAnalNonRecRhs env ire mb_join tagged_bndr rhs+    in WUD (foldr andUDs body_uds rhs_uds_s)      -- Note `andUDs`+           (combine [NonRec final_bndr rhs'] body)++-----------------+occAnalNonRecBody :: OccEnv -> Id+                  -> (OccEnv -> WithUsageDetails r)  -- Scope of the bind+                  -> (WithUsageDetails (OccInfo, r))+occAnalNonRecBody env bndr thing_inside+  = addInScopeOne env bndr $ \env ->+    let !(WUD inner_uds res) = thing_inside env+        !occ = lookupLetOccInfo inner_uds bndr+    in WUD inner_uds (occ, res)++-----------------+occAnalNonRecRhs :: OccEnv -> ImpRuleEdges -> JoinPointHood+                 -> Id -> CoreExpr+                 -> ([UsageDetails], Id, CoreExpr)+occAnalNonRecRhs !env imp_rule_edges mb_join bndr rhs+  | null rules, null imp_rule_infos+  =  -- Fast path for common case of no rules. This is only worth+     -- 0.1% perf on average, but it's also only a line or two of code+    ( [adj_rhs_uds, adj_unf_uds],              final_bndr_no_rules,   final_rhs )+  | otherwise+  = (adj_rhs_uds : adj_unf_uds : adj_rule_uds, final_bndr_with_rules, final_rhs )+  where+    is_join_point = isJoinPoint mb_join++    --------- Right hand side ---------+    -- For join points, set occ_encl to OccVanilla, via setTailCtxt.  If we have+    --    join j = Just (f x) in ...+    -- we do not want to float the (f x) to+    --    let y = f x in join j = Just y in ...+    -- That's that OccRhs would do; but there's no point because+    -- j will never be scrutinised.+    env1 | is_join_point = setTailCtxt env+         | otherwise     = setNonTailCtxt rhs_ctxt env  -- Zap occ_join_points+    rhs_ctxt = mkNonRecRhsCtxt bndr unf++    -- See Note [Sources of one-shot information]+    rhs_env = addOneShotsFromDmd bndr env1+    -- See Note [Join arity prediction based on joinRhsArity]+    -- Match join arity O from mb_join_arity with manifest join arity M as+    -- returned by of occAnalLamTail. It's totally OK for them to mismatch;+    -- hence adjust the UDs from the RHS+    WUD adj_rhs_uds final_rhs = adjustNonRecRhs mb_join $+                                occAnalLamTail rhs_env rhs+    final_bndr_with_rules+      | noBinderSwaps env = bndr -- See Note [Unfoldings and rules]+      | otherwise         = bndr `setIdSpecialisation` mkRuleInfo rules'+                                 `setIdUnfolding` unf2+    final_bndr_no_rules+      | noBinderSwaps env = bndr -- See Note [Unfoldings and rules]+      | otherwise         = bndr `setIdUnfolding` unf2++    --------- Unfolding ---------+    -- See Note [Join points and unfoldings/rules]+    unf = idUnfolding bndr+    WTUD unf_tuds unf1 = occAnalUnfolding rhs_env unf+    unf2 = markNonRecUnfoldingOneShots mb_join unf1+    adj_unf_uds = adjustTailArity mb_join unf_tuds++    --------- Rules ---------+    -- See Note [Rules are extra RHSs] and Note [Rule dependency info]+    -- and Note [Join points and unfoldings/rules]+    rules        = idCoreRules bndr+    rules_w_uds  = map (occAnalRule rhs_env) rules+    rules'       = map fstOf3 rules_w_uds+    imp_rule_infos = lookupImpRules imp_rule_edges bndr+    imp_rule_uds   = [impRulesScopeUsage imp_rule_infos]+         -- imp_rule_uds: consider+         --     h = ...+         --     g = ...+         --     RULE map g = h+         -- Then we want to ensure that h is in scope everywhere+         -- that g is (since the RULE might turn g into h), so+         -- we make g mention h.++    adj_rule_uds :: [UsageDetails]+    adj_rule_uds = imp_rule_uds +++                   [ l `andUDs` adjustTailArity mb_join r+                   | (_,l,r) <- rules_w_uds ]++mkNonRecRhsCtxt :: Id -> Unfolding -> OccEncl+-- Precondition: Id is not a join point+mkNonRecRhsCtxt bndr unf+  | certainly_inline = OccVanilla -- See Note [Cascading inlines]+  | otherwise        = OccRhs+  where+    certainly_inline -- See Note [Cascading inlines]+      = -- mkNonRecRhsCtxt is only used for non-join points, so occAnalBind+        -- has set the OccInfo for this binder before calling occAnalNonRecRhs+        case idOccInfo bndr of+          OneOcc { occ_in_lam = NotInsideLam, occ_n_br = 1 }+            -> active && not_stable+          _ -> False++    active     = isAlwaysActive (idInlineActivation bndr)+    not_stable = not (isStableUnfolding unf)++-----------------+occAnalRecBind :: OccEnv -> TopLevelFlag -> ImpRuleEdges -> [(Var,CoreExpr)]+               -> UsageDetails -> WithUsageDetails [CoreBind]+-- For a recursive group, we+--      * occ-analyse all the RHSs+--      * compute strongly-connected components+--      * feed those components to occAnalRec+-- See Note [Recursive bindings: the grand plan]+occAnalRecBind !rhs_env lvl imp_rule_edges pairs body_usage+  = foldr (occAnalRec rhs_env lvl) (WUD body_usage []) sccs+  where+    sccs :: [SCC NodeDetails]+    sccs = stronglyConnCompFromEdgedVerticesUniq nodes++    nodes :: [LetrecNode]+    nodes = map (makeNode rhs_env imp_rule_edges bndr_set) pairs++    bndrs    = map fst pairs+    bndr_set = mkVarSet bndrs++-----------------------------+occAnalRec :: OccEnv -> TopLevelFlag+           -> SCC NodeDetails+           -> WithUsageDetails [CoreBind]+           -> WithUsageDetails [CoreBind]++-- The NonRec case is just like a Let (NonRec ...) above+occAnalRec !_ lvl+           (AcyclicSCC (ND { nd_bndr = bndr, nd_rhs = wtuds }))+           (WUD body_uds binds)+  | isDeadOcc occ  -- Check for dead code: see Note [Dead code]+  = WUD body_uds binds+  | otherwise+  = let (tagged_bndr, mb_join) = tagNonRecBinder lvl occ bndr+        !(WUD rhs_uds' rhs') = adjustNonRecRhs mb_join wtuds+        !unf'  = markNonRecUnfoldingOneShots mb_join (idUnfolding tagged_bndr)+        !bndr' = tagged_bndr `setIdUnfolding` unf'+    in WUD (body_uds `andUDs` rhs_uds')+           (NonRec bndr' rhs' : binds)+  where+    occ = lookupLetOccInfo body_uds bndr++-- The Rec case is the interesting one+-- See Note [Recursive bindings: the grand plan]+-- See Note [Loop breaking]+occAnalRec env lvl (CyclicSCC details_s) (WUD body_uds binds)+  | not (any needed details_s)+  = -- Check for dead code: see Note [Dead code]+    -- NB: Only look at body_uds, ignoring uses in the SCC+    WUD body_uds binds++  | otherwise+  = WUD final_uds (Rec pairs : binds)+  where+    all_simple = all nd_simple details_s++    needed :: NodeDetails -> Bool+    needed (ND { nd_bndr = bndr }) = isExportedId bndr || bndr `elemVarEnv` body_env+    body_env = ud_env body_uds++    ------------------------------+    -- Make the nodes for the loop-breaker analysis+    -- See Note [Choosing loop breakers] for loop_breaker_nodes+    final_uds :: UsageDetails+    loop_breaker_nodes :: [LoopBreakerNode]+    WUD final_uds loop_breaker_nodes = mkLoopBreakerNodes env lvl body_uds details_s++    ------------------------------+    weak_fvs :: VarSet+    weak_fvs = mapUnionVarSet nd_weak_fvs details_s++    ---------------------------+    -- Now reconstruct the cycle+    pairs :: [(Id,CoreExpr)]+    pairs | all_simple = reOrderNodes   0 weak_fvs loop_breaker_nodes []+          | otherwise  = loopBreakNodes 0 weak_fvs loop_breaker_nodes []+          -- In the common case when all are "simple" (no rules at all)+          -- the loop_breaker_nodes will include all the scope edges+          -- so a SCC computation would yield a single CyclicSCC result;+          -- and reOrderNodes deals with exactly that case.+          -- Saves a SCC analysis in a common case+++{- *********************************************************************+*                                                                      *+                Loop breaking+*                                                                      *+********************************************************************* -}++{- Note [Choosing loop breakers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In Step 4 in Note [Recursive bindings: the grand plan]), occAnalRec does+loop-breaking on each CyclicSCC of the original program:++* mkLoopBreakerNodes: Form the loop-breaker graph for that CyclicSCC++* loopBreakNodes: Do SCC analysis on it++* reOrderNodes: For each CyclicSCC, pick a loop breaker+    * Delete edges to that loop breaker+    * Do another SCC analysis on that reduced SCC+    * Repeat++To form the loop-breaker graph, we construct a new set of Nodes, the+"loop-breaker nodes", with the same details but different edges, the+"loop-breaker edges".  The loop-breaker nodes have both more and fewer+dependencies than the scope edges:++  More edges:+     If f calls g, and g has an active rule that mentions h then+     we add an edge from f -> h.  See Note [Rules and loop breakers].++  Fewer edges: we only include dependencies+     * only on /active/ rules,+     * on rule /RHSs/ (not LHSs)++The scope edges, by contrast, must be much more inclusive.++The nd_simple flag tracks the common case when a binding has no RULES+at all, in which case the loop-breaker edges will be identical to the+scope edges.++Note that in Example [eftInt], *neither* eftInt *nor* eftIntFB is+chosen as a loop breaker, because their RHSs don't mention each other.+And indeed both can be inlined safely.++Note [inl_fvs]+~~~~~~~~~~~~~~+Note that the loop-breaker graph includes edges for occurrences in+/both/ the RHS /and/ the stable unfolding.  Consider this, which actually+occurred when compiling BooleanFormula.hs in GHC:++  Rec { lvl1 = go+      ; lvl2[StableUnf = go] = lvl1+      ; go = ...go...lvl2... }++From the point of view of infinite inlining, we need only these edges:+   lvl1 :-> go+   lvl2 :-> go       -- The RHS lvl1 will never be used for inlining+   go   :-> go, lvl2++But the danger is that, lacking any edge to lvl1, we'll put it at the+end thus+  Rec { lvl2[ StableUnf = go] = lvl1+      ; go[LoopBreaker] = ...go...lvl2... }+      ; lvl1[Occ=Once]  = go }++And now the Simplifer will try to use PreInlineUnconditionally on lvl1+(which occurs just once), but because it is last we won't actually+substitute in lvl2.  Sigh.++To avoid this possibility, we include edges from lvl2 to /both/ its+stable unfolding /and/ its RHS.  Hence the defn of inl_fvs in+makeNode.  Maybe we could be more clever, but it's very much a corner+case.++Note [Weak loop breakers]+~~~~~~~~~~~~~~~~~~~~~~~~~+There is a last nasty wrinkle.  Suppose we have++    Rec { f = f_rhs+          RULE f [] = g++          h = h_rhs+          g = h+          ...more... }++Remember that we simplify the RULES before any RHS (see Note+[Rules are visible in their own rec group] above).++So we must *not* postInlineUnconditionally 'g', even though+its RHS turns out to be trivial.  (I'm assuming that 'g' is+not chosen as a loop breaker.)  Why not?  Because then we+drop the binding for 'g', which leaves it out of scope in the+RULE!++Here's a somewhat different example of the same thing+    Rec { q = r+        ; r = ...p...+        ; p = p_rhs+          RULE p [] = q }+Here the RULE is "below" q, but we *still* can't postInlineUnconditionally+q, because the RULE for p is active throughout.  So the RHS of r+might rewrite to     r = ...q...+So q must remain in scope in the output program!++We "solve" this by:++    Make q a "weak" loop breaker (OccInfo = IAmLoopBreaker True)+    iff q is a mentioned in the RHS of any RULE (active on not)+    in the Rec group++Note the "active or not" comment; even if a RULE is inactive, we+want its RHS free vars to stay alive (#20820)!++A normal "strong" loop breaker has IAmLoopBreaker False.  So:++                                Inline  postInlineUnconditionally+strong   IAmLoopBreaker False    no      no+weak     IAmLoopBreaker True     yes     no+         other                   yes     yes++The **sole** reason for this kind of loop breaker is so that+postInlineUnconditionally does not fire.  Ugh.++Annoyingly, since we simplify the rules *first* we'll never inline+q into p's RULE.  That trivial binding for q will hang around until+we discard the rule.  Yuk.  But it's rare.++Note [Rules and loop breakers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When we form the loop-breaker graph (Step 4 in Note [Recursive+bindings: the grand plan]), we must be careful about RULEs.++For a start, we want a loop breaker to cut every cycle, so inactive+rules play no part; we need only consider /active/ rules.+See Note [Finding rule RHS free vars]++The second point is more subtle.  A RULE is like an equation for+'f' that is *always* inlined if it is applicable.  We do *not* disable+rules for loop-breakers.  It's up to whoever makes the rules to make+sure that the rules themselves always terminate.  See Note [Rules for+recursive functions] in GHC.Core.Opt.Simplify++Hence, if+    f's RHS (or its stable unfolding if it has one) mentions g, and+    g has a RULE that mentions h, and+    h has a RULE that mentions f++then we *must* choose f to be a loop breaker.  Example: see Note+[Specialisation rules]. So our plan is this:++   Take the free variables of f's RHS, and augment it with all the+   variables reachable by a transitive sequence RULES from those+   starting points.++That is the whole reason for computing rule_fv_env in mkLoopBreakerNodes.+Wrinkles:++* We only consider /active/ rules. See Note [Finding rule RHS free vars]++* We need only consider free vars that are also binders in this Rec+  group.  See also Note [Finding rule RHS free vars]++* We only consider variables free in the *RHS* of the rule, in+  contrast to the way we build the Rec group in the first place (Note+  [Rule dependency info])++* Why "transitive sequence of rules"?  Because active rules apply+  unconditionally, without checking loop-breaker-ness.+ See Note [Loop breaker dependencies].++Note [Finding rule RHS free vars]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider this real example from Data Parallel Haskell+     tagZero :: Array Int -> Array Tag+     {-# INLINE [1] tagZeroes #-}+     tagZero xs = pmap (\x -> fromBool (x==0)) xs++     {-# RULES "tagZero" [~1] forall xs n.+         pmap fromBool <blah blah> = tagZero xs #-}+So tagZero's RHS mentions pmap, and pmap's RULE mentions tagZero.+However, tagZero can only be inlined in phase 1 and later, while+the RULE is only active *before* phase 1.  So there's no problem.++To make this work, we look for the RHS free vars only for+*active* rules. That's the reason for the occ_rule_act field+of the OccEnv.++Note [loopBreakNodes]+~~~~~~~~~~~~~~~~~~~~~+loopBreakNodes is applied to the list of nodes for a cyclic strongly+connected component (there's guaranteed to be a cycle).  It returns+the same nodes, but+        a) in a better order,+        b) with some of the Ids having a IAmALoopBreaker pragma++The "loop-breaker" Ids are sufficient to break all cycles in the SCC.  This means+that the simplifier can guarantee not to loop provided it never records an inlining+for these no-inline guys.++Furthermore, the order of the binds is such that if we neglect dependencies+on the no-inline Ids then the binds are topologically sorted.  This means+that the simplifier will generally do a good job if it works from top bottom,+recording inlinings for any Ids which aren't marked as "no-inline" as it goes.+-}++type Binding = (Id,CoreExpr)++-- See Note [loopBreakNodes]+loopBreakNodes :: Int+               -> VarSet        -- Binders whose dependencies may be "missing"+                                -- See Note [Weak loop breakers]+               -> [LoopBreakerNode]+               -> [Binding]             -- Append these to the end+               -> [Binding]++-- Return the bindings sorted into a plausible order, and marked with loop breakers.+-- See Note [loopBreakNodes]+loopBreakNodes depth weak_fvs nodes binds+  = -- pprTrace "loopBreakNodes" (ppr nodes) $+    go (stronglyConnCompFromEdgedVerticesUniqR nodes)+  where+    go []         = binds+    go (scc:sccs) = loop_break_scc scc (go sccs)++    loop_break_scc scc binds+      = case scc of+          AcyclicSCC node  -> nodeBinding (mk_non_loop_breaker weak_fvs) node : binds+          CyclicSCC nodes  -> reOrderNodes depth weak_fvs nodes binds++----------------------------------+reOrderNodes :: Int -> VarSet -> [LoopBreakerNode] -> [Binding] -> [Binding]+    -- Choose a loop breaker, mark it no-inline,+    -- and call loopBreakNodes on the rest+reOrderNodes _ _ []     _     = panic "reOrderNodes"+reOrderNodes _ _ [node] binds = nodeBinding mk_loop_breaker node : binds+reOrderNodes depth weak_fvs (node : nodes) binds+  = -- pprTrace "reOrderNodes" (vcat [ text "unchosen" <+> ppr unchosen+    --                               , text "chosen" <+> ppr chosen_nodes ]) $+    loopBreakNodes new_depth weak_fvs unchosen $+    (map (nodeBinding mk_loop_breaker) chosen_nodes ++ binds)+  where+    (chosen_nodes, unchosen) = chooseLoopBreaker approximate_lb+                                                 (snd_score (node_payload node))+                                                 [node] [] nodes++    approximate_lb = depth >= 2+    new_depth | approximate_lb = 0+              | otherwise      = depth+1+        -- After two iterations (d=0, d=1) give up+        -- and approximate, returning to d=0++nodeBinding :: (Id -> Id) -> LoopBreakerNode -> Binding+nodeBinding set_id_occ (node_payload -> SND { snd_bndr = bndr, snd_rhs = rhs})+  = (set_id_occ bndr, rhs)++mk_loop_breaker :: Id -> Id+mk_loop_breaker bndr+  = bndr `setIdOccInfo` occ'+  where+    occ'      = strongLoopBreaker { occ_tail = tail_info }+    tail_info = tailCallInfo (idOccInfo bndr)++mk_non_loop_breaker :: VarSet -> Id -> Id+-- See Note [Weak loop breakers]+mk_non_loop_breaker weak_fvs bndr+  | bndr `elemVarSet` weak_fvs = setIdOccInfo bndr occ'+  | otherwise                  = bndr+  where+    occ'      = weakLoopBreaker { occ_tail = tail_info }+    tail_info = tailCallInfo (idOccInfo bndr)++----------------------------------+chooseLoopBreaker :: Bool                -- True <=> Too many iterations,+                                         --          so approximate+                  -> NodeScore           -- Best score so far+                  -> [LoopBreakerNode]   -- Nodes with this score+                  -> [LoopBreakerNode]   -- Nodes with higher scores+                  -> [LoopBreakerNode]   -- Unprocessed nodes+                  -> ([LoopBreakerNode], [LoopBreakerNode])+    -- This loop looks for the bind with the lowest score+    -- to pick as the loop  breaker.  The rest accumulate in+chooseLoopBreaker _ _ loop_nodes acc []+  = (loop_nodes, acc)        -- Done++    -- If approximate_loop_breaker is True, we pick *all*+    -- nodes with lowest score, else just one+    -- See Note [Complexity of loop breaking]+chooseLoopBreaker approx_lb loop_sc loop_nodes acc (node : nodes)+  | approx_lb+  , rank sc == rank loop_sc+  = chooseLoopBreaker approx_lb loop_sc (node : loop_nodes) acc nodes++  | sc `betterLB` loop_sc  -- Better score so pick this new one+  = chooseLoopBreaker approx_lb sc [node] (loop_nodes ++ acc) nodes++  | otherwise              -- Worse score so don't pick it+  = chooseLoopBreaker approx_lb loop_sc loop_nodes (node : acc) nodes+  where+    sc = snd_score (node_payload node)++{-+Note [Complexity of loop breaking]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The loop-breaking algorithm knocks out one binder at a time, and+performs a new SCC analysis on the remaining binders.  That can+behave very badly in tightly-coupled groups of bindings; in the+worst case it can be (N**2)*log N, because it does a full SCC+on N, then N-1, then N-2 and so on.++To avoid this, we switch plans after 2 (or whatever) attempts:+  Plan A: pick one binder with the lowest score, make it+          a loop breaker, and try again+  Plan B: pick *all* binders with the lowest score, make them+          all loop breakers, and try again+Since there are only a small finite number of scores, this will+terminate in a constant number of iterations, rather than O(N)+iterations.++You might thing that it's very unlikely, but RULES make it much+more likely.  Here's a real example from #1969:+  Rec { $dm = \d.\x. op d+        {-# RULES forall d. $dm Int d  = $s$dm1+                  forall d. $dm Bool d = $s$dm2 #-}++        dInt = MkD .... opInt ...+        dInt = MkD .... opBool ...+        opInt  = $dm dInt+        opBool = $dm dBool++        $s$dm1 = \x. op dInt+        $s$dm2 = \x. op dBool }+The RULES stuff means that we can't choose $dm as a loop breaker+(Note [Choosing loop breakers]), so we must choose at least (say)+opInt *and* opBool, and so on.  The number of loop breakers is+linear in the number of instance declarations.++Note [Loop breakers and INLINE/INLINABLE pragmas]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Avoid choosing a function with an INLINE pramga as the loop breaker!+If such a function is mutually-recursive with a non-INLINE thing,+then the latter should be the loop-breaker.++It's vital to distinguish between INLINE and INLINABLE (the+Bool returned by hasStableCoreUnfolding_maybe).  If we start with+   Rec { {-# INLINABLE f #-}+         f x = ...f... }+and then worker/wrapper it through strictness analysis, we'll get+   Rec { {-# INLINABLE $wf #-}+         $wf p q = let x = (p,q) in ...f...++         {-# INLINE f #-}+         f x = case x of (p,q) -> $wf p q }++Now it is vital that we choose $wf as the loop breaker, so we can+inline 'f' in '$wf'.++Note [DFuns should not be loop breakers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It's particularly bad to make a DFun into a loop breaker.  See+Note [How instance declarations are translated] in GHC.Tc.TyCl.Instance++We give DFuns a higher score than ordinary CONLIKE things because+if there's a choice we want the DFun to be the non-loop breaker. Eg++rec { sc = /\ a \$dC. $fBWrap (T a) ($fCT @ a $dC)++      $fCT :: forall a_afE. (Roman.C a_afE) => Roman.C (Roman.T a_afE)+      {-# DFUN #-}+      $fCT = /\a \$dC. MkD (T a) ((sc @ a $dC) |> blah) ($ctoF @ a $dC)+    }++Here 'sc' (the superclass) looks CONLIKE, but we'll never get to it+if we can't unravel the DFun first.++Note [Constructor applications]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+It's really really important to inline dictionaries.  Real+example (the Enum Ordering instance from GHC.Base):++     rec     f = \ x -> case d of (p,q,r) -> p x+             g = \ x -> case d of (p,q,r) -> q x+             d = (v, f, g)++Here, f and g occur just once; but we can't inline them into d.+On the other hand we *could* simplify those case expressions if+we didn't stupidly choose d as the loop breaker.+But we won't because constructor args are marked "Many".+Inlining dictionaries is really essential to unravelling+the loops in static numeric dictionaries, see GHC.Float.++Note [Closure conversion]+~~~~~~~~~~~~~~~~~~~~~~~~~+We treat (\x. C p q) as a high-score candidate in the letrec scoring algorithm.+The immediate motivation came from the result of a closure-conversion transformation+which generated code like this:++    data Clo a b = forall c. Clo (c -> a -> b) c++    ($:) :: Clo a b -> a -> b+    Clo f env $: x = f env x++    rec { plus = Clo plus1 ()++        ; plus1 _ n = Clo plus2 n++        ; plus2 Zero     n = n+        ; plus2 (Succ m) n = Succ (plus $: m $: n) }++If we inline 'plus' and 'plus1', everything unravels nicely.  But if+we choose 'plus1' as the loop breaker (which is entirely possible+otherwise), the loop does not unravel nicely.+++@occAnalUnfolding@ deals with the question of bindings where the Id is marked+by an INLINE pragma.  For these we record that anything which occurs+in its RHS occurs many times.  This pessimistically assumes that this+inlined binder also occurs many times in its scope, but if it doesn't+we'll catch it next time round.  At worst this costs an extra simplifier pass.+ToDo: try using the occurrence info for the inline'd binder.++[March 97] We do the same for atomic RHSs.  Reason: see notes with loopBreakSCC.+[June 98, SLPJ]  I've undone this change; I don't understand it.  See notes with loopBreakSCC.+++************************************************************************+*                                                                      *+                   Making nodes+*                                                                      *+************************************************************************+-}++-- | Digraph node as constructed by 'makeNode' and consumed by 'occAnalRec'.+-- The Unique key is gotten from the Id.+type LetrecNode = Node Unique NodeDetails++-- | Node details as consumed by 'occAnalRec'.+data NodeDetails+  = ND { nd_bndr :: Id          -- Binder++       , nd_rhs  :: !(WithTailUsageDetails CoreExpr)+         -- ^ RHS, already occ-analysed+         -- With TailUsageDetails from RHS, and RULES, and stable unfoldings,+         -- ignoring phase (ie assuming all are active).+         -- NB: Unadjusted TailUsageDetails, as if this Node becomes a+         -- non-recursive join point!+         -- See Note [TailUsageDetails when forming Rec groups]++       , nd_inl  :: IdSet       -- Free variables of the stable unfolding and the RHS+                                -- but excluding any RULES+                                -- This is the IdSet that may be used if the Id is inlined++       , nd_simple :: Bool      -- True iff this binding has no local RULES+                                -- If all nodes are simple we don't need a loop-breaker+                                -- dep-anal before reconstructing.++       , nd_weak_fvs :: IdSet    -- Variables bound in this Rec group that are free+                                 -- in the RHS of any rule (active or not) for this bndr+                                 -- See Note [Weak loop breakers]++       , nd_active_rule_fvs :: IdSet    -- Variables bound in this Rec group that are free+                                        -- in the RHS of an active rule for this bndr+                                        -- See Note [Rules and loop breakers]+  }++instance Outputable NodeDetails where+   ppr nd = text "ND" <> braces+             (sep [ text "bndr =" <+> ppr (nd_bndr nd)+                  , text "uds =" <+> ppr uds+                  , text "inl =" <+> ppr (nd_inl nd)+                  , text "simple =" <+> ppr (nd_simple nd)+                  , text "active_rule_fvs =" <+> ppr (nd_active_rule_fvs nd)+             ])+            where+               WTUD uds _ = nd_rhs nd++-- | Digraph with simplified and completely occurrence analysed+-- 'SimpleNodeDetails', retaining just the info we need for breaking loops.+type LoopBreakerNode = Node Unique SimpleNodeDetails++-- | Condensed variant of 'NodeDetails' needed during loop breaking.+data SimpleNodeDetails+  = SND { snd_bndr  :: IdWithOccInfo  -- OccInfo accurate+        , snd_rhs   :: CoreExpr       -- properly occur-analysed+        , snd_score :: NodeScore+        }++instance Outputable SimpleNodeDetails where+   ppr nd = text "SND" <> braces+             (sep [ text "bndr =" <+> ppr (snd_bndr nd)+                  , text "score =" <+> ppr (snd_score nd)+             ])++-- The NodeScore is compared lexicographically;+--      e.g. lower rank wins regardless of size+type NodeScore = ( Int     -- Rank: lower => more likely to be picked as loop breaker+                 , Int     -- Size of rhs: higher => more likely to be picked as LB+                           -- Maxes out at maxExprSize; we just use it to prioritise+                           -- small functions+                 , Bool )  -- Was it a loop breaker before?+                           -- True => more likely to be picked+                           -- Note [Loop breakers, node scoring, and stability]++rank :: NodeScore -> Int+rank (r, _, _) = r++makeNode :: OccEnv -> ImpRuleEdges -> VarSet+         -> (Var, CoreExpr) -> LetrecNode+-- See Note [Recursive bindings: the grand plan]+makeNode !env imp_rule_edges bndr_set (bndr, rhs)+  = -- pprTrace "makeNode" (ppr bndr <+> ppr (sizeVarSet bndr_set)) $+    DigraphNode { node_payload      = details+                , node_key          = varUnique bndr+                , node_dependencies = nonDetKeysUniqSet scope_fvs }+    -- It's OK to use nonDetKeysUniqSet here as stronglyConnCompFromEdgedVerticesR+    -- is still deterministic with edges in nondeterministic order as+    -- explained in Note [Deterministic SCC] in GHC.Data.Graph.Directed.+  where+    details = ND { nd_bndr            = bndr'+                 , nd_rhs             = WTUD (TUD rhs_ja unadj_scope_uds) rhs'+                 , nd_inl             = inl_fvs+                 , nd_simple          = null rules_w_uds && null imp_rule_info+                 , nd_weak_fvs        = weak_fvs+                 , nd_active_rule_fvs = active_rule_fvs }++    bndr' | noBinderSwaps env = bndr  -- See Note [Unfoldings and rules]+          | otherwise         = bndr `setIdUnfolding`      unf'+                                     `setIdSpecialisation` mkRuleInfo rules'++    -- NB: Both adj_unf_uds and adj_rule_uds have been adjusted to match the+    --     JoinArity rhs_ja of unadj_rhs_uds.+    unadj_inl_uds   = unadj_rhs_uds `andUDs` adj_unf_uds+    unadj_scope_uds = unadj_inl_uds `andUDs` adj_rule_uds+                   -- Note [Rules are extra RHSs]+                   -- Note [Rule dependency info]+    scope_fvs = udFreeVars bndr_set unadj_scope_uds+    -- scope_fvs: all occurrences from this binder: RHS, unfolding,+    --            and RULES, both LHS and RHS thereof, active or inactive++    inl_fvs  = udFreeVars bndr_set unadj_inl_uds+    -- inl_fvs: vars that would become free if the function was inlined.+    -- We conservatively approximate that by the free vars from the RHS+    -- and the unfolding together.+    -- See Note [inl_fvs]+++    --------- Right hand side ---------+    -- Constructing the edges for the main Rec computation+    -- See Note [Forming Rec groups]+    -- and Note [TailUsageDetails when forming Rec groups]+    -- Compared to occAnalNonRecBind, we can't yet adjust the RHS because+    --   (a) we don't yet know the final joinpointhood. It might not become a+    --       join point after all!+    --   (b) we don't even know whether it stays a recursive RHS after the SCC+    --       analysis we are about to seed! So we can't markAllInsideLam in+    --       advance, because if it ends up as a non-recursive join point we'll+    --       consider it as one-shot and don't need to markAllInsideLam.+    -- Instead, do the occAnalLamTail call here and postpone adjustTailUsage+    -- until occAnalRec. In effect, we pretend that the RHS becomes a+    -- non-recursive join point and fix up later with adjustTailUsage.+    rhs_env | isJoinId bndr = setTailCtxt env+            | otherwise     = setNonTailCtxt OccRhs env+            -- If bndr isn't an /existing/ join point, it's safe to zap the+            -- occ_join_points, because they can't occur in RHS.+    WTUD (TUD rhs_ja unadj_rhs_uds) rhs' = occAnalLamTail rhs_env rhs+      -- The corresponding call to adjustTailUsage is in occAnalRec and tagRecBinders++    --------- Unfolding ---------+    -- See Note [Join points and unfoldings/rules]+    unf = realIdUnfolding bndr -- realIdUnfolding: Ignore loop-breaker-ness+                               -- here because that is what we are setting!+    WTUD unf_tuds unf' = occAnalUnfolding rhs_env unf+    adj_unf_uds = adjustTailArity (JoinPoint rhs_ja) unf_tuds+      -- `rhs_ja` is `joinRhsArity rhs` and is the prediction for source M+      -- of Note [Join arity prediction based on joinRhsArity]++    --------- IMP-RULES --------+    is_active     = occ_rule_act env :: Activation -> Bool+    imp_rule_info = lookupImpRules imp_rule_edges bndr+    imp_rule_uds  = impRulesScopeUsage imp_rule_info+    imp_rule_fvs  = impRulesActiveFvs is_active bndr_set imp_rule_info++    --------- All rules --------+    -- See Note [Join points and unfoldings/rules]+    -- `rhs_ja` is `joinRhsArity rhs'` and is the prediction for source M+    -- of Note [Join arity prediction based on joinRhsArity]+    rules_w_uds :: [(CoreRule, UsageDetails, UsageDetails)]+    rules_w_uds = [ (r,l,adjustTailArity (JoinPoint rhs_ja) rhs_wuds)+                  | rule <- idCoreRules bndr+                  , let (r,l,rhs_wuds) = occAnalRule rhs_env rule ]+    rules'      = map fstOf3 rules_w_uds++    adj_rule_uds = foldr add_rule_uds imp_rule_uds rules_w_uds+    add_rule_uds (_, l, r) uds = l `andUDs` r `andUDs` uds++    -------- active_rule_fvs ------------+    active_rule_fvs = foldr add_active_rule imp_rule_fvs rules_w_uds+    add_active_rule (rule, _, rhs_uds) fvs+      | is_active (ruleActivation rule)+      = udFreeVars bndr_set rhs_uds `unionVarSet` fvs+      | otherwise+      = fvs++    -------- weak_fvs ------------+    -- See Note [Weak loop breakers]+    weak_fvs = foldr add_rule emptyVarSet rules_w_uds+    add_rule (_, _, rhs_uds) fvs = udFreeVars bndr_set rhs_uds `unionVarSet` fvs++mkLoopBreakerNodes :: OccEnv -> TopLevelFlag+                   -> UsageDetails   -- for BODY of let+                   -> [NodeDetails]+                   -> WithUsageDetails [LoopBreakerNode] -- with OccInfo up-to-date+-- See Note [Choosing loop breakers]+-- This function primarily creates the Nodes for the+-- loop-breaker SCC analysis.  More specifically:+--   a) tag each binder with its occurrence info+--   b) add a NodeScore to each node+--   c) make a Node with the right dependency edges for+--      the loop-breaker SCC analysis+--   d) adjust each RHS's usage details according to+--      the binder's (new) shotness and join-point-hood+mkLoopBreakerNodes !env lvl body_uds details_s+  = WUD final_uds (zipWithEqual "mkLoopBreakerNodes" mk_lb_node details_s bndrs')+  where+    WUD final_uds bndrs' = tagRecBinders lvl body_uds details_s++    mk_lb_node nd@(ND { nd_bndr = old_bndr, nd_inl = inl_fvs+                      , nd_rhs = WTUD _ rhs }) new_bndr+      = DigraphNode { node_payload      = simple_nd+                    , node_key          = varUnique old_bndr+                    , node_dependencies = nonDetKeysUniqSet lb_deps }+              -- It's OK to use nonDetKeysUniqSet here as+              -- stronglyConnCompFromEdgedVerticesR is still deterministic with edges+              -- in nondeterministic order as explained in+              -- Note [Deterministic SCC] in GHC.Data.Graph.Directed.+      where+        simple_nd = SND { snd_bndr = new_bndr, snd_rhs = rhs, snd_score = score }+        score  = nodeScore env new_bndr lb_deps nd+        lb_deps = extendFvs_ rule_fv_env inl_fvs+        -- See Note [Loop breaker dependencies]++    rule_fv_env :: IdEnv IdSet+    -- Maps a variable f to the variables from this group+    --      reachable by a sequence of RULES starting with f+    -- Domain is *subset* of bound vars (others have no rule fvs)+    -- See Note [Finding rule RHS free vars]+    -- Why transClosureFV?  See Note [Loop breaker dependencies]+    rule_fv_env = transClosureFV $ mkVarEnv $+                  [ (b, rule_fvs)+                  | ND { nd_bndr = b, nd_active_rule_fvs = rule_fvs } <- details_s+                  , not (isEmptyVarSet rule_fvs) ]++{- Note [Loop breaker dependencies]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The loop breaker dependencies of x in a recursive+group { f1 = e1; ...; fn = en } are:++- The "inline free variables" of f: the fi free in+  f's stable unfolding and RHS; see Note [inl_fvs]++- Any fi reachable from those inline free variables by a sequence+  of RULE rewrites.  Remember, rule rewriting is not affected+  by fi being a loop breaker, so we have to take the transitive+  closure in case f is the only possible loop breaker in the loop.++  Hence rule_fv_env.  We need only account for /active/ rules.+-}++------------------------------------------+nodeScore :: OccEnv+          -> Id        -- Binder with new occ-info+          -> VarSet    -- Loop-breaker dependencies+          -> NodeDetails+          -> NodeScore+nodeScore !env new_bndr lb_deps+          (ND { nd_bndr = old_bndr, nd_rhs = WTUD _ bind_rhs })++  | not (isId old_bndr)     -- A type or coercion variable is never a loop breaker+  = (100, 0, False)++  | old_bndr `elemVarSet` lb_deps  -- Self-recursive things are great loop breakers+  = (0, 0, True)                   -- See Note [Self-recursion and loop breakers]++  | not (occ_unf_act env old_bndr) -- A binder whose inlining is inactive (e.g. has+  = (0, 0, True)                   -- a NOINLINE pragma) makes a great loop breaker++  | exprIsTrivial rhs+  = mk_score 10  -- Practically certain to be inlined+    -- Used to have also: && not (isExportedId bndr)+    -- But I found this sometimes cost an extra iteration when we have+    --      rec { d = (a,b); a = ...df...; b = ...df...; df = d }+    -- where df is the exported dictionary. Then df makes a really+    -- bad choice for loop breaker++  | DFunUnfolding { df_args = args } <- old_unf+    -- Never choose a DFun as a loop breaker+    -- Note [DFuns should not be loop breakers]+  = (9, length args, is_lb)++    -- Data structures are more important than INLINE pragmas+    -- so that dictionary/method recursion unravels++  | CoreUnfolding { uf_guidance = UnfWhen {} } <- old_unf+  = mk_score 6++  | is_con_app rhs   -- Data types help with cases:+  = mk_score 5       -- Note [Constructor applications]++  | isStableUnfolding old_unf+  , can_unfold+  = mk_score 3++  | isOneOcc (idOccInfo new_bndr)+  = mk_score 2  -- Likely to be inlined++  | can_unfold  -- The Id has some kind of unfolding+  = mk_score 1++  | otherwise+  = (0, 0, is_lb)++  where+    mk_score :: Int -> NodeScore+    mk_score rank = (rank, rhs_size, is_lb)++    -- is_lb: see Note [Loop breakers, node scoring, and stability]+    is_lb = isStrongLoopBreaker (idOccInfo old_bndr)++    old_unf = realIdUnfolding old_bndr+    can_unfold = canUnfold old_unf+    rhs        = case old_unf of+                   CoreUnfolding { uf_src = src, uf_tmpl = unf_rhs }+                     | isStableSource src+                     -> unf_rhs+                   _ -> bind_rhs+       -- 'bind_rhs' is irrelevant for inlining things with a stable unfolding+    rhs_size = case old_unf of+                 CoreUnfolding { uf_guidance = guidance }+                    | UnfIfGoodArgs { ug_size = size } <- guidance+                    -> size+                 _  -> cheapExprSize rhs+++        -- Checking for a constructor application+        -- Cheap and cheerful; the simplifier moves casts out of the way+        -- The lambda case is important to spot x = /\a. C (f a)+        -- which comes up when C is a dictionary constructor and+        -- f is a default method.+        -- Example: the instance for Show (ST s a) in GHC.ST+        --+        -- However we *also* treat (\x. C p q) as a con-app-like thing,+        --      Note [Closure conversion]+    is_con_app (Var v)    = isConLikeId v+    is_con_app (App f _)  = is_con_app f+    is_con_app (Lam _ e)  = is_con_app e+    is_con_app (Tick _ e) = is_con_app e+    is_con_app (Let _ e)  = is_con_app e  -- let x = let y = blah in (a,b)+    is_con_app _          = False         -- We will float the y out, so treat+                                          -- the x-binding as a con-app (#20941)++maxExprSize :: Int+maxExprSize = 20  -- Rather arbitrary++cheapExprSize :: CoreExpr -> Int+-- Maxes out at maxExprSize+cheapExprSize e+  = go 0 e+  where+    go n e | n >= maxExprSize = n+           | otherwise        = go1 n e++    go1 n (Var {})        = n+1+    go1 n (Lit {})        = n+1+    go1 n (Type {})       = n+    go1 n (Coercion {})   = n+    go1 n (Tick _ e)      = go1 n e+    go1 n (Cast e _)      = go1 n e+    go1 n (App f a)       = go (go1 n f) a+    go1 n (Lam b e)+      | isTyVar b         = go1 n e+      | otherwise         = go (n+1) e+    go1 n (Let b e)       = gos (go1 n e) (rhssOfBind b)+    go1 n (Case e _ _ as) = gos (go1 n e) (rhssOfAlts as)++    gos n [] = n+    gos n (e:es) | n >= maxExprSize = n+                 | otherwise        = gos (go1 n e) es++betterLB :: NodeScore -> NodeScore -> Bool+-- If  n1 `betterLB` n2  then choose n1 as the loop breaker+betterLB (rank1, size1, lb1) (rank2, size2, _)+  | rank1 < rank2 = True+  | rank1 > rank2 = False+  | size1 < size2 = False   -- Make the bigger n2 into the loop breaker+  | size1 > size2 = True+  | lb1           = True    -- Tie-break: if n1 was a loop breaker before, choose it+  | otherwise     = False   -- See Note [Loop breakers, node scoring, and stability]++{- Note [Self-recursion and loop breakers]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+If we have+   rec { f = ...f...g...+       ; g = .....f...   }+then 'f' has to be a loop breaker anyway, so we may as well choose it+right away, so that g can inline freely.++This is really just a cheap hack. Consider+   rec { f = ...g...+       ; g = ..f..h...+      ;  h = ...f....}+Here f or g are better loop breakers than h; but we might accidentally+choose h.  Finding the minimal set of loop breakers is hard.++Note [Loop breakers, node scoring, and stability]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+To choose a loop breaker, we give a NodeScore to each node in the SCC,+and pick the one with the best score (according to 'betterLB').++We need to be jolly careful (#12425, #12234) about the stability+of this choice. Suppose we have++    let rec { f = ...g...g...+            ; g = ...f...f... }+    in+    case x of+      True  -> ...f..+      False -> ..f...++In each iteration of the simplifier the occurrence analyser OccAnal+chooses a loop breaker. Suppose in iteration 1 it choose g as the loop+breaker. That means it is free to inline f.++Suppose that GHC decides to inline f in the branches of the case, but+(for some reason; eg it is not saturated) in the rhs of g. So we get++    let rec { f = ...g...g...+            ; g = ...f...f... }+    in+    case x of+      True  -> ...g...g.....+      False -> ..g..g....++Now suppose that, for some reason, in the next iteration the occurrence+analyser chooses f as the loop breaker, so it can freely inline g. And+again for some reason the simplifier inlines g at its calls in the case+branches, but not in the RHS of f. Then we get++    let rec { f = ...g...g...+            ; g = ...f...f... }+    in+    case x of+      True  -> ...(...f...f...)...(...f..f..).....+      False -> ..(...f...f...)...(..f..f...)....++You can see where this is going! Each iteration of the simplifier+doubles the number of calls to f or g. No wonder GHC is slow!++(In the particular example in comment:3 of #12425, f and g are the two+mutually recursive fmap instances for CondT and Result. They are both+marked INLINE which, oddly, is why they don't inline in each other's+RHS, because the call there is not saturated.)++The root cause is that we flip-flop on our choice of loop breaker. I+always thought it didn't matter, and indeed for any single iteration+to terminate, it doesn't matter. But when we iterate, it matters a+lot!!++So The Plan is this:+   If there is a tie, choose the node that+   was a loop breaker last time round++Hence the is_lb field of NodeScore+-}++{- *********************************************************************+*                                                                      *+                  Lambda groups+*                                                                      *+********************************************************************* -}++{- Note [Occurrence analysis for lambda binders]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+For value lambdas we do a special hack.  Consider+     (\x. \y. ...x...)+If we did nothing, x is used inside the \y, so would be marked+as dangerous to dup.  But in the common case where the abstraction+is applied to two arguments this is over-pessimistic, which delays+inlining x, which forces more simplifier iterations.++So the occurrence analyser collaborates with the simplifier to treat+a /lambda-group/ specially.   A lambda-group is a contiguous run of+lambda and casts, e.g.+    Lam x (Lam y (Cast (Lam z body) co))++* Occurrence analyser: we just mark each binder in the lambda-group+  (here: x,y,z) with its occurrence info in the *body* of the+  lambda-group.  See occAnalLamTail.++* Simplifier.  The simplifier is careful when partially applying+  lambda-groups. See the call to zapLambdaBndrs in+     GHC.Core.Opt.Simplify.simplExprF1+     GHC.Core.SimpleOpt.simple_app++* Why do we take care to account for intervening casts? Answer:+  currently we don't do eta-expansion and cast-swizzling in a stable+  unfolding (see Historical-note [Eta-expansion in stable unfoldings]).+  So we can get+    f = \x. ((\y. ...x...y...) |> co)+  Now, since the lambdas aren't together, the occurrence analyser will+  say that x is OnceInLam.  Now if we have a call+    (f e1 |> co) e2+  we'll end up with+    let x = e1 in ...x..e2...+  and it'll take an extra iteration of the Simplifier to substitute for x.++A thought: a lambda-group is pretty much what GHC.Core.Opt.Arity.manifestArity+recognises except that the latter looks through (some) ticks.  Maybe a lambda+group should also look through (some) ticks?+-}++isOneShotFun :: CoreExpr -> Bool+-- The top level lambdas, ignoring casts, of the expression+-- are all one-shot.  If there aren't any lambdas at all, this is True+isOneShotFun (Lam b e)  = isOneShotBndr b && isOneShotFun e+isOneShotFun (Cast e _) = isOneShotFun e+isOneShotFun _          = True++zapLambdaBndrs :: CoreExpr -> FullArgCount -> CoreExpr+-- If (\xyz. t) appears under-applied to only two arguments,+-- we must zap the occ-info on x,y, because they appear under the \z+-- See Note [Occurrence analysis for lambda binders] in GHc.Core.Opt.OccurAnal+--+-- NB: `arg_count` includes both type and value args+zapLambdaBndrs fun arg_count+  = -- If the lambda is fully applied, leave it alone; if not+    -- zap the OccInfo on the lambdas that do have arguments,+    -- so they beta-reduce to use-many Lets rather than used-once ones.+    zap arg_count fun `orElse` fun+  where+    zap :: FullArgCount -> CoreExpr -> Maybe CoreExpr+    -- Nothing => No need to change the occ-info+    -- Just e  => Had to change+    zap 0 e | isOneShotFun e = Nothing  -- All remaining lambdas are one-shot+            | otherwise      = Just e   -- in which case no need to zap+    zap n (Cast e co) = do { e' <- zap n e; return (Cast e' co) }+    zap n (Lam b e)   = do { e' <- zap (n-1) e+                           ; return (Lam (zap_bndr b) e') }+    zap _ _           = Nothing  -- More arguments than lambdas++    zap_bndr b | isTyVar b = b+               | otherwise = zapLamIdInfo b++occAnalLamTail :: OccEnv -> CoreExpr -> WithTailUsageDetails CoreExpr+-- ^ See Note [Occurrence analysis for lambda binders].+-- It does the following:+--   * Sets one-shot info on the lambda binder from the OccEnv, and+--     removes that one-shot info from the OccEnv+--   * Sets the OccEnv to OccVanilla when going under a value lambda+--   * Tags each lambda with its occurrence information+--   * Walks through casts+--   * Package up the analysed lambda with its manifest join arity+--+-- This function does /not/ do+--   markAllInsideLam or+--   markAllNonTail+-- The caller does that, via adjustTailUsage (mostly calls go through+-- adjustNonRecRhs). Every call to occAnalLamTail must ultimately call+-- adjustTailUsage to discharge the assumed join arity.+--+-- In effect, the analysis result is for a non-recursive join point with+-- manifest arity and adjustTailUsage does the fixup.+-- See Note [Adjusting right-hand sides]+occAnalLamTail env expr+  = let !(WUD usage expr') = occ_anal_lam_tail env expr+    in WTUD (TUD (joinRhsArity expr) usage) expr'++occ_anal_lam_tail :: OccEnv -> CoreExpr -> WithUsageDetails CoreExpr+-- Does not markInsidLam etc for the outmost batch of lambdas+occ_anal_lam_tail env expr@(Lam {})+  = go env [] expr+  where+    go :: OccEnv -> [Var] -> CoreExpr -> WithUsageDetails CoreExpr+    go env rev_bndrs (Lam bndr body)+      | isTyVar bndr+      = go env (bndr:rev_bndrs) body+              -- Important: Unlike a value binder, do not modify occ_encl+              -- to OccVanilla, so that with a RHS like+              --   \(@ x) -> K @x (f @x)+              -- we'll see that (K @x (f @x)) is in a OccRhs, and hence refrain+              -- from inlining f. See the beginning of Note [Cascading inlines].++      | otherwise+      = let (env_one_shots', bndr')+              = case occ_one_shots env of+                  []         -> ([],  bndr)+                  (os : oss) -> (oss, updOneShotInfo bndr os)+                  -- Use updOneShotInfo, not setOneShotInfo, as pre-existing+                  -- one-shot info might be better than what we can infer, e.g.+                  -- due to explicit use of the magic 'oneShot' function.+                  -- See Note [oneShot magic]+            env' = env { occ_encl = OccVanilla, occ_one_shots = env_one_shots' }+         in go env' (bndr':rev_bndrs) body++    go env rev_bndrs body+      = addInScope env rev_bndrs $ \env ->+        let !(WUD usage body') = occ_anal_lam_tail env body+            wrap_lam body bndr = Lam (tagLamBinder usage bndr) body+        in WUD (usage `addLamCoVarOccs` rev_bndrs)+               (foldl' wrap_lam body' rev_bndrs)++-- For casts, keep going in the same lambda-group+-- See Note [Occurrence analysis for lambda binders]+occ_anal_lam_tail env (Cast expr co)+  = let  WUD usage expr' = occ_anal_lam_tail env expr+         -- usage1: see Note [Gather occurrences of coercion variables]+         usage1 = addManyOccs usage (coVarsOfCo co)++         -- usage2: see Note [Occ-anal and cast worker/wrapper]+         usage2 = case expr of+                    Var {} | isRhsEnv env -> markAllMany usage1+                    _ -> usage1++         -- usage3: you might think this was not necessary, because of+         -- the markAllNonTail in adjustTailUsage; but not so!  For a+         -- join point, adjustTailUsage doesn't do this; yet if there is+         -- a cast, we must!  Also: why markAllNonTail?  See+         -- GHC.Core.Lint: Note Note [Join points and casts]+         usage3 = markAllNonTail usage2++    in WUD usage3 (Cast expr' co)++occ_anal_lam_tail env expr  -- Not Lam, not Cast+  = occAnal env expr++{- Note [Occ-anal and cast worker/wrapper]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider   y = e; x = y |> co+If we mark y as used-once, we'll inline y into x, and the Cast+worker/wrapper transform will float it straight back out again.  See+Note [Cast worker/wrapper] in GHC.Core.Opt.Simplify.++So in this particular case we want to mark 'y' as Many.  It's very+ad-hoc, but it's also simple.  It's also what would happen if we gave+the binding for x a stable unfolding (as we usually do for wrappers, thus+      y = e+      {-# INLINE x #-}+      x = y |> co+Now y appears twice -- once in x's stable unfolding, and once in x's+RHS. So it'll get a Many occ-info.  (Maybe Cast w/w should create a stable+unfolding, which would obviate this Note; but that seems a bit of a+heavyweight solution.)++We only need to this in occAnalLamTail, not occAnal, because the top leve+of a right hand side is handled by occAnalLamTail.+-}+++{- *********************************************************************+*                                                                      *+                   Right hand sides+*                                                                      *+********************************************************************* -}++occAnalUnfolding :: OccEnv+                 -> Unfolding+                 -> WithTailUsageDetails Unfolding+-- Occurrence-analyse a stable unfolding;+-- discard a non-stable one altogether and return empty usage details.+occAnalUnfolding !env unf+  = case unf of+      unf@(CoreUnfolding { uf_tmpl = rhs, uf_src = src })+        | isStableSource src ->+            let+              WTUD (TUD rhs_ja uds) rhs' = occAnalLamTail env rhs+              unf' = unf { uf_tmpl = rhs' }+            in WTUD (TUD rhs_ja (markAllMany uds)) unf'+              -- markAllMany: see Note [Occurrences in stable unfoldings]++        | otherwise -> WTUD (TUD 0 emptyDetails) unf+              -- For non-Stable unfoldings we leave them undisturbed, but+              -- don't count their usage because the simplifier will discard them.+              -- We leave them undisturbed because nodeScore uses their size info+              -- to guide its decisions.  It's ok to leave un-substituted+              -- expressions in the tree because all the variables that were in+              -- scope remain in scope; there is no cloning etc.++      unf@(DFunUnfolding { df_bndrs = bndrs, df_args = args })+        -> let WUD uds args' = addInScopeList env bndrs $ \ env ->+                               occAnalList env args+           in WTUD (TUD 0 uds) (unf { df_args = args' })+              -- No need to use tagLamBinders because we+              -- never inline DFuns so the occ-info on binders doesn't matter++      unf -> WTUD (TUD 0 emptyDetails) unf++occAnalRule :: OccEnv+             -> CoreRule+             -> (CoreRule,         -- Each (non-built-in) rule+                 UsageDetails,     -- Usage details for LHS+                 TailUsageDetails) -- Usage details for RHS+occAnalRule env rule@(Rule { ru_bndrs = bndrs, ru_args = args, ru_rhs = rhs })+  = (rule', lhs_uds', TUD rhs_ja rhs_uds')+  where+    rule' = rule { ru_args = args', ru_rhs = rhs' }++    WUD lhs_uds args' = addInScopeList env bndrs $ \env ->+                        occAnalList env args++    lhs_uds' = markAllManyNonTail lhs_uds+    WUD rhs_uds rhs' = addInScopeList env bndrs $ \env ->+                       occAnal env rhs+                          -- Note [Rules are extra RHSs]+                          -- Note [Rule dependency info]+    rhs_uds' = markAllMany rhs_uds+    rhs_ja = length args -- See Note [Join points and unfoldings/rules]++occAnalRule _ other_rule = (other_rule, emptyDetails, TUD 0 emptyDetails)++{- Note [Join point RHSs]+~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+   x = e+   join j = Just x++We want to inline x into j right away, so we don't want to give+the join point a RhsCtxt (#14137).  It's not a huge deal, because+the FloatIn pass knows to float into join point RHSs; and the simplifier+does not float things out of join point RHSs.  But it's a simple, cheap+thing to do.  See #14137.++Note [Occurrences in stable unfoldings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+    f p = BIG+    {-# INLINE g #-}+    g y = not (f y)+where this is the /only/ occurrence of 'f'.  So 'g' will get a stable+unfolding.  Now suppose that g's RHS gets optimised (perhaps by a rule+or inlining f) so that it doesn't mention 'f' any more.  Now the last+remaining call to f is in g's Stable unfolding. But, even though there+is only one syntactic occurrence of f, we do /not/ want to do+preinlineUnconditionally here!++The INLINE pragma says "inline exactly this RHS"; perhaps the+programmer wants to expose that 'not', say. If we inline f that will make+the Stable unfoldign big, and that wasn't what the programmer wanted.++Another way to think about it: if we inlined g as-is into multiple+call sites, now there's be multiple calls to f.++Bottom line: treat all occurrences in a stable unfolding as "Many".+We still leave tail call information intact, though, as to not spoil+potential join points.++Note [Unfoldings and rules]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+Generally unfoldings and rules are already occurrence-analysed, so we+don't want to reconstruct their trees; we just want to analyse them to+find how they use their free variables.++EXCEPT if there is a binder-swap going on, in which case we do want to+produce a new tree.++So we have a fast-path that keeps the old tree if the occ_bs_env is+empty.   This just saves a bit of allocation and reconstruction; not+a big deal.++This fast path exposes a tricky cornder, though (#22761). Supose we have+    Unfolding = \x. let y = foo in x+1+which includes a dead binding for `y`. In occAnalUnfolding we occ-anal+the unfolding and produce /no/ occurrences of `foo` (since `y` is+dead).  But if we discard the occ-analysed syntax tree (which we do on+our fast path), and use the old one, we still /have/ an occurrence of+`foo` -- and that can lead to out-of-scope variables (#22761).++Solution: always keep occ-analysed trees in unfoldings and rules, so they+have no dead code.  See Note [OccInfo in unfoldings and rules] in GHC.Core.++Note [Cascading inlines]+~~~~~~~~~~~~~~~~~~~~~~~~+By default we use an OccRhs for the RHS of a binding.  This tells the+occ anal n that it's looking at an RHS, which has an effect in+occAnalApp.  In particular, for constructor applications, it makes+the arguments appear to have NoOccInfo, so that we don't inline into+them. Thus    x = f y+              k = Just x+we do not want to inline x.++But there's a problem.  Consider+     x1 = a0 : []+     x2 = a1 : x1+     x3 = a2 : x2+     g  = f x3+First time round, it looks as if x1 and x2 occur as an arg of a+let-bound constructor ==> give them a many-occurrence.+But then x3 is inlined (unconditionally as it happens) and+next time round, x2 will be, and the next time round x1 will be+Result: multiple simplifier iterations.  Sigh.++So, when analysing the RHS of x3 we notice that x3 will itself+definitely inline the next time round, and so we analyse x3's rhs in+an OccVanilla context, not OccRhs.  Hence the "certainly_inline" stuff.++Annoyingly, we have to approximate GHC.Core.Opt.Simplify.Utils.preInlineUnconditionally.+If (a) the RHS is expandable (see isExpandableApp in occAnalApp), and+   (b) certainly_inline says "yes" when preInlineUnconditionally says "no"+then the simplifier iterates indefinitely:+        x = f y+        k = Just x   -- We decide that k is 'certainly_inline'+        v = ...k...  -- but preInlineUnconditionally doesn't inline it+inline ==>+        k = Just (f y)+        v = ...k...+float ==>+        x1 = f y+        k = Just x1+        v = ...k...++This is worse than the slow cascade, so we only want to say "certainly_inline"+if it really is certain.  Look at the note with preInlineUnconditionally+for the various clauses.+++************************************************************************+*                                                                      *+                Expressions+*                                                                      *+************************************************************************+-}++occAnalList :: OccEnv -> [CoreExpr] -> WithUsageDetails [CoreExpr]+occAnalList !_   []    = WUD emptyDetails []+occAnalList env (e:es) = let+                          (WUD uds1 e') = occAnal env e+                          (WUD uds2 es') = occAnalList env es+                         in WUD (uds1 `andUDs` uds2) (e' : es')++occAnal :: OccEnv+        -> CoreExpr+        -> WithUsageDetails CoreExpr       -- Gives info only about the "interesting" Ids++occAnal !_   expr@(Lit _)  = WUD emptyDetails expr++occAnal env expr@(Var _) = occAnalApp env (expr, [], [])+    -- At one stage, I gathered the idRuleVars for the variable here too,+    -- which in a way is the right thing to do.+    -- But that went wrong right after specialisation, when+    -- the *occurrences* of the overloaded function didn't have any+    -- rules in them, so the *specialised* versions looked as if they+    -- weren't used at all.++occAnal _ expr@(Type ty)+  = WUD (addManyOccs emptyDetails (coVarsOfType ty)) expr+occAnal _ expr@(Coercion co)+  = WUD (addManyOccs emptyDetails (coVarsOfCo co)) expr+        -- See Note [Gather occurrences of coercion variables]++{- Note [Gather occurrences of coercion variables]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We need to gather info about what coercion variables appear, for two reasons:++1. So that we can sort them into the right place when doing dependency analysis.++2. So that we know when they are surely dead.++It is useful to know when they a coercion variable is surely dead,+when we want to discard a case-expression, in GHC.Core.Opt.Simplify.rebuildCase.+For example (#20143):++  case unsafeEqualityProof @blah of+     UnsafeRefl cv -> ...no use of cv...++Here we can discard the case, since unsafeEqualityProof always terminates.+But only if the coercion variable 'cv' is unused.++Another example from #15696: we had something like+  case eq_sel d of co -> ...(typeError @(...co...) "urk")...+Then 'd' was substituted by a dictionary, so the expression+simpified to+  case (Coercion <blah>) of cv -> ...(typeError @(...cv...) "urk")...++We can only  drop the case altogether if 'cv' is unused, which is not+the case here.++Conclusion: we need accurate dead-ness info for CoVars.+We gather CoVar occurrences from:++  * The (Type ty) and (Coercion co) cases of occAnal++  * The type 'ty' of a lambda-binder (\(x:ty). blah)+    See addCoVarOccs++But it is not necessary to gather CoVars from the types of other binders.++* For let-binders, if the type mentions a CoVar, so will the RHS (since+  it has the same type)++* For case-alt binders, if the type mentions a CoVar, so will the scrutinee+  (since it has the same type)+-}++occAnal env (Tick tickish body)+  = WUD usage' (Tick tickish body')+  where+    WUD usage body' = occAnal env body++    usage'+      | tickish `tickishScopesLike` SoftScope+      = usage  -- For soft-scoped ticks (including SourceNotes) we don't want+               -- to lose join-point-hood, so we don't mess with `usage` (#24078)++      -- For a non-soft tick scope, we can inline lambdas only, so we+      -- abandon tail calls, and do markAllInsideLam too: usage_lam++      |  Breakpoint _ _ ids _ <- tickish+      = -- Never substitute for any of the Ids in a Breakpoint+        addManyOccs usage_lam (mkVarSet ids)++      | otherwise+      = usage_lam++    usage_lam = markAllNonTail (markAllInsideLam usage)++    -- TODO There may be ways to make ticks and join points play+    -- nicer together, but right now there are problems:+    --   let j x = ... in tick<t> (j 1)+    -- Making j a join point may cause the simplifier to drop t+    -- (if the tick is put into the continuation). So we don't+    -- count j 1 as a tail call.+    -- See #14242.++occAnal env (Cast expr co)+  = let  (WUD usage expr') = occAnal env expr+         usage1 = addManyOccs usage (coVarsOfCo co)+             -- usage2: see Note [Gather occurrences of coercion variables]+         usage2 = markAllNonTail usage1+             -- usage3: calls inside expr aren't tail calls any more+    in WUD usage2 (Cast expr' co)++occAnal env app@(App _ _)+  = occAnalApp env (collectArgsTicks tickishFloatable app)++occAnal env expr@(Lam {})+  = adjustNonRecRhs NotJoinPoint $ -- NotJoinPoint <=> markAllManyNonTail+    occAnalLamTail env expr++occAnal env (Case scrut bndr ty alts)+  = let+      WUD scrut_usage scrut' = occAnal (setScrutCtxt env alts) scrut++      WUD alts_usage (tagged_bndr, alts')+         = addInScopeOne env bndr $ \env ->+           let alt_env = addBndrSwap scrut' bndr $+                         setTailCtxt env  -- Kill off OccRhs+               WUD alts_usage alts' = do_alts alt_env alts+               tagged_bndr = tagLamBinder alts_usage bndr+           in WUD alts_usage (tagged_bndr, alts')++      total_usage = markAllNonTail scrut_usage `andUDs` alts_usage+                    -- Alts can have tail calls, but the scrutinee can't++    in WUD total_usage (Case scrut' tagged_bndr ty alts')+  where+    do_alts :: OccEnv -> [CoreAlt] -> WithUsageDetails [CoreAlt]+    do_alts _   []         = WUD emptyDetails []+    do_alts env (alt:alts) = WUD (uds1 `orUDs` uds2) (alt':alts')+      where+        WUD uds1 alt'  = do_alt  env alt+        WUD uds2 alts' = do_alts env alts++    do_alt !env (Alt con bndrs rhs)+      = addInScopeList env bndrs $ \ env ->+        let WUD rhs_usage rhs' = occAnal env rhs+            tagged_bndrs = tagLamBinders rhs_usage bndrs+        in                 -- See Note [Binders in case alternatives]+        WUD rhs_usage (Alt con tagged_bndrs rhs')++occAnal env (Let bind body)+  = occAnalBind env NotTopLevel noImpRuleEdges bind+                (\env -> occAnal env body) mkLets++occAnalArgs :: OccEnv -> CoreExpr -> [CoreExpr]+            -> [OneShots]  -- Very commonly empty, notably prior to dmd anal+            -> WithUsageDetails CoreExpr+-- The `fun` argument is just an accumulating parameter,+-- the base for building the application we return+occAnalArgs !env fun args !one_shots+  = go emptyDetails fun args one_shots+  where+    env_args = setNonTailCtxt OccVanilla env++    go uds fun [] _ = WUD uds fun+    go uds fun (arg:args) one_shots+      = go (uds `andUDs` arg_uds) (fun `App` arg') args one_shots'+      where+        !(WUD arg_uds arg') = occAnal arg_env arg+        !(arg_env, one_shots')+            | isTypeArg arg+            = (env_args, one_shots)+            | otherwise+            = case one_shots of+                []                -> (env_args, []) -- Fast path; one_shots is often empty+                (os : one_shots') -> (addOneShots os env_args, one_shots')++{-+Applications are dealt with specially because we want+the "build hack" to work.++Note [Arguments of let-bound constructors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+    f x = let y = expensive x in+          let z = (True,y) in+          (case z of {(p,q)->q}, case z of {(p,q)->q})+We feel free to duplicate the WHNF (True,y), but that means+that y may be duplicated thereby.++If we aren't careful we duplicate the (expensive x) call!+Constructors are rather like lambdas in this way.+-}++occAnalApp :: OccEnv+           -> (Expr CoreBndr, [Arg CoreBndr], [CoreTickish])+           -> WithUsageDetails (Expr CoreBndr)+-- Naked variables (not applied) end up here too+occAnalApp !env (Var fun, args, ticks)+  -- Account for join arity of runRW# continuation+  -- See Note [Simplification of runRW#]+  --+  -- NB: Do not be tempted to make the next (Var fun, args, tick)+  --     equation into an 'otherwise' clause for this equation+  --     The former has a bang-pattern to occ-anal the args, and+  --     we don't want to occ-anal them twice in the runRW# case!+  --     This caused #18296+  | fun `hasKey` runRWKey+  , [t1, t2, arg]  <- args+  , WUD usage arg' <- adjustNonRecRhs (JoinPoint 1) $ occAnalLamTail env arg+  = WUD usage (mkTicks ticks $ mkApps (Var fun) [t1, t2, arg'])++occAnalApp env (Var fun_id, args, ticks)+  = WUD all_uds (mkTicks ticks app')+  where+    -- Lots of banged bindings: this is a very heavily bit of code,+    -- so it pays not to make lots of thunks here, all of which+    -- will ultimately be forced.+    !(fun', fun_id')  = lookupBndrSwap env fun_id+    !(WUD args_uds app') = occAnalArgs env fun' args one_shots++    fun_uds = mkOneOcc env fun_id' int_cxt n_args+       -- NB: fun_uds is computed for fun_id', not fun_id+       -- See (BS1) in Note [The binder-swap substitution]++    all_uds = fun_uds `andUDs` final_args_uds++    !final_args_uds = markAllNonTail                              $+                      markAllInsideLamIf (isRhsEnv env && is_exp) $+                        -- isRhsEnv: see Note [OccEncl]+                      args_uds+       -- We mark the free vars of the argument of a constructor or PAP+       -- as "inside-lambda", if it is the RHS of a let(rec).+       -- This means that nothing gets inlined into a constructor or PAP+       -- argument position, which is what we want.  Typically those+       -- constructor arguments are just variables, or trivial expressions.+       -- We use inside-lam because it's like eta-expanding the PAP.+       --+       -- This is the *whole point* of the isRhsEnv predicate+       -- See Note [Arguments of let-bound constructors]++    !n_val_args = valArgCount args+    !n_args     = length args+    !int_cxt    = case occ_encl env of+                   OccScrut -> IsInteresting+                   _other   | n_val_args > 0 -> IsInteresting+                            | otherwise      -> NotInteresting++    !is_exp     = isExpandableApp fun_id n_val_args+        -- See Note [CONLIKE pragma] in GHC.Types.Basic+        -- The definition of is_exp should match that in GHC.Core.Opt.Simplify.prepareRhs++    one_shots  = argsOneShots (idDmdSig fun_id) guaranteed_val_args+    guaranteed_val_args = n_val_args + length (takeWhile isOneShotInfo+                                                         (occ_one_shots env))+        -- See Note [Sources of one-shot information], bullet point A']++occAnalApp env (fun, args, ticks)+  = WUD (markAllNonTail (fun_uds `andUDs` args_uds))+                     (mkTicks ticks app')+  where+    !(WUD args_uds app') = occAnalArgs env fun' args []+    !(WUD fun_uds fun')  = occAnal (addAppCtxt env args) fun+        -- The addAppCtxt is a bit cunning.  One iteration of the simplifier+        -- often leaves behind beta redexes like+        --      (\x y -> e) a1 a2+        -- Here we would like to mark x,y as one-shot, and treat the whole+        -- thing much like a let.  We do this by pushing some OneShotLam items+        -- onto the context stack.++addAppCtxt :: OccEnv -> [Arg CoreBndr] -> OccEnv+addAppCtxt env@(OccEnv { occ_one_shots = ctxt }) args+  | n_val_args > 0+  = env { occ_one_shots = replicate n_val_args OneShotLam ++ ctxt+        , occ_encl      = OccVanilla }+          -- OccVanilla: the function part of the application+          -- is no longer on OccRhs or OccScrut+  | otherwise+  = env+  where+    n_val_args = valArgCount args+++{-+Note [Sources of one-shot information]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The occurrence analyser obtains one-shot-lambda information from two sources:++A:  Saturated applications:  eg   f e1 .. en++    In general, given a call (f e1 .. en) we can propagate one-shot info from+    f's strictness signature into e1 .. en, but /only/ if n is enough to+    saturate the strictness signature. A strictness signature like++          f :: C(1,C(1,L))LS++    means that *if f is applied to three arguments* then it will guarantee to+    call its first argument at most once, and to call the result of that at+    most once. But if f has fewer than three arguments, all bets are off; e.g.++          map (f (\x y. expensive) e2) xs++    Here the \x y abstraction may be called many times (once for each element of+    xs) so we should not mark x and y as one-shot. But if it was++          map (f (\x y. expensive) 3 2) xs++    then the first argument of f will be called at most once.++    The one-shot info, derived from f's strictness signature, is+    computed by 'argsOneShots', called in occAnalApp.++A': Non-obviously saturated applications: eg    build (f (\x y -> expensive))+    where f is as above.++    In this case, f is only manifestly applied to one argument, so it does not+    look saturated. So by the previous point, we should not use its strictness+    signature to learn about the one-shotness of \x y. But in this case we can:+    build is fully applied, so we may use its strictness signature; and from+    that we learn that build calls its argument with two arguments *at most once*.++    So there is really only one call to f, and it will have three arguments. In+    that sense, f is saturated, and we may proceed as described above.++    Hence the computation of 'guaranteed_val_args' in occAnalApp, using+    '(occ_one_shots env)'.  See also #13227, comment:9++B:  Let-bindings:  eg   let f = \c. let ... in \n -> blah+                        in (build f, build f)++    Propagate one-shot info from the demand-info on 'f' to the+    lambdas in its RHS (which may not be syntactically at the top)++    This information must have come from a previous run of the demand+    analyser.++Previously, the demand analyser would *also* set the one-shot information, but+that code was buggy (see #11770), so doing it only in on place, namely here, is+saner.++Note [OneShots]+~~~~~~~~~~~~~~~+When analysing an expression, the occ_one_shots argument contains information+about how the function is being used. The length of the list indicates+how many arguments will eventually be passed to the analysed expression,+and the OneShotInfo indicates whether this application is once or multiple times.++Example:++ Context of f                occ_one_shots when analysing f++ f 1 2                       [OneShot, OneShot]+ map (f 1)                   [OneShot, NoOneShotInfo]+ build f                     [OneShot, OneShot]+ f 1 2 `seq` f 2 1           [NoOneShotInfo, OneShot]++Note [Binders in case alternatives]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+    case x of y { (a,b) -> f y }+We treat 'a', 'b' as dead, because they don't physically occur in the+case alternative.  (Indeed, a variable is dead iff it doesn't occur in+its scope in the output of OccAnal.)  It really helps to know when+binders are unused.  See esp the call to isDeadBinder in+Simplify.mkDupableAlt++In this example, though, the Simplifier will bring 'a' and 'b' back to+life, because it binds 'y' to (a,b) (imagine got inlined and+scrutinised y).+-}++{-+************************************************************************+*                                                                      *+                    OccEnv+*                                                                      *+************************************************************************+-}++data OccEnv+  = OccEnv { occ_encl       :: !OccEncl      -- Enclosing context information+           , occ_one_shots  :: !OneShots     -- See Note [OneShots]+           , occ_unf_act    :: Id -> Bool          -- Which Id unfoldings are active+           , occ_rule_act   :: Activation -> Bool  -- Which rules are active+             -- See Note [Finding rule RHS free vars]++           -- See Note [The binder-swap substitution]+           -- If  x :-> (y, co)  is in the env,+           -- then please replace x by (y |> mco)+           -- Invariant of course: idType x = exprType (y |> mco)+           , occ_bs_env  :: !(IdEnv (OutId, MCoercion))+              -- Domain is Global and Local Ids+              -- Range is just Local Ids+           , occ_bs_rng  :: !VarSet+               -- Vars (TyVars and Ids) free in the range of occ_bs_env++             -- Usage details of the RHS of in-scope non-recursive join points+             -- Invariant: no Id maps to an empty OccInfoEnv+             -- See Note [Occurrence analysis for join points]+           , occ_join_points :: !JoinPointInfo+    }++type JoinPointInfo = IdEnv OccInfoEnv++-----------------------------+{- Note [OccEncl]+~~~~~~~~~~~~~~~~~+OccEncl is used to control whether to inline into constructor arguments.++* OccRhs: consider+     let p = <blah> in+     let x = Just p+     in ...case p of ...++  Here `p` occurs syntactically once, but we want to mark it as InsideLam+  to stop `p` inlining.  We want to leave the x-binding as a constructor+  applied to variables, so that the Simplifier can simplify that inner `case`.++  The OccRhs just tells occAnalApp to mark occurrences in constructor args++* OccScrut: consider (case x of ...).  Here we want to give `x` OneOcc+  with "interesting context" field int_cxt = True.  The OccScrut tells+  occAnalApp (which deals with lone variables too) when to set this field+  to True.+-}++data OccEncl -- See Note [OccEncl]+  = OccRhs         -- RHS of let(rec), albeit perhaps inside a type lambda+  | OccScrut       -- Scrutintee of a case+  | OccVanilla     -- Everything else++instance Outputable OccEncl where+  ppr OccRhs     = text "occRhs"+  ppr OccScrut   = text "occScrut"+  ppr OccVanilla = text "occVanilla"++-- See Note [OneShots]+type OneShots = [OneShotInfo]++initOccEnv :: OccEnv+initOccEnv+  = OccEnv { occ_encl      = OccVanilla+           , occ_one_shots = []++                 -- To be conservative, we say that all+                 -- inlines and rules are active+           , occ_unf_act   = \_ -> True+           , occ_rule_act  = \_ -> True++           , occ_join_points = emptyVarEnv+           , occ_bs_env = emptyVarEnv+           , occ_bs_rng = emptyVarSet }++noBinderSwaps :: OccEnv -> Bool+noBinderSwaps (OccEnv { occ_bs_env = bs_env }) = isEmptyVarEnv bs_env++setScrutCtxt :: OccEnv -> [CoreAlt] -> OccEnv+setScrutCtxt !env alts+  = setNonTailCtxt encl env+  where+    encl | interesting_alts = OccScrut+         | otherwise        = OccVanilla++    interesting_alts = case alts of+                         []    -> False+                         [alt] -> not (isDefaultAlt alt)+                         _     -> True+     -- 'interesting_alts' is True if the case has at least one+     -- non-default alternative.  That in turn influences+     -- pre/postInlineUnconditionally.  Grep for "occ_int_cxt"!++setNonTailCtxt :: OccEncl -> OccEnv -> OccEnv+setNonTailCtxt ctxt !env+  = env { occ_encl        = ctxt+        , occ_one_shots   = []+        , occ_join_points = zapped_jp_env }+  where+    -- zapped_jp_env is basically just emptyVarEnv (hence zapped).  See (W3) of+    -- Note [Occurrence analysis for join points] Zapping improves efficiency,+    -- slightly, if you accidentally introduce a bug, in which you zap [jx :-> uds] and+    -- then find an occurrence of jx anyway, you might lose those uds, and+    -- that might mean we don't record all occurrencs, and that means we+    -- duplicate a redex....  a very nasty bug (which I encountered!).  Hence+    -- this DEBUG code which doesn't remove jx from the envt; it just gives it+    -- emptyDetails, which in turn causes a panic in mkOneOcc. That will catch+    -- this bug before it does any damage.+#ifdef DEBUG+    zapped_jp_env = mapVarEnv (\ _ -> emptyVarEnv) (occ_join_points env)+#else+    zapped_jp_env = emptyVarEnv+#endif++setTailCtxt :: OccEnv -> OccEnv+setTailCtxt !env+  = env { occ_encl = OccVanilla }+    -- Preserve occ_one_shots, occ_join points+    -- Do not use OccRhs for the RHS of a join point (which is a tail ctxt):+    --    see Note [Join point RHSs]++addOneShots :: OneShots -> OccEnv -> OccEnv+addOneShots os !env+  | null os   = env  -- Fast path for common case+  | otherwise = env { occ_one_shots = os }++addOneShotsFromDmd :: Id -> OccEnv -> OccEnv+addOneShotsFromDmd bndr = addOneShots (argOneShots (idDemandInfo bndr))++isRhsEnv :: OccEnv -> Bool+isRhsEnv (OccEnv { occ_encl = cxt }) = case cxt of+                                          OccRhs -> True+                                          _      -> False++addInScopeList :: OccEnv -> [Var]+               -> (OccEnv -> WithUsageDetails a) -> WithUsageDetails a+{-# INLINE addInScopeList #-}+addInScopeList env bndrs thing_inside+ | null bndrs = thing_inside env  -- E.g. nullary constructors in a `case`+ | otherwise  = addInScope env bndrs thing_inside++addInScopeOne :: OccEnv -> Id+               -> (OccEnv -> WithUsageDetails a) -> WithUsageDetails a+{-# INLINE addInScopeOne #-}+addInScopeOne env bndr = addInScope env [bndr]++addInScope :: OccEnv -> [Var]+           -> (OccEnv -> WithUsageDetails a) -> WithUsageDetails a+{-# INLINE addInScope #-}+-- This function is called a lot, so we want to inline the fast path+-- so we don't have to allocate thing_inside and call it+-- The bndrs must include TyVars as well as Ids, because of+--     (BS3) in Note [Binder swap]+-- We do not assume that the bndrs are in scope order; in fact the+-- call in occ_anal_lam_tail gives them to addInScope in /reverse/ order++-- Fast path when the is no environment-munging to do+-- This is rather common: notably at top level, but nested too+addInScope env bndrs thing_inside+  | isEmptyVarEnv (occ_bs_env env)+  , isEmptyVarEnv (occ_join_points env)+  , WUD uds res <- thing_inside env+  = WUD (delBndrsFromUDs bndrs uds) res++addInScope env bndrs thing_inside+  = WUD uds' res+  where+    bndr_set           = mkVarSet bndrs+    !(env', bad_joins) = preprocess_env env bndr_set+    !(WUD uds res)     = thing_inside env'+    uds'               = postprocess_uds bndrs bad_joins uds++preprocess_env :: OccEnv -> VarSet -> (OccEnv, JoinPointInfo)+preprocess_env env@(OccEnv { occ_join_points = join_points+                           , occ_bs_rng = bs_rng_vars })+               bndr_set+  | bad_joins = (drop_shadowed_swaps (drop_shadowed_joins env), join_points)+  | otherwise = (drop_shadowed_swaps env,                       emptyVarEnv)+  where+    drop_shadowed_swaps :: OccEnv -> OccEnv+    -- See Note [The binder-swap substitution] (BS3)+    drop_shadowed_swaps env@(OccEnv { occ_bs_env = swap_env })+      | isEmptyVarEnv swap_env+      = env+      | bs_rng_vars `intersectsVarSet` bndr_set+      = env { occ_bs_env = emptyVarEnv, occ_bs_rng = emptyVarSet }+      | otherwise+      = env { occ_bs_env = swap_env `minusUFM` bndr_fm }++    drop_shadowed_joins :: OccEnv -> OccEnv+    -- See Note [Occurrence analysis for join points] wrinkle2 (W1) and (W2)+    drop_shadowed_joins env = env { occ_join_points = emptyVarEnv }++    -- bad_joins is true if it would be wrong to push occ_join_points inwards+    --  (a) `bndrs` includes any of the occ_join_points+    --  (b) `bndrs` includes any variables free in the RHSs of occ_join_points+    bad_joins :: Bool+    bad_joins = nonDetStrictFoldVarEnv_Directly is_bad False join_points++    bndr_fm :: UniqFM Var Var+    bndr_fm = getUniqSet bndr_set++    is_bad :: Unique -> OccInfoEnv -> Bool -> Bool+    is_bad uniq join_uds rest+      = uniq `elemUniqSet_Directly` bndr_set ||+        not (bndr_fm `disjointUFM` join_uds) ||+        rest++postprocess_uds :: [Var] -> JoinPointInfo -> UsageDetails -> UsageDetails+postprocess_uds bndrs bad_joins uds+  = add_bad_joins (delBndrsFromUDs bndrs uds)+  where+    add_bad_joins :: UsageDetails -> UsageDetails+    -- Add usage info for occ_join_points that we cannot push inwards+    -- because of shadowing+    -- See Note [Occurrence analysis for join points] wrinkle (W2)+    add_bad_joins uds+       | isEmptyVarEnv bad_joins = uds+       | otherwise               = modifyUDEnv extend_with_bad_joins uds++    extend_with_bad_joins :: OccInfoEnv -> OccInfoEnv+    extend_with_bad_joins env+       = nonDetStrictFoldUFM_Directly add_bad_join env bad_joins++    add_bad_join :: Unique -> OccInfoEnv -> OccInfoEnv -> OccInfoEnv+    -- Behave like `andUDs` when adding in the bad_joins+    add_bad_join uniq join_env env+      | uniq `elemVarEnvByKey` env = plusVarEnv_C andLocalOcc env join_env+      | otherwise                  = env++addJoinPoint :: OccEnv -> Id -> UsageDetails -> OccEnv+addJoinPoint env bndr rhs_uds+  | isEmptyVarEnv zeroed_form+  = env+  | otherwise+  = env { occ_join_points = extendVarEnv (occ_join_points env) bndr zeroed_form }+  where+    zeroed_form = mkZeroedForm rhs_uds++mkZeroedForm :: UsageDetails -> OccInfoEnv+-- See Note [Occurrence analysis for join points] for "zeroed form"+mkZeroedForm (UD { ud_env = rhs_occs })+  = mapMaybeUFM do_one rhs_occs+  where+    do_one :: LocalOcc -> Maybe LocalOcc+    do_one (ManyOccL {})    = Nothing+    do_one occ@(OneOccL {}) = Just (occ { lo_n_br = 0 })++--------------------+transClosureFV :: VarEnv VarSet -> VarEnv VarSet+-- If (f,g), (g,h) are in the input, then (f,h) is in the output+--                                   as well as (f,g), (g,h)+transClosureFV env+  | no_change = env+  | otherwise = transClosureFV (listToUFM_Directly new_fv_list)+  where+    (no_change, new_fv_list) = mapAccumL bump True (nonDetUFMToList env)+      -- It's OK to use nonDetUFMToList here because we'll forget the+      -- ordering by creating a new set with listToUFM+    bump no_change (b,fvs)+      | no_change_here = (no_change, (b,fvs))+      | otherwise      = (False,     (b,new_fvs))+      where+        (new_fvs, no_change_here) = extendFvs env fvs++-------------+extendFvs_ :: VarEnv VarSet -> VarSet -> VarSet+extendFvs_ env s = fst (extendFvs env s)   -- Discard the Bool flag++extendFvs :: VarEnv VarSet -> VarSet -> (VarSet, Bool)+-- (extendFVs env s) returns+--     (s `union` env(s), env(s) `subset` s)+extendFvs env s+  | isNullUFM env+  = (s, True)+  | otherwise+  = (s `unionVarSet` extras, extras `subVarSet` s)+  where+    extras :: VarSet    -- env(s)+    extras = nonDetStrictFoldUFM unionVarSet emptyVarSet $+      -- It's OK to use nonDetStrictFoldUFM here because unionVarSet commutes+             intersectUFM_C (\x _ -> x) env (getUniqSet s)++{-+************************************************************************+*                                                                      *+                    Binder swap+*                                                                      *+************************************************************************++Note [Binder swap]+~~~~~~~~~~~~~~~~~~+The "binder swap" transformation swaps occurrence of the+scrutinee of a case for occurrences of the case-binder:++ (1)  case x of b { pi -> ri }+         ==>+      case x of b { pi -> ri[b/x] }++ (2)  case (x |> co) of b { pi -> ri }+        ==>+      case (x |> co) of b { pi -> ri[b |> sym co/x] }++The substitution ri[b/x] etc is done by the occurrence analyser.+See Note [The binder-swap substitution].++There are two reasons for making this swap:++(A) It reduces the number of occurrences of the scrutinee, x.+    That in turn might reduce its occurrences to one, so we+    can inline it and save an allocation.  E.g.+      let x = factorial y in case x of b { I# v -> ...x... }+    If we replace 'x' by 'b' in the alternative we get+      let x = factorial y in case x of b { I# v -> ...b... }+    and now we can inline 'x', thus+      case (factorial y) of b { I# v -> ...b... }++(B) The case-binder b has unfolding information; in the+    example above we know that b = I# v. That in turn allows+    nested cases to simplify.  Consider+       case x of b { I# v ->+       ...(case x of b2 { I# v2 -> rhs })...+    If we replace 'x' by 'b' in the alternative we get+       case x of b { I# v ->+       ...(case b of b2 { I# v2 -> rhs })...+    and now it is trivial to simplify the inner case:+       case x of b { I# v ->+       ...(let b2 = b in rhs)...++    The same can happen even if the scrutinee is a variable+    with a cast: see Note [Case of cast]++The reason for doing these transformations /here in the occurrence+analyser/ is because it allows us to adjust the OccInfo for 'x' and+'b' as we go.++  * Suppose the only occurrences of 'x' are the scrutinee and in the+    ri; then this transformation makes it occur just once, and hence+    get inlined right away.++  * If instead the Simplifier replaces occurrences of x with+    occurrences of b, that will mess up b's occurrence info. That in+    turn might have consequences.++There is a danger though.  Consider+      let v = x +# y+      in case (f v) of w -> ...v...v...+And suppose that (f v) expands to just v.  Then we'd like to+use 'w' instead of 'v' in the alternative.  But it may be too+late; we may have substituted the (cheap) x+#y for v in the+same simplifier pass that reduced (f v) to v.++I think this is just too bad.  CSE will recover some of it.++Note [The binder-swap substitution]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The binder-swap is implemented by the occ_bs_env field of OccEnv.+There are two main pieces:++* Given    case x |> co of b { alts }+  we add [x :-> (b, sym co)] to the occ_bs_env environment; this is+  done by addBndrSwap.++* Then, at an occurrence of a variable, we look up in the occ_bs_env+  to perform the swap. This is done by lookupBndrSwap.++Some tricky corners:++(BS1) We do the substitution before gathering occurrence info. So in+      the above example, an occurrence of x turns into an occurrence+      of b, and that's what we gather in the UsageDetails.  It's as+      if the binder-swap occurred before occurrence analysis. See+      the computation of fun_uds in occAnalApp.++(BS2) When doing a lookup in occ_bs_env, we may need to iterate,+      as you can see implemented in lookupBndrSwap.  Why?+      Consider   case x of a { 1# -> e1; DEFAULT ->+                 case x of b { 2# -> e2; DEFAULT ->+                 case x of c { 3# -> e3; DEFAULT -> ..x..a..b.. }}}+      At the first case addBndrSwap will extend occ_bs_env with+          [x :-> a]+      At the second case we occ-anal the scrutinee 'x', which looks up+        'x in occ_bs_env, returning 'a', as it should.+      Then addBndrSwap will add [a :-> b] to occ_bs_env, yielding+         occ_bs_env = [x :-> a, a :-> b]+      At the third case we'll again look up 'x' which returns 'a'.+      But we don't want to stop the lookup there, else we'll end up with+                 case x of a { 1# -> e1; DEFAULT ->+                 case a of b { 2# -> e2; DEFAULT ->+                 case a of c { 3# -> e3; DEFAULT -> ..a..b..c.. }}}+      Instead, we want iterate the lookup in addBndrSwap, to give+                 case x of a { 1# -> e1; DEFAULT ->+                 case a of b { 2# -> e2; DEFAULT ->+                 case b of c { 3# -> e3; DEFAULT -> ..c..c..c.. }}}+      This makes a particular difference for case-merge, which works+      only if the scrutinee is the case-binder of the immediately enclosing+      case (Note [Merge Nested Cases] in GHC.Core.Opt.Simplify.Utils+      See #19581 for the bug report that showed this up.++(BS3) We need care when shadowing.  Suppose [x :-> b] is in occ_bs_env,+      and we encounter:+         (i) \x. blah+             Here we want to delete the x-binding from occ_bs_env++         (ii) \b. blah+              This is harder: we really want to delete all bindings that+              have 'b' free in the range.  That is a bit tiresome to implement,+              so we compromise.  We keep occ_bs_rng, which is the set of+              free vars of rng(occc_bs_env).  If a binder shadows any of these+              variables, we discard all of occ_bs_env.  Safe, if a bit+              brutal.  NB, however: the simplifer de-shadows the code, so the+              next time around this won't happen.++      These checks are implemented in addInScope.+      (i) is needed only for Ids, but (ii) is needed for tyvars too (#22623)+      because if occ_bs_env has [x :-> ...a...] where `a` is a tyvar, we+      must not replace `x` by `...a...` under /\a. ...x..., or similarly+      under a case pattern match that binds `a`.++      An alternative would be for the occurrence analyser to do cloning as+      it goes.  In principle it could do so, but it'd make it a bit more+      complicated and there is no great benefit. The simplifer uses+      cloning to get a no-shadowing situation, the care-when-shadowing+      behaviour above isn't needed for long.++(BS4) The domain of occ_bs_env can include GlobaIds.  Eg+         case M.foo of b { alts }+      We extend occ_bs_env with [M.foo :-> b].  That's fine.++(BS5) We have to apply the occ_bs_env substitution uniformly,+      including to (local) rules and unfoldings.++(BS6) We must be very careful with dictionaries.+      See Note [Care with binder-swap on dictionaries]++Note [Case of cast]+~~~~~~~~~~~~~~~~~~~+Consider        case (x `cast` co) of b { I# ->+                ... (case (x `cast` co) of {...}) ...+We'd like to eliminate the inner case.  That is the motivation for+equation (2) in Note [Binder swap].  When we get to the inner case, we+inline x, cancel the casts, and away we go.++Note [Care with binder-swap on dictionaries]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+This Note explains why we need isDictId in scrutBinderSwap_maybe.+Consider this tricky example (#21229, #21470):++  class Sing (b :: Bool) where sing :: Bool+  instance Sing 'True  where sing = True+  instance Sing 'False where sing = False++  f :: forall a. Sing a => blah++  h = \ @(a :: Bool) ($dSing :: Sing a)+      let the_co =  Main.N:Sing[0] <a> :: Sing a ~R# Bool+      case ($dSing |> the_co) of wild+        True  -> f @'True (True |> sym the_co)+        False -> f @a     dSing++Now do a binder-swap on the case-expression:++  h = \ @(a :: Bool) ($dSing :: Sing a)+      let the_co =  Main.N:Sing[0] <a> :: Sing a ~R# Bool+      case ($dSing |> the_co) of wild+        True  -> f @'True (True |> sym the_co)+        False -> f @a     (wild |> sym the_co)++And now substitute `False` for `wild` (since wild=False in the False branch):++  h = \ @(a :: Bool) ($dSing :: Sing a)+      let the_co =  Main.N:Sing[0] <a> :: Sing a ~R# Bool+      case ($dSing |> the_co) of wild+        True  -> f @'True (True  |> sym the_co)+        False -> f @a     (False |> sym the_co)++And now we have a problem.  The specialiser will specialise (f @a d)a (for all+vtypes a and dictionaries d!!) with the dictionary (False |> sym the_co), using+Note [Specialising polymorphic dictionaries] in GHC.Core.Opt.Specialise.++The real problem is the binder-swap.  It swaps a dictionary variable $dSing+(of kind Constraint) for a term variable wild (of kind Type).  And that is+dangerous: a dictionary is a /singleton/ type whereas a general term variable is+not.  In this particular example, Bool is most certainly not a singleton type!++Conclusion:+  for a /dictionary variable/ do not perform+  the clever cast version of the binder-swap++Hence the subtle isDictId in scrutBinderSwap_maybe.++Note [Zap case binders in proxy bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+From the original+     case x of cb(dead) { p -> ...x... }+we will get+     case x of cb(live) { p -> ...cb... }++Core Lint never expects to find an *occurrence* of an Id marked+as Dead, so we must zap the OccInfo on cb before making the+binding x = cb.  See #5028.++NB: the OccInfo on /occurrences/ really doesn't matter much; the simplifier+doesn't use it. So this is only to satisfy the perhaps-over-picky Lint.++-}++addBndrSwap :: OutExpr -> Id -> OccEnv -> OccEnv+-- See Note [The binder-swap substitution]+addBndrSwap scrut case_bndr+            env@(OccEnv { occ_bs_env = swap_env, occ_bs_rng = rng_vars })+  | Just (scrut_var, mco) <- scrutBinderSwap_maybe scrut+  , scrut_var /= case_bndr+      -- Consider: case x of x { ... }+      -- Do not add [x :-> x] to occ_bs_env, else lookupBndrSwap will loop+  = env { occ_bs_env = extendVarEnv swap_env scrut_var (case_bndr', mco)+        , occ_bs_rng = rng_vars `extendVarSet` case_bndr'+                       `unionVarSet` tyCoVarsOfMCo mco }++  | otherwise+  = env+  where+    case_bndr' = zapIdOccInfo case_bndr+                 -- See Note [Zap case binders in proxy bindings]++scrutBinderSwap_maybe :: OutExpr -> Maybe (OutVar, MCoercion)+-- If (scrutBinderSwap_maybe e = Just (v, mco), then+--    v = e |> mco+-- See Note [Case of cast]+-- See Note [Care with binder-swap on dictionaries]+--+-- We use this same function in SpecConstr, and Simplify.Iteration,+-- when something binder-swap-like is happening+scrutBinderSwap_maybe (Var v)    = Just (v, MRefl)+scrutBinderSwap_maybe (Cast (Var v) co)+  | not (isDictId v)             = Just (v, MCo (mkSymCo co))+        -- Cast: see Note [Case of cast]+        -- isDictId: see Note [Care with binder-swap on dictionaries]+        -- The isDictId rejects a Constraint/Constraint binder-swap, perhaps+        -- over-conservatively. But I have never seen one, so I'm leaving+        -- the code as simple as possible. Losing the binder-swap in a+        -- rare case probably has very low impact.+scrutBinderSwap_maybe (Tick _ e) = scrutBinderSwap_maybe e  -- Drop ticks+scrutBinderSwap_maybe _          = Nothing++lookupBndrSwap :: OccEnv -> Id -> (CoreExpr, Id)+-- See Note [The binder-swap substitution]+-- Returns an expression of the same type as Id+lookupBndrSwap env@(OccEnv { occ_bs_env = bs_env })  bndr+  = case lookupVarEnv bs_env bndr of {+       Nothing           -> (Var bndr, bndr) ;+       Just (bndr1, mco) ->++    -- Why do we iterate here?+    -- See (BS2) in Note [The binder-swap substitution]+    case lookupBndrSwap env bndr1 of+      (fun, fun_id) -> (mkCastMCo fun mco, fun_id) }++{- Historical note [Proxy let-bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We used to do the binder-swap transformation by introducing+a proxy let-binding, thus;++   case x of b { pi -> ri }+      ==>+   case x of b { pi -> let x = b in ri }++But that had two problems:++1. If 'x' is an imported GlobalId, we'd end up with a GlobalId+   on the LHS of a let-binding which isn't allowed.  We worked+   around this for a while by "localising" x, but it turned+   out to be very painful #16296,++2. In CorePrep we use the occurrence analyser to do dead-code+   elimination (see Note [Dead code in CorePrep]).  But that+   occasionally led to an unlifted let-binding+       case x of b { DEFAULT -> let x::Int# = b in ... }+   which disobeys one of CorePrep's output invariants (no unlifted+   let-bindings) -- see #5433.++Doing a substitution (via occ_bs_env) is much better.++Historical Note [no-case-of-case]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We *used* to suppress the binder-swap in case expressions when+-fno-case-of-case is on.  Old remarks:+    "This happens in the first simplifier pass,+    and enhances full laziness.  Here's the bad case:+            f = \ y -> ...(case x of I# v -> ...(case x of ...) ... )+    If we eliminate the inner case, we trap it inside the I# v -> arm,+    which might prevent some full laziness happening.  I've seen this+    in action in spectral/cichelli/Prog.hs:+             [(m,n) | m <- [1..max], n <- [1..max]]+    Hence the check for NoCaseOfCase."+However, now the full-laziness pass itself reverses the binder-swap, so this+check is no longer necessary.++Historical Note [Suppressing the case binder-swap]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+This old note describes a problem that is also fixed by doing the+binder-swap in OccAnal:++    There is another situation when it might make sense to suppress the+    case-expression binde-swap. If we have++        case x of w1 { DEFAULT -> case x of w2 { A -> e1; B -> e2 }+                       ...other cases .... }++    We'll perform the binder-swap for the outer case, giving++        case x of w1 { DEFAULT -> case w1 of w2 { A -> e1; B -> e2 }+                       ...other cases .... }++    But there is no point in doing it for the inner case, because w1 can't+    be inlined anyway.  Furthermore, doing the case-swapping involves+    zapping w2's occurrence info (see paragraphs that follow), and that+    forces us to bind w2 when doing case merging.  So we get++        case x of w1 { A -> let w2 = w1 in e1+                       B -> let w2 = w1 in e2+                       ...other cases .... }++    This is plain silly in the common case where w2 is dead.++    Even so, I can't see a good way to implement this idea.  I tried+    not doing the binder-swap if the scrutinee was already evaluated+    but that failed big-time:++            data T = MkT !Int++            case v of w  { MkT x ->+            case x of x1 { I# y1 ->+            case x of x2 { I# y2 -> ...++    Notice that because MkT is strict, x is marked "evaluated".  But to+    eliminate the last case, we must either make sure that x (as well as+    x1) has unfolding MkT y1.  The straightforward thing to do is to do+    the binder-swap.  So this whole note is a no-op.++It's fixed by doing the binder-swap in OccAnal because we can do the+binder-swap unconditionally and still get occurrence analysis+information right.+++************************************************************************+*                                                                      *+\subsection[OccurAnal-types]{OccEnv}+*                                                                      *+************************************************************************++Note [UsageDetails and zapping]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+On many occasions, we must modify all gathered occurrence data at once. For+instance, all occurrences underneath a (non-one-shot) lambda set the+'occ_in_lam' flag to become 'True'. We could use 'mapVarEnv' to do this, but+that takes O(n) time and we will do this often---in particular, there are many+places where tail calls are not allowed, and each of these causes all variables+to get marked with 'NoTailCallInfo'.++Instead of relying on `mapVarEnv`, then, we carry three 'IdEnv's around along+with the 'OccInfoEnv'. Each of these extra environments is a "zapped set"+recording which variables have been zapped in some way. Zapping all occurrence+info then simply means setting the corresponding zapped set to the whole+'OccInfoEnv', a fast O(1) operation.++Note [LocalOcc]+~~~~~~~~~~~~~~~+LocalOcc is used purely internally, in the occurrence analyser.  It differs from+GHC.Types.Basic.OccInfo because it has only OneOcc and ManyOcc; it does not need+IAmDead or IAmALoopBreaker.++Note that `OneOccL` doesn't meant that it occurs /syntactially/ only once; it+means that it is /used/ only once. It might occur syntactically many times.+For example, in (case x of A -> y; B -> y; C -> True),+* `y` is used only once+* but it occurs syntactically twice++-}++type OccInfoEnv = IdEnv LocalOcc  -- A finite map from an expression's+                                  -- free variables to their usage++data LocalOcc  -- See Note [LocalOcc]+     = OneOccL { lo_n_br  :: {-# UNPACK #-} !BranchCount  -- Number of syntactic occurrences+               , lo_tail  :: !TailCallInfo+                   -- Combining (AlwaysTailCalled 2) and (AlwaysTailCalled 3)+                   -- gives NoTailCallInfo+              , lo_int_cxt :: !InterestingCxt }+    | ManyOccL !TailCallInfo++instance Outputable LocalOcc where+  ppr (OneOccL { lo_n_br = n, lo_tail = tci })+    = text "OneOccL" <> braces (ppr n <> comma <> ppr tci)+  ppr (ManyOccL tci) = text "ManyOccL" <> braces (ppr tci)++localTailCallInfo :: LocalOcc -> TailCallInfo+localTailCallInfo (OneOccL  { lo_tail = tci }) = tci+localTailCallInfo (ManyOccL tci)               = tci++type ZappedSet = OccInfoEnv -- Values are ignored++data UsageDetails+  = UD { ud_env       :: !OccInfoEnv+       , ud_z_many    :: !ZappedSet   -- apply 'markMany' to these+       , ud_z_in_lam  :: !ZappedSet   -- apply 'markInsideLam' to these+       , ud_z_tail    :: !ZappedSet   -- zap tail-call info for these+       }+  -- INVARIANT: All three zapped sets are subsets of ud_env++instance Outputable UsageDetails where+  ppr ud@(UD { ud_env = env, ud_z_tail = z_tail })+    = text "UD" <+> (braces $ fsep $ punctuate comma $+      [ ppr uq <+> text ":->" <+> ppr (lookupOccInfoByUnique ud uq)+      | (uq, _) <- nonDetStrictFoldVarEnv_Directly do_one [] env ])+      $$ nest 2 (text "ud_z_tail" <+> ppr z_tail)+    where+      do_one :: Unique -> LocalOcc -> [(Unique,LocalOcc)] -> [(Unique,LocalOcc)]+      do_one uniq occ occs = (uniq, occ) : occs++---------------------+-- | TailUsageDetails captures the result of applying 'occAnalLamTail'+--   to a function `\xyz.body`. The TailUsageDetails pairs together+--   * the number of lambdas (including type lambdas: a JoinArity)+--   * UsageDetails for the `body` of the lambda, unadjusted by `adjustTailUsage`.+-- If the binding turns out to be a join point with the indicated join+-- arity, this unadjusted usage details is just what we need; otherwise we+-- need to discard tail calls. That's what `adjustTailUsage` does.+data TailUsageDetails = TUD !JoinArity !UsageDetails++instance Outputable TailUsageDetails where+  ppr (TUD ja uds) = lambda <> ppr ja <> ppr uds++---------------------+data WithUsageDetails     a = WUD  !UsageDetails     !a+data WithTailUsageDetails a = WTUD !TailUsageDetails !a++-------------------+-- UsageDetails API++andUDs, orUDs+        :: UsageDetails -> UsageDetails -> UsageDetails+andUDs = combineUsageDetailsWith andLocalOcc+orUDs  = combineUsageDetailsWith orLocalOcc++mkOneOcc :: OccEnv -> Id -> InterestingCxt -> JoinArity -> UsageDetails+mkOneOcc !env id int_cxt arity+  | not (isLocalId id)+  = emptyDetails++  | Just join_uds <- lookupVarEnv (occ_join_points env) id+  = -- See Note [Occurrence analysis for join points]+    assertPpr (not (isEmptyVarEnv join_uds)) (ppr id) $+       -- We only put non-empty join-points into occ_join_points+    mkSimpleDetails (extendVarEnv join_uds id occ)++  | otherwise+  = mkSimpleDetails (unitVarEnv id occ)++  where+    occ = OneOccL { lo_n_br = 1, lo_int_cxt = int_cxt+                  , lo_tail = AlwaysTailCalled arity }++-- Add several occurrences, assumed not to be tail calls+add_many_occ :: Var -> OccInfoEnv -> OccInfoEnv+add_many_occ v env | isId v    = extendVarEnv env v (ManyOccL NoTailCallInfo)+                   | otherwise = env+        -- Give a non-committal binder info (i.e noOccInfo) because+        --   a) Many copies of the specialised thing can appear+        --   b) We don't want to substitute a BIG expression inside a RULE+        --      even if that's the only occurrence of the thing+        --      (Same goes for INLINE.)++addManyOccs :: UsageDetails -> VarSet -> UsageDetails+addManyOccs uds var_set+  | isEmptyVarSet var_set = uds+  | otherwise             = uds { ud_env = add_to (ud_env uds) }+  where+    add_to env = nonDetStrictFoldUniqSet add_many_occ env var_set+    -- It's OK to use nonDetStrictFoldUniqSet here because add_many_occ commutes++addLamCoVarOccs :: UsageDetails -> [Var] -> UsageDetails+-- Add any CoVars free in the type of a lambda-binder+-- See Note [Gather occurrences of coercion variables]+addLamCoVarOccs uds bndrs+  = foldr add uds bndrs+  where+    add bndr uds = uds `addManyOccs` coVarsOfType (varType bndr)++emptyDetails :: UsageDetails+emptyDetails = mkSimpleDetails emptyVarEnv++isEmptyDetails :: UsageDetails -> Bool+isEmptyDetails (UD { ud_env = env }) = isEmptyVarEnv env++mkSimpleDetails :: OccInfoEnv -> UsageDetails+mkSimpleDetails env = UD { ud_env       = env+                         , ud_z_many    = emptyVarEnv+                         , ud_z_in_lam  = emptyVarEnv+                         , ud_z_tail    = emptyVarEnv }++modifyUDEnv :: (OccInfoEnv -> OccInfoEnv) -> UsageDetails -> UsageDetails+modifyUDEnv f uds@(UD { ud_env = env }) = uds { ud_env = f env }++delBndrsFromUDs :: [Var] -> UsageDetails -> UsageDetails+-- Delete these binders from the UsageDetails+delBndrsFromUDs bndrs (UD { ud_env = env, ud_z_many = z_many+                          , ud_z_in_lam  = z_in_lam, ud_z_tail = z_tail })+  = UD { ud_env       = env      `delVarEnvList` bndrs+       , ud_z_many    = z_many   `delVarEnvList` bndrs+       , ud_z_in_lam  = z_in_lam `delVarEnvList` bndrs+       , ud_z_tail    = z_tail   `delVarEnvList` bndrs }++markAllMany, markAllInsideLam, markAllNonTail, markAllManyNonTail+  :: UsageDetails -> UsageDetails+markAllMany      ud@(UD { ud_env = env }) = ud { ud_z_many   = env }+markAllInsideLam ud@(UD { ud_env = env }) = ud { ud_z_in_lam = env }+markAllNonTail   ud@(UD { ud_env = env }) = ud { ud_z_tail   = env }+markAllManyNonTail = markAllMany . markAllNonTail -- effectively sets to noOccInfo++markAllInsideLamIf, markAllNonTailIf :: Bool -> UsageDetails -> UsageDetails++markAllInsideLamIf  True  ud = markAllInsideLam ud+markAllInsideLamIf  False ud = ud++markAllNonTailIf True  ud = markAllNonTail ud+markAllNonTailIf False ud = ud++lookupTailCallInfo :: UsageDetails -> Id -> TailCallInfo+lookupTailCallInfo uds id+  | UD { ud_z_tail = z_tail, ud_env = env } <- uds+  , not (id `elemVarEnv` z_tail)+  , Just occ <- lookupVarEnv env id+  = localTailCallInfo occ+  | otherwise+  = NoTailCallInfo++udFreeVars :: VarSet -> UsageDetails -> VarSet+-- Find the subset of bndrs that are mentioned in uds+udFreeVars bndrs (UD { ud_env = env }) = restrictFreeVars bndrs env++restrictFreeVars :: VarSet -> OccInfoEnv -> VarSet+restrictFreeVars bndrs fvs = restrictUniqSetToUFM bndrs fvs++-------------------+-- Auxiliary functions for UsageDetails implementation++combineUsageDetailsWith :: (LocalOcc -> LocalOcc -> LocalOcc)+                        -> UsageDetails -> UsageDetails -> UsageDetails+{-# INLINE combineUsageDetailsWith #-}+combineUsageDetailsWith plus_occ_info+    uds1@(UD { ud_env = env1, ud_z_many = z_many1, ud_z_in_lam = z_in_lam1, ud_z_tail = z_tail1 })+    uds2@(UD { ud_env = env2, ud_z_many = z_many2, ud_z_in_lam = z_in_lam2, ud_z_tail = z_tail2 })+  | isEmptyVarEnv env1 = uds2+  | isEmptyVarEnv env2 = uds1+  | otherwise+  = UD { ud_env       = plusVarEnv_C plus_occ_info env1 env2+       , ud_z_many    = plusVarEnv z_many1   z_many2+       , ud_z_in_lam  = plusVarEnv z_in_lam1 z_in_lam2+       , ud_z_tail    = plusVarEnv z_tail1   z_tail2 }++lookupLetOccInfo :: UsageDetails -> Id -> OccInfo+-- Don't use locally-generated occ_info for exported (visible-elsewhere)+-- things.  Instead just give noOccInfo.+-- NB: setBinderOcc will (rightly) erase any LoopBreaker info;+--     we are about to re-generate it and it shouldn't be "sticky"+lookupLetOccInfo ud id+ | isExportedId id = noOccInfo+ | otherwise       = lookupOccInfoByUnique ud (idUnique id)++lookupOccInfo :: UsageDetails -> Id -> OccInfo+lookupOccInfo ud id = lookupOccInfoByUnique ud (idUnique id)++lookupOccInfoByUnique :: UsageDetails -> Unique -> OccInfo+lookupOccInfoByUnique (UD { ud_env       = env+                          , ud_z_many    = z_many+                          , ud_z_in_lam  = z_in_lam+                          , ud_z_tail    = z_tail })+                  uniq+  = case lookupVarEnv_Directly env uniq of+      Nothing -> IAmDead+      Just (OneOccL { lo_n_br = n_br, lo_int_cxt = int_cxt+                    , lo_tail = tail_info })+          | uniq `elemVarEnvByKey`z_many+          -> ManyOccs { occ_tail = mk_tail_info tail_info }+          | otherwise+          -> OneOcc { occ_in_lam  = in_lam+                    , occ_n_br    = n_br+                    , occ_int_cxt = int_cxt+                    , occ_tail    = mk_tail_info tail_info }+         where+           in_lam | uniq `elemVarEnvByKey` z_in_lam = IsInsideLam+                  | otherwise                       = NotInsideLam++      Just (ManyOccL tail_info) -> ManyOccs { occ_tail = mk_tail_info tail_info }+  where+    mk_tail_info ti+        | uniq `elemVarEnvByKey` z_tail = NoTailCallInfo+        | otherwise                     = ti++++-------------------+-- See Note [Adjusting right-hand sides]++adjustNonRecRhs :: JoinPointHood+                -> WithTailUsageDetails CoreExpr+                -> WithUsageDetails CoreExpr+-- ^ This function concentrates shared logic between occAnalNonRecBind and the+-- AcyclicSCC case of occAnalRec.+--   * It applies 'markNonRecJoinOneShots' to the RHS+--   * and returns the adjusted rhs UsageDetails combined with the body usage+adjustNonRecRhs mb_join_arity rhs_wuds@(WTUD _ rhs)+  = WUD rhs_uds' rhs'+  where+    --------- Marking (non-rec) join binders one-shot ---------+    !rhs' | JoinPoint ja <- mb_join_arity = markNonRecJoinOneShots ja rhs+          | otherwise                     = rhs++    --------- Adjusting right-hand side usage ---------+    rhs_uds' = adjustTailUsage mb_join_arity rhs_wuds++adjustTailUsage :: JoinPointHood+                -> WithTailUsageDetails CoreExpr    -- Rhs usage, AFTER occAnalLamTail+                -> UsageDetails+adjustTailUsage mb_join_arity (WTUD (TUD rhs_ja uds) rhs)+  = -- c.f. occAnal (Lam {})+    markAllInsideLamIf (not one_shot) $+    markAllNonTailIf (not exact_join) $+    uds+  where+    one_shot   = isOneShotFun rhs+    exact_join = mb_join_arity == JoinPoint rhs_ja++adjustTailArity :: JoinPointHood -> TailUsageDetails -> UsageDetails+adjustTailArity mb_rhs_ja (TUD ja usage)+  = markAllNonTailIf (mb_rhs_ja /= JoinPoint ja) usage++markNonRecJoinOneShots :: JoinArity -> CoreExpr -> CoreExpr+-- For a /non-recursive/ join point we can mark all+-- its join-lambda as one-shot; and it's a good idea to do so+markNonRecJoinOneShots join_arity rhs+  = go join_arity rhs+  where+    go 0 rhs         = rhs+    go n (Lam b rhs) = Lam (if isId b then setOneShotLambda b else b)+                           (go (n-1) rhs)+    go _ rhs         = rhs  -- Not enough lambdas.  This can legitimately happen.+                            -- e.g.    let j = case ... in j True+                            -- This will become an arity-1 join point after the+                            -- simplifier has eta-expanded it; but it may not have+                            -- enough lambdas /yet/. (Lint checks that JoinIds do+                            -- have enough lambdas.)++markNonRecUnfoldingOneShots :: JoinPointHood -> Unfolding -> Unfolding+-- ^ Apply 'markNonRecJoinOneShots' to a stable unfolding+markNonRecUnfoldingOneShots mb_join_arity unf+  | JoinPoint ja <- mb_join_arity+  , CoreUnfolding{uf_src=src,uf_tmpl=tmpl} <- unf+  , isStableSource src+  , let !tmpl' = markNonRecJoinOneShots ja tmpl+  = unf{uf_tmpl=tmpl'}+  | otherwise+  = unf++type IdWithOccInfo = Id++tagLamBinders :: UsageDetails        -- Of scope+              -> [Id]                -- Binders+              -> [IdWithOccInfo]     -- Tagged binders+tagLamBinders usage binders+  = map (tagLamBinder usage) binders++tagLamBinder :: UsageDetails       -- Of scope+             -> Id                 -- Binder+             -> IdWithOccInfo      -- Tagged binders+-- Used for lambda and case binders+-- No-op on TyVars+-- A lambda binder never has an unfolding, so no need to look for that+tagLamBinder usage bndr+  = setBinderOcc (markNonTail occ) bndr+      -- markNonTail: don't try to make an argument into a join point+  where+    occ = lookupOccInfo usage bndr++tagNonRecBinder :: TopLevelFlag           -- At top level?+                -> OccInfo                -- Of scope+                -> CoreBndr               -- Binder+                -> (IdWithOccInfo, JoinPointHood)  -- Tagged binder+-- No-op on TyVars+-- Precondition: OccInfo is not IAmDead+tagNonRecBinder lvl occ bndr+  | okForJoinPoint lvl bndr tail_call_info+  , AlwaysTailCalled ar <- tail_call_info+  = (setBinderOcc occ bndr,        JoinPoint ar)+  | otherwise+  = (setBinderOcc zapped_occ bndr, NotJoinPoint)+ where+    tail_call_info = tailCallInfo occ+    zapped_occ     = markNonTail occ++tagRecBinders :: TopLevelFlag           -- At top level?+              -> UsageDetails           -- Of body of let ONLY+              -> [NodeDetails]+              -> WithUsageDetails       -- Adjusted details for whole scope,+                                        -- with binders removed+                  [IdWithOccInfo]       -- Tagged binders+-- Substantially more complicated than non-recursive case. Need to adjust RHS+-- details *before* tagging binders (because the tags depend on the RHSes).+tagRecBinders lvl body_uds details_s+ = let+     bndrs = map nd_bndr details_s++     -- 1. See Note [Join arity prediction based on joinRhsArity]+     --    Determine possible join-point-hood of whole group, by testing for+     --    manifest join arity M.+     --    This (re-)asserts that makeNode had made tuds for that same arity M!+     unadj_uds = foldr (andUDs . test_manifest_arity) body_uds details_s+     test_manifest_arity ND{nd_rhs = WTUD tuds rhs}+       = adjustTailArity (JoinPoint (joinRhsArity rhs)) tuds++     will_be_joins = decideRecJoinPointHood lvl unadj_uds bndrs++     mb_join_arity :: Id -> JoinPointHood+     -- mb_join_arity: See Note [Join arity prediction based on joinRhsArity]+     -- This is the source O+     mb_join_arity bndr+         -- Can't use willBeJoinId_maybe here because we haven't tagged+         -- the binder yet (the tag depends on these adjustments!)+       | will_be_joins+       , AlwaysTailCalled arity <- lookupTailCallInfo unadj_uds bndr+       = JoinPoint arity+       | otherwise+       = assert (not will_be_joins) -- Should be AlwaysTailCalled if+         NotJoinPoint               -- we are making join points!++     -- 2. Adjust usage details of each RHS, taking into account the+     --    join-point-hood decision+     rhs_udss' = [ adjustTailUsage (mb_join_arity bndr) rhs_wuds+                     -- Matching occAnalLamTail in makeNode+                 | ND { nd_bndr = bndr, nd_rhs = rhs_wuds } <- details_s ]++     -- 3. Compute final usage details from adjusted RHS details+     adj_uds = foldr andUDs body_uds rhs_udss'++     -- 4. Tag each binder with its adjusted details+     bndrs'    = [ setBinderOcc (lookupLetOccInfo adj_uds bndr) bndr+                 | bndr <- bndrs ]++   in+   WUD adj_uds bndrs'++setBinderOcc :: OccInfo -> CoreBndr -> CoreBndr+setBinderOcc occ_info bndr+  | isTyVar bndr               = bndr+  | occ_info == idOccInfo bndr = bndr+  | otherwise                  = setIdOccInfo bndr occ_info++-- | Decide whether some bindings should be made into join points or not, based+-- on its occurrences. This is+-- Returns `False` if they can't be join points. Note that it's an+-- all-or-nothing decision, as if multiple binders are given, they're+-- assumed to be mutually recursive.+--+-- It must, however, be a final decision. If we say `True` for 'f',+-- and then subsequently decide /not/ make 'f' into a join point, then+-- the decision about another binding 'g' might be invalidated if (say)+-- 'f' tail-calls 'g'.+--+-- See Note [Invariants on join points] in "GHC.Core".+decideRecJoinPointHood :: TopLevelFlag -> UsageDetails+                       -> [CoreBndr] -> Bool+decideRecJoinPointHood lvl usage bndrs+  = all ok bndrs  -- Invariant 3: Either all are join points or none are+  where+    ok bndr = okForJoinPoint lvl bndr (lookupTailCallInfo usage bndr)++okForJoinPoint :: TopLevelFlag -> Id -> TailCallInfo -> Bool+    -- See Note [Invariants on join points]; invariants cited by number below.+    -- Invariant 2 is always satisfiable by the simplifier by eta expansion.+okForJoinPoint lvl bndr tail_call_info+  | isJoinId bndr        -- A current join point should still be one!+  = warnPprTrace lost_join "Lost join point" lost_join_doc $+    True+  | valid_join+  = True+  | otherwise+  = False+  where+    valid_join | NotTopLevel <- lvl+               , AlwaysTailCalled arity <- tail_call_info++               , -- Invariant 1 as applied to LHSes of rules+                 all (ok_rule arity) (idCoreRules bndr)++                 -- Invariant 2a: stable unfoldings+                  -- See Note [Join points and INLINE pragmas]+               , ok_unfolding arity (realIdUnfolding bndr)++                 -- Invariant 4: Satisfies polymorphism rule+               , isValidJoinPointType arity (idType bndr)+               = True+               | otherwise+               = False++    lost_join | JoinPoint ja <- idJoinPointHood bndr+              = not valid_join ||+                (case tail_call_info of  -- Valid join but arity differs+                   AlwaysTailCalled ja' -> ja /= ja'+                   _                    -> False)+              | otherwise = False++    ok_rule _ BuiltinRule{} = False -- only possible with plugin shenanigans+    ok_rule join_arity (Rule { ru_args = args })+      = args `lengthIs` join_arity+        -- Invariant 1 as applied to LHSes of rules++    -- ok_unfolding returns False if we should /not/ convert a non-join-id+    -- into a join-id, even though it is AlwaysTailCalled+    ok_unfolding join_arity (CoreUnfolding { uf_src = src, uf_tmpl = rhs })+      = not (isStableSource src && join_arity > joinRhsArity rhs)+    ok_unfolding _ (DFunUnfolding {})+      = False+    ok_unfolding _ _+      = True++    lost_join_doc+      = vcat [ text "bndr:" <+> ppr bndr+             , text "tc:" <+> ppr tail_call_info+             , text "rules:" <+> ppr (idCoreRules bndr)+             , case tail_call_info of+                 AlwaysTailCalled arity ->+                    vcat [ text "ok_unf:" <+> ppr (ok_unfolding arity (realIdUnfolding bndr))+                         , text "ok_type:" <+> ppr (isValidJoinPointType arity (idType bndr)) ]+                 _ -> empty ]++{- Note [Join points and INLINE pragmas]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Consider+   f x = let g = \x. not  -- Arity 1+             {-# INLINE g #-}+         in case x of+              A -> g True True+              B -> g True False+              C -> blah2++Here 'g' is always tail-called applied to 2 args, but the stable+unfolding captured by the INLINE pragma has arity 1.  If we try to+convert g to be a join point, its unfolding will still have arity 1+(since it is stable, and we don't meddle with stable unfoldings), and+Lint will complain (see Note [Invariants on join points], (2a), in+GHC.Core.  #13413.++Moreover, since g is going to be inlined anyway, there is no benefit+from making it a join point.++If it is recursive, and uselessly marked INLINE, this will stop us+making it a join point, which is annoying.  But occasionally+(notably in class methods; see Note [Instances and loop breakers] in+GHC.Tc.TyCl.Instance) we mark recursive things as INLINE but the recursion+unravels; so ignoring INLINE pragmas on recursive things isn't good+either.++See Invariant 2a of Note [Invariants on join points] in GHC.Core+++************************************************************************+*                                                                      *+\subsection{Operations over OccInfo}+*                                                                      *+************************************************************************+-}++markNonTail :: OccInfo -> OccInfo+markNonTail IAmDead = IAmDead+markNonTail occ     = occ { occ_tail = NoTailCallInfo }++andLocalOcc :: LocalOcc -> LocalOcc -> LocalOcc+andLocalOcc occ1 occ2 = ManyOccL (tci1 `andTailCallInfo` tci2)+  where+    !tci1 = localTailCallInfo occ1+    !tci2 = localTailCallInfo occ2++orLocalOcc :: LocalOcc -> LocalOcc -> LocalOcc+-- (orLocalOcc occ1 occ2) is used+-- when combining occurrence info from branches of a case+orLocalOcc (OneOccL { lo_n_br = nbr1, lo_int_cxt = int_cxt1, lo_tail = tci1 })+           (OneOccL { lo_n_br = nbr2, lo_int_cxt = int_cxt2, lo_tail = tci2 })+  = OneOccL { lo_n_br    = nbr1 + nbr2+            , lo_int_cxt = int_cxt1 `mappend` int_cxt2+            , lo_tail    = tci1 `andTailCallInfo` tci2 }+orLocalOcc occ1 occ2 = andLocalOcc occ1 occ2  andTailCallInfo :: TailCallInfo -> TailCallInfo -> TailCallInfo andTailCallInfo info@(AlwaysTailCalled arity1) (AlwaysTailCalled arity2)
compiler/GHC/Core/Opt/Simplify.hs view
@@ -43,10 +43,6 @@ import Control.Monad import Data.Foldable ( for_ ) -#if __GLASGOW_HASKELL__ <= 810-import GHC.Utils.Panic ( panic )-#endif- {- ************************************************************************ *                                                                      *@@ -285,9 +281,6 @@                 -- Loop            do_iteration (iteration_no + 1) (counts1:counts_so_far) binds2 rules1            } }-#if __GLASGOW_HASKELL__ <= 810-      | otherwise = panic "do_iteration"-#endif       where         -- Remember the counts_so_far are reversed         totalise :: [SimplCount] -> SimplCount
compiler/GHC/Core/Opt/Simplify/Env.hs view
@@ -84,7 +84,6 @@ import GHC.Utils.Monad import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Utils.Panic.Plain import GHC.Utils.Misc  import Data.List ( intersperse, mapAccumL )@@ -377,7 +376,7 @@  -- | A substitution result. data SimplSR-  = DoneEx OutExpr (Maybe JoinArity)+  = DoneEx OutExpr JoinPointHood        -- If  x :-> DoneEx e ja   is in the SimplIdSubst        -- then replace occurrences of x by e        -- and  ja = Just a <=> x is a join-point of arity a@@ -402,8 +401,8 @@   ppr (DoneEx e mj) = text "DoneEx" <> pp_mj <+> ppr e     where       pp_mj = case mj of-                Nothing -> empty-                Just n  -> parens (int n)+                NotJoinPoint -> empty+                JoinPoint n  -> parens (int n)    ppr (ContEx _tv _cv _id e) = vcat [text "ContEx" <+> ppr e {-,                                 ppr (filter_env tv), ppr (filter_env id) -}]@@ -1238,9 +1237,8 @@ -}  getSubst :: SimplEnv -> Subst-getSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env-                      , seCvSubst = cv_env })-  = mkSubst in_scope tv_env cv_env emptyIdSubstEnv+getSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seCvSubst = cv_env })+  = mkTCvSubst in_scope tv_env cv_env  substTy :: HasDebugCallStack => SimplEnv -> Type -> Type substTy env ty = Type.substTy (getSubst env) ty
compiler/GHC/Core/Opt/Simplify/Inline.hs view
@@ -6,7 +6,6 @@ -}  -{-# LANGUAGE BangPatterns #-}  module GHC.Core.Opt.Simplify.Inline (         -- * Cheap and cheerful inlining checks.@@ -206,7 +205,7 @@  Some guidance on setting these defaults: -* A low treshold (<= 2) is needed to prevent exponential cases from spiraling out of+* A low threshold (<= 2) is needed to prevent exponential cases from spiraling out of   control. We picked 2 for no particular reason. * Scaling the penalty by any more than 30 means the reproducer from   T18730 won't compile even with reasonably small values of n. Instead
compiler/GHC/Core/Opt/Simplify/Iteration.hs view
@@ -20,7 +20,7 @@ import GHC.Core import GHC.Core.Opt.Simplify.Monad import GHC.Core.Opt.ConstantFold-import GHC.Core.Type hiding ( substTy, substTyVar, extendTvSubst, extendCvSubst )+import GHC.Core.Type hiding ( substTy, substCo, substTyVar, extendTvSubst, extendCvSubst ) import GHC.Core.TyCo.Compare( eqType ) import GHC.Core.Opt.Simplify.Env import GHC.Core.Opt.Simplify.Inline@@ -69,7 +69,6 @@ import GHC.Unit.Module ( moduleName ) import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Utils.Panic.Plain import GHC.Utils.Constants (debugIsOn) import GHC.Utils.Monad  ( mapAccumLM, liftIO ) import GHC.Utils.Logger@@ -415,7 +414,7 @@   = return ( emptyFloats env            , case new_rhs of                 Coercion co -> extendCvSubst env bndr co-                _           -> extendIdSubst env bndr (DoneEx new_rhs Nothing) )+                _           -> extendIdSubst env bndr (DoneEx new_rhs NotJoinPoint) )    | otherwise   = do  { -- ANF-ise the RHS@@ -615,7 +614,7 @@           then do { tick (PostInlineUnconditionally bndr)                   ; return ( floats                            , extendIdSubst (setInScopeFromF env floats) old_bndr $-                             DoneEx triv_rhs Nothing ) }+                             DoneEx triv_rhs NotJoinPoint ) }            else do { wrap_unf <- mkLetUnfolding uf_opts top_lvl VanillaSrc bndr triv_rhs                   ; let bndr' = bndr `setInlinePragma` mkCastWrapperInlinePrag (idInlinePragma bndr)@@ -952,7 +951,7 @@                  ; simplTrace "PostInlineUnconditionally" (ppr new_bndr <+> ppr unf_rhs) $                    return ( emptyFloats env                           , extendIdSubst env old_bndr $-                            DoneEx unf_rhs (isJoinId_maybe new_bndr)) }+                            DoneEx unf_rhs (idJoinPointHood new_bndr)) }                 -- Use the substitution to make quite, quite sure that the                 -- substitution will happen, since we are going to discard the binding @@ -1173,7 +1172,8 @@       ]) $ -}     simplExprF1 env e cont -simplExprF1 :: SimplEnv -> InExpr -> SimplCont+simplExprF1 :: HasDebugCallStack+            => SimplEnv -> InExpr -> SimplCont             -> SimplM (SimplFloats, OutExpr)  simplExprF1 _ (Type ty) cont@@ -1323,7 +1323,7 @@ simplJoinRhs :: SimplEnv -> InId -> InExpr -> SimplCont              -> SimplM OutExpr simplJoinRhs env bndr expr cont-  | Just arity <- isJoinId_maybe bndr+  | JoinPoint arity <- idJoinPointHood bndr   =  do { let (join_bndrs, join_body) = collectNBinders arity expr               mult = contHoleScaling cont         ; (env', join_bndrs') <- simplLamBndrs env (map (scaleVarBy mult) join_bndrs)@@ -1456,8 +1456,8 @@     simplTickish env tickish-    | Breakpoint ext n ids <- tickish-          = Breakpoint ext n (mapMaybe (getDoneId . substId env) ids)+    | Breakpoint ext n ids modl <- tickish+          = Breakpoint ext n (mapMaybe (getDoneId . substId env) ids) modl     | otherwise = tickish    -- Push type application and coercion inside a tick@@ -1540,7 +1540,7 @@       ApplyToVal { sc_arg = arg, sc_env = se, sc_dup = dup_flag                  , sc_cont = cont, sc_hole_ty = fun_ty }         -- See Note [Avoid redundant simplification]-        -> do { (_, _, arg') <- simplArg env dup_flag fun_ty se arg+        -> do { (_, _, arg') <- simplLazyArg env dup_flag fun_ty Nothing se arg               ; rebuild env (App expr arg') cont }  completeBindX :: SimplEnv@@ -1551,8 +1551,8 @@               -> SimplCont         -- Consumed by this continuation               -> SimplM (SimplFloats, OutExpr) completeBindX env from_what bndr rhs body cont-  | FromBeta arg_ty <- from_what-  , needsCaseBinding arg_ty rhs -- Enforcing the let-can-float-invariant+  | FromBeta arg_levity <- from_what+  , needsCaseBindingL arg_levity rhs -- Enforcing the let-can-float-invariant   = do { (env1, bndr1)   <- simplNonRecBndr env bndr  -- Lambda binders don't have rules        ; (floats, expr') <- simplNonRecBody env1 from_what body cont        -- Do not float floats past the Case binder below@@ -1656,7 +1656,6 @@                                    , sc_hole_ty = coercionLKind co }) }                                         -- NB!  As the cast goes past, the                                         -- type of the hole changes (#16312)-         -- (f |> co) e   ===>   (f (e |> co1)) |> co2         -- where   co :: (s1->s2) ~ (t1->t2)         --         co1 :: t1 ~ s1@@ -1675,7 +1674,7 @@                       -- See Note [Avoiding exponential behaviour]                     MCo co1 ->-            do { (dup', arg_se', arg') <- simplArg env dup fun_ty arg_se arg+            do { (dup', arg_se', arg') <- simplLazyArg env dup fun_ty Nothing arg_se arg                     -- When we build the ApplyTo we can't mix the OutCoercion                     -- 'co' with the InExpr 'arg', so we simplify                     -- to make it all consistent.  It's a bit messy.@@ -1701,16 +1700,24 @@           -- See Note [Representation polymorphism invariants] in GHC.Core           -- test: typecheck/should_run/EtaExpandLevPoly -simplArg :: SimplEnv -> DupFlag-         -> OutType                 -- Type of the function applied to this arg-         -> StaticEnv -> CoreExpr   -- Expression with its static envt-         -> SimplM (DupFlag, StaticEnv, OutExpr)-simplArg env dup_flag fun_ty arg_env arg+simplLazyArg :: SimplEnv -> DupFlag+             -> OutType                 -- ^ Type of the function applied to this arg+             -> Maybe ArgInfo           -- ^ Just <=> This arg `ai` occurs in an app+                                        --   `f a1 ... an` where we have ArgInfo on+                                        --   how `f` uses `ai`, affecting the Stop+                                        --   continuation passed to 'simplExprC'+             -> StaticEnv -> CoreExpr   -- ^ Expression with its static envt+             -> SimplM (DupFlag, StaticEnv, OutExpr)+simplLazyArg env dup_flag fun_ty mb_arg_info arg_env arg   | isSimplified dup_flag   = return (dup_flag, arg_env, arg)   | otherwise   = do { let arg_env' = arg_env `setInScopeFromE` env-       ; arg' <- simplExprC arg_env' arg (mkBoringStop (funArgTy fun_ty))+       ; let arg_ty = funArgTy fun_ty+       ; let stop = case mb_arg_info of+               Nothing -> mkBoringStop arg_ty+               Just ai -> mkLazyArgStop arg_ty ai+       ; arg' <- simplExprC arg_env' arg stop        ; return (Simplified, zapSubstEnv arg_env', arg') }          -- Return a StaticEnv that includes the in-scope set from 'env',          -- because arg' may well mention those variables (#20639)@@ -1737,7 +1744,8 @@ simplLam env (Lam bndr body) cont = simpl_lam env bndr body cont simplLam env expr            cont = simplExprF env expr cont -simpl_lam :: SimplEnv -> InBndr -> InExpr -> SimplCont+simpl_lam :: HasDebugCallStack+          => SimplEnv -> InBndr -> InExpr -> SimplCont           -> SimplM (SimplFloats, OutExpr)  -- Type beta-reduction@@ -1745,26 +1753,47 @@   = do { tick (BetaReduction bndr)        ; simplLam (extendTvSubst env bndr arg_ty) body cont } +-- Coercion beta-reduction+simpl_lam env bndr body (ApplyToVal { sc_arg = Coercion arg_co, sc_env = arg_se+                                    , sc_cont = cont })+  = assertPpr (isCoVar bndr) (ppr bndr) $+    do { tick (BetaReduction bndr)+       ; let arg_co' = substCo (arg_se `setInScopeFromE` env) arg_co+       ; simplLam (extendCvSubst env bndr arg_co') body cont }+ -- Value beta-reduction+-- This works for /coercion/ lambdas too simpl_lam env bndr body (ApplyToVal { sc_arg = arg, sc_env = arg_se                                     , sc_cont = cont, sc_dup = dup                                     , sc_hole_ty = fun_ty})   = do { tick (BetaReduction bndr)-       ; let arg_ty = funArgTy fun_ty+       ; let from_what = FromBeta arg_levity+             arg_levity+               | isForAllTy fun_ty = assertPpr (isCoVar bndr) (ppr bndr) Unlifted+               | otherwise         = typeLevity (funArgTy fun_ty)+             -- Example:  (\(cv::a ~# b). blah) co+             -- The type of (\cv.blah) can be (forall cv. ty); see GHC.Core.Utils.mkLamType++             -- Using fun_ty: see Note [Dark corner with representation polymorphism]+             -- e.g  (\r \(a::TYPE r) \(x::a). blah) @LiftedRep @Int arg+             --      When we come to `x=arg` we must choose lazy/strict correctly+             --      It's wrong to err in either direction+             --      But fun_ty is an OutType, so is fully substituted+        ; if | isSimplified dup  -- Don't re-simplify if we've simplified it once                                 -- Including don't preInlineUnconditionally                                 -- See Note [Avoiding exponential behaviour]-            -> completeBindX env (FromBeta arg_ty) bndr arg body cont+            -> completeBindX env from_what bndr arg body cont              | Just env' <- preInlineUnconditionally env NotTopLevel bndr arg arg_se-            , not (needsCaseBinding arg_ty arg)+            , not (needsCaseBindingL arg_levity arg)               -- Ok to test arg::InExpr in needsCaseBinding because               -- exprOkForSpeculation is stable under simplification             -> do { tick (PreInlineUnconditionally bndr)                   ; simplLam env' body cont }              | otherwise-            -> simplNonRecE env (FromBeta arg_ty) bndr (arg, arg_se) body cont }+            -> simplNonRecE env from_what bndr (arg, arg_se) body cont }  -- Discard a non-counting tick on a lambda.  This may change the -- cost attribution slightly (moving the allocation of the@@ -1795,7 +1824,8 @@ simplLamBndrs env bndrs = mapAccumLM simplLamBndr env bndrs  -------------------simplNonRecE :: SimplEnv+simplNonRecE :: HasDebugCallStack+             => SimplEnv              -> FromWhat              -> InId               -- The binder, always an Id                                    -- Never a join point@@ -1837,15 +1867,12 @@    where     is_strict_bind = case from_what of-       FromBeta arg_ty | isUnliftedType arg_ty -> True-         -- If we are coming from a beta-reduction (FromBeta) we must-         -- establish the let-can-float invariant, so go via StrictBind-         -- If not, the invariant holds already, and it's optional.-         -- Using arg_ty: see Note [Dark corner with representation polymorphism]-         -- e.g  (\r \(a::TYPE r) \(x::a). blah) @LiftedRep @Int arg-         --      When we come to `x=arg` we myst choose lazy/strict correctly-         --      It's wrong to err in either directly+       FromBeta Unlifted -> True+       -- If we are coming from a beta-reduction (FromBeta) we must+       -- establish the let-can-float invariant, so go via StrictBind+       -- If not, the invariant holds already, and it's optional. +       -- (FromBeta Lifted) or FromLet: look at the demand info        _ -> seCaseCase env && isStrUsedDmd (idDemandInfo bndr)  @@ -2004,14 +2031,14 @@  -------------------- trimJoinCont :: Id         -- Used only in error message-             -> Maybe JoinArity+             -> JoinPointHood              -> SimplCont -> SimplCont -- Drop outer context from join point invocation (jump) -- See Note [Join points and case-of-case] -trimJoinCont _ Nothing cont+trimJoinCont _ NotJoinPoint cont   = cont -- Not a jump-trimJoinCont var (Just arity) cont+trimJoinCont var (JoinPoint arity) cont   = trim arity cont   where     trim 0 cont@(Stop {})@@ -2158,7 +2185,7 @@        DoneId var1 ->         do { rule_base <- getSimplRules-           ; let cont' = trimJoinCont var1 (isJoinId_maybe var1) cont+           ; let cont' = trimJoinCont var1 (idJoinPointHood var1) cont                  info  = mkArgInfo env rule_base var1 cont'            ; rebuildCall env info cont' } @@ -2251,44 +2278,34 @@             (ApplyToVal { sc_arg = arg, sc_env = arg_se                         , sc_cont = cont, sc_hole_ty = fun_ty })   | fun_id `hasKey` runRWKey-  , [ TyArg { as_arg_ty = hole_ty }, TyArg {} ] <- rev_args-  -- Do this even if (contIsStop cont), or if seCaseCase is off.+  , [ TyArg {}, TyArg {} ] <- rev_args+  -- Do this even if (contIsStop cont)   -- See Note [No eta-expansion in runRW#]   = do { let arg_env = arg_se `setInScopeFromE` env--             overall_res_ty  = contResultType cont-             -- hole_ty is the type of the current runRW# application-             (outer_cont, new_runrw_res_ty, inner_cont)-                | seCaseCase env = (mkBoringStop overall_res_ty, overall_res_ty, cont)-                | otherwise      = (cont, hole_ty, mkBoringStop hole_ty)-                -- Only when case-of-case is on. See GHC.Driver.Config.Core.Opt.Simplify-                --    Note [Case-of-case and full laziness]+             ty'   = contResultType cont         -- If the argument is a literal lambda already, take a short cut-       -- This isn't just efficiency:-       --    * If we don't do this we get a beta-redex every time, so the-       --      simplifier keeps doing more iterations.-       --    * Even more important: see Note [No eta-expansion in runRW#]+       -- This isn't just efficiency; if we don't do this we get a beta-redex+       -- every time, so the simplifier keeps doing more iterations.        ; arg' <- case arg of            Lam s body -> do { (env', s') <- simplBinder arg_env s-                            ; body' <- simplExprC env' body inner_cont+                            ; body' <- simplExprC env' body cont                             ; return (Lam s' body') }                             -- Important: do not try to eta-expand this lambda                             -- See Note [No eta-expansion in runRW#]-            _ -> do { s' <- newId (fsLit "s") ManyTy realWorldStatePrimTy                    ; let (m,_,_) = splitFunTy fun_ty                          env'  = arg_env `addNewInScopeIds` [s']                          cont' = ApplyToVal { sc_dup = Simplified, sc_arg = Var s'-                                            , sc_env = env', sc_cont = inner_cont-                                            , sc_hole_ty = mkVisFunTy m realWorldStatePrimTy new_runrw_res_ty }+                                            , sc_env = env', sc_cont = cont+                                            , sc_hole_ty = mkVisFunTy m realWorldStatePrimTy ty' }                                 -- cont' applies to s', then K                    ; body' <- simplExprC env' arg cont'                    ; return (Lam s' body') } -       ; let rr'   = getRuntimeRep new_runrw_res_ty-             call' = mkApps (Var fun_id) [mkTyArg rr', mkTyArg new_runrw_res_ty, arg']-       ; rebuild env call' outer_cont }+       ; let rr'   = getRuntimeRep ty'+             call' = mkApps (Var fun_id) [mkTyArg rr', mkTyArg ty', arg']+       ; return (emptyFloats env, call') }  ---------- Simplify value arguments -------------------- rebuildCall env fun_info@@ -2301,8 +2318,7 @@    -- Strict arguments   | isStrictArgInfo fun_info-  , seCaseCase env    -- Only when case-of-case is on. See GHC.Driver.Config.Core.Opt.Simplify-                      --    Note [Case-of-case and full laziness]+  , seCaseCase env   = -- pprTrace "Strict Arg" (ppr arg $$ ppr (seIdSubst env) $$ ppr (seInScope env)) $     simplExprF (arg_se `setInScopeFromE` env) arg                (StrictArg { sc_fun = fun_info, sc_fun_ty = fun_ty@@ -2316,13 +2332,9 @@         -- There is no benefit (unlike in a let-binding), and we'd         -- have to be very careful about bogus strictness through         -- floating a demanded let.-  = do  { arg' <- simplExprC (arg_se `setInScopeFromE` env) arg-                             (mkLazyArgStop arg_ty fun_info)+  = do  { (_, _, arg') <- simplLazyArg env dup_flag fun_ty (Just fun_info) arg_se arg         ; rebuildCall env (addValArgTo fun_info  arg' fun_ty) cont }-  where-    arg_ty = funArgTy fun_ty - ---------- No further useful info, revert to generic rebuild ------------ rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args }) cont   = rebuild env (argInfoExpr fun rev_args) cont@@ -2498,27 +2510,6 @@   | null rules   = return Nothing -{- Disabled until we fix #8326-  | fn `hasKey` tagToEnumKey   -- See Note [Optimising tagToEnum#]-  , [_type_arg, val_arg] <- args-  , Select dup bndr ((_,[],rhs1) : rest_alts) se cont <- call_cont-  , isDeadBinder bndr-  = do { let enum_to_tag :: CoreAlt -> CoreAlt-                -- Takes   K -> e  into   tagK# -> e-                -- where tagK# is the tag of constructor K-             enum_to_tag (DataAlt con, [], rhs)-               = assert (isEnumerationTyCon (dataConTyCon con) )-                (LitAlt tag, [], rhs)-              where-                tag = mkLitInt (sePlatform env) (toInteger (dataConTag con - fIRST_TAG))-             enum_to_tag alt = pprPanic "tryRules: tagToEnum" (ppr alt)--             new_alts = (DEFAULT, [], rhs1) : map enum_to_tag rest_alts-             new_bndr = setIdType bndr intPrimTy-                 -- The binder is dead, but should have the right type-      ; return (Just (val_arg, Select dup new_bndr new_alts se cont)) }--}-   | Just (rule, rule_rhs) <- lookupRule ropts (getUnfoldingInRuleMatch env)                                         (activeRule (seMode env)) fn                                         (argInfoAppArgs args) rules@@ -2694,25 +2685,6 @@ unsatisfactory about doing it twice; but the rule RHS is usually very small, and this is simple. -Note [Optimising tagToEnum#]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~-If we have an enumeration data type:--  data Foo = A | B | C--Then we want to transform--   case tagToEnum# x of   ==>    case x of-     A -> e1                       DEFAULT -> e1-     B -> e2                       1#      -> e2-     C -> e3                       2#      -> e3--thereby getting rid of the tagToEnum# altogether.  If there was a DEFAULT-alternative we retain it (remember it comes first).  If not the case must-be exhaustive, and we reflect that in the transformed version by adding-a DEFAULT.  Otherwise Lint complains that the new case is not exhaustive.-See #8317.- Note [Rules for recursive functions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ You might think that we shouldn't apply rules for a loop breaker:@@ -2815,31 +2787,74 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If we have this:    case <scrut> of r { _ -> ..r.. }--where 'r' is used strictly in (..r..), we can safely transform to+where 'r' is used strictly in (..r..), we /could/ safely transform to    let r = <scrut> in ...r...+As a special case,  we have a plain `seq` like+   case r of r1 { _ -> ...r1... }+where `r` is used strictly, we /could/ simply drop the `case` to get+   ...r.... -This is a Good Thing, because 'r' might be dead (if the body just-calls error), or might be used just once (in which case it can be-inlined); or we might be able to float the let-binding up or down.-E.g. #15631 has an example.+HOWEVER, there are some serious downsides to this transformation, so+GHC doesn't do it any longer (#24251): -Note that this can change the error behaviour.  For example, we might-transform-    case x of { _ -> error "bad" }-    --> error "bad"-which is might be puzzling if 'x' currently lambda-bound, but later gets-let-bound to (error "good").+* Suppose the Simplifier sees+     case x of y* { __DEFAULT ->+     let z = case y of { __DEFAULT -> expr } in+     z+1 }+  The "y*" means "y is used strictly in its scope.  Now we may:+   - Eliminate the inner case because `y` is evaluated.+  Now the demand-info on `y` is not right, because `y` is no longer used+  strictly in its scope.  But it is hard to spot that without doing a new+  demand analysis.  So there is a danger that we will subsequently:+   - Eliminate the outer case because `y` is used strictly+  Yikes!  We can't eliminate both! -Nevertheless, the paper "A semantics for imprecise exceptions" allows-this transformation. If you want to fix the evaluation order, use-'pseq'.  See #8900 for an example where the loss of this-transformation bit us in practice.+* It introduces space leaks (#24251).  Consider+      go 0 where go x = x `seq` go (x + 1)+  It is an infinite loop, true, but it should not leak space. Yet if we drop+  the `seq`, it will.  Another great example is #21741. -See also Note [Empty case alternatives] in GHC.Core.+* Dropping the outer `case can change the error behaviour.  For example,+  we might transform+       case x of { _ -> error "bad" }    -->     error "bad"+  which is might be puzzling if 'x' currently lambda-bound, but later gets+  let-bound to (error "good").  Tht is OK accoring to the paper "A semantics for+  imprecise exceptions", but see #8900 for an example where the loss of this+  transformation bit us in practice. -Historical notes+* If we have (case e of x -> f x), where `f` is strict, then it looks as if `x`+  is strictly used, and we could soundly transform to+     let x = e in f x+  But if f's strictness info got worse (which can happen in in obscure cases;+  see #21392) then we might have turned a non-thunk into a thunk!  Bad. +Lacking this "drop-strictly-used-seq" transformation means we can end up with+some redundant-looking evals.  For example, consider+    f x y = case x of DEFAULT ->    -- A redundant-looking eval+            case y of+              True  -> case x of { Nothing -> False; Just z  -> z }+              False -> case x of { Nothing -> True;  Just z  -> z }+That outer eval will be retained right through to code generation.  But,+perhaps surprisingly, that is probably a /good/ thing:++   Key point: those inner (case x) expressions will be compiled a simple 'if',+   because the code generator can see that `x` is, at those points, evaluated+   and properly tagged.++If we dropped the outer eval, both the inner (case x) expressions would need to+do a proper eval, pushing a return address, with an info table. See the example+in #15631 where, in the Description, the (case ys) will be a simple multi-way+jump.++In fact (#24251), when I stopped GHC implementing the drop-strictly-used-seqs+transformation, binary sizes fell by 1%, and a few programs actually allocated+less and ran faster.  A case in point is nofib/imaginary/digits-of-e2. (I'm not+sure exactly why it improves so much, though.)++Slightly related: Note [Empty case alternatives] in GHC.Core.++Historical notes:+ There have been various earlier versions of this patch:  * By Sept 18 the code looked like this:@@ -3048,11 +3063,10 @@   --      a) it binds nothing (so it's really just a 'seq')   --      b) evaluating the scrutinee has no side effects   | is_plain_seq-  , exprOkForSideEffects scrut+  , exprOkToDiscard scrut           -- The entire case is dead, so we can drop it           -- if the scrutinee converges without having imperative           -- side effects or raising a Haskell exception-          -- See Note [PrimOp can_fail and has_side_effects] in GHC.Builtin.PrimOps    = simplExprF env rhs cont    -- 2b.  Turn the case into a let, if@@ -3113,17 +3127,16 @@    | otherwise  -- Scrut has a lifted type   = exprIsHNF scrut-    || isStrUsedDmd (idDemandInfo case_bndr)-    -- See Note [Case-to-let for strictly-used binders]+       --    || isStrUsedDmd (idDemandInfo case_bndr)+       -- We no longer look at the demand on the case binder+       -- See Note [Case-to-let for strictly-used binders]  -------------------------------------------------- --      3. Catch-all case --------------------------------------------------  reallyRebuildCase env scrut case_bndr alts cont-  | not (seCaseCase env)    -- Only when case-of-case is on.-                            -- See GHC.Driver.Config.Core.Opt.Simplify-                            --    Note [Case-of-case and full laziness]+  | not (seCaseCase env)   = do { case_expr <- simplAlts env scrut case_bndr alts                                 (mkBoringStop (contHoleType cont))        ; rebuild env case_expr cont }@@ -3294,7 +3307,7 @@ improveSeq fam_envs env scrut case_bndr case_bndr1 [Alt DEFAULT _ _]   | Just (Reduction co ty2) <- topNormaliseType_maybe fam_envs (idType case_bndr1)   = do { case_bndr2 <- newId (fsLit "nt") ManyTy ty2-        ; let rhs  = DoneEx (Var case_bndr2 `Cast` mkSymCo co) Nothing+        ; let rhs  = DoneEx (Var case_bndr2 `Cast` mkSymCo co) NotJoinPoint               env2 = extendIdSubst env case_bndr rhs         ; return (env2, scrut `Cast` co, case_bndr2) } @@ -3583,7 +3596,7 @@     bind_case_bndr env       | isDeadBinder bndr   = return (emptyFloats env, env)       | exprIsTrivial scrut = return (emptyFloats env-                                     , extendIdSubst env bndr (DoneEx scrut Nothing))+                                     , extendIdSubst env bndr (DoneEx scrut NotJoinPoint))                               -- See Note [Do not duplicate constructor applications]       | otherwise           = do { dc_args <- mapM (simplVar env) bs                                          -- dc_ty_args are already OutTypes,@@ -3770,7 +3783,7 @@     do  { let (dmd:cont_dmds) = dmds   -- Never fails         ; (floats1, cont') <- mkDupableContWithDmds env cont_dmds cont         ; let env' = env `setInScopeFromF` floats1-        ; (_, se', arg') <- simplArg env' dup hole_ty se arg+        ; (_, se', arg') <- simplLazyArg env' dup hole_ty Nothing se arg         ; (let_floats2, arg'') <- makeTrivial env NotTopLevel dmd (fsLit "karg") arg'         ; let all_floats = floats1 `addLetFloats` let_floats2         ; return ( all_floats@@ -4497,11 +4510,11 @@                  -- binder matches that of the rule, so that pushing the                  -- continuation into the RHS makes sense                  join_ok = case mb_new_id of-                             Just id | Just join_arity <- isJoinId_maybe id+                             Just id | JoinPoint join_arity <- idJoinPointHood id                                      -> length args == join_arity                              _ -> False                  bad_join_msg = vcat [ ppr mb_new_id, ppr rule-                                     , ppr (fmap isJoinId_maybe mb_new_id) ]+                                     , ppr (fmap idJoinPointHood mb_new_id) ]             ; args' <- mapM (simplExpr lhs_env) args            ; rhs'  <- simplExprC rhs_env rhs rhs_cont
compiler/GHC/Core/Opt/Simplify/Utils.hs view
@@ -74,6 +74,7 @@ import GHC.Types.Var.Set import GHC.Types.Basic +import GHC.Data.Maybe ( orElse ) import GHC.Data.OrdList ( isNilOL ) import GHC.Data.FastString ( fsLit ) @@ -81,10 +82,11 @@ import GHC.Utils.Monad import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Utils.Panic.Plain  import Control.Monad    ( when ) import Data.List        ( sortBy )+import GHC.Types.Name.Env+import Data.Graph  {- ********************************************************************* *                                                                      *@@ -215,7 +217,7 @@  type StaticEnv = SimplEnv       -- Just the static part is relevant -data FromWhat = FromLet | FromBeta OutType+data FromWhat = FromLet | FromBeta Levity  -- See Note [DupFlag invariants] data DupFlag = NoDup       -- Unsimplified, might be big@@ -1472,6 +1474,18 @@     -- simplifications).  Until phase zero we take no special notice of     -- top level things, but then we become more leery about inlining     -- them.+    --+    -- What exactly to check in `early_phase` above is the subject of #17910.+    --+    -- !10088 introduced an additional Simplifier iteration in LargeRecord+    -- because we first FloatOut `case unsafeEqualityProof of ... -> I# 2#`+    -- (a non-trivial value) which we immediately inline back in.+    -- Ideally, we'd never have inlined it because the binding turns out to+    -- be expandable; unfortunately we need an iteration of the Simplifier to+    -- attach the proper unfolding and can't check isExpandableUnfolding right+    -- here.+    -- (Nor can we check for `exprIsExpandable rhs`, because that needs to look+    -- at the non-existent unfolding for the `I# 2#` which is also floated out.)  {- ************************************************************************@@ -2096,6 +2110,27 @@       which showed that it's harder to do polymorphic specialisation well       if there are dictionaries abstracted over unnecessary type variables.       See Note [Weird special case for SpecDict] in GHC.Core.Opt.Specialise++(AB5) We do dependency analysis on recursive groups prior to determining+      which variables to abstract over.+      This is useful, because ANFisation in prepareBinding may float out+      values out of a complex recursive binding, e.g.,+          letrec { xs = g @a "blah"# ((:) 1 []) xs } in ...+        ==> { prepareBinding }+          letrec { foo = "blah"#+                   bar = [42]+                   xs = g @a foo bar xs } in+          ...+      and we don't want to abstract foo and bar over @a.++      (Why is it OK to float the unlifted `foo` there?+      See Note [Core top-level string literals] in GHC.Core;+      it is controlled by GHC.Core.Opt.Simplify.Env.unitLetFloat.)++      It is also necessary to do dependency analysis, because+      otherwise (in #24551) we might get `foo = \@_ -> "missing"#` at the+      top-level, and that triggers a CoreLint error because `foo` is *not*+      manifestly a literal string. -}  abstractFloats :: UnfoldingOpts -> TopLevelFlag -> [OutTyVar] -> SimplFloats@@ -2103,15 +2138,27 @@ abstractFloats uf_opts top_lvl main_tvs floats body   = assert (notNull body_floats) $     assert (isNilOL (sfJoinFloats floats)) $-    do  { (subst, float_binds) <- mapAccumLM abstract empty_subst body_floats+    do  { let sccs = concatMap to_sccs body_floats+        ; (subst, float_binds) <- mapAccumLM abstract empty_subst sccs         ; return (float_binds, GHC.Core.Subst.substExpr subst body) }   where     is_top_lvl  = isTopLevel top_lvl     body_floats = letFloatBinds (sfLetFloats floats)     empty_subst = GHC.Core.Subst.mkEmptySubst (sfInScope floats) -    abstract :: GHC.Core.Subst.Subst -> OutBind -> SimplM (GHC.Core.Subst.Subst, OutBind)-    abstract subst (NonRec id rhs)+    -- See wrinkle (AB5) in Note [Which type variables to abstract over]+    -- for why we need to re-do dependency analysis+    to_sccs :: OutBind -> [SCC (Id, CoreExpr, VarSet)]+    to_sccs (NonRec id e) = [AcyclicSCC (id, e, emptyVarSet)] -- emptyVarSet: abstract doesn't need it+    to_sccs (Rec prs)     = sccs+      where+        (ids,rhss) = unzip prs+        sccs = depAnal (\(id,_rhs,_fvs) -> [getName id])+                       (\(_id,_rhs,fvs) -> nonDetStrictFoldVarSet ((:) . getName) [] fvs) -- Wrinkle (AB3)+                       (zip3 ids rhss (map exprFreeVars rhss))++    abstract :: GHC.Core.Subst.Subst -> SCC (Id, CoreExpr, VarSet) -> SimplM (GHC.Core.Subst.Subst, OutBind)+    abstract subst (AcyclicSCC (id, rhs, _empty_var_set))       = do { (poly_id1, poly_app) <- mk_poly1 tvs_here id            ; let (poly_id2, poly_rhs) = mk_poly2 poly_id1 tvs_here rhs'                  !subst' = GHC.Core.Subst.extendIdSubst subst id poly_app@@ -2122,7 +2169,7 @@         -- tvs_here: see Note [Which type variables to abstract over]         tvs_here = choose_tvs (exprSomeFreeVars isTyVar rhs') -    abstract subst (Rec prs)+    abstract subst (CyclicSCC trpls)       = do { (poly_ids, poly_apps) <- mapAndUnzipM (mk_poly1 tvs_here) ids            ; let subst' = GHC.Core.Subst.extendSubstList subst (ids `zip` poly_apps)                  poly_pairs = [ mk_poly2 poly_id tvs_here rhs'@@ -2130,15 +2177,15 @@                               , let rhs' = GHC.Core.Subst.substExpr subst' rhs ]            ; return (subst', Rec poly_pairs) }       where-        (ids,rhss) = unzip prs-+        (ids,rhss,_fvss) = unzip3 trpls          -- tvs_here: see Note [Which type variables to abstract over]-        tvs_here = choose_tvs (mapUnionVarSet get_bind_fvs prs)+        tvs_here = choose_tvs (mapUnionVarSet get_bind_fvs trpls)          -- See wrinkle (AB4) in Note [Which type variables to abstract over]-        get_bind_fvs (id,rhs) = tyCoVarsOfType (idType id) `unionVarSet` get_rec_rhs_tvs rhs-        get_rec_rhs_tvs rhs   = nonDetStrictFoldVarSet get_tvs emptyVarSet (exprFreeVars rhs)+        get_bind_fvs (id,_rhs,rhs_fvs) = tyCoVarsOfType (idType id) `unionVarSet` get_rec_rhs_tvs rhs_fvs+        get_rec_rhs_tvs rhs_fvs        = nonDetStrictFoldVarSet get_tvs emptyVarSet rhs_fvs+                                  -- nonDet is safe because of wrinkle (AB3)          get_tvs :: Var -> VarSet -> VarSet         get_tvs var free_tvs@@ -2347,6 +2394,44 @@ transformation is called Case Merging.  It avoids that the same variable is scrutinised multiple times. +Wrinkles++(MC1) `tryCaseMerge` "looks though" an inner single-alternative case-on-variable.+     For example+       case x of {+          ...outer-alts...+          DEFAULT -> case y of (a,b) ->+                     case x of { A -> rhs1; B -> rhs2 }+    ===>+       case x of+         ...outer-alts...+         a -> case y of (a,b) -> rhs1+         B -> case y of (a,b) -> rhs2++    This duplicates the `case y` but it removes the case x; so it is a win+    in terms of execution time (combining the cases on x) at the cost of+    perhaps duplicating the `case y`.  A case in point is integerEq, which+    is defined thus+        integerEq :: Integer -> Integer -> Bool+        integerEq !x !y = isTrue# (integerEq# x y)+    which becomes+        integerEq+          = \ (x :: Integer) (y_aAL :: Integer) ->+              case x of x1 { __DEFAULT ->+              case y of y1 { __DEFAULT ->+              case x1 of {+                IS x2 -> case y1 of {+                           __DEFAULT -> GHC.Types.False;+                           IS y2     -> tagToEnum# @Bool (==# x2 y2) };+                IP x2 -> ...+                IN x2 -> ...+    We want to merge the outer `case x` with the inner `case x1`.++    This story is not fully robust; it will be defeated by a let-binding,+    whih we don't want to duplicate.   But accounting for single-alternative+    case-on-variable is easy to do, and seems useful in common cases so+    `tryMergeCase` does it.+ Note [Eliminate Identity Case] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~         case e of               ===> e@@ -2454,9 +2539,9 @@  In Core after a bit of simplification we get: -    f x = case dataToTag# x of a# { _DEFAULT ->+    f x = case dataToTagLarge# x of a# { _DEFAULT ->           case a# of-            _DEFAULT -> case dataToTag# x of b# { _DEFAULT ->+            _DEFAULT -> case dataToTagLarge# x of b# { _DEFAULT ->                         case b# of                            _DEFAULT -> ...                            1# -> "two"@@ -2468,8 +2553,8 @@ The case-merge transformation Note [Merge Nested Cases] does this (affecting both pairs of cases): -    f x = case dataToTag# x of a# {-             _DEFAULT -> case dataToTag# x of b# {+    f x = case dataToTagLarge# x of a# {+             _DEFAULT -> case dataToTagLarge# x of b# {                           _DEFAULT -> ...                           1# -> "two"                          }@@ -2477,22 +2562,22 @@           }  Now Note [caseRules for dataToTag] does its work, again-on both dataToTag# cases:+on both dataToTagLarge# cases:      f x = case x of x1 {-             _DEFAULT -> case dataToTag# x1 of a# { _DEFAULT ->+             _DEFAULT -> case dataToTagLarge# x1 of a# { _DEFAULT ->                          case x of x2 {-                           _DEFAULT -> case dataToTag# x2 of b# { _DEFAULT -> ... }+                           _DEFAULT -> case dataToTagLarge# x2 of b# { _DEFAULT -> ... }                            B -> "two"                          }}              A -> "one"           }  -The new dataToTag# calls come from the "reconstruct scrutinee" part of+The new dataToTagLarge# calls come from the "reconstruct scrutinee" part of caseRules (note that a# and b# were not dead in the original program before all this merging).  However, since a# and b# /are/ in fact dead-in the resulting program, we are left with redundant dataToTag# calls.+in the resulting program, we are left with redundant dataToTagLarge# calls. But they are easily eliminated by doing caseRules again, in the next Simplifier iteration, this time noticing that a# and b# are dead.  Hence the "dead-binder" sub-case of Wrinkle 1 of Note@@ -2526,24 +2611,25 @@ --      1. Merge Nested Cases -------------------------------------------------- -mkCase mode scrut outer_bndr alts_ty (Alt DEFAULT _ deflt_rhs : outer_alts)+mkCase mode scrut outer_bndr alts_ty alts   | sm_case_merge mode-  , (ticks, Case (Var inner_scrut_var) inner_bndr _ inner_alts)-       <- stripTicksTop tickishFloatable deflt_rhs-  , inner_scrut_var == outer_bndr+  , Just alts' <- tryMergeCase outer_bndr alts   = do  { tick (CaseMerge outer_bndr)--        ; let wrap_alt (Alt con args rhs) = assert (outer_bndr `notElem` args)-                                            (Alt con args (wrap_rhs rhs))-                -- Simplifier's no-shadowing invariant should ensure-                -- that outer_bndr is not shadowed by the inner patterns-              wrap_rhs rhs = Let (NonRec inner_bndr (Var outer_bndr)) rhs-                -- The let is OK even for unboxed binders,--              wrapped_alts | isDeadBinder inner_bndr = inner_alts-                           | otherwise               = map wrap_alt inner_alts+        ; mkCase1 mode scrut outer_bndr alts_ty alts' }+        -- Warning: don't call mkCase recursively!+        -- Firstly, there's no point, because inner alts have already had+        -- mkCase applied to them, so they won't have a case in their default+        -- Secondly, if you do, you get an infinite loop, because the bindCaseBndr+        -- in munge_rhs may put a case into the DEFAULT branch!+  | otherwise+  = mkCase1 mode scrut outer_bndr alts_ty alts -              merged_alts = mergeAlts outer_alts wrapped_alts+tryMergeCase :: OutId -> [OutAlt] -> Maybe [OutAlt]+-- See Note [Merge Nested Cases]+tryMergeCase outer_bndr (Alt DEFAULT _ deflt_rhs : outer_alts)+  = case go 5 (\e -> e) emptyVarSet deflt_rhs of+       Nothing         -> Nothing+       Just inner_alts -> Just (mergeAlts outer_alts inner_alts)                 -- NB: mergeAlts gives priority to the left                 --      case x of                 --        A -> e1@@ -2552,17 +2638,42 @@                 --                      B -> e3                 -- When we merge, we must ensure that e1 takes                 -- precedence over e2 as the value for A!+  where+    go :: Int -> (OutExpr -> OutExpr) -> VarSet -> OutExpr -> Maybe [OutAlt]+    -- In the call (go wrap free_bndrs rhs), the `wrap` function has free `free_bndrs`;+    -- so do not push `wrap` under any binders that would shadow `free_bndrs`+    --+    -- The 'n' is just a depth-bound to avoid pathalogical quadratic behaviour with+    --   case x1 of DEFAULT -> case x2 of DEFAULT -> case x3 of DEFAULT -> ...+    -- when for each `case` we'll look down the whole chain to see if there is+    -- another `case` on that same variable.  Also all of these (case xi) evals+    -- get duplicated in each branch of the outer case, so 'n' controls how much+    -- duplication we are prepared to put up with.+    go 0 _ _ _ = Nothing -        ; fmap (mkTicks ticks) $-          mkCase1 mode scrut outer_bndr alts_ty merged_alts-        }-        -- Warning: don't call mkCase recursively!-        -- Firstly, there's no point, because inner alts have already had-        -- mkCase applied to them, so they won't have a case in their default-        -- Secondly, if you do, you get an infinite loop, because the bindCaseBndr-        -- in munge_rhs may put a case into the DEFAULT branch!+    go n wrap free_bndrs (Tick t rhs)+       = go n (wrap . Tick t) free_bndrs rhs+    go _ wrap free_bndrs (Case (Var inner_scrut_var) inner_bndr _ inner_alts)+       | inner_scrut_var == outer_bndr+       , let wrap_let rhs' | isDeadBinder inner_bndr = rhs'+                           | otherwise = Let (NonRec inner_bndr (Var outer_bndr)) rhs'+                              -- The let is OK even for unboxed binders,+             free_bndrs' = extendVarSet free_bndrs outer_bndr+       = Just [ assert (not (any (`elemVarSet` free_bndrs') bndrs)) $+                Alt con bndrs (wrap (wrap_let rhs))+              | Alt con bndrs rhs <- inner_alts ]+    go n wrap free_bndrs (Case (Var inner_scrut) inner_bndr ty inner_alts)+       | [Alt con bndrs rhs] <- inner_alts -- Wrinkle (MC1)+       , let wrap_case rhs' = Case (Var inner_scrut) inner_bndr ty $+                              tryMergeCase inner_bndr alts `orElse` alts+                where+                  alts = [Alt con bndrs rhs']+        = assert (not (outer_bndr `elem` (inner_bndr : bndrs))) $+         go (n-1) (wrap . wrap_case) (free_bndrs `extendVarSet` inner_scrut) rhs -mkCase mode scrut bndr alts_ty alts = mkCase1 mode scrut bndr alts_ty alts+    go _ _ _ _ = Nothing++tryMergeCase _ _ = Nothing  -------------------------------------------------- --      2. Eliminate Identity Case
compiler/GHC/Core/Ppr.hs view
@@ -44,7 +44,6 @@ import GHC.Core.TyCo.Ppr import GHC.Core.Coercion import GHC.Types.Basic-import GHC.Data.Maybe import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Types.SrcLoc ( pprUserRealSpan )@@ -140,8 +139,8 @@     pp_val_bdr = pprPrefixOcc val_bdr      pp_bind = case bndrIsJoin_maybe val_bdr of-                Nothing -> pp_normal_bind-                Just ar -> pp_join_bind ar+                NotJoinPoint -> pp_normal_bind+                JoinPoint ar -> pp_join_bind ar      pp_normal_bind = hang pp_val_bdr 2 (equals <+> pprCoreExpr expr) @@ -240,7 +239,13 @@         _ -> parens (hang (pprParendExpr fun) 2 pp_args)     } -ppr_expr add_par (Case expr var ty [Alt con args rhs])+ppr_expr add_par (Case expr _ ty []) -- Empty Case+  = add_par $ sep [text "case"+                      <+> pprCoreExpr expr+                      <+> whenPprDebug (text "return" <+> ppr ty),+                    text "of {}"]++ppr_expr add_par (Case expr var ty [Alt con args rhs]) -- Single alt Case   = sdocOption sdocPrintCaseAsLet $ \case       True -> add_par $  -- See Note [Print case as let]                sep [ sep [ text "let! {"@@ -264,7 +269,7 @@   where     ppr_bndr = pprBndr CaseBind -ppr_expr add_par (Case expr var ty alts)+ppr_expr add_par (Case expr var ty alts) -- Multi alt Case   = add_par $     sep [sep [text "case"                 <+> pprCoreExpr expr@@ -306,12 +311,12 @@          pprCoreExpr expr]   where     keyword (NonRec b _)-     | isJust (bndrIsJoin_maybe b) = text "join"-     | otherwise                   = text "let"+     | isJoinPoint (bndrIsJoin_maybe b) = text "join"+     | otherwise                        = text "let"     keyword (Rec pairs)      | ((b,_):_) <- pairs-     , isJust (bndrIsJoin_maybe b) = text "joinrec"-     | otherwise                   = text "letrec"+     , isJoinPoint (bndrIsJoin_maybe b) = text "joinrec"+     | otherwise                        = text "letrec"  ppr_expr add_par (Tick tickish expr)   = sdocOption sdocSuppressTicks $ \case@@ -382,13 +387,13 @@   pprBndr = pprCoreBinder   pprInfixOcc  = pprInfixName  . varName   pprPrefixOcc = pprPrefixName . varName-  bndrIsJoin_maybe = isJoinId_maybe+  bndrIsJoin_maybe = idJoinPointHood  instance Outputable b => OutputableBndr (TaggedBndr b) where   pprBndr _    b = ppr b   -- Simple   pprInfixOcc  b = ppr b   pprPrefixOcc b = ppr b-  bndrIsJoin_maybe (TB b _) = isJoinId_maybe b+  bndrIsJoin_maybe (TB b _) = idJoinPointHood b  pprOcc :: OutputableBndr a => LexicalFixity -> a -> SDoc pprOcc Infix  = pprInfixOcc@@ -689,8 +694,9 @@             ppr modl, comma,             ppr ix,             text ">"]-  ppr (Breakpoint _ext ix vars) =+  ppr (Breakpoint _ext ix vars modl) =       hcat [text "break<",+            ppr modl, comma,             ppr ix,             text ">",             parens (hcat (punctuate comma (map ppr vars)))]
compiler/GHC/Core/Predicate.hs view
@@ -27,6 +27,7 @@   -- Implicit parameters   isIPLikePred, mentionsIP, isIPTyCon, isIPClass,   isCallStackTy, isCallStackPred, isCallStackPredTy,+  isExceptionContextPred,   isIPPred_maybe,    -- Evidence variables@@ -73,7 +74,7 @@   -- NB: There is no TuplePred case   --     Tuple predicates like (Eq a, Ord b) are just treated   --     as ClassPred, as if we had a tuple class with two superclasses-  --        class (c1, c2) => (%,%) c1 c2+  --        class (c1, c2) => CTuple2 c1 c2  classifyPredType :: PredType -> Pred classifyPredType ev_ty = case splitTyConApp_maybe ev_ty of@@ -276,6 +277,28 @@   = Just (t1,t2)   | otherwise   = Nothing++-- --------------------- ExceptionContext predicates --------------------------++-- | Is a 'PredType' an @ExceptionContext@ implicit parameter?+--+-- If so, return the name of the parameter.+isExceptionContextPred :: Class -> [Type] -> Maybe FastString+isExceptionContextPred cls tys+  | [ty1, ty2] <- tys+  , isIPClass cls+  , isExceptionContextTy ty2+  = isStrLitTy ty1+  | otherwise+  = Nothing++-- | Is a type a 'CallStack'?+isExceptionContextTy :: Type -> Bool+isExceptionContextTy ty+  | Just tc <- tyConAppTyCon_maybe ty+  = tc `hasKey` exceptionContextTyConKey+  | otherwise+  = False  -- --------------------- CallStack predicates ---------------------------------
compiler/GHC/Core/Reduction.hs view
@@ -1,6 +1,3 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE FlexibleContexts #-}  module GHC.Core.Reduction   (@@ -376,7 +373,7 @@              -> Reduction mkForAllRedn vis tv1 (Reduction h ki') (Reduction co ty)   = mkReduction-      (mkForAllCo tv1 h co)+      (mkForAllCo tv1 vis vis h co)       (mkForAllTy (Bndr tv2 vis) ty)   where     tv2 = setTyVarKind tv1 ki'@@ -389,7 +386,7 @@ mkHomoForAllRedn :: [TyVarBinder] -> Reduction -> Reduction mkHomoForAllRedn bndrs (Reduction co ty)   = mkReduction-      (mkHomoForAllCos (binderVars bndrs) co)+      (mkHomoForAllCos bndrs co)       (mkForAllTys bndrs ty) {-# INLINE mkHomoForAllRedn #-}
compiler/GHC/Core/RoughMap.hs view
@@ -1,7 +1,3 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE BangPatterns #-}- -- | 'RoughMap' is an approximate finite map data structure keyed on -- @['RoughMatchTc']@. This is useful when keying maps on lists of 'Type's -- (e.g. an instance head).
compiler/GHC/Core/Rules.hs view
@@ -9,7 +9,7 @@ -- The 'CoreRule' datatype itself is declared elsewhere. module GHC.Core.Rules (         -- ** Looking up rules-        lookupRule,+        lookupRule, matchExprs,          -- ** RuleBase, RuleEnv         RuleBase, RuleEnv(..), mkRuleEnv, emptyRuleEnv,@@ -86,6 +86,7 @@ import GHC.Data.Bag import GHC.Data.List.SetOps( hasNoDups ) +import GHC.Utils.FV( filterFV, fvVarSet ) import GHC.Utils.Misc as Utils import GHC.Utils.Outputable import GHC.Utils.Panic@@ -220,9 +221,9 @@            -> Id -> [CoreBndr] -> [CoreExpr] -> CoreExpr -> CoreRule -- Make a specialisation rule, for Specialise or SpecConstr mkSpecRule dflags this_mod is_auto inl_act herald fn bndrs args rhs-  = case isJoinId_maybe fn of-      Just join_arity -> etaExpandToJoinPointRule join_arity rule-      Nothing         -> rule+  = case idJoinPointHood fn of+      JoinPoint join_arity -> etaExpandToJoinPointRule join_arity rule+      NotJoinPoint         -> rule   where     rule = mkRule this_mod is_auto is_local                   rule_name@@ -443,23 +444,39 @@ getRules :: RuleEnv -> Id -> [CoreRule] -- Given a RuleEnv and an Id, find the visible rules for that Id -- See Note [Where rules are found]-getRules (RuleEnv { re_local_rules   = local_rules-                  , re_home_rules    = home_rules-                  , re_eps_rules     = eps_rules+--+-- This function is quite heavily used, so it's worth trying to make it efficient+getRules (RuleEnv { re_local_rules   = local_rule_base+                  , re_home_rules    = home_rule_base+                  , re_eps_rules     = eps_rule_base                   , re_visible_orphs = orphs }) fn    | Just {} <- isDataConId_maybe fn   -- Short cut for data constructor workers   = []                                -- and wrappers, which never have any rules -  | otherwise-  = idCoreRules fn          ++-    get local_rules         ++-    find_visible home_rules ++-    find_visible eps_rules+  | Just export_flag <- isLocalId_maybe fn+  = -- LocalIds can't have rules in the local_rule_base (used for imported fns)+    -- nor external packages; but there can (just) be rules in another module+    -- in the home package, if it is exported+    case export_flag of+      NotExported -> idCoreRules fn+      Exported -> case get home_rule_base of+          []           -> idCoreRules fn+          home_rules   -> drop_orphs home_rules ++ idCoreRules fn +  | otherwise+  = -- This case expression is a fast path, to avoid calling the+    -- recursive (++) in the common case where there are no rules at all+    case (get local_rule_base, get home_rule_base, get eps_rule_base) of+      ([], [], [])                         -> idCoreRules fn+      (local_rules, home_rules, eps_rules) -> local_rules           +++                                              drop_orphs home_rules +++                                              drop_orphs eps_rules  +++                                              idCoreRules fn   where     fn_name = idName fn-    find_visible rb = filter (ruleIsVisible orphs) (get rb)+    drop_orphs [] = []  -- Fast path; avoid invoking recursive filter+    drop_orphs xs = filter (ruleIsVisible orphs) xs     get rb = lookupNameEnv rb fn_name `orElse` []  ruleIsVisible :: ModuleSet -> CoreRule -> Bool@@ -588,10 +605,8 @@ isMoreSpecific _        (BuiltinRule {}) _                = False isMoreSpecific _        (Rule {})        (BuiltinRule {}) = True isMoreSpecific in_scope (Rule { ru_bndrs = bndrs1, ru_args = args1 })-                        (Rule { ru_bndrs = bndrs2, ru_args = args2-                              , ru_name = rule_name2, ru_rhs = rhs2 })-  = isJust (matchN in_scope_env-                   rule_name2 bndrs2 args2 args1 rhs2)+                        (Rule { ru_bndrs = bndrs2, ru_args = args2 })+  = isJust (matchExprs in_scope_env bndrs2 args2 args1)   where    full_in_scope = in_scope `extendInScopeSetList` bndrs1    in_scope_env  = ISE full_in_scope noUnfoldingFun@@ -704,15 +719,23 @@ -- trailing ones, returning the result of applying the rule to a prefix -- of the actual arguments. -matchN (ISE in_scope id_unf) rule_name tmpl_vars tmpl_es target_es rhs+matchN ise _rule_name tmpl_vars tmpl_es target_es rhs+  = do { (bind_wrapper, matched_es) <- matchExprs ise tmpl_vars tmpl_es target_es+       ; return (bind_wrapper $+                 mkLams tmpl_vars rhs `mkApps` matched_es) }++matchExprs :: InScopeEnv -> [Var] -> [CoreExpr] -> [CoreExpr]+           -> Maybe (BindWrapper, [CoreExpr])  -- 1-1 with the [Var]+matchExprs (ISE in_scope id_unf) tmpl_vars tmpl_es target_es   = do  { rule_subst <- match_exprs init_menv emptyRuleSubst tmpl_es target_es         ; let (_, matched_es) = mapAccumL (lookup_tmpl rule_subst)                                           (mkEmptySubst in_scope) $                                 tmpl_vars `zip` tmpl_vars1-              bind_wrapper = rs_binds rule_subst++        ; let bind_wrapper = rs_binds rule_subst                              -- Floated bindings; see Note [Matching lets]-       ; return (bind_wrapper $-                 mkLams tmpl_vars rhs `mkApps` matched_es) }++        ; return (bind_wrapper, matched_es) }   where     (init_rn_env, tmpl_vars1) = mapAccumL rnBndrL (mkRnEnv2 in_scope) tmpl_vars                   -- See Note [Cloning the template binders]@@ -723,7 +746,7 @@                    , rv_unf   = id_unf }      lookup_tmpl :: RuleSubst -> Subst -> (InVar,OutVar) -> (Subst, CoreExpr)-                   -- Need to return a RuleSubst solely for the benefit of mk_fake_ty+                   -- Need to return a RuleSubst solely for the benefit of fake_ty     lookup_tmpl (RS { rs_tv_subst = tv_subst, rs_id_subst = id_subst })                 tcv_subst (tmpl_var, tmpl_var1)         | isId tmpl_var1@@ -752,7 +775,6 @@     unbound tmpl_var        = pprPanic "Template variable unbound in rewrite rule" $          vcat [ text "Variable:" <+> ppr tmpl_var <+> dcolon <+> ppr (varType tmpl_var)-              , text "Rule" <+> pprRuleName rule_name               , text "Rule bndrs:" <+> ppr tmpl_vars               , text "LHS args:" <+> ppr tmpl_es               , text "Actual args:" <+> ppr target_es ]@@ -944,45 +966,78 @@ but the Simplifer pushes the casts in an application to to the right, if it can, so this doesn't really arise. -Note [Coercion arguments]-~~~~~~~~~~~~~~~~~~~~~~~~~-What if we have (f co) in the template, where the 'co' is a coercion-argument to f?  Right now we have nothing in place to ensure that a-coercion /argument/ in the template is a variable.  We really should,-perhaps by abstracting over that variable.--C.f. the treatment of dictionaries in GHC.HsToCore.Binds.decompseRuleLhs.--For now, though, we simply behave badly, by failing in match_co.-We really should never rely on matching the structure of a coercion-(which is just a proof).- Note [Casts in the template] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Consider the definition+This Note concerns `matchTemplateCast`.  Consider the definition   f x = e, and SpecConstr on call pattern   f ((e1,e2) |> co) -We'll make a RULE+The danger is that We'll make a RULE    RULE forall a,b,g.  f ((a,b)|> g) = $sf a b g    $sf a b g = e[ ((a,b)|> g) / x ] -So here is the invariant:+This requires the rule-matcher to bind the coercion variable `g`.+That is Very Deeply Suspicious: -  In the template, in a cast (e |> co),-  the cast `co` is always a /variable/.+* It would be unreasonable to match on a structured coercion in a pattern,+  such as    RULE   forall g.  f (x |> Sym g) = ...+  because the strucure of a coercion is arbitrary and may change -- it's their+  /type/ that matters. -Matching should bind that variable to an actual coercion, so that we-can use it in $sf.  So a Cast on the LHS (the template) calls-match_co, which succeeds when the template cast is a variable -- which-it always is.  That is why match_co has so few cases.+* We considered insisting that in a template, in a cast (e |> co), the the cast+  `co` is always a /variable/ cv.  That looks a bit more plausible, but #23209+  (and related tickets) shows that it's very fragile.  For example suppose `e`+  is a variable `f`, and the simplifier has an unconditional substitution+     [f :-> g |> co2]+  Now the rule LHS becomes (f |> (co2 ; cv)); not a coercion variable any more! +In short, it is Very Deeply Suspicious for a rule to quantify over a coercion+variable.  And SpecConstr no longer does so: see Note [SpecConstr and casts] in+SpecConstr.++It is, however, OK for a cast to appear in a template.  For example+    newtype N a = MkN (a,a)    -- Axiom ax:N a :: (a,a) ~R N a+    f :: N a -> bah+    RULE forall b x:b y:b. f @b ((x,y) |> (axN @b)) = ...++When matching we can just move these casts to the other side:+    match (tmpl |> co) tgt  -->   match tmpl (tgt |> sym co)+See matchTemplateCast.++Wrinkles:++(CT1) We need to be careful about scoping, and to match left-to-right, so that we+  know the substitution [a :-> b] before we meet (co :: (a,a) ~R N a), and so we+  can apply that substitition++(CT2) Annoyingly, we still want support one case in which the RULE quantifies+  over a coercion variable: the dreaded map/coerce RULE.+  See Note [Getting the map/coerce RULE to work] in GHC.Core.SimpleOpt.++  Since that can happen, matchTemplateCast laboriously checks whether the+  coercion mentions a template coercion variable; and if so does the Very Deeply+  Suspicious `match_co` instead.  It works fine for map/coerce, where the+  coercion is always a variable and will (robustly) remain so.+ See also * Note [Coercion arguments] * Note [Matching coercion variables] in GHC.Core.Unify. * Note [Cast swizzling on rule LHSs] in GHC.Core.Opt.Simplify.Utils:   sm_cast_swizzle is switched off in the template of a RULE++Note [Coercion arguments]+~~~~~~~~~~~~~~~~~~~~~~~~~+What if we have (f (Coercion co)) in the template, where the 'co' is a coercion+argument to f?  Right now we have nothing in place to ensure that a+coercion /argument/ in the template is a variable.  We really should,+perhaps by abstracting over that variable.++C.f. the treatment of dictionaries in GHC.HsToCore.Binds.decompseRuleLhs.++For now, though, we simply behave badly, by failing in match_co.+We really should never rely on matching the structure of a coercion+(which is just a proof). -}  ----------------------@@ -1044,14 +1099,7 @@     -- This is important: see Note [Cancel reflexive casts]  match renv subst (Cast e1 co1) e2 mco-  = -- See Note [Casts in the template]-    do { let co2 = case mco of-                     MRefl   -> mkRepReflCo (exprType e2)-                     MCo co2 -> co2-       ; subst1 <- match_co renv subst co1 co2-         -- If match_co succeeds, then (exprType e1) = (exprType e2)-         -- Hence the MRefl in the next line-       ; match renv subst1 e1 e2 MRefl }+  = matchTemplateCast renv subst e1 co1 e2 mco  ------------------------ Literals --------------------- match _ subst (Lit lit1) (Lit lit2) mco@@ -1274,7 +1322,7 @@         in_scope_env = ISE in_scope (rv_unf renv)         -- extendInScopeSetSet: The InScopeSet of rn_env is not necessarily         -- a superset of the free vars of e2; it is only guaranteed a superset of-        -- applyng the (rnEnvR rn_env) substitution to e2. But exprIsLambda_maybe+        -- applying the (rnEnvR rn_env) substitution to e2. But exprIsLambda_maybe         -- wants an in-scope set that includes all the free vars of its argument.         -- Hence adding adding (exprFreeVars casted_e2) to the in-scope set (#23630)   , Just (x2, e2', ts) <- exprIsLambda_maybe in_scope_env casted_e2@@ -1433,6 +1481,40 @@ -}  -------------+matchTemplateCast+    :: RuleMatchEnv -> RuleSubst+    -> CoreExpr -> Coercion+    -> CoreExpr -> MCoercion+    -> Maybe RuleSubst+matchTemplateCast renv subst e1 co1 e2 mco+  | isEmptyVarSet $ fvVarSet $+    filterFV (`elemVarSet` rv_tmpls renv) $    -- Check that the coercion does not+    tyCoFVsOfCo substed_co                     -- mention any of the template variables+  = -- This is the good path+    -- See Note [Casts in the template]+    match renv subst e1 e2 (checkReflexiveMCo (mkTransMCoL mco (mkSymCo substed_co)))++  | otherwise+  = -- This is the Deeply Suspicious Path+    do { let co2 = case mco of+                     MRefl   -> mkRepReflCo (exprType e2)+                     MCo co2 -> co2+       ; subst1 <- match_co renv subst co1 co2+         -- If match_co succeeds, then (exprType e1) = (exprType e2)+         -- Hence the MRefl in the next line+       ; match renv subst1 e1 e2 MRefl }+  where+    substed_co = substCo current_subst co1++    current_subst :: Subst+    current_subst = mkTCvSubst (rnInScopeSet (rv_lcl renv))+                               (rs_tv_subst subst)+                               emptyCvSubstEnv+       -- emptyCvSubstEnv: ugh!+       -- If there were any CoVar substitutions they would be in+       -- rs_id_subst; but we don't expect there to be any; see+       -- Note [Casts in the template]+ match_co :: RuleMatchEnv          -> RuleSubst          -> Coercion
compiler/GHC/Core/SimpleOpt.hs view
@@ -49,7 +49,6 @@ import GHC.Utils.Encoding import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Utils.Panic.Plain import GHC.Utils.Misc import GHC.Data.Maybe       ( orElse ) import GHC.Data.Graph.UnVar@@ -229,14 +228,13 @@     (env', r) = k env{soe_rec_ids = extendUnVarSetList bndrs (soe_rec_ids env)}  ----------------simple_opt_clo :: HasCallStack-               => InScopeSet+simple_opt_clo :: InScopeSet                -> SimpleClo                -> OutExpr simple_opt_clo in_scope (e_env, e)   = simple_opt_expr (soeSetInScope in_scope e_env) e -simple_opt_expr :: HasDebugCallStack => SimpleOptEnv -> InExpr -> OutExpr+simple_opt_expr :: HasCallStack => SimpleOptEnv -> InExpr -> OutExpr simple_opt_expr env expr   = go expr   where@@ -264,7 +262,6 @@      go lam@(Lam {})     = go_lam env [] lam     go (Case e b ty as)-       -- See Note [Getting the map/coerce RULE to work]       | isDeadBinder b       , Just (_, [], con, _tys, es) <- exprIsConApp_maybe in_scope_env e'         -- We don't need to be concerned about floats when looking for coerce.@@ -400,8 +397,7 @@ simple_app env e as   = finish_app env (simple_opt_expr env e) as -finish_app :: HasCallStack-           => SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr+finish_app :: SimpleOptEnv -> OutExpr -> [SimpleClo] -> OutExpr -- See Note [Eliminate casts in function position] finish_app env (Cast (Lam x e) co) as@(_:_)   | not (isTyVar x) && not (isCoVar x)@@ -478,7 +474,7 @@     occ        = idOccInfo in_bndr     in_scope   = getSubstInScope subst -    out_rhs | Just join_arity <- isJoinId_maybe in_bndr+    out_rhs | JoinPoint join_arity <- idJoinPointHood in_bndr             = simple_join_rhs join_arity             | otherwise             = simple_opt_clo in_scope clo@@ -822,35 +818,40 @@  This matches literal uses of `map coerce` in code, but that's not what we want. We want it to match, say, `map MkAge` (where newtype Age = MkAge Int)-too. Some of this is addressed by compulsorily unfolding coerce on the LHS,-yielding+too.  Achieving all this is surprisingly tricky: -  forall a b (dict :: Coercible * a b).-    map @a @b (\(x :: a) -> case dict of-      MkCoercible (co :: a ~R# b) -> x |> co) = ...+(MC1) We must compulsorily unfold MkAge to a cast.+      See Note [Compulsory newtype unfolding] in GHC.Types.Id.Make -Getting better. But this isn't exactly what gets produced. This is because-Coercible essentially has ~R# as a superclass, and superclasses get eagerly-extracted during solving. So we get this:+(MC2) We must compulsorily unfolding coerce on the rule LHS, yielding+        forall a b (dict :: Coercible * a b).+          map @a @b (\(x :: a) -> case dict of+            MkCoercible (co :: a ~R# b) -> x |> co) = ... -  forall a b (dict :: Coercible * a b).-    case Coercible_SCSel @* @a @b dict of-      _ [Dead] -> map @a @b (\(x :: a) -> case dict of-                               MkCoercible (co :: a ~R# b) -> x |> co) = ...+  Getting better. But this isn't exactly what gets produced. This is because+  Coercible essentially has ~R# as a superclass, and superclasses get eagerly+  extracted during solving. So we get this: -Unfortunately, this still abstracts over a Coercible dictionary. We really-want it to abstract over the ~R# evidence. So, we have Desugar.unfold_coerce,-which transforms the above to (see also Note [Desugaring coerce as cast] in-Desugar)+    forall a b (dict :: Coercible * a b).+      case Coercible_SCSel @* @a @b dict of+        _ [Dead] -> map @a @b (\(x :: a) -> case dict of+                                 MkCoercible (co :: a ~R# b) -> x |> co) = ... -  forall a b (co :: a ~R# b).-    let dict = MkCoercible @* @a @b co in-    case Coercible_SCSel @* @a @b dict of-      _ [Dead] -> map @a @b (\(x :: a) -> case dict of-         MkCoercible (co :: a ~R# b) -> x |> co) = let dict = ... in ...+  Unfortunately, this still abstracts over a Coercible dictionary. We really+  want it to abstract over the ~R# evidence. So, we have Desugar.unfold_coerce,+  which transforms the above to+  Desugar) -Now, we need simpleOptExpr to fix this up. It does so by taking three-separate actions:+    forall a b (co :: a ~R# b).+      let dict = MkCoercible @* @a @b co in+      case Coercible_SCSel @* @a @b dict of+        _ [Dead] -> map @a @b (\(x :: a) -> case dict of+           MkCoercible (co :: a ~R# b) -> x |> co) = let dict = ... in ...++  See Note [Desugaring coerce as cast] in GHC.HsToCore++(MC3) Now, we need simpleOptExpr to fix this up. It does so by taking three+  separate actions:   1. Inline certain non-recursive bindings. The choice whether to inline      is made in simple_bind_pair. Note the rather specific check for      MkCoercible in there.@@ -861,6 +862,10 @@   3. Look for case expressions that unpack something that was      just packed and inline them. This is also done in simple_opt_expr's      `go` function.++(MC4) The map/coerce rule is the only compelling reason for having a RULE that+  quantifies over a coercion variable, something that is otherwise Very Deeply+  Suspicous.  See Note [Casts in the template] in GHC.Core.Rules. Ugh!  This is all a fair amount of special-purpose hackery, but it's for a good cause. And it won't hurt other RULES and such that it comes across.
compiler/GHC/Core/Stats.hs view
@@ -98,7 +98,7 @@ coStats co = zeroCS { cs_co = coercionSize co }  coreBindsSize :: [CoreBind] -> Int--- We use coreBindStats for user printout+-- We use coreBindsStats for user printout -- but this one is a quick and dirty basis for -- the simplifier's tick limit coreBindsSize bs = sum (map bindSize bs)
compiler/GHC/Core/Subst.hs view
@@ -19,7 +19,7 @@         substTickish, substDVarSet, substIdInfo,          -- ** Operations on substitutions-        emptySubst, mkEmptySubst, mkSubst, mkOpenSubst, isEmptySubst,+        emptySubst, mkEmptySubst, mkTCvSubst, mkOpenSubst, isEmptySubst,         extendIdSubst, extendIdSubstList, extendTCvSubst, extendTvSubstList,         extendIdSubstWithClone,         extendSubst, extendSubstList, extendSubstWithVar,@@ -61,7 +61,6 @@ import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Utils.Panic.Plain  import Data.Functor.Identity (Identity (..)) import Data.List (mapAccumL)@@ -371,7 +370,7 @@  substIdBndr _doc rec_subst subst@(Subst in_scope env tvs cvs) old_id   = -- pprTrace "substIdBndr" (doc $$ ppr old_id $$ ppr in_scope) $-    (Subst (in_scope `InScopeSet.extendInScopeSet` new_id) new_env tvs cvs, new_id)+    (Subst new_in_scope new_env tvs cvs, new_id)   where     id1 = uniqAway in_scope old_id      -- id1 is cloned if necessary     id2 | no_type_change = id1@@ -385,14 +384,16 @@         -- new_id has the right IdInfo         -- The lazy-set is because we're in a loop here, with         -- rec_subst, when dealing with a mutually-recursive group-    new_id = maybeModifyIdInfo mb_new_info id2+    !new_id = maybeModifyIdInfo mb_new_info id2     mb_new_info = substIdInfo rec_subst id2 (idInfo id2)         -- NB: unfolding info may be zapped          -- Extend the substitution if the unique has changed         -- See the notes with substTyVarBndr for the delVarEnv-    new_env | no_change = delVarEnv env old_id-            | otherwise = extendVarEnv env old_id (Var new_id)+    !new_in_scope = in_scope `InScopeSet.extendInScopeSet` new_id+        -- Forcing new_in_scope improves T9675 by 1.7%+    !new_env | no_change = delVarEnv env old_id+             | otherwise = extendVarEnv env old_id (Var new_id)      no_change = id1 == old_id         -- See Note [Extending the IdSubstEnv]@@ -444,13 +445,15 @@             -> (Subst, Id)              -- Transformed pair  clone_id rec_subst subst@(Subst in_scope idvs tvs cvs) (old_id, uniq)-  = (Subst (in_scope `InScopeSet.extendInScopeSet` new_id) new_idvs tvs new_cvs, new_id)+  = (Subst new_in_scope new_idvs tvs new_cvs, new_id)   where     id1     = setVarUnique old_id uniq     id2     = substIdType subst id1-    new_id  = maybeModifyIdInfo (substIdInfo rec_subst id2 (idInfo old_id)) id2-    (new_idvs, new_cvs) | isCoVar old_id = (idvs, extendVarEnv cvs old_id (mkCoVarCo new_id))-                        | otherwise      = (extendVarEnv idvs old_id (Var new_id), cvs)+    !new_id = maybeModifyIdInfo (substIdInfo rec_subst id2 (idInfo old_id)) id2+    !new_in_scope = in_scope `InScopeSet.extendInScopeSet` new_id+        -- Forcing new_in_scope improves T9675 by 1.7%+    (!new_idvs, !new_cvs) | isCoVar old_id = (idvs, extendVarEnv cvs old_id (mkCoVarCo new_id))+                          | otherwise      = (extendVarEnv idvs old_id (Var new_id), cvs)  {- ************************************************************************@@ -592,8 +595,8 @@ ------------------ -- | Drop free vars from the breakpoint if they have a non-variable substitution. substTickish :: Subst -> CoreTickish -> CoreTickish-substTickish subst (Breakpoint ext n ids)-   = Breakpoint ext n (mapMaybe do_one ids)+substTickish subst (Breakpoint ext n ids modl)+   = Breakpoint ext n (mapMaybe do_one ids) modl  where     do_one = getIdFromTrivialExpr_maybe . lookupIdSubst subst
compiler/GHC/Core/Tidy.hs view
@@ -132,7 +132,7 @@                -> Id -- computeCbvInfo fun_id rhs = fun_id computeCbvInfo fun_id rhs-  | is_wkr_like || isJust mb_join_id+  | is_wkr_like || isJoinPoint mb_join_id   , valid_unlifted_worker val_args   = -- pprTrace "computeCbvInfo"     --   (text "fun" <+> ppr fun_id $$@@ -147,14 +147,14 @@    | otherwise = fun_id   where-    mb_join_id  = isJoinId_maybe fun_id+    mb_join_id  = idJoinPointHood fun_id     is_wkr_like = isWorkerLikeId fun_id      val_args = filter isId lam_bndrs     -- When computing CbvMarks, we limit the arity of join points to     -- the JoinArity, because that's the arity we are going to use     -- when calling it. There may be more lambdas than that on the RHS.-    lam_bndrs | Just join_arity <- mb_join_id+    lam_bndrs | JoinPoint join_arity <- mb_join_id               = fst $ collectNBinders join_arity rhs               | otherwise               = fst $ collectBinders rhs@@ -234,8 +234,8 @@  ------------  Tickish  -------------- tidyTickish :: TidyEnv -> CoreTickish -> CoreTickish-tidyTickish env (Breakpoint ext ix ids)-  = Breakpoint ext ix (map (tidyVarOcc env) ids)+tidyTickish env (Breakpoint ext ix ids modl)+  = Breakpoint ext ix (map (tidyVarOcc env) ids) modl tidyTickish _   other_tickish       = other_tickish  ------------  Rules  --------------@@ -430,7 +430,7 @@ Not all OneShotInfo is determined by a compiler analysis; some is added by a call of GHC.Exts.oneShot, which is then discarded before the end of the optimisation pipeline, leaving only the OneShotInfo on the lambda. Hence we-must preserve this info in inlinings. See Note [The oneShot function] in GHC.Types.Id.Make.+must preserve this info in inlinings. See Note [oneShot magic] in GHC.Types.Id.Make.  This applies to lambda binders only, hence it is stored in IfaceLamBndr. -}
compiler/GHC/Core/TyCo/Compare.hs view
@@ -73,7 +73,7 @@ Note [Type comparisons using object pointer comparisons] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Quite often we substitute the type from a definition site into-occurances without a change. This means for code like:+occurrences without a change. This means for code like:     \x -> (x,x,x) The type of every `x` will often be represented by a single object in the heap. We can take advantage of this by shortcutting the equality@@ -173,7 +173,7 @@      go env (ForAllTy (Bndr tv1 vis1) ty1)            (ForAllTy (Bndr tv2 vis2) ty2)-      =  vis1 `eqForAllVis` vis2+      =  vis1 `eqForAllVis` vis2  -- See Note [ForAllTy and type equality]       && (vis_only || go env (varType tv1) (varType tv2))       && go (rnBndr2 env tv1 tv2) ty1 ty2 @@ -230,7 +230,6 @@ -- equates 'Specified' and 'Inferred'. Used for printing. eqForAllVis :: ForAllTyFlag -> ForAllTyFlag -> Bool -- See Note [ForAllTy and type equality]--- If you change this, see IMPORTANT NOTE in the above Note eqForAllVis Required      Required      = True eqForAllVis (Invisible _) (Invisible _) = True eqForAllVis _             _             = False@@ -240,7 +239,6 @@ -- equates 'Specified' and 'Inferred'. Used for printing. cmpForAllVis :: ForAllTyFlag -> ForAllTyFlag -> Ordering -- See Note [ForAllTy and type equality]--- If you change this, see IMPORTANT NOTE in the above Note cmpForAllVis Required      Required       = EQ cmpForAllVis Required      (Invisible {}) = LT cmpForAllVis (Invisible _) Required       = GT@@ -251,13 +249,59 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ When we compare (ForAllTy (Bndr tv1 vis1) ty1)          and    (ForAllTy (Bndr tv2 vis2) ty2)-what should we do about `vis1` vs `vis2`.+what should we do about `vis1` vs `vis2`? -First, we always compare with `eqForAllVis` and `cmpForAllVis`.-But what decision do we make?+We had a long debate about this: see #22762 and GHC Proposal 558.+Here is the conclusion. -Should GHC type-check the following program (adapted from #15740)?+* In Haskell, we really do want (forall a. ty) and (forall a -> ty) to be+  distinct types, not interchangeable.  The latter requires a type argument,+  but the former does not.  See GHC Proposal 558. +* We /really/ do not want the typechecker and Core to have different notions of+  equality.  That is, we don't want `tcEqType` and `eqType` to differ.  Why not?+  Not so much because of code duplication but because it is virtually impossible+  to cleave the two apart. Here is one particularly awkward code path:+     The type checker calls `substTy`, which calls `mkAppTy`,+     which calls `mkCastTy`, which calls `isReflexiveCo`, which calls `eqType`.++* Moreover the resolution of the TYPE vs CONSTRAINT story was to make the+  typechecker and Core have a single notion of equality.++* So in GHC:+  - `tcEqType` and `eqType` implement the same equality+  - (forall a. ty) and (forall a -> ty) are distinct types in both Core and typechecker+  - That is, both `eqType` and `tcEqType` distinguish them.++* But /at representational role/ we can relate the types. That is,+    (forall a. ty) ~R (forall a -> ty)+  After all, since types are erased, they are represented the same way.+  See Note [ForAllCo] and the typing rule for ForAllCo given there++* What about (forall a. ty) and (forall {a}. ty)?  See Note [Comparing visibility].++Note [Comparing visibility]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+We are sure that we want to distinguish (forall a. ty) and (forall a -> ty); see+Note [ForAllTy and type equality].  But we have /three/ settings for the ForAllTyFlag:+  * Specified: forall a. ty+  * Inferred:  forall {a}. ty+  * Required:  forall a -> ty++We could (and perhaps should) distinguish all three. But for now we distinguish+Required from Specified/Inferred, and ignore the distinction between Specified+and Inferred.++The answer doesn't matter too much, provided we are consistent. And we are consistent+because we always compare ForAllTyFlags with+  * `eqForAllVis`+  * `cmpForAllVis`.+(You can only really check this by inspecting all pattern matches on ForAllTyFlags.)+So if we change the decision, we just need to change those functions.++Why don't we distinguish all three? Should GHC type-check the following program+(adapted from #15740)?+   {-# LANGUAGE PolyKinds, ... #-}   data D a   type family F :: forall k. k -> Type@@ -303,15 +347,11 @@   |                   | forall k -> <...> | Yes    |   -------------------------------------------------- -IMPORTANT NOTE: if we want to change this decision, ForAllCo will need to carry-visiblity (by taking a ForAllTyBinder rathre than a TyCoVar), so that-coercionLKind/RKind build forall types that match (are equal to) the desired-ones.  Otherwise we get an infinite loop in the solver via canEqCanLHSHetero. Examples: T16946, T15079.  Historical Note [Typechecker equality vs definitional equality] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-This Note describes some history, in case there are vesitges of this+This Note describes some history, in case there are vestiges of this history lying around in the code.  Summary: prior to summer 2022, GHC had have two notions of equality@@ -514,7 +554,7 @@     go env (TyVarTy tv1)       (TyVarTy tv2)       = liftOrdering $ rnOccL env tv1 `nonDetCmpVar` rnOccR env tv2     go env (ForAllTy (Bndr tv1 vis1) t1) (ForAllTy (Bndr tv2 vis2) t2)-      = liftOrdering (vis1 `cmpForAllVis` vis2)+      = liftOrdering (vis1 `cmpForAllVis` vis2)   -- See Note [ForAllTy and type equality]         `thenCmpTy` go env (varType tv1) (varType tv2)         `thenCmpTy` go (rnBndr2 env tv1 tv2) t1 t2
compiler/GHC/Core/TyCo/FVs.hs view
@@ -631,7 +631,7 @@ tyCoFVsOfCo (TyConAppCo _ _ cos) fv_cand in_scope acc = tyCoFVsOfCos cos fv_cand in_scope acc tyCoFVsOfCo (AppCo co arg) fv_cand in_scope acc   = (tyCoFVsOfCo co `unionFV` tyCoFVsOfCo arg) fv_cand in_scope acc-tyCoFVsOfCo (ForAllCo tv kind_co co) fv_cand in_scope acc+tyCoFVsOfCo (ForAllCo { fco_tcv = tv, fco_kind = kind_co, fco_body = co }) fv_cand in_scope acc   = (tyCoFVsVarBndr tv (tyCoFVsOfCo co) `unionFV` tyCoFVsOfCo kind_co) fv_cand in_scope acc tyCoFVsOfCo (FunCo { fco_mult = w, fco_arg = co1, fco_res = co2 }) fv_cand in_scope acc   = (tyCoFVsOfCo co1 `unionFV` tyCoFVsOfCo co2 `unionFV` tyCoFVsOfCo w) fv_cand in_scope acc@@ -661,7 +661,6 @@ tyCoFVsOfProv (PhantomProv co)    fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc tyCoFVsOfProv (ProofIrrelProv co) fv_cand in_scope acc = tyCoFVsOfCo co fv_cand in_scope acc tyCoFVsOfProv (PluginProv _)      fv_cand in_scope acc = emptyFV fv_cand in_scope acc-tyCoFVsOfProv (CorePrepProv _)    fv_cand in_scope acc = emptyFV fv_cand in_scope acc  tyCoFVsOfCos :: [Coercion] -> FV tyCoFVsOfCos []       fv_cand in_scope acc = emptyFV fv_cand in_scope acc@@ -672,7 +671,7 @@  -- | Given a covar and a coercion, returns True if covar is almost devoid in -- the coercion. That is, covar can only appear in Refl and GRefl.--- See last wrinkle in Note [Unused coercion variable in ForAllCo] in "GHC.Core.Coercion"+-- See (FC6) in Note [ForAllCo] in "GHC.Core.TyCo.Rep" almostDevoidCoVarOfCo :: CoVar -> Coercion -> Bool almostDevoidCoVarOfCo cv co =   almost_devoid_co_var_of_co co cv@@ -686,7 +685,7 @@ almost_devoid_co_var_of_co (AppCo co arg) cv   = almost_devoid_co_var_of_co co cv   && almost_devoid_co_var_of_co arg cv-almost_devoid_co_var_of_co (ForAllCo v kind_co co) cv+almost_devoid_co_var_of_co (ForAllCo { fco_tcv = v, fco_kind = kind_co, fco_body = co }) cv   = almost_devoid_co_var_of_co kind_co cv   && (v == cv || almost_devoid_co_var_of_co co cv) almost_devoid_co_var_of_co (FunCo { fco_mult = w, fco_arg = co1, fco_res = co2 }) cv@@ -731,8 +730,7 @@   = almost_devoid_co_var_of_co co cv almost_devoid_co_var_of_prov (ProofIrrelProv co) cv   = almost_devoid_co_var_of_co co cv-almost_devoid_co_var_of_prov (PluginProv _)   _ = True-almost_devoid_co_var_of_prov (CorePrepProv _) _ = True+almost_devoid_co_var_of_prov (PluginProv _) _ = True  almost_devoid_co_var_of_type :: Type -> CoVar -> Bool almost_devoid_co_var_of_type (TyVarTy _) _ = True@@ -809,7 +807,7 @@ isInjectiveInType :: TyVar -> Type -> Bool -- True <=> tv /definitely/ appears injectively in ty -- A bit more efficient that (tv `elemVarSet` injectiveTyVarsOfType ty)--- Ignore occurence in coercions, and even in injective positions of+-- Ignore occurrence in coercions, and even in injective positions of -- type families. isInjectiveInType tv ty   = go ty@@ -1109,7 +1107,8 @@      go_co (GRefl _ ty mco)        = go ty `unionUniqSets` go_mco mco      go_co (TyConAppCo _ tc args)  = go_tc tc `unionUniqSets` go_cos args      go_co (AppCo co arg)          = go_co co `unionUniqSets` go_co arg-     go_co (ForAllCo _ kind_co co) = go_co kind_co `unionUniqSets` go_co co+     go_co (ForAllCo { fco_kind = kind_co, fco_body = co })+                                   = go_co kind_co `unionUniqSets` go_co co      go_co (FunCo { fco_mult = m, fco_arg = a, fco_res = r })                                    = go_co m `unionUniqSets` go_co a `unionUniqSets` go_co r      go_co (AxiomInstCo ax _ args) = go_ax ax `unionUniqSets` go_cos args@@ -1131,9 +1130,6 @@      go_prov (PhantomProv co)    = go_co co      go_prov (ProofIrrelProv co) = go_co co      go_prov (PluginProv _)      = emptyUniqSet-     go_prov (CorePrepProv _)    = emptyUniqSet-        -- this last case can happen from the tyConsOfType used from-        -- checkTauTvUpdate       go_cos cos   = foldr (unionUniqSets . go_co)  emptyUniqSet cos @@ -1293,14 +1289,14 @@     go_co cxt (AppCo co arg)            = do { co' <- go_co cxt co                                              ; arg' <- go_co cxt arg                                              ; return (AppCo co' arg') }-    go_co cxt@(as, env) (ForAllCo tv kind_co body_co)+    go_co cxt@(as, env) co@(ForAllCo { fco_tcv = tv, fco_kind = kind_co, fco_body = body_co })       = do { kind_co' <- go_co cxt kind_co            ; let tv' = setVarType tv $                        coercionLKind kind_co'                  env' = extendVarEnv env tv tv'                  as'  = as `delVarSet` tv            ; body' <- go_co (as', env') body_co-           ; return (ForAllCo tv' kind_co' body') }+           ; return (co { fco_tcv = tv', fco_kind = kind_co', fco_body = body' }) }     go_co cxt co@(FunCo { fco_mult = w, fco_arg = co1 ,fco_res = co2 })       = do { co1' <- go_co cxt co1            ; co2' <- go_co cxt co2@@ -1345,5 +1341,3 @@     go_prov cxt (PhantomProv co)    = PhantomProv <$> go_co cxt co     go_prov cxt (ProofIrrelProv co) = ProofIrrelProv <$> go_co cxt co     go_prov _   p@(PluginProv _)    = return p-    go_prov _   p@(CorePrepProv _)  = return p-
compiler/GHC/Core/TyCo/FVs.hs-boot view
@@ -1,6 +1,8 @@ module GHC.Core.TyCo.FVs where  import GHC.Prelude ( Bool )+import GHC.Types.Var.Set( TyCoVarSet ) import {-# SOURCE #-} GHC.Core.TyCo.Rep ( Type )  noFreeVarsOfType :: Type -> Bool+tyCoVarsOfType   :: Type -> TyCoVarSet
compiler/GHC/Core/TyCo/Rep.hs view
@@ -48,7 +48,7 @@         mkFunTy, mkNakedFunTy,         mkVisFunTy, mkScaledFunTys,         mkInvisFunTy, mkInvisFunTys,-        tcMkVisFunTy, tcMkInvisFunTy, tcMkScaledFunTys,+        tcMkVisFunTy, tcMkInvisFunTy, tcMkScaledFunTy, tcMkScaledFunTys,         mkForAllTy, mkForAllTys, mkInvisForAllTys,         mkPiTy, mkPiTys,         mkVisFunTyMany, mkVisFunTysMany,@@ -71,12 +71,14 @@  import {-# SOURCE #-} GHC.Core.TyCo.Ppr ( pprType, pprCo, pprTyLit ) import {-# SOURCE #-} GHC.Builtin.Types+import {-# SOURCE #-} GHC.Core.TyCo.FVs( tyCoVarsOfType ) -- Use in assertions import {-# SOURCE #-} GHC.Core.Type( chooseFunTyFlag, typeKind, typeTypeOrConstraint )     -- Transitively pulls in a LOT of stuff, better to break the loop  -- friends: import GHC.Types.Var+import GHC.Types.Var.Set( elemVarSet ) import GHC.Core.TyCon import GHC.Core.Coercion.Axiom @@ -152,13 +154,13 @@                         --    for example unsaturated type synonyms                         --    can appear as the right hand side of a type synonym. -  | ForAllTy+  | ForAllTy  -- See Note [ForAllTy]         {-# UNPACK #-} !ForAllTyBinder         Type            -- ^ A Π type.-             -- Note [When we quantify over a coercion variable]+             -- See Note [Why ForAllTy can quantify over a coercion variable]              -- INVARIANT: If the binder is a coercion variable, it must-             -- be mentioned in the Type. See-             -- Note [Unused coercion variable in ForAllTy]+             --            be mentioned in the Type.+             --            See Note [Unused coercion variable in ForAllTy]    | FunTy      -- ^ FUN m t1 t2   Very common, so an important special case                 -- See Note [Function types]@@ -294,7 +296,7 @@     implicitly instantiated    - Coercion types, and non-pred evidence types (i.e. not-    of kind Constrain), are just regular old types, are+    of kind Constraint), are just regular old types, are     visible, and are not implicitly instantiated.  In a FunTy { ft_af = af } and af = FTF_C_T or FTF_C_C, the argument@@ -452,7 +454,7 @@  Accordingly, by eliminating reflexive casts, splitTyConApp need not worry about outermost casts to uphold (EQ). Eliminating reflexive casts is done-in mkCastTy. This is (EQ1) below.+in mkCastTy. This is (EQ2) below.  Unfortunately, that's not the end of the story. Consider comparing   (T a b c)      =?       (T a b |> (co -> <Type>)) (c |> co)@@ -475,7 +477,7 @@  In order to detect reflexive casts reliably, we must make sure not to have nested casts: we update (t |> co1 |> co2) to (t |> (co1 `TransCo` co2)).-This is (EQ2) below.+This is (EQ3) below.  One other troublesome case is ForAllTy. See Note [Weird typing rule for ForAllTy]. The kind of the body is the same as the kind of the ForAllTy. Accordingly,@@ -488,9 +490,9 @@  In sum, in order to uphold (EQ), we need the following invariants: -  (EQ1) No decomposable CastTy to the left of an AppTy, where a decomposable-        cast is one that relates either a FunTy to a FunTy or a-        ForAllTy to a ForAllTy.+  (EQ1) No decomposable CastTy to the left of an AppTy,+        where a "decomposable cast" is one that relates+        either a FunTy to a FunTy, or a ForAllTy to a ForAllTy.   (EQ2) No reflexive casts in CastTy.   (EQ3) No nested CastTys.   (EQ4) No CastTy over (ForAllTy (Bndr tyvar vis) body).@@ -517,8 +519,22 @@ expand into TyConApps, we must check the kinds of the arg and the res. -Note [When we quantify over a coercion variable]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Note [ForAllTy]+~~~~~~~~~~~~~~~+A (ForAllTy (Bndr tcv vis) ty) can quantify over a TyVar or, less commonly, a CoVar.+See Note [Why ForAllTy can quantify over a coercion variable] for why we need the latter.++(FT1) Invariant: See Note [Weird typing rule for ForAllTy]++(FT2) Invariant: in (ForAllTy (Bndr tcv vis) ty),+      if tcv is a CoVar, then vis = coreTyLamForAllTyFlag.+   Visibility is not important for coercion abstractions,+   because they are not user-visible.++(FT3) Invariant: see Note [Unused coercion variable in ForAllTy]++Note [Why ForAllTy can quantify over a coercion variable]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The ForAllTyBinder in a ForAllTy can be (most often) a TyVar or (rarely) a CoVar. We support quantifying over a CoVar here in order to support a homogeneous (~#) relation (someday -- not yet implemented). Here is@@ -541,10 +557,8 @@ make this work out.  See also https://gitlab.haskell.org/ghc/ghc/-/wikis/dependent-haskell/phase2-which gives a general road map that covers this space.--Having this feature in Core does *not* mean we have it in source Haskell.-See #15710 about that.+which gives a general road map that covers this space.  Having this feature in+Core does *not* mean we have it in source Haskell.  See #15710 about that.  Note [Unused coercion variable in ForAllTy] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -721,22 +735,6 @@   where     af = invisArg (typeTypeOrConstraint res) -tcMkVisFunTy :: Mult -> Type -> Type -> Type--- Always TypeLike, user-specified multiplicity.--- Does not have the assert-checking in mkFunTy: used by the typechecker--- to avoid looking at the result kind, which may not be zonked-tcMkVisFunTy mult arg res-  = FunTy { ft_af = visArgTypeLike, ft_mult = mult-          , ft_arg = arg, ft_res = res }--tcMkInvisFunTy :: TypeOrConstraint -> Type -> Type -> Type--- Always TypeLike, invisible argument--- Does not have the assert-checking in mkFunTy: used by the typechecker--- to avoid looking at the result kind, which may not be zonked-tcMkInvisFunTy res_torc arg res-  = FunTy { ft_af = invisArg res_torc, ft_mult = manyDataConTy-          , ft_arg = arg, ft_res = res }- mkVisFunTy :: HasDebugCallStack => Mult -> Type -> Type -> Type -- Always TypeLike, user-specified multiplicity. mkVisFunTy = mkFunTy visArgTypeLike@@ -763,19 +761,21 @@   where     af = visArg (typeTypeOrConstraint ty) -tcMkScaledFunTys :: [Scaled Type] -> Type -> Type--- All visible args--- Result type must be TypeLike--- No mkFunTy assert checking; result kind may not be zonked-tcMkScaledFunTys tys ty = foldr mk ty tys-  where-    mk (Scaled mult arg) res = tcMkVisFunTy mult arg res- --------------- -- | Like 'mkTyCoForAllTy', but does not check the occurrence of the binder -- See Note [Unused coercion variable in ForAllTy] mkForAllTy :: ForAllTyBinder -> Type -> Type-mkForAllTy = ForAllTy+mkForAllTy bndr body+  = assertPpr (good_bndr bndr) (ppr bndr <+> ppr body) $+    ForAllTy bndr body+  where+    -- Check ForAllTy invariants+    good_bndr (Bndr cv vis)+      | isCoVar cv = vis == coreTyLamForAllTyFlag+                     -- See (FT2) in Note [ForAllTy]+                  && (cv `elemVarSet` tyCoVarsOfType body)+                     -- See (FT3) in Note [ForAllTy]+      | otherwise = True  -- | Wraps foralls over the type using the provided 'TyCoVar's from left to right mkForAllTys :: [ForAllTyBinder] -> Type -> Type@@ -785,11 +785,11 @@ mkInvisForAllTys :: [InvisTVBinder] -> Type -> Type mkInvisForAllTys tyvars = mkForAllTys (tyVarSpecToBinders tyvars) -mkPiTy :: PiTyBinder -> Type -> Type+mkPiTy :: HasDebugCallStack => PiTyBinder -> Type -> Type mkPiTy (Anon ty1 af) ty2  = mkScaledFunTy af ty1 ty2 mkPiTy (Named bndr) ty    = mkForAllTy bndr ty -mkPiTys :: [PiTyBinder] -> Type -> Type+mkPiTys :: HasDebugCallStack => [PiTyBinder] -> Type -> Type mkPiTys tbs ty = foldr mkPiTy ty tbs  -- | 'mkNakedTyConTy' creates a nullary 'TyConApp'. In general you@@ -800,6 +800,31 @@ mkNakedTyConTy :: TyCon -> Type mkNakedTyConTy tycon = TyConApp tycon [] +tcMkVisFunTy :: Mult -> Type -> Type -> Type+-- Always TypeLike result, user-specified multiplicity.+-- Does not have the assert-checking in mkFunTy: used by the typechecker+-- to avoid looking at the result kind, which may not be zonked+tcMkVisFunTy mult arg res+  = FunTy { ft_af = visArgTypeLike, ft_mult = mult+          , ft_arg = arg, ft_res = res }++tcMkInvisFunTy :: TypeOrConstraint -> Type -> Type -> Type+-- Always invisible (constraint) argument, result specified by res_torc+-- Does not have the assert-checking in mkFunTy: used by the typechecker+-- to avoid looking at the result kind, which may not be zonked+tcMkInvisFunTy res_torc arg res+  = FunTy { ft_af = invisArg res_torc, ft_mult = manyDataConTy+          , ft_arg = arg, ft_res = res }++tcMkScaledFunTys :: [Scaled Type] -> Type -> Type+-- All visible args+-- Result type must be TypeLike+-- No mkFunTy assert checking; result kind may not be zonked+tcMkScaledFunTys tys ty = foldr tcMkScaledFunTy ty tys++tcMkScaledFunTy :: Scaled Type -> Type -> Type+tcMkScaledFunTy (Scaled mult arg) res = tcMkVisFunTy mult arg res+ {- %************************************************************************ %*                                                                      *@@ -849,8 +874,14 @@   | AppCo Coercion CoercionN             -- lift AppTy           -- AppCo :: e -> N -> e -  -- See Note [Forall coercions]-  | ForAllCo TyCoVar KindCoercion Coercion+  -- See Note [ForAllCo]+  | ForAllCo+      { fco_tcv  :: TyCoVar+      , fco_visL :: !ForAllTyFlag -- Visibility of coercionLKind+      , fco_visR :: !ForAllTyFlag -- Visibility of coercionRKind+                                  -- See (FC7) of Note [ForAllCo]+      , fco_kind :: KindCoercion+      , fco_body :: Coercion }          -- ForAllCo :: _ -> N -> e -> e    | FunCo  -- FunCo :: "e" -> N/P -> e -> e -> e@@ -1159,44 +1190,106 @@ The Int in the AxiomInstCo constructor is the 0-indexed number of the chosen branch. -Note [Forall coercions]-~~~~~~~~~~~~~~~~~~~~~~~+Note [ForAllCo]+~~~~~~~~~~~~~~~+See also Note [ForAllTy and type equality] in GHC.Core.TyCo.Compare.+ Constructing coercions between forall-types can be a bit tricky, because the kinds of the bound tyvars can be different.  The typing rule is: +  kind_co : k1 ~N k2+  tv1:k1 |- co : t1 ~r t2+  if r=N, then vis1=vis2+  ------------------------------------+  ForAllCo (tv1:k1) vis1 vis2 kind_co co+     : forall (tv1:k1) <vis1>. t1+              ~r+       forall (tv1:k2) <vis2>. (t2[tv1 |-> (tv1:k2) |> sym kind_co]) -  kind_co : k1 ~ k2-  tv1:k1 |- co : t1 ~ t2-  --------------------------------------------------------------------  ForAllCo tv1 kind_co co : all tv1:k1. t1  ~-                            all tv1:k2. (t2[tv1 |-> tv1 |> sym kind_co])+Several things to note here -First, the TyCoVar stored in a ForAllCo is really an optimisation: this field-should be a Name, as its kind is redundant. Thinking of the field as a Name-is helpful in understanding what a ForAllCo means.-The kind of TyCoVar always matches the left-hand kind of the coercion.+(FC1) First, the TyCoVar stored in a ForAllCo is really just a convenience: this+  field should be a Name, as its kind is redundant. Thinking of the field as a+  Name is helpful in understanding what a ForAllCo means.  The kind of TyCoVar+  always matches the left-hand kind of the coercion. -The idea is that kind_co gives the two kinds of the tyvar. See how, in the-conclusion, tv1 is assigned kind k1 on the left but kind k2 on the right.+  * The idea is that kind_co gives the two kinds of the tyvar. See how, in the+    conclusion, tv1 is assigned kind k1 on the left but kind k2 on the right. -Of course, a type variable can't have different kinds at the same time. So,-we arbitrarily prefer the first kind when using tv1 in the inner coercion-co, which shows that t1 equals t2.+  * Of course, a type variable can't have different kinds at the same time.+    So, in `co` itself we use (tv1 : k1); hence the premise+          tv1:k1 |- co : t1 ~r t2 -The last wrinkle is that we need to fix the kinds in the conclusion. In-t2, tv1 is assumed to have kind k1, but it has kind k2 in the conclusion of-the rule. So we do a kind-fixing substitution, replacing (tv1:k1) with-(tv1:k2) |> sym kind_co. This substitution is slightly bizarre, because it-mentions the same name with different kinds, but it *is* well-kinded, noting-that `(tv1:k2) |> sym kind_co` has kind k1.+  * The last wrinkle is that we need to fix the kinds in the conclusion. In+    t2, tv1 is assumed to have kind k1, but it has kind k2 in the conclusion of+     the rule. So we do a kind-fixing substitution, replacing (tv1:k1) with+     (tv1:k2) |> sym kind_co. This substitution is slightly bizarre, because it+    mentions the same name with different kinds, but it *is* well-kinded, noting+     that `(tv1:k2) |> sym kind_co` has kind k1. -This all really would work storing just a Name in the ForAllCo. But we can't-add Names to, e.g., VarSets, and there generally is just an impedance mismatch-in a bunch of places. So we use tv1. When we need tv2, we can use-setTyVarKind.+  We could instead store just a Name in the ForAllCo, and it might even be+  more efficient to do so. But we can't add Names to, e.g., VarSets, and+  there generally is just an impedance mismatch in a bunch of places. So we+  use tv1. When we need tv2, we can use setTyVarKind. +(FC2) Note that the kind coercion must be Nominal; and that the role `r` of+  the final coercion is the same as that of the body coercion.++(FC3) A ForAllCo allows casting between visibilities.  For example:+         ForAllCo a Required Specified (SubCo (Refl ty))+           : (forall a -> ty) ~R (forall a. ty)+  But you can only cast between visiblities at Representational role;+  Hence the premise+      if r=N, then vis1=vis2+  in the typing rule.  See also Note [ForAllTy and type equality] in+  GHC.Core.TyCo.Compare.++(FC4) A lambda term (Lam a e) has type (forall a. ty), with visibility+  flag `GHC.Type.Var.coreTyLamForAllTyFlag`, not (forall a -> ty).+  See `GHC.Type.Var.coreTyLamForAllTyFlag` and `GHC.Core.Utils.mkLamType`.+  The only way to get a term of type (forall a -> ty) is to cast a lambda.++(FC5) In a /type/, in (ForAllTy cv ty) where cv is a CoVar, we insist that+  `cv` must appear free in `ty`; see Note [Unused coercion variable in ForAllTy]+  in GHC.Core.TyCo.Rep for the motivation.  If it does not appear free,+  use FunTy.++  However we do /not/ impose the same restriction on ForAllCo in /coercions/.+  Instead, in coercionLKind and coercionRKind, we use mkTyCoForAllTy to perform+  the check and construct a FunTy when necessary.  Why?+    * For a coercion, all that matters is its kind, So ForAllCo vs FunCo does not+       make a difference.+    * Even if cv occurs in body_co, it is possible that cv does not occur in the kind+      of body_co. Therefore the check in coercionKind is inevitable.++(FC6) Invariant: in a ForAllCo where fco_tcv is a coercion variable, `cv`,+  we insist that `cv` appears only in positions that are erased. In fact we use+  a conservative approximation of this: we require that+       (almostDevoidCoVarOfCo cv fco_body)+  holds.  This function checks that `cv` appers only within the type in a Refl+  node and under a GRefl node (including in the Coercion stored in a GRefl).+  It's possible other places are OK, too, but this is a safe approximation.++  Why all this fuss?  See Section 5.8.5.2 of Richard's thesis. The idea is that+  we cannot prove that the type system is consistent with unrestricted use of this+  cv; the consistency proof uses an untyped rewrite relation that works over types+  with all coercions and casts removed. So, we can allow the cv to appear only in+  positions that are erased.++  Sadly, with heterogeneous equality, this restriction might be able to be+  violated; Richard's thesis is unable to prove that it isn't. Specifically, the+  liftCoSubst function might create an invalid coercion. Because a violation of+  the restriction might lead to a program that "goes wrong", it is checked all+  the time, even in a production compiler and without -dcore-lint. We *have*+  proved that the problem does not occur with homogeneous equality, so this+  check can be dropped once ~# is made to be homogeneous.++(FC7) Invariant: in a ForAllCo, if fco_tcv is a CoVar, then+         fco_visL = fco_visR = coreTyLamForAllTyFlag+  c.f. (FT2) in Note [ForAllTy]+ Note [Predicate coercions] ~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose we have@@ -1437,17 +1530,12 @@   | PluginProv String  -- ^ From a plugin, which asserts that this coercion                        --   is sound. The string is for the use of the plugin. -  | CorePrepProv       -- See Note [Unsafe coercions] in GHC.Core.CoreToStg.Prep-      Bool   -- True  <=> the UnivCo must be homogeneously kinded-             -- False <=> allow hetero-kinded, e.g. Int ~ Int#-   deriving Data.Data  instance Outputable UnivCoProvenance where   ppr (PhantomProv _)    = text "(phantom)"   ppr (ProofIrrelProv _) = text "(proof irrel.)"   ppr (PluginProv str)   = parens (text "plugin" <+> brackets (text str))-  ppr (CorePrepProv _)   = text "(CorePrep)"  -- | A coercion to be filled in by the type-checker. See Note [Coercion holes] data CoercionHole@@ -1760,7 +1848,7 @@     go_co env (FunCo { fco_mult = cw, fco_arg = c1, fco_res = c2 })        = go_co env cw `mappend` go_co env c1 `mappend` go_co env c2 -    go_co env (ForAllCo tv kind_co co)+    go_co env (ForAllCo tv _vis1 _vis2 kind_co co)       = go_co env kind_co `mappend` go_ty env (varType tv)                           `mappend` go_co env' co       where@@ -1769,7 +1857,6 @@     go_prov env (PhantomProv co)    = go_co env co     go_prov env (ProofIrrelProv co) = go_co env co     go_prov _   (PluginProv _)      = mempty-    go_prov _   (CorePrepProv _)    = mempty  -- | A view function that looks through nothing. noView :: Type -> Maybe Type@@ -1815,7 +1902,8 @@ coercionSize (GRefl _ ty (MCo co)) = 1 + typeSize ty + coercionSize co coercionSize (TyConAppCo _ _ args) = 1 + sum (map coercionSize args) coercionSize (AppCo co arg)        = coercionSize co + coercionSize arg-coercionSize (ForAllCo _ h co)     = 1 + coercionSize co + coercionSize h+coercionSize (ForAllCo { fco_kind = h, fco_body = co })+                                   = 1 + coercionSize co + coercionSize h coercionSize (FunCo _ _ _ w c1 c2) = 1 + coercionSize c1 + coercionSize c2                                                          + coercionSize w coercionSize (CoVarCo _)         = 1@@ -1835,7 +1923,6 @@ provSize (PhantomProv co)    = 1 + coercionSize co provSize (ProofIrrelProv co) = 1 + coercionSize co provSize (PluginProv _)      = 1-provSize (CorePrepProv _)    = 1  {- ************************************************************************
compiler/GHC/Core/TyCo/Subst.hs view
@@ -5,7 +5,6 @@ -}  -{-# LANGUAGE BangPatterns #-}  -- | Substitution into types and coercions. module GHC.Core.TyCo.Subst@@ -14,14 +13,14 @@         Subst(..), TvSubstEnv, CvSubstEnv, IdSubstEnv,         emptyIdSubstEnv, emptyTvSubstEnv, emptyCvSubstEnv, composeTCvSubst,         emptySubst, mkEmptySubst, isEmptyTCvSubst, isEmptySubst,-        mkSubst, mkTvSubst, mkCvSubst, mkIdSubst,+        mkTCvSubst, mkTvSubst, mkCvSubst, mkIdSubst,         getTvSubstEnv, getIdSubstEnv,         getCvSubstEnv, getSubstInScope, setInScope, getSubstRangeTyCoFVs,         isInScope, elemSubst, notElemSubst, zapSubst,         extendSubstInScope, extendSubstInScopeList, extendSubstInScopeSet,         extendTCvSubst, extendTCvSubstWithClone,         extendCvSubst, extendCvSubstWithClone,-        extendTvSubst, extendTvSubstBinderAndInScope, extendTvSubstWithClone,+        extendTvSubst, extendTvSubstWithClone,         extendTvSubstList, extendTvSubstAndInScope,         extendTCvSubstList,         unionSubst, zipTyEnv, zipCoEnv,@@ -82,7 +81,6 @@ import GHC.Types.Unique.Set import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Utils.Panic.Plain  import Data.List (mapAccumL) @@ -272,8 +270,8 @@ isEmptyTCvSubst (Subst _ _ tv_env cv_env)   = isEmptyVarEnv tv_env && isEmptyVarEnv cv_env -mkSubst :: InScopeSet -> TvSubstEnv -> CvSubstEnv -> IdSubstEnv -> Subst-mkSubst in_scope tvs cvs ids = Subst in_scope ids tvs cvs+mkTCvSubst :: InScopeSet -> TvSubstEnv -> CvSubstEnv -> Subst+mkTCvSubst in_scope tvs cvs = Subst in_scope emptyIdSubstEnv tvs cvs  mkIdSubst :: InScopeSet -> IdSubstEnv -> Subst mkIdSubst in_scope ids = Subst in_scope ids emptyTvSubstEnv emptyCvSubstEnv@@ -374,13 +372,6 @@   = assert (isTyVar tv) $     Subst in_scope ids (extendVarEnv tvs tv ty) cvs -extendTvSubstBinderAndInScope :: Subst -> PiTyBinder -> Type -> Subst-extendTvSubstBinderAndInScope subst (Named (Bndr v _)) ty-  = assert (isTyVar v )-    extendTvSubstAndInScope subst v ty-extendTvSubstBinderAndInScope subst (Anon {}) _-  = subst- extendTvSubstWithClone :: Subst -> TyVar -> TyVar -> Subst -- Adds a new tv -> tv mapping, /and/ extends the in-scope set with the clone -- Does not look in the kind of the new variable;@@ -535,7 +526,8 @@ In OptCoercion, we try to push "sym" out to the leaves of a coercion. But, how do we push sym into a ForAllCo? It's a little ugly. -Here is the typing rule:+Ignoring visibility, here is the typing rule+(see Note [ForAllCo] in GHC.Core.TyCo.Rep).  h : k1 ~# k2 (tv : k1) |- g : ty1 ~# ty2@@ -622,7 +614,7 @@ -- Pre-condition: the 'in_scope' set should satisfy Note [The substitution -- invariant]; specifically it should include the free vars of 'tys', -- and of 'ty' minus the domain of the subst.-substTyWithInScope :: InScopeSet -> [TyVar] -> [Type] -> Type -> Type+substTyWithInScope :: HasDebugCallStack => InScopeSet -> [TyVar] -> [Type] -> Type -> Type substTyWithInScope in_scope tvs tys ty =   assert (tvs `equalLength` tys )   substTy (mkTvSubst in_scope tenv) ty@@ -650,12 +642,12 @@ substTyWithCoVars cvs cos = substTy (zipCvSubst cvs cos)  -- | Type substitution, see 'zipTvSubst'-substTysWith :: [TyVar] -> [Type] -> [Type] -> [Type]+substTysWith :: HasDebugCallStack => [TyVar] -> [Type] -> [Type] -> [Type] substTysWith tvs tys = assert (tvs `equalLength` tys )                        substTys (zipTvSubst tvs tys)  -- | Type substitution, see 'zipTvSubst'-substTysWithCoVars :: [CoVar] -> [Coercion] -> [Type] -> [Type]+substTysWithCoVars :: HasDebugCallStack => [CoVar] -> [Coercion] -> [Type] -> [Type] substTysWithCoVars cvs cos = assert (cvs `equalLength` cos )                              substTys (zipCvSubst cvs cos) @@ -663,7 +655,7 @@ -- to the in-scope set. This is useful for the case when the free variables -- aren't already in the in-scope set or easily available. -- See also Note [The substitution invariant].-substTyAddInScope :: Subst -> Type -> Type+substTyAddInScope :: HasDebugCallStack => Subst -> Type -> Type substTyAddInScope subst ty =   substTy (extendSubstInScopeSet subst $ tyCoVarsOfType ty) ty @@ -715,7 +707,7 @@ -- Note [The substitution invariant]. substTy :: HasDebugCallStack => Subst -> Type  -> Type substTy subst ty-  | isEmptyTCvSubst    subst = ty+  | isEmptyTCvSubst subst = ty   | otherwise             = checkValidSubst subst [ty] [] $                             subst_ty subst ty @@ -726,8 +718,8 @@ -- substTy and remove this function. Please don't use in new code. substTyUnchecked :: Subst -> Type -> Type substTyUnchecked subst ty-                 | isEmptyTCvSubst subst    = ty-                 | otherwise             = subst_ty subst ty+  | isEmptyTCvSubst subst = ty+  | otherwise             = subst_ty subst ty  substScaledTy :: HasDebugCallStack => Subst -> Scaled Type -> Scaled Type substScaledTy subst scaled_ty = mapScaledType (substTy subst) scaled_ty@@ -820,7 +812,7 @@       Nothing -> TyVarTy tv  substTyVarToTyVar :: HasDebugCallStack => Subst -> TyVar -> TyVar--- Apply the substitution, expecing the result to be a TyVarTy+-- Apply the substitution, expecting the result to be a TyVarTy substTyVarToTyVar (Subst _ _ tenv _) tv   = assert (isTyVar tv) $     case lookupVarEnv tenv tv of@@ -889,10 +881,10 @@     go (TyConAppCo r tc args)= let args' = map go args                                in  args' `seqList` mkTyConAppCo r tc args'     go (AppCo co arg)        = (mkAppCo $! go co) $! go arg-    go (ForAllCo tv kind_co co)+    go (ForAllCo tv visL visR kind_co co)       = case substForAllCoBndrUnchecked subst tv kind_co of          (subst', tv', kind_co') ->-          ((mkForAllCo $! tv') $! kind_co') $! subst_co subst' co+          ((mkForAllCo $! tv') visL visR $! kind_co') $! subst_co subst' co     go (FunCo r afl afr w co1 co2)   = ((mkFunCo2 r afl afr $! go w) $! go co1) $! go co2     go (CoVarCo cv)          = substCoVar subst cv     go (AxiomInstCo con ind cos) = mkAxiomInstCo con ind $! map go cos@@ -912,7 +904,6 @@     go_prov (PhantomProv kco)    = PhantomProv (go kco)     go_prov (ProofIrrelProv kco) = ProofIrrelProv (go kco)     go_prov p@(PluginProv _)     = p-    go_prov p@(CorePrepProv _)   = p      -- See Note [Substituting in a coercion hole]     go_hole h@(CoercionHole { ch_co_var = cv })
compiler/GHC/Core/TyCo/Tidy.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE BangPatterns #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}  -- | Tidying types and coercions for printing in error messages.@@ -228,7 +227,8 @@     go (GRefl r ty mco)      = (GRefl r $! tidyType env ty) $! go_mco mco     go (TyConAppCo r tc cos) = TyConAppCo r tc $! strictMap go cos     go (AppCo co1 co2)       = (AppCo $! go co1) $! go co2-    go (ForAllCo tv h co)    = ((ForAllCo $! tvp) $! (go h)) $! (tidyCo envp co)+    go (ForAllCo tv visL visR h co)+      = ((((ForAllCo $! tvp) $! visL) $! visR) $! (go h)) $! (tidyCo envp co)                                where (envp, tvp) = tidyVarBndr env tv             -- the case above duplicates a bit of work in tidying h and the kind             -- of tv. But the alternative is to use coercionKind, which seems worse.@@ -252,7 +252,6 @@     go_prov (PhantomProv co)    = PhantomProv $! go co     go_prov (ProofIrrelProv co) = ProofIrrelProv $! go co     go_prov p@(PluginProv _)    = p-    go_prov p@(CorePrepProv _)  = p  tidyCos :: TidyEnv -> [Coercion] -> [Coercion] tidyCos env = strictMap (tidyCo env)
compiler/GHC/Core/TyCon.hs view
@@ -1,4 +1,4 @@-+{-# LANGUAGE CPP  #-} {-# LANGUAGE FlexibleInstances  #-} {-# LANGUAGE LambdaCase         #-} {-# LANGUAGE DeriveDataTypeable #-}@@ -56,7 +56,7 @@         tyConMustBeSaturated,         isPromotedDataCon, isPromotedDataCon_maybe,         isDataKindsPromotedDataCon,-        isKindTyCon, isLiftedTypeKindTyConName,+        isKindTyCon, isKindName, isLiftedTypeKindTyConName,         isTauTyCon, isFamFreeTyCon, isForgetfulSynTyCon,          isDataTyCon,@@ -75,6 +75,7 @@         isTcTyCon, setTcTyConKind,         tcHasFixedRuntimeRep,         isConcreteTyCon,+        isValidDTT2TyCon,          -- ** Extracting information out of TyCons         tyConName,@@ -125,10 +126,11 @@          -- * Primitive representations of Types         PrimRep(..), PrimElemRep(..), Levity(..),+        PrimOrVoidRep(..),         primElemRepToPrimRep,-        isVoidRep, isGcPtrRep,-        primRepSizeB,-        primElemRepSizeB,+        isGcPtrRep,+        primRepSizeB, primRepSizeW64_B,+        primElemRepSizeB, primElemRepSizeW64_B,         primRepIsFloat,         primRepsCompatible,         primRepCompatible,@@ -173,7 +175,6 @@ import GHC.Data.Maybe import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Utils.Panic.Plain import GHC.Data.FastString.Env import GHC.Types.FieldLabel import GHC.Settings.Constants@@ -599,10 +600,11 @@   - but changing Anon/Required to Specified  The last part about Required->Specified comes from this:-  data T k (a:k) b = MkT (a b)-Here k is Required in T's kind, but we don't have Required binders in-the PiTyBinders for a term (see Note [No Required PiTyBinder in terms]-in GHC.Core.TyCo.Rep), so we change it to Specified when making MkT's PiTyBinders+  data T k (a :: k) b = MkT (a b)+Here k is Required in T's kind, but we didn't have Required binders in+types of terms before the advent of the new, experimental RequiredTypeArguments+extension. So we historically changed Required to Specified when making MkT's PiTyBinders+and now continue to do so to avoid a breaking change. -}  @@ -1336,7 +1338,7 @@ Note [Enumeration types] ~~~~~~~~~~~~~~~~~~~~~~~~ We define datatypes with no constructors to *not* be-enumerations; this fixes trac #2578,  Otherwise we+enumerations; this fixes #2578,  Otherwise we end up generating an empty table for   <mod>_<type>_closure_tbl which is used by tagToEnum# to map Int# to constructors@@ -1530,13 +1532,20 @@  -} --- | A 'PrimRep' is an abstraction of a type.  It contains information that--- the code generator needs in order to pass arguments, return results,++-- | A 'PrimRep' is an abstraction of a /non-void/ type.+-- (Use 'PrimRepOrVoidRep' if you want void types too.)+-- It contains information that the code generator needs+-- in order to pass arguments, return results, -- and store values of this type. See also Note [RuntimeRep and PrimRep] in -- "GHC.Types.RepType" and Note [VoidRep] in "GHC.Types.RepType". data PrimRep-  = VoidRep-  | BoxedRep {-# UNPACK #-} !(Maybe Levity) -- ^ Boxed, heap value+-- Unpacking of sum types is only supported since 9.6.1+#if MIN_VERSION_GLASGOW_HASKELL(9,6,0,0)+  = BoxedRep {-# UNPACK #-} !(Maybe Levity) -- ^ Boxed, heap value+#else+  = BoxedRep                !(Maybe Levity) -- ^ Boxed, heap value+#endif   | Int8Rep       -- ^ Signed, 8-bit value   | Int16Rep      -- ^ Signed, 16-bit value   | Int32Rep      -- ^ Signed, 32-bit value@@ -1553,6 +1562,9 @@   | VecRep Int PrimElemRep  -- ^ A vector   deriving( Data.Data, Eq, Ord, Show ) +data PrimOrVoidRep = VoidRep | NVRep PrimRep+  -- See Note [VoidRep] in GHC.Types.RepType+ data PrimElemRep   = Int8ElemRep   | Int16ElemRep@@ -1573,58 +1585,52 @@   ppr r = text (show r)  instance Binary PrimRep where-  put_ bh VoidRep        = putByte bh 0   put_ bh (BoxedRep ml)  = case ml of     -- cheaper storage of the levity than using     -- the Binary (Maybe Levity) instance-    Nothing       -> putByte bh 1-    Just Lifted   -> putByte bh 2-    Just Unlifted -> putByte bh 3-  put_ bh Int8Rep        = putByte bh 4-  put_ bh Int16Rep       = putByte bh 5-  put_ bh Int32Rep       = putByte bh 6-  put_ bh Int64Rep       = putByte bh 7-  put_ bh IntRep         = putByte bh 8-  put_ bh Word8Rep       = putByte bh 9-  put_ bh Word16Rep      = putByte bh 10-  put_ bh Word32Rep      = putByte bh 11-  put_ bh Word64Rep      = putByte bh 12-  put_ bh WordRep        = putByte bh 13-  put_ bh AddrRep        = putByte bh 14-  put_ bh FloatRep       = putByte bh 15-  put_ bh DoubleRep      = putByte bh 16-  put_ bh (VecRep n per) = putByte bh 17 *> put_ bh n *> put_ bh per+    Nothing       -> putByte bh 0+    Just Lifted   -> putByte bh 1+    Just Unlifted -> putByte bh 2+  put_ bh Int8Rep        = putByte bh 3+  put_ bh Int16Rep       = putByte bh 4+  put_ bh Int32Rep       = putByte bh 5+  put_ bh Int64Rep       = putByte bh 6+  put_ bh IntRep         = putByte bh 7+  put_ bh Word8Rep       = putByte bh 8+  put_ bh Word16Rep      = putByte bh 9+  put_ bh Word32Rep      = putByte bh 10+  put_ bh Word64Rep      = putByte bh 11+  put_ bh WordRep        = putByte bh 12+  put_ bh AddrRep        = putByte bh 13+  put_ bh FloatRep       = putByte bh 14+  put_ bh DoubleRep      = putByte bh 15+  put_ bh (VecRep n per) = putByte bh 16 *> put_ bh n *> put_ bh per   get  bh = do     h <- getByte bh     case h of-      0  -> pure VoidRep-      1  -> pure $ BoxedRep Nothing-      2  -> pure $ BoxedRep (Just Lifted)-      3  -> pure $ BoxedRep (Just Unlifted)-      4  -> pure Int8Rep-      5  -> pure Int16Rep-      6  -> pure Int32Rep-      7  -> pure Int64Rep-      8  -> pure IntRep-      9  -> pure Word8Rep-      10 -> pure Word16Rep-      11 -> pure Word32Rep-      12 -> pure Word64Rep-      13 -> pure WordRep-      14 -> pure AddrRep-      15 -> pure FloatRep-      16 -> pure DoubleRep-      17 -> VecRep <$> get bh <*> get bh+      0  -> pure $ BoxedRep Nothing+      1  -> pure $ BoxedRep (Just Lifted)+      2  -> pure $ BoxedRep (Just Unlifted)+      3  -> pure Int8Rep+      4  -> pure Int16Rep+      5  -> pure Int32Rep+      6  -> pure Int64Rep+      7  -> pure IntRep+      8  -> pure Word8Rep+      9  -> pure Word16Rep+      10 -> pure Word32Rep+      11 -> pure Word64Rep+      12 -> pure WordRep+      13 -> pure AddrRep+      14 -> pure FloatRep+      15 -> pure DoubleRep+      16 -> VecRep <$> get bh <*> get bh       _  -> pprPanic "Binary:PrimRep" (int (fromIntegral h))  instance Binary PrimElemRep where   put_ bh per = putByte bh (fromIntegral (fromEnum per))   get  bh = toEnum . fromIntegral <$> getByte bh -isVoidRep :: PrimRep -> Bool-isVoidRep VoidRep = True-isVoidRep _other  = False- isGcPtrRep :: PrimRep -> Bool isGcPtrRep (BoxedRep _) = True isGcPtrRep _            = False@@ -1669,12 +1675,40 @@    DoubleRep        -> dOUBLE_SIZE    AddrRep          -> platformWordSizeInBytes platform    BoxedRep _       -> platformWordSizeInBytes platform-   VoidRep          -> 0    (VecRep len rep) -> len * primElemRepSizeB platform rep +-- | Like primRepSizeB but assumes pointers/words are 8 words wide.+--+-- This can be useful to compute the size of a rep as if we were compiling+-- for a 64bit platform.+primRepSizeW64_B :: PrimRep -> Int+primRepSizeW64_B = \case+   IntRep           -> 8+   WordRep          -> 8+   Int8Rep          -> 1+   Int16Rep         -> 2+   Int32Rep         -> 4+   Int64Rep         -> 8+   Word8Rep         -> 1+   Word16Rep        -> 2+   Word32Rep        -> 4+   Word64Rep        -> 8+   FloatRep         -> fLOAT_SIZE+   DoubleRep        -> dOUBLE_SIZE+   AddrRep          -> 8+   BoxedRep{}       -> 8+   (VecRep len rep) -> len * primElemRepSizeW64_B rep+ primElemRepSizeB :: Platform -> PrimElemRep -> Int primElemRepSizeB platform = primRepSizeB platform . primElemRepToPrimRep +-- | Like primElemRepSizeB but assumes pointers/words are 8 words wide.+--+-- This can be useful to compute the size of a rep as if we were compiling+-- for a 64bit platform.+primElemRepSizeW64_B :: PrimElemRep -> Int+primElemRepSizeW64_B = primRepSizeW64_B . primElemRepToPrimRep+ primElemRepToPrimRep :: PrimElemRep -> PrimRep primElemRepToPrimRep Int8ElemRep   = Int8Rep primElemRepToPrimRep Int16ElemRep  = Int16Rep@@ -1868,7 +1902,7 @@ noTcTyConScopedTyVars :: [(Name, TcTyVar)] noTcTyConScopedTyVars = [] --- | Create an primitive 'TyCon', such as @Int#@, @Type@ or @RealWorld#@+-- | Create an primitive 'TyCon', such as @Int#@, @Type@ or @RealWorld@ -- Primitive TyCons are marshalable iff not lifted. -- If you'd like to change this, modify marshalablePrimTyCon. mkPrimTyCon :: Name -> [TyConBinder]@@ -1946,6 +1980,12 @@   | AlgTyCon { algTcFlavour = VanillaAlgTyCon _ } <- details = True   | otherwise                                                = False +-- | Returns @True@ if a boxed type headed by the given @TyCon@+-- satisfies condition DTT2 of Note [DataToTag overview] in+-- GHC.Tc.Instance.Class+isValidDTT2TyCon :: TyCon -> Bool+isValidDTT2TyCon = isDataTyCon+ isDataTyCon :: TyCon -> Bool -- ^ Returns @True@ for data types that are /definitely/ represented by -- heap-allocated constructors.  These are scrutinised by Core-level@@ -2278,16 +2318,32 @@               = not (isTypeDataCon dc)   | otherwise = False --- | Is this tycon really meant for use at the kind level? That is,--- should it be permitted without -XDataKinds?+-- | Is this 'TyCon' really meant for use at the kind level? That is,+-- should it be permitted without @DataKinds@? isKindTyCon :: TyCon -> Bool-isKindTyCon tc = getUnique tc `elementOfUniqSet` kindTyConKeys+isKindTyCon = isKindUniquable +-- | This is 'Name' really meant for use at the kind level? That is,+-- should it be permitted wihout @DataKinds@?+isKindName :: Name -> Bool+isKindName = isKindUniquable++-- | The workhorse for 'isKindTyCon' and 'isKindName'.+isKindUniquable :: Uniquable a => a -> Bool+isKindUniquable thing = getUnique thing `elementOfUniqSet` kindTyConKeys+ -- | These TyCons should be allowed at the kind level, even without -- -XDataKinds. kindTyConKeys :: UniqSet Unique kindTyConKeys = unionManyUniqSets-  ( mkUniqSet [ liftedTypeKindTyConKey, liftedRepTyConKey, constraintKindTyConKey, tYPETyConKey ]+  -- Make sure to keep this in sync with the following:+  --+  -- - The Overview section in docs/users_guide/exts/data_kinds.rst in the GHC+  --   User's Guide.+  --+  -- - The typecheck/should_compile/T22141f.hs test case, which ensures that all+  --   of these can successfully be used without DataKinds.+  ( mkUniqSet [ liftedTypeKindTyConKey, liftedRepTyConKey, constraintKindTyConKey, tYPETyConKey, cONSTRAINTTyConKey ]   : map (mkUniqSet . tycon_with_datacons) [ runtimeRepTyCon, levityTyCon                                           , multiplicityTyCon                                           , vecCountTyCon, vecElemTyCon ] )
compiler/GHC/Core/Type.hs view
@@ -48,11 +48,11 @@          mkForAllTy, mkForAllTys, mkInvisForAllTys, mkTyCoInvForAllTys,         mkSpecForAllTy, mkSpecForAllTys,-        mkVisForAllTys, mkTyCoInvForAllTy,+        mkVisForAllTys, mkTyCoForAllTy, mkTyCoForAllTys, mkTyCoInvForAllTy,         mkInfForAllTy, mkInfForAllTys,         splitForAllTyCoVars, splitForAllTyVars,         splitForAllReqTyBinders, splitForAllInvisTyBinders,-        splitForAllForAllTyBinders,+        splitForAllForAllTyBinders, splitForAllForAllTyBinder_maybe,         splitForAllTyCoVar_maybe, splitForAllTyCoVar,         splitForAllTyVar_maybe, splitForAllCoVar_maybe,         splitPiTy_maybe, splitPiTy, splitPiTys,@@ -77,7 +77,7 @@         mkCastTy, mkCoercionTy, splitCastTy_maybe,          ErrorMsgType,-        userTypeError_maybe, pprUserTypeErrorTy,+        userTypeError_maybe, deepUserTypeError_maybe, pprUserTypeErrorTy,          coAxNthLHS,         stripCoercionTy,@@ -126,7 +126,7 @@          -- *** Levity and boxity         sORTKind_maybe, typeTypeOrConstraint,-        typeLevity_maybe, tyConIsTYPEorCONSTRAINT,+        typeLevity, typeLevity_maybe, tyConIsTYPEorCONSTRAINT,         isLiftedTypeKind, isUnliftedTypeKind, pickyIsLiftedTypeKind,         isLiftedRuntimeRep, isUnliftedRuntimeRep, runtimeRepLevity_maybe,         isBoxedRuntimeRep,@@ -154,7 +154,7 @@         Kind,          -- ** Finding the kind of a type-        typeKind, typeHasFixedRuntimeRep, argsHaveFixedRuntimeRep,+        typeKind, typeHasFixedRuntimeRep,         tcIsLiftedTypeKind,         isConstraintKind, isConstraintLikeKind, returnsConstraintKind,         tcIsBoxedTypeKind, isTypeLikeKind,@@ -198,15 +198,14 @@         -- ** Manipulating type substitutions         emptyTvSubstEnv, emptySubst, mkEmptySubst, -        mkSubst, zipTvSubst, mkTvSubstPrs,+        mkTCvSubst, zipTvSubst, mkTvSubstPrs,         zipTCvSubst,         notElemSubst,         getTvSubstEnv,         zapSubst, getSubstInScope, setInScope, getSubstRangeTyCoFVs,         extendSubstInScope, extendSubstInScopeList, extendSubstInScopeSet,         extendTCvSubst, extendCvSubst,-        extendTvSubst, extendTvSubstBinderAndInScope,-        extendTvSubstList, extendTvSubstAndInScope,+        extendTvSubst, extendTvSubstList, extendTvSubstAndInScope,         extendTCvSubstList,         extendTvSubstWithClone,         extendTCvSubstWithClone,@@ -288,11 +287,9 @@ import GHC.Utils.FV import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Utils.Panic.Plain import GHC.Data.FastString -import Control.Monad    ( guard )-import GHC.Data.Maybe   ( orElse, isJust )+import GHC.Data.Maybe   ( orElse, isJust, firstJust )  -- $type_classification -- #type_classification#@@ -430,7 +427,7 @@ saturates []      _ = False saturates (_:tys) n = assert( n >= 0 ) $ saturates tys (n-1)                        -- Arities are always positive; the assertion just checks-                       -- that, to avoid an ininite loop in the bad case+                       -- that, to avoid an infinite loop in the bad case  -- | A helper for 'expandSynTyConApp_maybe' to avoid inlining this cold path -- into call-sites.@@ -549,9 +546,10 @@       = mkTyConAppCo r tc (map (go_co subst) args)     go_co subst (AppCo co arg)       = mkAppCo (go_co subst co) (go_co subst arg)-    go_co subst (ForAllCo tv kind_co co)+    go_co subst (ForAllCo { fco_tcv = tv, fco_visL = visL, fco_visR = visR+                          , fco_kind = kind_co, fco_body = co })       = let (subst', tv', kind_co') = go_cobndr subst tv kind_co in-        mkForAllCo tv' kind_co' (go_co subst' co)+        mkForAllCo tv' visL visR kind_co' (go_co subst' co)     go_co subst (FunCo r afl afr w co1 co2)       = mkFunCo2 r afl afr (go_co subst w) (go_co subst co1) (go_co subst co2)     go_co subst (CoVarCo cv)@@ -582,7 +580,6 @@     go_prov subst (PhantomProv co)    = PhantomProv (go_co subst co)     go_prov subst (ProofIrrelProv co) = ProofIrrelProv (go_co subst co)     go_prov _     p@(PluginProv _)    = p-    go_prov _     p@(CorePrepProv _)  = p        -- the "False" and "const" are to accommodate the type of       -- substForAllCoBndrUsing, which is general enough to@@ -816,7 +813,7 @@             [lev] -> levityType_maybe lev             _     -> Nothing  -- Type isn't of kind RuntimeRep                      -- The latter case happens via the call to isLiftedRuntimeRep-                     -- in GHC.Tc.Errors.Ppr.pprMisMatchMsg (#22742)+                     -- in GHC.Tc.Errors.Ppr.pprMismatchMsg (#22742)     else Just Unlifted         -- Avoid searching all the unlifted RuntimeRep type cons         -- In the RuntimeRep data type, only LiftedRep is lifted@@ -827,7 +824,7 @@ --  Splitting Levity -------------------------------------------- --- | `levity_maybe` takes a Type of kind Levity, and returns its levity+-- | `levityType_maybe` takes a Type of kind Levity, and returns its levity -- May not be possible for a type variable or type family application levityType_maybe :: LevityType -> Maybe Levity levityType_maybe lev@@ -850,7 +847,7 @@  Note [Efficiency for ForAllCo case of mapTyCoX] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-As noted in Note [Forall coercions] in GHC.Core.TyCo.Rep, a ForAllCo is a bit redundant.+As noted in Note [ForAllCo] in GHC.Core.TyCo.Rep, a ForAllCo is a bit redundant. It stores a TyCoVar and a Coercion, where the kind of the TyCoVar always matches the left-hand kind of the coercion. This is convenient lots of the time, but not when mapping a function over a coercion.@@ -991,17 +988,17 @@        | otherwise       = mkTyConAppCo r tc <$> go_cos env cos-    go_co !env (ForAllCo tv kind_co co)+    go_co !env (ForAllCo { fco_tcv = tv, fco_visL = visL, fco_visR = visR+                         , fco_kind = kind_co, fco_body = co })       = do { kind_co' <- go_co env kind_co-           ; tycobinder env tv Inferred $ \env' tv' ->  do+           ; tycobinder env tv visL $ \env' tv' ->  do            ; co' <- go_co env' co-           ; return $ mkForAllCo tv' kind_co' co' }+           ; return $ mkForAllCo tv' visL visR kind_co' co' }         -- See Note [Efficiency for ForAllCo case of mapTyCoX]      go_prov !env (PhantomProv co)    = PhantomProv <$> go_co env co     go_prov !env (ProofIrrelProv co) = ProofIrrelProv <$> go_co env co     go_prov !_   p@(PluginProv _)    = return p-    go_prov !_   p@(CorePrepProv _)  = return p   {- *********************************************************************@@ -1063,14 +1060,13 @@ but suppose we want that.  But then in the call to 'i', we end up decomposing (Eq Int => Int), and we definitely don't want that. -This really only applies to the type checker; in Core, '=>' and '->'-are the same, as are 'Constraint' and '*'.  But for now I've put-the test in splitAppTyNoView_maybe, which applies throughout, because-the other calls to splitAppTy are in GHC.Core.Unify, which is also used by-the type checker (e.g. when matching type-function equations).- We are willing to split (t1 -=> t2) because the argument is still of kind Type, not Constraint.  So the criterion is isVisibleFunArg.++In Core there is no real reason to avoid such decomposition.  But for now I've+put the test in splitAppTyNoView_maybe, which applies throughout, because the+other calls to splitAppTy are in GHC.Core.Unify, which is also used by the+type checker (e.g. when matching type-function equations). -}  -- | Applies a type to another, as in e.g. @k a@@@ -1151,7 +1147,7 @@   = splitAppTyNoView_maybe ty  --------------splitAppTys :: Type -> (Type, [Type])+splitAppTys :: HasDebugCallStack => Type -> (Type, [Type]) -- ^ Recursively splits a type as far as is possible, leaving a residual -- type being applied to and the type arguments applied to it. Never fails, -- even if that means returning an empty list of type applications.@@ -1238,14 +1234,42 @@ -- | Is this type a custom user error? -- If so, give us the error message. userTypeError_maybe :: Type -> Maybe ErrorMsgType-userTypeError_maybe t-  = do { (tc, _kind : msg : _) <- splitTyConApp_maybe t+userTypeError_maybe ty+  | Just ty' <- coreView ty = userTypeError_maybe ty'+userTypeError_maybe (TyConApp tc (_kind : msg : _))+  | tyConName tc == errorMessageTypeErrorFamName           -- There may be more than 2 arguments, if the type error is           -- used as a type constructor (e.g. at kind `Type -> Type`).+  = Just msg+userTypeError_maybe _+  = Nothing -       ; guard (tyConName tc == errorMessageTypeErrorFamName)-       ; return msg }+deepUserTypeError_maybe :: Type -> Maybe ErrorMsgType+-- Look for custom user error, deeply inside the type+deepUserTypeError_maybe ty+  | Just ty' <- coreView ty = userTypeError_maybe ty'+deepUserTypeError_maybe (TyConApp tc tys)+  | tyConName tc == errorMessageTypeErrorFamName+  , _kind : msg : _ <- tys+          -- There may be more than 2 arguments, if the type error is+          -- used as a type constructor (e.g. at kind `Type -> Type`).+  = Just msg +  | tyConMustBeSaturated tc  -- Don't go looking for user type errors+                             -- inside type family arguments (see #20241).+  = foldr (firstJust . deepUserTypeError_maybe) Nothing (drop (tyConArity tc) tys)+  | otherwise+  = foldr (firstJust . deepUserTypeError_maybe) Nothing tys+deepUserTypeError_maybe (ForAllTy _ ty) = deepUserTypeError_maybe ty+deepUserTypeError_maybe (FunTy { ft_arg = arg, ft_res = res })+  = deepUserTypeError_maybe arg `firstJust` deepUserTypeError_maybe res+deepUserTypeError_maybe (AppTy t1 t2)+  = deepUserTypeError_maybe t1 `firstJust` deepUserTypeError_maybe t2+deepUserTypeError_maybe (CastTy ty _)+  = deepUserTypeError_maybe ty+deepUserTypeError_maybe _   -- TyVarTy, CoercionTy, LitTy+  = Nothing+ -- | Render a type corresponding to a user type error into a SDoc. pprUserTypeErrorTy :: ErrorMsgType -> SDoc pprUserTypeErrorTy ty =@@ -1419,7 +1443,7 @@   | FunTy { ft_res = res } <- coreFullView ty = res   | otherwise                                 = pprPanic "funResultTy" (ppr ty) -funArgTy :: Type -> Type+funArgTy :: HasDebugCallStack => Type -> Type -- ^ Extract the function argument type and panic if that is not possible funArgTy ty   | FunTy { ft_arg = arg } <- coreFullView ty = arg@@ -1473,8 +1497,9 @@   | FunTy { ft_res = res } <- ty   = piResultTys res args -  | ForAllTy (Bndr tv _) res <- ty-  = go (extendTCvSubst init_subst tv arg) res args+  | ForAllTy (Bndr tcv _) res <- ty+  = -- Both type and coercion variables+    go (extendTCvSubst init_subst tcv arg) res args    | Just ty' <- coreView ty   = piResultTys ty' orig_args@@ -1587,7 +1612,7 @@                           Just (_, tys) -> Just tys                           Nothing       -> Nothing -tyConAppArgs :: HasDebugCallStack => Type -> [Type]+tyConAppArgs :: HasCallStack => Type -> [Type] tyConAppArgs ty = tyConAppArgs_maybe ty `orElse` pprPanic "tyConAppArgs" (ppr ty)  -- | Attempts to tease a type apart into a type constructor and the application@@ -1601,7 +1626,7 @@ splitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type]) splitTyConApp_maybe ty = splitTyConAppNoView_maybe (coreFullView ty) -splitTyConAppNoView_maybe :: Type -> Maybe (TyCon, [Type])+splitTyConAppNoView_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type]) -- Same as splitTyConApp_maybe but without looking through synonyms splitTyConAppNoView_maybe ty   = case ty of@@ -1620,14 +1645,14 @@ -- of a 'FunTy' with an argument of unknown kind 'FunTy' -- (e.g. `FunTy (a :: k) Int`, since the kind of @a@ isn't of -- the form `TYPE rep`.  This isn't usually a problem but may--- be temporarily the cas during canonicalization:+-- be temporarily the case during canonicalization: --     see Note [Decomposing FunTy] in GHC.Tc.Solver.Equality --     and Note [The Purely Kinded Type Invariant (PKTI)] in GHC.Tc.Gen.HsType, --         Wrinkle around FunTy -- -- Consequently, you may need to zonk your type before -- using this function.-tcSplitTyConApp_maybe :: HasDebugCallStack => Type -> Maybe (TyCon, [Type])+tcSplitTyConApp_maybe :: HasCallStack => Type -> Maybe (TyCon, [Type]) -- Defined here to avoid module loops between Unify and TcType. tcSplitTyConApp_maybe ty   = case coreFullView ty of@@ -1763,15 +1788,26 @@     to_tyb (Bndr tv (NamedTCB vis)) = Named (Bndr tv vis)     to_tyb (Bndr tv AnonTCB)        = Anon (tymult (varType tv)) FTF_T_T --- | Make a dependent forall over an 'Inferred' variable-mkTyCoInvForAllTy :: TyCoVar -> Type -> Type-mkTyCoInvForAllTy tv ty+-- | Make a dependent forall over a TyCoVar+mkTyCoForAllTy :: TyCoVar -> ForAllTyFlag -> Type -> Type+mkTyCoForAllTy tv vis ty   | isCoVar tv   , not (tv `elemVarSet` tyCoVarsOfType ty)+   -- Maintain ForAllTy's invariants+    -- See Note [Unused coercion variable in ForAllTy] in GHC.Core.TyCo.Rep   = mkVisFunTyMany (varType tv) ty   | otherwise-  = ForAllTy (Bndr tv Inferred) ty+  = ForAllTy (mkForAllTyBinder vis tv) ty +-- | Make a dependent forall over a TyCoVar+mkTyCoForAllTys :: [ForAllTyBinder] -> Type -> Type+mkTyCoForAllTys bndrs ty+  = foldr (\(Bndr var vis) -> mkTyCoForAllTy var vis) ty bndrs++-- | Make a dependent forall over an 'Inferred' variable+mkTyCoInvForAllTy :: TyCoVar -> Type -> Type+mkTyCoInvForAllTy tv ty = mkTyCoForAllTy tv Inferred ty+ -- | Like 'mkTyCoInvForAllTy', but tv should be a tyvar mkInfForAllTy :: TyVar -> Type -> Type mkInfForAllTy tv ty = assert (isTyVar tv )@@ -1937,14 +1973,20 @@     go ty | Just ty' <- coreView ty = go ty'     go res                         = res --- | Attempts to take a forall type apart, but only if it's a proper forall,--- with a named binder+-- | Attempts to take a ForAllTy apart, returning the full ForAllTyBinder+splitForAllForAllTyBinder_maybe :: Type -> Maybe (ForAllTyBinder, Type)+splitForAllForAllTyBinder_maybe ty+  | ForAllTy bndr inner_ty <- coreFullView ty = Just (bndr, inner_ty)+  | otherwise                                 = Nothing+++-- | Attempts to take a ForAllTy apart, returning the Var splitForAllTyCoVar_maybe :: Type -> Maybe (TyCoVar, Type) splitForAllTyCoVar_maybe ty   | ForAllTy (Bndr tv _) inner_ty <- coreFullView ty = Just (tv, inner_ty)   | otherwise                                        = Nothing --- | Like 'splitForAllTyCoVar_maybe', but only returns Just if it is a tyvar binder.+-- | Attempts to take a ForAllTy apart, but only if the binder is a TyVar splitForAllTyVar_maybe :: Type -> Maybe (TyVar, Type) splitForAllTyVar_maybe ty   | ForAllTy (Bndr tv _) inner_ty <- coreFullView ty@@ -2276,6 +2318,11 @@ typeLevity_maybe :: HasDebugCallStack => Type -> Maybe Levity typeLevity_maybe ty = runtimeRepLevity_maybe (getRuntimeRep ty) +typeLevity :: HasDebugCallStack => Type -> Levity+typeLevity ty = case typeLevity_maybe ty of+                   Just lev -> lev+                   Nothing  -> pprPanic "typeLevity" (ppr ty)+ -- | Is the given type definitely unlifted? -- See "Type#type_classification" for what an unlifted type is. --@@ -2286,8 +2333,6 @@         -- isUnliftedType returns True for forall'd unlifted types:         --      x :: forall a. Int#         -- I found bindings like these were getting floated to the top level.-        -- They are pretty bogus types, mind you.  It would be better never to-        -- construct them isUnliftedType ty =   case typeLevity_maybe ty of     Just Lifted   -> False@@ -2634,18 +2679,20 @@     go fun             args = piResultTys (typeKind fun) args  typeKind ty@(ForAllTy {})-  = case occCheckExpand tvs body_kind of-      -- We must make sure tv does not occur in kind-      -- As it is already out of scope!+  = assertPpr (not (null tcvs)) (ppr ty) $+       -- If tcvs is empty somehow we'll get an infinite loop!+    case occCheckExpand tcvs body_kind of+      -- We must make sure tvs do not occur in kind,+      -- as they would be out of scope!       -- See Note [Phantom type variables in kinds]       Nothing -> pprPanic "typeKind"-                  (ppr ty $$ ppr tvs $$ ppr body <+> dcolon <+> ppr body_kind)+                  (ppr ty $$ ppr tcvs $$ ppr body <+> dcolon <+> ppr body_kind) -      Just k' | all isTyVar tvs -> k'                     -- Rule (FORALL1)-              | otherwise       -> lifted_kind_from_body  -- Rule (FORALL2)+      Just k' | all isTyVar tcvs -> k'                     -- Rule (FORALL1)+              | otherwise        -> lifted_kind_from_body  -- Rule (FORALL2)   where-    (tvs, body) = splitForAllTyVars ty-    body_kind   = typeKind body+    (tcvs, body) = splitForAllTyCoVars ty  -- Important: splits both TyVar and CoVar binders+    body_kind    = typeKind body      lifted_kind_from_body  -- Implements (FORALL2)       = case sORTKind_maybe body_kind of@@ -2782,19 +2829,6 @@     go (LitTy {})               = True     go (ForAllTy _ ty)          = go ty     go ty                       = isFixedRuntimeRepKind (typeKind ty)--argsHaveFixedRuntimeRep :: Type -> Bool--- ^ True if the argument types of this function type--- all have a fixed-runtime-rep-argsHaveFixedRuntimeRep ty-  = all ok bndrs-  where-    ok :: PiTyBinder -> Bool-    ok (Anon ty _) = typeHasFixedRuntimeRep (scaledThing ty)-    ok _           = True--    bndrs :: [PiTyBinder]-    (bndrs, _) = splitPiTys ty  -- | Checks that a kind of the form 'Type', 'Constraint' -- or @'TYPE r@ is concrete. See 'isConcreteType'.
compiler/GHC/Core/Unfold.hs view
@@ -16,7 +16,6 @@ -}  -{-# LANGUAGE BangPatterns #-}  module GHC.Core.Unfold (         Unfolding, UnfoldingGuidance,   -- Abstract types@@ -180,24 +179,6 @@   ppr RuleArgCtxt = text "RuleArgCtxt"  {--Note [Occurrence analysis of unfoldings]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We do occurrence-analysis of unfoldings once and for all, when the-unfolding is built, rather than each time we inline them.--But given this decision it's vital that we do-*always* do it.  Consider this unfolding-    \x -> letrec { f = ...g...; g* = f } in body-where g* is (for some strange reason) the loop breaker.  If we don't-occ-anal it when reading it in, we won't mark g as a loop breaker, and-we may inline g entirely in body, dropping its binding, and leaving-the occurrence in f out of scope. This happened in #8892, where-the unfolding in question was a DFun unfolding.--But more generally, the simplifier is designed on the-basis that it is looking at occurrence-analysed expressions, so better-ensure that they actually are.- Note [Calculate unfolding guidance on the non-occ-anal'd expression] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Notice that we give the non-occur-analysed expression to@@ -249,9 +230,13 @@                         , exprIsTrivial a  = go (credit-1) f     go credit (Tick _ e)                   = go credit e -- dubious     go credit (Cast e _)                   = go credit e-    go credit (Case scrut _ _ [Alt _ _ rhs]) -- See Note [Inline unsafeCoerce]-      | isUnsafeEqualityProof scrut        = go credit rhs+    go credit (Case e b _ alts)+      | null alts+      = go credit e   -- EmptyCase is like e+      | Just rhs <- isUnsafeEqualityCase e b alts+      = go credit rhs -- See Note [Inline unsafeCoerce]     go _      (Var {})                     = boringCxtOk+    go _      (Lit l)                      = litIsTrivial l && boringCxtOk     go _      _                            = boringCxtNotOk  calcUnfoldingGuidance@@ -303,7 +288,7 @@ We really want to inline unsafeCoerce, even when applied to boring arguments.  It doesn't look as if its RHS is smaller than the call    unsafeCoerce x = case unsafeEqualityProof @a @b of UnsafeRefl -> x-but that case is discarded -- see Note [Implementing unsafeCoerce]+but that case is discarded in CoreToStg -- see Note [Implementing unsafeCoerce] in base:Unsafe.Coerce.  Moreover, if we /don't/ inline it, we may be left with@@ -311,7 +296,9 @@ which will build a thunk -- bad, bad, bad.  Conclusion: we really want inlineBoringOk to be True of the RHS of-unsafeCoerce.  This is (U4) in Note [Implementing unsafeCoerce].+unsafeCoerce. And it really is, because we regard+  case unsafeEqualityProof @a @b of UnsafeRefl -> rhs+as trivial iff rhs is. This is (U4) in Note [Implementing unsafeCoerce].  Note [Computing the size of an expression] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -563,7 +550,7 @@                 = False      size_up_rhs (bndr, rhs)-      | Just join_arity <- isJoinId_maybe bndr+      | JoinPoint join_arity <- idJoinPointHood bndr         -- Skip arguments to join point       , (_bndrs, body) <- collectNBinders join_arity rhs       = size_up body
compiler/GHC/Core/Unfold/Make.hs view
@@ -86,7 +86,7 @@   = DFunUnfolding { df_bndrs = bndrs                   , df_con = con                   , df_args = map occurAnalyseExpr ops }-                  -- See Note [Occurrence analysis of unfoldings]+                  -- See Note [OccInfo in unfoldings and rules] in GHC.Core  mkDataConUnfolding :: CoreExpr -> Unfolding -- Used for non-newtype data constructors with non-trivial wrappers@@ -338,7 +338,7 @@ mkCoreUnfolding src top_lvl expr precomputed_cache guidance   = CoreUnfolding { uf_tmpl = cache `seq`                               occurAnalyseExpr expr-      -- occAnalyseExpr: see Note [Occurrence analysis of unfoldings]+      -- occAnalyseExpr: see Note [OccInfo in unfoldings and rules] in GHC.Core       -- See #20905 for what a discussion of this 'seq'.       -- We are careful to make sure we only       -- have one copy of an unfolding around at once.@@ -459,7 +459,7 @@ a single CoreExpr. One place where we have to be careful is in mkCoreUnfolding.  * The template of the unfolding is the result of performing occurrence analysis-  (Note [Occurrence analysis of unfoldings])+  (Note [OccInfo in unfoldings and rules] in GHC.Core) * Predicates are applied to the unanalysed expression  Therefore if we are not thoughtful about forcing you can end up in a situation where the
compiler/GHC/Core/Unify.hs view
@@ -49,7 +49,6 @@ import GHC.Types.Unique.Set import GHC.Exts( oneShot ) import GHC.Utils.Panic-import GHC.Utils.Panic.Plain import GHC.Data.FastString  import Data.List ( mapAccumL )@@ -1485,7 +1484,7 @@ getSubst env = do { tv_env <- getTvSubstEnv                   ; cv_env <- getCvSubstEnv                   ; let in_scope = rnInScopeSet (um_rn_env env)-                  ; return (mkSubst in_scope tv_env cv_env emptyIdSubstEnv) }+                  ; return (mkTCvSubst in_scope tv_env cv_env) }  extendTvEnv :: TyVar -> Type -> UM () extendTvEnv tv ty = UM $ \state ->@@ -1678,10 +1677,14 @@     -- NB: we include the RuntimeRep arguments in the matching;     --     not doing so caused #21205. -ty_co_match menv subst (ForAllTy (Bndr tv1 _) ty1)-                       (ForAllCo tv2 kind_co2 co2)+ty_co_match menv subst (ForAllTy (Bndr tv1 vis1t) ty1)+                       (ForAllCo tv2 vis1c vis2c kind_co2 co2)                        lkco rkco   | isTyVar tv1 && isTyVar tv2+  , vis1t == vis1c && vis1c == vis2c -- Is this necessary?+      -- Is this visibility check necessary?  @rae says: yes, I think the+      -- check is necessary, if we're caring about visibility (and we are).+      -- But ty_co_match is a dark and not important corner.   = do { subst1 <- ty_co_match menv subst (tyVarKind tv1) kind_co2                                ki_ki_co ki_ki_co        ; let rn_env0 = me_env menv@@ -1781,9 +1784,10 @@       ->  Just (FunCo r af af (mkReflCo r w) (mkReflCo r ty1) (mkReflCo r ty2))     Just (TyConApp tc tys, r)       -> Just (TyConAppCo r tc (zipWith mkReflCo (tyConRoleListX r tc) tys))-    Just (ForAllTy (Bndr tv _) ty, r)-      -> Just (ForAllCo tv (mkNomReflCo (varType tv)) (mkReflCo r ty))-    -- NB: NoRefl variant. Otherwise, we get a loop!+    Just (ForAllTy (Bndr tv vis) ty, r)+      -> Just (ForAllCo { fco_tcv = tv, fco_visL = vis, fco_visR = vis+                        , fco_kind = mkNomReflCo (varType tv)+                        , fco_body = mkReflCo r ty })     _ -> Nothing  {-
compiler/GHC/Core/Utils.hs view
@@ -11,7 +11,7 @@         -- * Constructing expressions         mkCast, mkCastMCo, mkPiMCo,         mkTick, mkTicks, mkTickNoHNF, tickHNFArgs,-        bindNonRec, needsCaseBinding,+        bindNonRec, needsCaseBinding, needsCaseBindingL,         mkAltExpr, mkDefaultCase, mkSingleAltCase,          -- * Taking expressions apart@@ -21,12 +21,13 @@         scaleAltsBy,          -- * Properties of expressions-        exprType, coreAltType, coreAltsType, mkLamType, mkLamTypes,+        exprType, coreAltType, coreAltsType,+        mkLamType, mkLamTypes,         mkFunctionType,         exprIsTrivial, getIdFromTrivialExpr, getIdFromTrivialExpr_maybe,         trivial_expr_fold,         exprIsDupable, exprIsCheap, exprIsExpandable, exprIsCheapX, CheapAppFun,-        exprIsHNF, exprOkForSpeculation, exprOkForSideEffects, exprOkForSpecEval,+        exprIsHNF, exprOkForSpeculation, exprOkToDiscard, exprOkForSpecEval,         exprIsWorkFree, exprIsConLike,         isCheapApp, isExpandableApp, isSaturatedConApp,         exprIsTickedString, exprIsTickedString_maybe,@@ -59,7 +60,7 @@         mkStrictFieldSeqs, shouldStrictifyIdForCbv, shouldUseCbvForId,          -- * unsafeEqualityProof-        isUnsafeEqualityProof,+        isUnsafeEqualityCase,          -- * Dumping stuff         dumpIdInfoOfProgram@@ -79,7 +80,7 @@ import GHC.Core.TyCon import GHC.Core.Multiplicity -import GHC.Builtin.Names ( makeStaticName, unsafeEqualityProofIdKey )+import GHC.Builtin.Names ( makeStaticName, unsafeEqualityProofIdKey, unsafeReflDataConKey ) import GHC.Builtin.PrimOps  import GHC.Types.Var@@ -104,7 +105,6 @@ import GHC.Utils.Constants (debugIsOn) import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Utils.Panic.Plain import GHC.Utils.Misc  import Data.ByteString     ( ByteString )@@ -161,17 +161,20 @@ -- ^ Makes a @(->)@ type or an implicit forall type, depending -- on whether it is given a type variable or a term variable. -- This is used, for example, when producing the type of a lambda.--- Always uses Inferred binders.+-- mkLamTypes :: [Var] -> Type -> Type -- ^ 'mkLamType' for multiple type or value arguments  mkLamType v body_ty    | isTyVar v-   = mkForAllTy (Bndr v Inferred) body_ty+   = mkForAllTy (Bndr v coreTyLamForAllTyFlag) body_ty+     -- coreTyLamForAllTyFlag: see (FC4) in Note [ForAllCo]+     --                        in GHC.Core.TyCo.Rep     | isCoVar v    , v `elemVarSet` tyCoVarsOfType body_ty-   = mkForAllTy (Bndr v Required) body_ty+     -- See Note [Unused coercion variable in ForAllTy] in GHC.Core.TyCo.Rep+   = mkForAllTy (Bndr v coreTyLamForAllTyFlag) body_ty     | otherwise    = mkFunctionType (varMult v) (varType v) body_ty@@ -510,15 +513,22 @@     case_bind = mkDefaultCase rhs bndr body     let_bind  = Let (NonRec bndr rhs) body --- | Tests whether we have to use a @case@ rather than @let@ binding for this--- expression as per the invariants of 'CoreExpr': see "GHC.Core#let_can_float_invariant"-needsCaseBinding :: Type -> CoreExpr -> Bool-needsCaseBinding ty rhs-  = mightBeUnliftedType ty && not (exprOkForSpeculation rhs)-        -- Make a case expression instead of a let-        -- These can arise either from the desugarer,-        -- or from beta reductions: (\x.e) (x +# y)+-- | `needsCaseBinding` tests whether we have to use a @case@ rather than @let@+-- binding for this expression as per the invariants of 'CoreExpr': see+-- "GHC.Core#let_can_float_invariant"+-- (needsCaseBinding ty rhs) requires that `ty` has a well-defined levity, else+-- `typeLevity ty` will fail; but that should be the case because+-- `needsCaseBinding` is only called once typechecking is complete+needsCaseBinding :: HasDebugCallStack => Type -> CoreExpr -> Bool+needsCaseBinding ty rhs = needsCaseBindingL (typeLevity ty) rhs +needsCaseBindingL :: Levity -> CoreExpr -> Bool+-- True <=> make a case expression instead of a let+-- These can arise either from the desugarer,+-- or from beta reductions: (\x.e) (x +# y)+needsCaseBindingL Lifted   _rhs = False+needsCaseBindingL Unlifted rhs = not (exprOkForSpeculation rhs)+ mkAltExpr :: AltCon     -- ^ Case alternative constructor           -> [CoreBndr] -- ^ Things bound by the pattern match           -> [Type]     -- ^ The type arguments to the case alternative@@ -1064,6 +1074,9 @@ -- * `case e of {}` an empty case trivial_expr_fold k_id k_lit k_triv k_not_triv = go   where+    -- If you change this function, be sure to change SetLevels.notWorthFloating+    -- as well!+    -- (Or yet better: Come up with a way to share code with this function.)     go (Var v)                            = k_id v  -- See Note [Variables are trivial]     go (Lit l)    | litIsTrivial l        = k_lit l     go (Type _)                           = k_triv@@ -1072,7 +1085,11 @@     go (Lam b e)  | not (isRuntimeVar b)  = go e     go (Tick t e) | not (tickishIsCode t) = go e              -- See Note [Tick trivial]     go (Cast e _)                         = go e-    go (Case e _ _ [])                    = go e              -- See Note [Empty case is trivial]+    go (Case e b _ as)+      | null as+      = go e     -- See Note [Empty case is trivial]+      | Just rhs <- isUnsafeEqualityCase e b as+      = go rhs   -- See (U2) of Note [Implementing unsafeCoerce] in base:Unsafe.Coerce     go _                                  = k_not_triv  exprIsTrivial :: CoreExpr -> Bool@@ -1383,6 +1400,7 @@   | otherwise   = case idDetails fn of       DataConWorkId {} -> True+      PrimOpId op _    -> primOpIsWorkFree op       _                -> False  isCheapApp :: CheapAppFun@@ -1490,35 +1508,46 @@ -}  -------------------------------- | 'exprOkForSpeculation' returns True of an expression that is:+-- | To a first approximation, 'exprOkForSpeculation' returns True of+-- an expression that is: -- --  * Safe to evaluate even if normal order eval might not---    evaluate the expression at all, or+--    evaluate the expression at all, and -- --  * Safe /not/ to evaluate even if normal order would do so ----- It is usually called on arguments of unlifted type, but not always--- In particular, Simplify.rebuildCase calls it on lifted types--- when a 'case' is a plain 'seq'. See the example in--- Note [exprOkForSpeculation: case expressions] below+-- More specifically, this means that:+--  * A: Evaluation of the expression reaches weak-head-normal-form,+--  * B: soon,+--  * C: without causing a write side effect (e.g. writing a mutable variable). ----- Precisely, it returns @True@ iff:---  a) The expression guarantees to terminate,---  b) soon,---  c) without causing a write side effect (e.g. writing a mutable variable)---  d) without throwing a Haskell exception---  e) without risking an unchecked runtime exception (array out of bounds,---     divide by zero)+-- In particular, an expression that may+--  * throw a synchronous Haskell exception, or+--  * risk an unchecked runtime exception (e.g. array+--    out of bounds, divide by zero)+-- is /not/ considered OK-for-speculation, as these violate condition A. ----- For @exprOkForSideEffects@ the list is the same, but omitting (e).+-- For 'exprOkToDiscard', condition A is weakened to allow expressions+-- that might risk an unchecked runtime exception but must otherwise+-- reach weak-head-normal-form.+-- (Note that 'exprOkForSpeculation' implies 'exprOkToDiscard') ----- Note that---    exprIsHNF            implies exprOkForSpeculation---    exprOkForSpeculation implies exprOkForSideEffects+-- But in fact both functions are a bit more conservative than the above,+-- in at least the following ways: ----- See Note [PrimOp can_fail and has_side_effects] in "GHC.Builtin.PrimOps"--- and Note [Transformations affected by can_fail and has_side_effects]+--  * W1: We do not take advantage of already-evaluated lifted variables.+--        As a result, 'exprIsHNF' DOES NOT imply 'exprOkForSpeculation';+--        if @y@ is a case-binder of lifted type, then @exprIsHNF y@ is+--        'True', while @exprOkForSpeculation y@ is 'False'.+--        See Note [exprOkForSpeculation and evaluated variables] for why.+--  * W2: Read-effects on mutable variables are currently also included.+--        See Note [Classifying primop effects] "GHC.Builtin.PrimOps".+--  * W3: Currently, 'exprOkForSpeculation' always returns 'False' for+--        let-expressions.  Lets can be stacked deeply, so we just give up.+--        In any case, the argument of 'exprOkForSpeculation' is usually in+--        a strict context, so any lets will have been floated away. --+-- -- As an example of the considerations in this test, consider: -- -- > let x = case y# +# 1# of { r# -> I# r# }@@ -1531,12 +1560,24 @@ -- >    in E -- > } ----- We can only do this if the @y + 1@ is ok for speculation: it has no+-- We can only do this if the @y# +# 1#@ is ok for speculation: it has no -- side effects, and can't diverge or raise an exception.+--+--+-- See also Note [Classifying primop effects] in "GHC.Builtin.PrimOps"+-- and Note [Transformations affected by primop effects].+--+-- 'exprOkForSpeculation' is used to define Core's let-can-float+-- invariant.  (See Note [Core let-can-float invariant] in+-- "GHC.Core".)  It is therefore frequently called on arguments of+-- unlifted type, especially via 'needsCaseBinding'.  But it is+-- sometimes called on expressions of lifted type as well.  For+-- example, see Note [Speculative evaluation] in "GHC.CoreToStg.Prep". -exprOkForSpeculation, exprOkForSideEffects :: CoreExpr -> Bool++exprOkForSpeculation, exprOkToDiscard :: CoreExpr -> Bool exprOkForSpeculation = expr_ok fun_always_ok primOpOkForSpeculation-exprOkForSideEffects = expr_ok fun_always_ok primOpOkForSideEffects+exprOkToDiscard      = expr_ok fun_always_ok primOpOkToDiscard  fun_always_ok :: Id -> Bool fun_always_ok _ = True@@ -1566,10 +1607,7 @@    | otherwise             = expr_ok fun_ok primop_ok e  expr_ok _ _ (Let {}) = False-  -- Lets can be stacked deeply, so just give up.-  -- In any case, the argument of exprOkForSpeculation is-  -- usually in a strict context, so any lets will have been-  -- floated away.+-- See W3 in the Haddock comment for exprOkForSpeculation  expr_ok fun_ok primop_ok (Case scrut bndr _ alts)   =  -- See Note [exprOkForSpeculation: case expressions]@@ -1601,16 +1639,24 @@ app_ok fun_ok primop_ok fun args   | not (fun_ok fun)   = False -- This code path is only taken for Note [Speculative evaluation]++  | idArity fun > n_val_args+  -- Partial application: just check passing the arguments is OK+  = args_ok+   | otherwise   = case idDetails fun of-      DFunId new_type ->  not new_type+      DFunId new_type -> not new_type          -- DFuns terminate, unless the dict is implemented          -- with a newtype in which case they may not -      DataConWorkId {} -> True+      DataConWorkId {} -> args_ok                 -- The strictness of the constructor has already                 -- been expressed by its "wrapper", so we don't need                 -- to take the arguments into account+                   -- Well, we thought so.  But it's definitely wrong!+                   -- See #20749 and Note [How untagged pointers can+                   -- end up in strict fields] in GHC.Stg.InferTags        ClassOpId _ is_terminating_result         | is_terminating_result -- See Note [exprOkForSpeculation and type classes]@@ -1632,16 +1678,7 @@               -- Often there is a literal divisor, and this               -- can get rid of a thunk in an inner loop -        | SeqOp <- op  -- See Note [exprOkForSpeculation and SeqOp/DataToTagOp]-        -> False       --     for the special cases for SeqOp and DataToTagOp-        | DataToTagOp <- op-        -> False-        | KeepAliveOp <- op-        -> False--        | otherwise-        -> primop_ok op  -- Check the primop itself-        && and (zipWith arg_ok arg_tys args)  -- Check the arguments+        | otherwise -> primop_ok op && args_ok        _other  -- Unlifted and terminating types;               -- Also c.f. the Var case of exprIsHNF@@ -1654,12 +1691,8 @@                   -- (If we added unlifted function types this would change,                   -- and we'd need to actually test n_val_args == 0.) -         -- Partial applications-         | idArity fun > n_val_args ->-           and (zipWith arg_ok arg_tys args)  -- Check the arguments-          -- Functions that terminate fast without raising exceptions etc-         -- See Note [Discarding unnecessary unsafeEqualityProofs]+         -- See (U12) of Note [Implementing unsafeCoerce]          | fun `hasKey` unsafeEqualityProofIdKey -> True           | otherwise -> False@@ -1671,12 +1704,14 @@     n_val_args   = valArgCount args     (arg_tys, _) = splitPiTys fun_ty -    -- Used for arguments to primops and to partial applications+    -- Even if a function call itself is OK, any unlifted+    -- args are still evaluated eagerly and must be checked+    args_ok = and (zipWith arg_ok arg_tys args)     arg_ok :: PiTyVarBinder -> CoreExpr -> Bool     arg_ok (Named _) _ = True   -- A type argument     arg_ok (Anon ty _) arg      -- A term argument        | definitelyLiftedType (scaledThing ty)-       = True -- See Note [Primops with lifted arguments]+       = True -- lifted args are not evaluated eagerly        | otherwise        = expr_ok fun_ok primop_ok arg @@ -1685,7 +1720,7 @@ -- True  <=> the case alternatives are definitely exhaustive -- False <=> they may or may not be altsAreExhaustive []-  = False    -- Should not happen+  = True    -- The scrutinee never returns; see Note [Empty case alternatives] in GHC.Core altsAreExhaustive (Alt con1 _ _ : alts)   = case con1 of       DEFAULT   -> True@@ -1823,78 +1858,37 @@ ------- End of historical note ------------  -Note [Primops with lifted arguments]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Is this ok-for-speculation (see #13027)?-   reallyUnsafePtrEquality# a b-Well, yes.  The primop accepts lifted arguments and does not-evaluate them.  Indeed, in general primops are, well, primitive-and do not perform evaluation.--Bottom line:-  * In exprOkForSpeculation we simply ignore all lifted arguments.-  * In the rare case of primops that /do/ evaluate their arguments,-    (namely DataToTagOp and SeqOp) return False; see-    Note [exprOkForSpeculation and evaluated variables]--Note [exprOkForSpeculation and SeqOp/DataToTagOp]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Most primops with lifted arguments don't evaluate them-(see Note [Primops with lifted arguments]), so we can ignore-that argument entirely when doing exprOkForSpeculation.--But DataToTagOp and SeqOp are exceptions to that rule.-For reasons described in Note [exprOkForSpeculation and-evaluated variables], we simply return False for them.--Not doing this made #5129 go bad.-Lots of discussion in #15696.- Note [exprOkForSpeculation and evaluated variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Recall that-  seq#       :: forall a s. a -> State# s -> (# State# s, a #)-  dataToTag# :: forall a.   a -> Int#-must always evaluate their first argument.--Now consider these examples:+Consider these examples:  * case x of y { DEFAULT -> ....y.... }    Should 'y' (alone) be considered ok-for-speculation? - * case x of y { DEFAULT -> ....let z = dataToTag# y... }-   Should (dataToTag# y) be considered ok-for-spec?+ * case x of y { DEFAULT -> ....let z = dataToTagLarge# y... }+   Should (dataToTagLarge# y) be considered ok-for-spec? Recall that+     dataToTagLarge# :: forall a. a -> Int#+   must always evaluate its argument. (See also Note [DataToTag overview].)  You could argue 'yes', because in the case alternative we know that 'y' is evaluated.  But the binder-swap transformation, which is extremely useful for float-out, changes these expressions to    case x of y { DEFAULT -> ....x.... }-   case x of y { DEFAULT -> ....let z = dataToTag# x... }+   case x of y { DEFAULT -> ....let z = dataToTagLarge# x... }  And now the expression does not obey the let-can-float invariant!  Yikes!-Moreover we really might float (dataToTag# x) outside the case,+Moreover we really might float (dataToTagLarge# x) outside the case, and then it really, really doesn't obey the let-can-float invariant.  The solution is simple: exprOkForSpeculation does not try to take advantage of the evaluated-ness of (lifted) variables.  And it returns-False (always) for DataToTagOp and SeqOp.+False (always) for primops that perform evaluation.  We achieve the latter+by marking the relevant primops as "ThrowsException" or+"ReadWriteEffect"; see also Note [Classifying primop effects] in+GHC.Builtin.PrimOps.  Note that exprIsHNF /can/ and does take advantage of evaluated-ness; it doesn't have the trickiness of the let-can-float invariant to worry about. -Note [Discarding unnecessary unsafeEqualityProofs]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In #20143 we found-   case unsafeEqualityProof @t1 @t2 of UnsafeRefl cv[dead] -> blah-where 'blah' didn't mention 'cv'.  We'd like to discard this-redundant use of unsafeEqualityProof, via GHC.Core.Opt.Simplify.rebuildCase.-To do this we need to know-  (a) that cv is unused (done by OccAnal), and-  (b) that unsafeEqualityProof terminates rapidly without side effects.--At the moment we check that explicitly here in exprOkForSideEffects,-but one might imagine a more systematic check in future.-- ************************************************************************ *                                                                      *              exprIsHNF, exprIsConLike@@ -1906,15 +1900,15 @@ -- ~~~~~~~~~~~~~~~~ -- | exprIsHNF returns true for expressions that are certainly /already/ -- evaluated to /head/ normal form.  This is used to decide whether it's ok--- to change:+-- to perform case-to-let for lifted expressions, which changes: ----- > case x of _ -> e+-- > case x of x' { _ -> e } -- --    into: ----- > e+-- > let x' = x in e ----- and to decide whether it's safe to discard a 'seq'.+-- and in so doing makes the binding lazy. -- -- So, it does /not/ treat variables as evaluated, unless they say they are. -- However, it /does/ treat partial applications and constructor applications@@ -1978,6 +1972,9 @@       | isValArg a               = app_is_value e 1       | otherwise                = is_hnf_like e     is_hnf_like (Let _ e)        = is_hnf_like e  -- Lazy let(rec)s don't affect us+    is_hnf_like (Case e b _ as)+      | Just rhs <- isUnsafeEqualityCase e b as+      = is_hnf_like rhs     is_hnf_like _                = False      -- 'n' is the number of value args to which the expression is applied@@ -2185,10 +2182,11 @@  -- Used by diffBinds, which is itself only used in GHC.Core.Lint.lintAnnots eqTickish :: RnEnv2 -> CoreTickish -> CoreTickish -> Bool-eqTickish env (Breakpoint lext lid lids) (Breakpoint rext rid rids)+eqTickish env (Breakpoint lext lid lids lmod) (Breakpoint rext rid rids rmod)       = lid == rid &&         map (rnOccL env) lids == map (rnOccR env) rids &&-        lext == rext+        lext == rext &&+        lmod == rmod eqTickish _ l r = l == r  -- | Finds differences between core bindings, see @diffExpr@.@@ -2672,7 +2670,7 @@  -- When we strictify we want to skip strict args otherwise the logic is the same -- as for shouldUseCbvForId so we common up the logic here.--- Basically returns true if it would be benefitial for runtime to pass this argument+-- Basically returns true if it would be beneficial for runtime to pass this argument -- as CBV independent of weither or not it's correct. E.g. it might return true for lazy args -- we are not allowed to force. wantCbvForId :: Bool -> Var -> Bool@@ -2707,11 +2705,20 @@ *                                                                      * ********************************************************************* -} -isUnsafeEqualityProof :: CoreExpr -> Bool+isUnsafeEqualityCase :: CoreExpr -> Id -> [CoreAlt] -> Maybe CoreExpr -- See (U3) and (U4) in -- Note [Implementing unsafeCoerce] in base:Unsafe.Coerce-isUnsafeEqualityProof e-  | Var v `App` Type _ `App` Type _ `App` Type _ <- e-  = v `hasKey` unsafeEqualityProofIdKey+isUnsafeEqualityCase scrut bndr alts+  | [Alt ac _ rhs] <- alts+  , DataAlt dc <- ac+  , dc `hasKey` unsafeReflDataConKey+  , isDeadBinder bndr+      -- We can only discard the case if the case-binder is dead+      -- It usually is, but see #18227+  , Var v `App` _ `App` _ `App` _ <- scrut+  , v `hasKey` unsafeEqualityProofIdKey+      -- Check that the scrutinee really is unsafeEqualityProof+      -- and not, say, error+  = Just rhs   | otherwise-  = False+  = Nothing
compiler/GHC/CoreToIface.hs view
@@ -85,7 +85,6 @@  import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Utils.Panic.Plain import GHC.Utils.Misc  import Data.Maybe ( isNothing, catMaybes )@@ -309,9 +308,12 @@     go (FunCo { fco_role = r, fco_mult = w, fco_arg = co1, fco_res = co2 })       = IfaceFunCo r (go w) (go co1) (go co2) -    go (ForAllCo tv k co) = IfaceForAllCo (toIfaceBndr tv)-                                          (toIfaceCoercionX fr' k)-                                          (toIfaceCoercionX fr' co)+    go (ForAllCo tv visL visR k co)+      = IfaceForAllCo (toIfaceBndr tv)+                      visL+                      visR+                      (toIfaceCoercionX fr' k)+                      (toIfaceCoercionX fr' co)                           where                             fr' = fr `delVarSet` tv @@ -319,7 +321,6 @@     go_prov (PhantomProv co)    = IfacePhantomProv (go co)     go_prov (ProofIrrelProv co) = IfaceProofIrrelProv (go co)     go_prov (PluginProv str)    = IfacePluginProv str-    go_prov (CorePrepProv b)    = IfaceCorePrepProv b  toIfaceTcArgs :: TyCon -> [Type] -> IfaceAppArgs toIfaceTcArgs = toIfaceTcArgsX emptyVarSet@@ -435,7 +436,7 @@ toIfaceLetBndr id  = IfLetBndr (occNameFS (getOccName id))                                (toIfaceType (idType id))                                (toIfaceIdInfo (idInfo id))-                               (toIfaceJoinInfo (isJoinId_maybe id))+                               (idJoinPointHood id)   -- Put into the interface file any IdInfo that GHC.Core.Tidy.tidyLetBndr   -- has left on the Id.  See Note [IdInfo on nested let-bindings] in GHC.Iface.Syntax @@ -502,10 +503,6 @@     inline_hsinfo | isDefaultInlinePragma inline_prag = Nothing                   | otherwise = Just (HsInline inline_prag) -toIfaceJoinInfo :: Maybe JoinArity -> IfaceJoinInfo-toIfaceJoinInfo (Just ar) = IfaceJoinPoint ar-toIfaceJoinInfo Nothing   = IfaceNotJoinPoint- -------------------------- toIfUnfolding :: Bool -> Unfolding -> Maybe IfaceInfoItem toIfUnfolding lb (CoreUnfolding { uf_tmpl = rhs@@ -561,9 +558,7 @@   | otherwise               = IfaceCase (toIfaceExpr s) (getOccFS x) (map toIfaceAlt as) toIfaceExpr (Let b e)       = IfaceLet (toIfaceBind b) (toIfaceExpr e) toIfaceExpr (Cast e co)     = IfaceCast (toIfaceExpr e) (toIfaceCoercion co)-toIfaceExpr (Tick t e)-  | Just t' <- toIfaceTickish t = IfaceTick t' (toIfaceExpr e)-  | otherwise                   = toIfaceExpr e+toIfaceExpr (Tick t e)      = IfaceTick (toIfaceTickish t) (toIfaceExpr e)  toIfaceOneShot :: Id -> IfaceOneShot toIfaceOneShot id | isId id@@ -573,13 +568,13 @@                   = IfaceNoOneShot  ----------------------toIfaceTickish :: CoreTickish -> Maybe IfaceTickish-toIfaceTickish (ProfNote cc tick push) = Just (IfaceSCC cc tick push)-toIfaceTickish (HpcTick modl ix)       = Just (IfaceHpcTick modl ix)-toIfaceTickish (SourceNote src (LexicalFastString names))  = Just (IfaceSource src names)-toIfaceTickish (Breakpoint {})         = Nothing-   -- Ignore breakpoints, since they are relevant only to GHCi, and-   -- should not be serialised (#8333)+toIfaceTickish :: CoreTickish -> IfaceTickish+toIfaceTickish (ProfNote cc tick push) = IfaceSCC cc tick push+toIfaceTickish (HpcTick modl ix)       = IfaceHpcTick modl ix+toIfaceTickish (SourceNote src (LexicalFastString names)) =+  IfaceSource src names+toIfaceTickish (Breakpoint _ ix fv m) =+  IfaceBreakpoint ix (toIfaceVar <$> fv) m  --------------------- toIfaceBind :: Bind Id -> IfaceBinding IfaceLetBndr
compiler/GHC/Data/Bag.hs view
@@ -7,6 +7,7 @@ -}  {-# LANGUAGE ScopedTypeVariables, DeriveTraversable, TypeFamilies #-}+{-# OPTIONS_GHC -Wno-unrecognised-warning-flags -Wno-x-data-list-nonempty-unzip #-}  module GHC.Data.Bag (         Bag, -- abstract type
compiler/GHC/Data/EnumSet.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- | A tiny wrapper around 'IntSet.IntSet' for representing sets of 'Enum' -- things. module GHC.Data.EnumSet
compiler/GHC/Data/FastMutInt.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples #-}+{-# LANGUAGE MagicHash, UnboxedTuples #-} {-# OPTIONS_GHC -O2 #-} -- We always optimise this, otherwise performance of a non-optimised -- compiler is severely affected
compiler/GHC/Data/FastString.hs view
@@ -1,8 +1,5 @@-{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE UnboxedTuples #-} {-# LANGUAGE UnliftedFFITypes #-}@@ -146,9 +143,6 @@ import GHC.Conc.Sync    (sharedCAF) #endif -#if __GLASGOW_HASKELL__ < 811-import GHC.Base (unpackCString#,unpackNBytes#)-#endif import GHC.Exts import GHC.IO @@ -399,7 +393,7 @@ #else   sharedCAF tab getOrSetLibHSghcFastStringTable --- from the 9.3 RTS; the previouss RTS before might not have this symbol.  The+-- from the 9.3 RTS; the previous RTS before might not have this symbol.  The -- right way to do this however would be to define some HAVE_FAST_STRING_TABLE -- or similar rather than use (odd parity) development versions. foreign import ccall unsafe "getOrSetLibHSghcFastStringTable"@@ -509,6 +503,10 @@         go (fs@(FastString {fs_sbs=fs_sbs}) : ls)           | fs_sbs == sbs = Just fs           | otherwise     = go ls+-- bucket_match used to inline before changes to instance Eq ShortByteString+-- in bytestring-0.12, which made it slightly larger than inlining threshold.+-- Non-inlining causes a small, but measurable performance regression, so let's force it.+{-# INLINE bucket_match #-}  mkFastStringBytes :: Ptr Word8 -> Int -> FastString mkFastStringBytes !ptr !len =@@ -583,11 +581,7 @@           -- DO NOT move this let binding! indexCharOffAddr# reads from the           -- pointer so we need to evaluate this based on the length check           -- above. Not doing this right caused #17909.-#if __GLASGOW_HASKELL__ >= 901           !c = int8ToInt# (indexInt8Array# ba# n)-#else-          !c = indexInt8Array# ba# n-#endif           !h2 = (h *# 16777619#) `xorI#` c         in           loop h2 (n +# 1#)
compiler/GHC/Data/Maybe.hs view
@@ -33,7 +33,7 @@ import Control.Exception (SomeException(..)) import Data.Maybe import Data.Foldable ( foldlM, for_ )-import GHC.Utils.Misc (HasDebugCallStack)+import GHC.Utils.Misc (HasCallStack) import Data.List.NonEmpty ( NonEmpty ) import Control.Applicative( Alternative( (<|>) ) ) @@ -66,7 +66,7 @@   go Nothing         action  = action   go result@(Just _) _action = return result -expectJust :: HasDebugCallStack => String -> Maybe a -> a+expectJust :: HasCallStack => String -> Maybe a -> a {-# INLINE expectJust #-} expectJust _   (Just x) = x expectJust err Nothing  = error ("expectJust " ++ err)
compiler/GHC/Data/OrdList.hs view
@@ -4,8 +4,6 @@   -}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE BangPatterns #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE UnboxedTuples #-}@@ -16,8 +14,8 @@         OrdList, pattern NilOL, pattern ConsOL, pattern SnocOL,         nilOL, isNilOL, unitOL, appOL, consOL, snocOL, concatOL, lastOL,         headOL,-        mapOL, mapOL', fromOL, toOL, foldrOL, foldlOL, reverseOL, fromOLReverse,-        strictlyEqOL, strictlyOrdOL+        mapOL, mapOL', fromOL, toOL, foldrOL, foldlOL,+        partitionOL, reverseOL, fromOLReverse, strictlyEqOL, strictlyOrdOL ) where  import GHC.Prelude@@ -219,6 +217,25 @@ foldlOL k z (Snoc xs x) = let !z' = (foldlOL k z xs) in k z' x foldlOL k z (Two b1 b2) = let !z' = (foldlOL k z b1) in foldlOL k z' b2 foldlOL k z (Many xs)   = foldl' k z xs++partitionOL :: (a -> Bool) -> OrdList a -> (OrdList a, OrdList a)+partitionOL _ None = (None,None)+partitionOL f (One x)+  | f x       = (One x, None)+  | otherwise = (None, One x)+partitionOL f (Two xs ys) = (Two ls1 ls2, Two rs1 rs2)+  where !(!ls1,!rs1) = partitionOL f xs+        !(!ls2,!rs2) = partitionOL f ys+partitionOL f (Cons x xs)+  | f x       = (Cons x ls, rs)+  | otherwise = (ls, Cons x rs)+  where !(!ls,!rs) = partitionOL f xs+partitionOL f (Snoc xs x)+  | f x       = (Snoc ls x, rs)+  | otherwise = (ls, Snoc rs x)+  where !(!ls,!rs) = partitionOL f xs+partitionOL f (Many xs) = (toOL ls, toOL rs)+  where !(!ls,!rs) = NE.partition f xs  toOL :: [a] -> OrdList a toOL [] = None
compiler/GHC/Data/StringBuffer.hs view
@@ -6,7 +6,6 @@ Buffers for scanning string input stored in external arrays. -} -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE UnboxedTuples #-}
compiler/GHC/Data/Word64Map.hs view
@@ -1,13 +1,6 @@ {-# LANGUAGE CPP #-}-#if !defined(TESTING) && defined(__GLASGOW_HASKELL__)-{-# LANGUAGE Safe #-}-#endif-#ifdef __GLASGOW_HASKELL__ {-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MonoLocalBinds #-}-#endif-  ----------------------------------------------------------------------------- -- |
compiler/GHC/Data/Word64Map/Internal.hs view
@@ -1,15 +1,6 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE PatternGuards #-}-#ifdef __GLASGOW_HASKELL__ {-# LANGUAGE MagicHash #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-}-#endif-#if !defined(TESTING) && defined(__GLASGOW_HASKELL__)-{-# LANGUAGE Trustworthy #-}-#endif  {-# OPTIONS_HADDOCK not-home #-} {-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
compiler/GHC/Data/Word64Map/Lazy.hs view
@@ -1,8 +1,4 @@ {-# LANGUAGE CPP #-}-#if !defined(TESTING) && defined(__GLASGOW_HASKELL__)-{-# LANGUAGE Safe #-}-#endif-  ----------------------------------------------------------------------------- -- |
compiler/GHC/Data/Word64Map/Strict.hs view
@@ -1,8 +1,4 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE BangPatterns #-}-#if !defined(TESTING) && defined(__GLASGOW_HASKELL__)-{-# LANGUAGE Trustworthy #-}-#endif  ----------------------------------------------------------------------------- -- |
compiler/GHC/Data/Word64Map/Strict/Internal.hs view
@@ -1,6 +1,4 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE PatternGuards #-}  {-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
compiler/GHC/Data/Word64Set.hs view
@@ -1,7 +1,4 @@ {-# LANGUAGE CPP #-}-#if !defined(TESTING) && defined(__GLASGOW_HASKELL__)-{-# LANGUAGE Safe #-}-#endif  ----------------------------------------------------------------------------- -- |
compiler/GHC/Data/Word64Set/Internal.hs view
@@ -1,14 +1,6 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE PatternGuards #-}-#ifdef __GLASGOW_HASKELL__ {-# LANGUAGE MagicHash #-}-{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-}-#endif-#if !defined(TESTING) && defined(__GLASGOW_HASKELL__)-{-# LANGUAGE Trustworthy #-}-#endif  {-# OPTIONS_HADDOCK not-home #-}
compiler/GHC/Driver/Backend.hs view
@@ -58,8 +58,6 @@    , DefunctionalizedCodeOutput(..)      -- *** Back-end functions for assembly    , DefunctionalizedPostHscPipeline(..)-   , DefunctionalizedAssemblerProg(..)-   , DefunctionalizedAssemblerInfoGetter(..)      -- *** Other back-end functions    , DefunctionalizedCDefs(..)      -- ** Names of back ends (for API clients of version 9.4 or earlier)@@ -94,8 +92,6 @@    , backendSupportsHpc    , backendSupportsCImport    , backendSupportsCExport-   , backendAssemblerProg-   , backendAssemblerInfoGetter    , backendCDefs    , backendCodeOutput    , backendUseJSLinker@@ -348,40 +344,6 @@   deriving Show  --- | Names a function that runs the assembler, of this type:------ > Logger -> DynFlags -> Platform -> [Option] -> IO ()------ The functions so named are defined in "GHC.Driver.Pipeline.Execute".--data DefunctionalizedAssemblerProg-  = StandardAssemblerProg-       -- ^ Use the standard system assembler-  | JSAssemblerProg-       -- ^ JS Backend compile to JS via Stg, and so does not use any assembler-  | DarwinClangAssemblerProg-       -- ^ If running on Darwin, use the assembler from the @clang@-       -- toolchain.  Otherwise use the standard system assembler.------ | Names a function that discover from what toolchain the assembler--- is coming, of this type:------ > Logger -> DynFlags -> Platform -> IO CompilerInfo------ The functions so named are defined in "GHC.Driver.Pipeline.Execute".--data DefunctionalizedAssemblerInfoGetter-  = StandardAssemblerInfoGetter-       -- ^ Interrogate the standard system assembler-  | JSAssemblerInfoGetter-       -- ^ If using the JS backend; return 'Emscripten'-  | DarwinClangAssemblerInfoGetter-       -- ^ If running on Darwin, return `Clang`; otherwise-       -- interrogate the standard system assembler.-- -- | Names a function that generates code and writes the results to a --  file, of this type: --@@ -766,45 +728,6 @@ backendSupportsCExport (Named JavaScript)  = True backendSupportsCExport (Named Interpreter) = False backendSupportsCExport (Named NoBackend)   = True---- | This (defunctionalized) function runs the assembler--- used on the code that is written by this back end.  A--- program determined by a combination of back end,--- `DynFlags`, and `Platform` is run with the given--- `Option`s.------ The function's type is--- @--- Logger -> DynFlags -> Platform -> [Option] -> IO ()--- @------ This field is usually defaulted.-backendAssemblerProg :: Backend -> DefunctionalizedAssemblerProg-backendAssemblerProg (Named NCG)  = StandardAssemblerProg-backendAssemblerProg (Named LLVM) = DarwinClangAssemblerProg-backendAssemblerProg (Named ViaC) = StandardAssemblerProg-backendAssemblerProg (Named JavaScript)  = JSAssemblerProg-backendAssemblerProg (Named Interpreter) = StandardAssemblerProg-backendAssemblerProg (Named NoBackend)   = StandardAssemblerProg---- | This (defunctionalized) function is used to retrieve--- an enumeration value that characterizes the C/assembler--- part of a toolchain.  The function caches the info in a--- mutable variable that is part of the `DynFlags`.------ The function's type is--- @--- Logger -> DynFlags -> Platform -> IO CompilerInfo--- @------ This field is usually defaulted.-backendAssemblerInfoGetter :: Backend -> DefunctionalizedAssemblerInfoGetter-backendAssemblerInfoGetter (Named NCG)         = StandardAssemblerInfoGetter-backendAssemblerInfoGetter (Named LLVM)        = DarwinClangAssemblerInfoGetter-backendAssemblerInfoGetter (Named ViaC)        = StandardAssemblerInfoGetter-backendAssemblerInfoGetter (Named JavaScript)  = JSAssemblerInfoGetter-backendAssemblerInfoGetter (Named Interpreter) = StandardAssemblerInfoGetter-backendAssemblerInfoGetter (Named NoBackend)   = StandardAssemblerInfoGetter  -- | When using this back end, it may be necessary or -- advisable to pass some `-D` options to a C compiler.
compiler/GHC/Driver/CmdLine.hs view
@@ -26,7 +26,6 @@  import GHC.Utils.Misc import GHC.Utils.Panic-import GHC.Utils.Panic.Plain import GHC.Data.Bag import GHC.Types.SrcLoc import GHC.Types.Error
compiler/GHC/Driver/Config/Core/Lint.hs view
@@ -83,7 +83,7 @@ coreDumpFlag CoreDoStaticArgs         = Just Opt_D_dump_static_argument_transformation coreDumpFlag CoreDoCallArity          = Just Opt_D_dump_call_arity coreDumpFlag CoreDoExitify            = Just Opt_D_dump_exitify-coreDumpFlag (CoreDoDemand {})        = Just Opt_D_dump_stranal+coreDumpFlag (CoreDoDemand {})        = Just Opt_D_dump_dmdanal coreDumpFlag CoreDoCpr                = Just Opt_D_dump_cpranal coreDumpFlag CoreDoWorkerWrapper      = Just Opt_D_dump_worker_wrapper coreDumpFlag CoreDoSpecialising       = Just Opt_D_dump_spec@@ -132,8 +132,7 @@     -- we have eta-expanded data constructors with representation-polymorphic     -- bindings; so we switch off the representation-polymorphism checks.     -- The very simple optimiser will beta-reduce them away.-    -- See Note [Checking for representation-polymorphic built-ins]-    -- in GHC.HsToCore.Expr.+    -- See Note [Representation-polymorphism checking built-ins] in GHC.Tc.Gen.Head.     check_fixed_rep = case pass of                         CoreDesugar -> False                         _           -> True
compiler/GHC/Driver/Config/Logger.hs view
@@ -17,6 +17,7 @@   , log_default_dump_context = initSDocContext dflags defaultDumpStyle   , log_dump_flags           = dumpFlags dflags   , log_show_caret           = gopt Opt_DiagnosticsShowCaret dflags+  , log_diagnostics_as_json  = gopt Opt_DiagnosticsAsJSON dflags   , log_show_warn_groups     = gopt Opt_ShowWarnGroups dflags   , log_enable_timestamps    = not (gopt Opt_SuppressTimestamps dflags)   , log_dump_to_file         = gopt Opt_DumpToFile dflags
compiler/GHC/Driver/DynFlags.hs view
@@ -71,6 +71,18 @@         -- * SDoc         initSDocContext, initDefaultSDocContext,         initPromotionTickContext,++        -- * Platform features+        isSse4_2Enabled,+        isAvxEnabled,+        isAvx2Enabled,+        isAvx512cdEnabled,+        isAvx512erEnabled,+        isAvx512fEnabled,+        isAvx512pfEnabled,+        isFmaEnabled,+        isBmiEnabled,+        isBmi2Enabled ) where  import GHC.Prelude@@ -116,7 +128,6 @@ import Control.Monad.Trans.Except (ExceptT) import Control.Monad.Trans.Reader (ReaderT) import Control.Monad.Trans.Writer (WriterT)-import Data.IORef import Data.Word import System.IO import System.IO.Error (catchIOError)@@ -402,6 +413,8 @@   useUnicode            :: Bool,   useColor              :: OverridingBool,   canUseColor           :: Bool,+  useErrorLinks         :: OverridingBool,+  canUseErrorLinks      :: Bool,   colScheme             :: Col.Scheme,    -- | what kind of {-# SCC #-} to add automatically@@ -421,15 +434,6 @@   avx512pf              :: Bool, -- Enable AVX-512 PreFetch Instructions.   fma                   :: Bool, -- ^ Enable FMA instructions. -  -- | Run-time linker information (what options we need, etc.)-  rtldInfo              :: IORef (Maybe LinkerInfo),--  -- | Run-time C compiler information-  rtccInfo              :: IORef (Maybe CompilerInfo),--  -- | Run-time assembler information-  rtasmInfo              :: IORef (Maybe CompilerInfo),-   -- Constants used to control the amount of optimization done.    -- | Max size, in bytes, of inline array allocations.@@ -491,9 +495,8 @@ initDynFlags :: DynFlags -> IO DynFlags initDynFlags dflags = do  let- refRtldInfo <- newIORef Nothing- refRtccInfo <- newIORef Nothing- refRtasmInfo <- newIORef Nothing+ -- This is not bulletproof: we test that 'localeEncoding' is Unicode-capable,+ -- but potentially 'hGetEncoding' 'stdout' might be different. Still good enough.  canUseUnicode <- do let enc = localeEncoding                          str = "‘’"                      (withCString enc str $ \cstr ->@@ -514,10 +517,9 @@         useUnicode    = useUnicode',         useColor      = useColor',         canUseColor   = stderrSupportsAnsiColors,+        -- if the terminal supports color, we assume it supports links as well+        canUseErrorLinks = stderrSupportsAnsiColors,         colScheme     = colScheme',-        rtldInfo      = refRtldInfo,-        rtccInfo      = refRtccInfo,-        rtasmInfo     = refRtasmInfo,         tmpDir        = TempDir tmp_dir         } @@ -683,6 +685,8 @@         useUnicode = False,         useColor = Auto,         canUseColor = False,+        useErrorLinks = Auto,+        canUseErrorLinks = False,         colScheme = Col.defaultScheme,         profAuto = NoProfAuto,         callerCcFilters = [],@@ -697,9 +701,6 @@         avx512pf = False,         -- Use FMA by default on AArch64         fma = (platformArch . sTargetPlatform $ mySettings) == ArchAArch64,-        rtldInfo = panic "defaultDynFlags: no rtldInfo",-        rtccInfo = panic "defaultDynFlags: no rtccInfo",-        rtasmInfo = panic "defaultDynFlags: no rtasmInfo",          maxInlineAllocSize = 128,         maxInlineMemcpyInsns = 32,@@ -1199,7 +1200,6 @@     -- Default floating flags (see Note [RHS Floating])     ++ [ Opt_LocalFloatOut, Opt_LocalFloatOutTopLevel ] -     ++ default_PIC platform      ++ validHoleFitDefaults@@ -1248,8 +1248,8 @@ -- Default settings of flags, before any command-line overrides optLevelFlags -- see Note [Documenting optimisation flags]   = [ ([0,1,2], Opt_DoLambdaEtaExpansion)-    , ([0,1,2], Opt_DoEtaReduction)       -- See Note [Eta-reduction in -O0]-    , ([0,1,2], Opt_LlvmTBAA)+    , ([1,2],   Opt_DoCleverArgEtaExpansion) -- See Note [Eta expansion of arguments in CorePrep]+    , ([0,1,2], Opt_DoEtaReduction)          -- See Note [Eta-reduction in -O0]     , ([0,1,2], Opt_ProfManualCcs )     , ([2], Opt_DictsStrict) @@ -1339,7 +1339,7 @@ languageExtensions :: Maybe Language -> [LangExt.Extension]  -- Nothing: the default case-languageExtensions Nothing = languageExtensions (Just GHC2021)+languageExtensions Nothing = languageExtensions (Just defaultLanguage)  languageExtensions (Just Haskell98)     = [LangExt.ImplicitPrelude,@@ -1357,8 +1357,9 @@            -- turning it off breaks code, so we're keeping it on for            -- backwards compatibility.  Cabal uses -XHaskell98 by            -- default unless you specify another language.-       LangExt.DeepSubsumption+       LangExt.DeepSubsumption,        -- Non-standard but enabled for backwards compatability (see GHC proposal #511)+       LangExt.ListTuplePuns       ]  languageExtensions (Just Haskell2010)@@ -1375,7 +1376,8 @@        LangExt.DoAndIfThenElse,        LangExt.FieldSelectors,        LangExt.RelaxedPolyRec,-       LangExt.DeepSubsumption ]+       LangExt.DeepSubsumption,+       LangExt.ListTuplePuns ]  languageExtensions (Just GHC2021)     = [LangExt.ImplicitPrelude,@@ -1389,6 +1391,7 @@        LangExt.DoAndIfThenElse,        LangExt.FieldSelectors,        LangExt.RelaxedPolyRec,+       LangExt.ListTuplePuns,        -- Now the new extensions (not in Haskell2010)        LangExt.BangPatterns,        LangExt.BinaryLiterals,@@ -1427,6 +1430,16 @@        LangExt.TypeOperators,        LangExt.TypeSynonymInstances] +languageExtensions (Just GHC2024)+    = languageExtensions (Just GHC2021) +++      [LangExt.DataKinds,+       LangExt.DerivingStrategies,+       LangExt.DisambiguateRecordFields,+       LangExt.ExplicitNamespaces,+       LangExt.GADTs,+       LangExt.MonoLocalBinds,+       LangExt.LambdaCase,+       LangExt.RoleAnnotations]  ways :: DynFlags -> Ways ways dflags@@ -1486,7 +1499,6 @@  -- SDoc -------------------------------------------- -- | Initialize the pretty-printing options initSDocContext :: DynFlags -> PprStyle -> SDocContext initSDocContext dflags style = SDC@@ -1497,6 +1509,7 @@   , sdocDefaultDepth                = pprUserLength dflags   , sdocLineLength                  = pprCols dflags   , sdocCanUseUnicode               = useUnicode dflags+  , sdocPrintErrIndexLinks          = overrideWith (canUseErrorLinks dflags) (useErrorLinks dflags)   , sdocHexWordLiterals             = gopt Opt_HexWordLiterals dflags   , sdocPprDebug                    = dopt Opt_D_ppr_debug dflags   , sdocPrintUnicodeSyntax          = gopt Opt_PrintUnicodeSyntax dflags@@ -1524,7 +1537,7 @@   , sdocErrorSpans                  = gopt Opt_ErrorSpans dflags   , sdocStarIsType                  = xopt LangExt.StarIsType dflags   , sdocLinearTypes                 = xopt LangExt.LinearTypes dflags-  , sdocListTuplePuns               = True+  , sdocListTuplePuns               = xopt LangExt.ListTuplePuns dflags   , sdocPrintTypeAbbreviations      = True   , sdocUnitIdForUser               = ftext   }@@ -1536,6 +1549,48 @@ initPromotionTickContext :: DynFlags -> PromotionTickContext initPromotionTickContext dflags =   PromTickCtx {-    ptcListTuplePuns = True,+    ptcListTuplePuns = xopt LangExt.ListTuplePuns dflags,     ptcPrintRedundantPromTicks = gopt Opt_PrintRedundantPromotionTicks dflags   }++-- -----------------------------------------------------------------------------+-- SSE, AVX, FMA++isSse4_2Enabled :: DynFlags -> Bool+isSse4_2Enabled dflags = sseVersion dflags >= Just SSE42++isAvxEnabled :: DynFlags -> Bool+isAvxEnabled dflags = avx dflags || avx2 dflags || avx512f dflags++isAvx2Enabled :: DynFlags -> Bool+isAvx2Enabled dflags = avx2 dflags || avx512f dflags++isAvx512cdEnabled :: DynFlags -> Bool+isAvx512cdEnabled dflags = avx512cd dflags++isAvx512erEnabled :: DynFlags -> Bool+isAvx512erEnabled dflags = avx512er dflags++isAvx512fEnabled :: DynFlags -> Bool+isAvx512fEnabled dflags = avx512f dflags++isAvx512pfEnabled :: DynFlags -> Bool+isAvx512pfEnabled dflags = avx512pf dflags++isFmaEnabled :: DynFlags -> Bool+isFmaEnabled dflags = fma dflags++-- -----------------------------------------------------------------------------+-- BMI2++isBmiEnabled :: DynFlags -> Bool+isBmiEnabled dflags = case platformArch (targetPlatform dflags) of+    ArchX86_64 -> bmiVersion dflags >= Just BMI1+    ArchX86    -> bmiVersion dflags >= Just BMI1+    _          -> False++isBmi2Enabled :: DynFlags -> Bool+isBmi2Enabled dflags = case platformArch (targetPlatform dflags) of+    ArchX86_64 -> bmiVersion dflags >= Just BMI2+    ArchX86    -> bmiVersion dflags >= Just BMI2+    _          -> False
compiler/GHC/Driver/Errors.hs view
@@ -17,13 +17,15 @@ printMessages logger msg_opts opts msgs   = sequence_ [ let style = mkErrStyle name_ppr_ctx                     ctx   = (diag_ppr_ctx opts) { sdocStyle = style }-                in logMsg logger (MCDiagnostic sev reason (diagnosticCode dia)) s $-                   updSDocContext (\_ -> ctx) (messageWithHints dia)-              | MsgEnvelope { errMsgSpan       = s,-                              errMsgDiagnostic = dia,-                              errMsgSeverity   = sev,-                              errMsgReason     = reason,-                              errMsgContext    = name_ppr_ctx }+                in (if log_diags_as_json+                    then logJsonMsg logger (MCDiagnostic sev reason (diagnosticCode dia)) msg+                    else logMsg logger (MCDiagnostic sev reason (diagnosticCode dia)) s $+                  updSDocContext (\_ -> ctx) (messageWithHints dia))+              | msg@MsgEnvelope { errMsgSpan       = s,+                                  errMsgDiagnostic = dia,+                                  errMsgSeverity   = sev,+                                  errMsgReason     = reason,+                                  errMsgContext    = name_ppr_ctx }                   <- sortMsgBag (Just opts) (getMessages msgs) ]   where     messageWithHints :: Diagnostic a => a -> SDoc@@ -34,6 +36,7 @@                [h] -> main_msg $$ hang (text "Suggested fix:") 2 (ppr h)                hs  -> main_msg $$ hang (text "Suggested fixes:") 2                                        (formatBulleted  $ mkDecorated . map ppr $ hs)+    log_diags_as_json = log_diagnostics_as_json (logFlags logger)  -- | Given a bag of diagnostics, turn them into an exception if -- any has 'SevError', or print them out otherwise.
compiler/GHC/Driver/Errors/Ppr.hs view
@@ -17,7 +17,7 @@ import GHC.HsToCore.Errors.Ppr () import GHC.Parser.Errors.Ppr () import GHC.Types.Error-import GHC.Types.Error.Codes ( constructorCode )+import GHC.Types.Error.Codes import GHC.Unit.Types import GHC.Utils.Outputable import GHC.Unit.Module
compiler/GHC/Driver/Flags.hs view
@@ -4,6 +4,7 @@    , enabledIfVerbose    , GeneralFlag(..)    , Language(..)+   , defaultLanguage    , optimisationFlags    , codeGenFlags @@ -38,9 +39,14 @@ import Data.List.NonEmpty (NonEmpty(..)) import Data.Maybe (fromMaybe,mapMaybe) -data Language = Haskell98 | Haskell2010 | GHC2021+data Language = Haskell98 | Haskell2010 | GHC2021 | GHC2024    deriving (Eq, Enum, Show, Bounded) +-- | The default Language is used if one is not specified explicitly, by both+-- GHC and GHCi.+defaultLanguage :: Language+defaultLanguage = GHC2021+ instance Outputable Language where     ppr = text . show @@ -118,8 +124,8 @@    | Opt_D_dump_stg_final     -- ^ Final STG (before cmm gen)    | Opt_D_dump_call_arity    | Opt_D_dump_exitify-   | Opt_D_dump_stranal-   | Opt_D_dump_str_signatures+   | Opt_D_dump_dmdanal+   | Opt_D_dump_dmd_signatures    | Opt_D_dump_cpranal    | Opt_D_dump_cpr_signatures    | Opt_D_dump_tc@@ -273,6 +279,7 @@    | Opt_SpecConstrKeen    | Opt_SpecialiseIncoherents    | Opt_DoLambdaEtaExpansion+   | Opt_DoCleverArgEtaExpansion        -- See Note [Eta expansion of arguments in CorePrep]    | Opt_IgnoreAsserts    | Opt_DoEtaReduction    | Opt_CaseMerge@@ -285,7 +292,6 @@    | Opt_RegsGraph                      -- do graph coloring register allocation    | Opt_RegsIterative                  -- do iterative coalescing graph coloring register allocation    | Opt_PedanticBottoms                -- Be picky about how we treat bottom-   | Opt_LlvmTBAA                       -- Use LLVM TBAA infrastructure for improving AA (hidden flag)    | Opt_LlvmFillUndefWithGarbage       -- Testing for undef bugs (hidden flag)    | Opt_IrrefutableTuples    | Opt_CmmSink@@ -322,17 +328,21 @@    | Opt_IgnoreInterfacePragmas    | Opt_OmitInterfacePragmas    | Opt_ExposeAllUnfoldings+   | Opt_KeepAutoRules -- ^Keep auto-generated rules even if they seem to have become useless    | Opt_WriteInterface -- forces .hi files to be written even with -fno-code    | Opt_WriteHie -- generate .hie files     -- JavaScript opts    | Opt_DisableJsMinifier -- ^ render JavaScript pretty-printed instead of minified (compacted)+   | Opt_DisableJsCsources -- ^ don't link C sources (compiled to JS) with Haskell code (compiled to JS)     -- profiling opts    | Opt_AutoSccsOnIndividualCafs    | Opt_ProfCountEntries    | Opt_ProfLateInlineCcs    | Opt_ProfLateCcs+   | Opt_ProfLateOverloadedCcs+   | Opt_ProfLateoverloadedCallsCCs    | Opt_ProfManualCcs -- ^ Ignore manual SCC annotations     -- misc opts@@ -342,6 +352,7 @@    | Opt_IgnoreHpcChanges    | Opt_ExcessPrecision    | Opt_EagerBlackHoling+   | Opt_OrigThunkInfo    | Opt_NoHsMain    | Opt_SplitSections    | Opt_StgStats@@ -409,6 +420,7 @@    | Opt_ErrorSpans -- Include full span info in error messages,                     -- instead of just the start position.    | Opt_DeferDiagnostics+   | Opt_DiagnosticsAsJSON  -- ^ Dump diagnostics as JSON    | Opt_DiagnosticsShowCaret -- Show snippets of offending code    | Opt_PprCaseAsLet    | Opt_PprShowTicks@@ -525,7 +537,6 @@    , Opt_EnableRewriteRules    , Opt_RegsGraph    , Opt_RegsIterative-   , Opt_LlvmTBAA    , Opt_IrrefutableTuples    , Opt_CmmSink    , Opt_CmmElimCommonBlocks@@ -571,6 +582,7 @@      -- Flags that affect generated code    , Opt_ExposeAllUnfoldings    , Opt_NoTypeableBinds+   , Opt_Haddock       -- Flags that affect catching of runtime errors    , Opt_CatchNonexhaustiveCases@@ -582,6 +594,7 @@    , Opt_InfoTableMap    , Opt_InfoTableMapWithStack    , Opt_InfoTableMapWithFallback+   , Opt_OrigThunkInfo    ]  data WarningFlag =@@ -617,7 +630,7 @@    | Opt_WarnRedundantRecordWildcards    | Opt_WarnDeprecatedFlags    | Opt_WarnMissingMonadFailInstances               -- since 8.0, has no effect since 8.8-   | Opt_WarnSemigroup                               -- since 8.0+   | Opt_WarnSemigroup                               -- since 8.0, has no effect since 9.8    | Opt_WarnDodgyExports    | Opt_WarnDodgyImports    | Opt_WarnOrphans@@ -683,12 +696,17 @@    | Opt_WarnGADTMonoLocalBinds                      -- Since 9.4    | Opt_WarnTypeEqualityOutOfScope                  -- Since 9.4    | Opt_WarnTypeEqualityRequiresOperators           -- Since 9.4-   | Opt_WarnLoopySuperclassSolve                    -- Since 9.6+   | Opt_WarnLoopySuperclassSolve                    -- Since 9.6, has no effect since 9.10    | Opt_WarnTermVariableCapture                     -- Since 9.8    | Opt_WarnMissingRoleAnnotations                  -- Since 9.8    | Opt_WarnImplicitRhsQuantification               -- Since 9.8    | Opt_WarnIncompleteExportWarnings                -- Since 9.8+   | Opt_WarnIncompleteRecordSelectors               -- Since 9.10+   | Opt_WarnBadlyStagedTypes                        -- Since 9.10    | Opt_WarnInconsistentFlags                       -- Since 9.8+   | Opt_WarnDataKindsTC                             -- Since 9.10+   | Opt_WarnDeprecatedTypeAbstractions              -- Since 9.10+   | Opt_WarnDefaultedExceptionContext               -- Since 9.10    deriving (Eq, Ord, Show, Enum, Bounded)  -- | Return the names of a WarningFlag@@ -799,7 +817,12 @@   Opt_WarnMissingRoleAnnotations                  -> "missing-role-annotations" :| []   Opt_WarnImplicitRhsQuantification               -> "implicit-rhs-quantification" :| []   Opt_WarnIncompleteExportWarnings                -> "incomplete-export-warnings" :| []+  Opt_WarnIncompleteRecordSelectors               -> "incomplete-record-selectors" :| []+  Opt_WarnBadlyStagedTypes                        -> "badly-staged-types" :| []   Opt_WarnInconsistentFlags                       -> "inconsistent-flags" :| []+  Opt_WarnDataKindsTC                             -> "data-kinds-tc" :| []+  Opt_WarnDeprecatedTypeAbstractions              -> "deprecated-type-abstractions" :| []+  Opt_WarnDefaultedExceptionContext               -> "defaulted-exception-context" :| []  -- ----------------------------------------------------------------------------- -- Standard sets of warning options@@ -934,12 +957,13 @@         Opt_WarnNonCanonicalMonadInstances,         Opt_WarnNonCanonicalMonoidInstances,         Opt_WarnOperatorWhitespaceExtConflict,-        Opt_WarnForallIdentifier,         Opt_WarnUnicodeBidirectionalFormatCharacters,         Opt_WarnGADTMonoLocalBinds,-        Opt_WarnLoopySuperclassSolve,+        Opt_WarnBadlyStagedTypes,         Opt_WarnTypeEqualityRequiresOperators,-        Opt_WarnInconsistentFlags+        Opt_WarnInconsistentFlags,+        Opt_WarnDataKindsTC,+        Opt_WarnTypeEqualityOutOfScope       ]  -- | Things you get with -W@@ -988,12 +1012,9 @@ -- code future compatible to fix issues before they even generate warnings. minusWcompatOpts :: [WarningFlag] minusWcompatOpts-    = [ Opt_WarnSemigroup-      , Opt_WarnNonCanonicalMonoidInstances-      , Opt_WarnNonCanonicalMonadInstances-      , Opt_WarnCompatUnqualifiedImports-      , Opt_WarnTypeEqualityOutOfScope+    = [ Opt_WarnCompatUnqualifiedImports       , Opt_WarnImplicitRhsQuantification+      , Opt_WarnDeprecatedTypeAbstractions       ]  -- | Things you get with -Wunused-binds
compiler/GHC/Driver/Hooks.hs view
@@ -154,6 +154,8 @@                                  -> IO (Stream IO RawCmmGroup a)))   } +{-# DEPRECATED cmmToRawCmmHook "cmmToRawCmmHook is being deprecated. If you do use it in your project, please raise a GHC issue!" #-}+ class HasHooks m where     getHooks :: m Hooks
compiler/GHC/Driver/Monad.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveFunctor, DerivingVia, RankNTypes #-}+{-# LANGUAGE DerivingVia, NoPolyKinds #-} {-# OPTIONS_GHC -funbox-strict-fields #-} -- ----------------------------------------------------------------------------- --@@ -23,6 +23,8 @@         modifyLogger,         pushLogHookM,         popLogHookM,+        pushJsonLogHookM,+        popJsonLogHookM,         putLogMsgM,         putMsgM,         withTimingM,@@ -120,6 +122,12 @@ -- | Pop a log hook from the stack popLogHookM :: GhcMonad m => m () popLogHookM  = modifyLogger popLogHook++pushJsonLogHookM :: GhcMonad m => (LogJsonAction -> LogJsonAction) -> m ()+pushJsonLogHookM = modifyLogger . pushJsonLogHook++popJsonLogHookM :: GhcMonad m => m ()+popJsonLogHookM = modifyLogger popJsonLogHook  -- | Put a log message putMsgM :: GhcMonad m => SDoc -> m ()
compiler/GHC/Driver/Pipeline/Phases.hs view
@@ -47,6 +47,7 @@   T_ForeignJs :: PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> TPhase FilePath   T_LlvmOpt :: PipeEnv -> HscEnv -> FilePath -> TPhase FilePath   T_LlvmLlc :: PipeEnv -> HscEnv -> FilePath -> TPhase FilePath+  T_LlvmAs :: Bool -> PipeEnv -> HscEnv -> Maybe ModLocation -> FilePath -> TPhase FilePath   T_LlvmMangle :: PipeEnv -> HscEnv -> FilePath -> TPhase FilePath   T_MergeForeign :: PipeEnv -> HscEnv -> FilePath -> [FilePath] -> TPhase FilePath
compiler/GHC/Driver/Plugins.hs view
@@ -58,6 +58,10 @@       -- | hole fit plugins allow plugins to change the behavior of valid hole       -- fit suggestions     , HoleFitPluginR+      -- ** Late plugins+      -- | Late plugins can access and modify the core of a module after+      -- optimizations have been applied and after interface creation.+    , LatePlugin        -- * Internal     , PluginWithArgs(..), pluginsWithArgs, pluginRecompile'@@ -89,8 +93,10 @@ import GHC.Hs import GHC.Types.Error (Messages) import GHC.Linker.Types+import GHC.Types.CostCentre.State import GHC.Types.Unique.DFM +import GHC.Unit.Module.ModGuts (CgGuts) import GHC.Utils.Fingerprint import GHC.Utils.Outputable import GHC.Utils.Panic@@ -157,6 +163,13 @@     --     --   @since 8.10.1 +  , latePlugin :: LatePlugin+    -- ^ A plugin that runs after interface creation and after late cost centre+    -- insertion. Useful for transformations that should not impact interfaces+    -- or optimization at all.+    --+    -- @since 9.10.1+   , pluginRecompile :: [CommandLineOption] -> IO PluginRecompile     -- ^ Specify how the plugin should affect recompilation.   , parsedResultAction :: [CommandLineOption] -> ModSummary@@ -260,6 +273,7 @@ type TcPlugin = [CommandLineOption] -> Maybe GHC.Tc.Types.TcPlugin type DefaultingPlugin = [CommandLineOption] -> Maybe GHC.Tc.Types.DefaultingPlugin type HoleFitPlugin = [CommandLineOption] -> Maybe HoleFitPluginR+type LatePlugin = HscEnv -> [CommandLineOption] -> (CgGuts, CostCentreState) -> IO (CgGuts, CostCentreState)  purePlugin, impurePlugin, flagRecompile :: [CommandLineOption] -> IO PluginRecompile purePlugin _args = return NoForceRecompile@@ -280,6 +294,7 @@       , defaultingPlugin      = const Nothing       , holeFitPlugin         = const Nothing       , driverPlugin          = const return+      , latePlugin            = \_ -> const return       , pluginRecompile       = impurePlugin       , renamedResultAction   = \_ env grp -> return (env, grp)       , parsedResultAction    = \_ _ -> return@@ -405,12 +420,12 @@ loadExternalPluginLib path = do   -- load library   loadDLL path >>= \case-    Left errmsg -> pprPanic "loadExternalPluginLib"-                     (vcat [ text "Can't load plugin library"-                           , text "  Library path: " <> text path-                           , text "  Error       : " <> text errmsg-                           ])-    Right _ -> do+    Just errmsg -> pprPanic "loadExternalPluginLib"+                    (vcat [ text "Can't load plugin library"+                          , text "  Library path: " <> text path+                          , text "  Error       : " <> text errmsg+                          ])+    Nothing -> do       -- resolve objects       resolveObjs >>= \case         True -> return ()
compiler/GHC/Driver/Session.hs view
@@ -99,17 +99,16 @@         sPgm_F,         sPgm_c,         sPgm_cxx,+        sPgm_cpp,         sPgm_a,         sPgm_l,         sPgm_lm,-        sPgm_dll,-        sPgm_T,         sPgm_windres,         sPgm_ar,         sPgm_ranlib,         sPgm_lo,         sPgm_lc,-        sPgm_lcc,+        sPgm_las,         sPgm_i,         sOpt_L,         sOpt_P,@@ -123,7 +122,6 @@         sOpt_windres,         sOpt_lo,         sOpt_lc,-        sOpt_lcc,         sOpt_i,         sExtraGccViaCFlags,         sTargetPlatformString,@@ -137,12 +135,12 @@         ghcUsagePath, ghciUsagePath, topDir,         versionedAppDir, versionedFilePath,         extraGccViaCFlags, globalPackageDatabasePath,-        pgm_L, pgm_P, pgm_F, pgm_c, pgm_cxx, pgm_a, pgm_l, pgm_lm, pgm_dll, pgm_T,+        pgm_L, pgm_P, pgm_F, pgm_c, pgm_cxx, pgm_cpp, pgm_a, pgm_l, pgm_lm,         pgm_windres, pgm_ar,-        pgm_ranlib, pgm_lo, pgm_lc, pgm_lcc, pgm_i,+        pgm_ranlib, pgm_lo, pgm_lc, pgm_las, pgm_i,         opt_L, opt_P, opt_F, opt_c, opt_cxx, opt_a, opt_l, opt_lm, opt_i,         opt_P_signature,-        opt_windres, opt_lo, opt_lc, opt_lcc,+        opt_windres, opt_lo, opt_lc, opt_las,         updatePlatformConstants,          -- ** Manipulating DynFlags@@ -399,20 +397,16 @@ pgm_c dflags = toolSettings_pgm_c $ toolSettings dflags pgm_cxx               :: DynFlags -> String pgm_cxx dflags = toolSettings_pgm_cxx $ toolSettings dflags+pgm_cpp               :: DynFlags -> (String,[Option])+pgm_cpp dflags = toolSettings_pgm_cpp $ toolSettings dflags pgm_a                 :: DynFlags -> (String,[Option]) pgm_a dflags = toolSettings_pgm_a $ toolSettings dflags pgm_l                 :: DynFlags -> (String,[Option]) pgm_l dflags = toolSettings_pgm_l $ toolSettings dflags pgm_lm                 :: DynFlags -> Maybe (String,[Option]) pgm_lm dflags = toolSettings_pgm_lm $ toolSettings dflags-pgm_dll               :: DynFlags -> (String,[Option])-pgm_dll dflags = toolSettings_pgm_dll $ toolSettings dflags-pgm_T                 :: DynFlags -> String-pgm_T dflags = toolSettings_pgm_T $ toolSettings dflags pgm_windres           :: DynFlags -> String pgm_windres dflags = toolSettings_pgm_windres $ toolSettings dflags-pgm_lcc               :: DynFlags -> (String,[Option])-pgm_lcc dflags = toolSettings_pgm_lcc $ toolSettings dflags pgm_ar                :: DynFlags -> String pgm_ar dflags = toolSettings_pgm_ar $ toolSettings dflags pgm_ranlib            :: DynFlags -> String@@ -421,6 +415,8 @@ pgm_lo dflags = toolSettings_pgm_lo $ toolSettings dflags pgm_lc                :: DynFlags -> (String,[Option]) pgm_lc dflags = toolSettings_pgm_lc $ toolSettings dflags+pgm_las               :: DynFlags -> (String,[Option])+pgm_las dflags = toolSettings_pgm_las $ toolSettings dflags pgm_i                 :: DynFlags -> String pgm_i dflags = toolSettings_pgm_i $ toolSettings dflags opt_L                 :: DynFlags -> [String]@@ -443,7 +439,8 @@ opt_c dflags = concatMap (wayOptc (targetPlatform dflags)) (ways dflags)             ++ toolSettings_opt_c (toolSettings dflags) opt_cxx               :: DynFlags -> [String]-opt_cxx dflags= toolSettings_opt_cxx $ toolSettings dflags+opt_cxx dflags = concatMap (wayOptcxx (targetPlatform dflags)) (ways dflags)+           ++ toolSettings_opt_cxx (toolSettings dflags) opt_a                 :: DynFlags -> [String] opt_a dflags= toolSettings_opt_a $ toolSettings dflags opt_l                 :: DynFlags -> [String]@@ -453,12 +450,12 @@ opt_lm dflags= toolSettings_opt_lm $ toolSettings dflags opt_windres           :: DynFlags -> [String] opt_windres dflags= toolSettings_opt_windres $ toolSettings dflags-opt_lcc                :: DynFlags -> [String]-opt_lcc dflags= toolSettings_opt_lcc $ toolSettings dflags opt_lo                :: DynFlags -> [String] opt_lo dflags= toolSettings_opt_lo $ toolSettings dflags opt_lc                :: DynFlags -> [String] opt_lc dflags= toolSettings_opt_lc $ toolSettings dflags+opt_las               :: DynFlags -> [String]+opt_las dflags = toolSettings_opt_las $ toolSettings dflags opt_i                 :: DynFlags -> [String] opt_i dflags= toolSettings_opt_i $ toolSettings dflags @@ -1063,6 +1060,8 @@       $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_lo  = (f,[]) }   , make_ord_flag defFlag "pgmlc"       $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_lc  = (f,[]) }+  , make_ord_flag defFlag "pgmlas"+      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_las  = (f,[]) }   , make_ord_flag defFlag "pgmlm"       $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_lm  =           if null f then Nothing else Just (f,[]) }@@ -1099,8 +1098,6 @@          }   , make_ord_flag defFlag "pgml-supports-no-pie"       $ noArg $ alterToolSettings $ \s -> s { toolSettings_ccSupportsNoPie = True }-  , make_ord_flag defFlag "pgmdll"-      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_dll = (f,[]) }   , make_ord_flag defFlag "pgmwindres"       $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_pgm_windres = f }   , make_ord_flag defFlag "pgmar"@@ -1120,6 +1117,8 @@       $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_lo  = f : toolSettings_opt_lo s }   , make_ord_flag defFlag "optlc"       $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_lc  = f : toolSettings_opt_lc s }+  , make_ord_flag defFlag "optlas"+      $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_las  = f : toolSettings_opt_las s }   , make_ord_flag defFlag "opti"       $ hasArg $ \f -> alterToolSettings $ \s -> s { toolSettings_opt_i   = f : toolSettings_opt_i s }   , make_ord_flag defFlag "optL"@@ -1140,9 +1139,6 @@       $ hasArg $ \f ->         alterToolSettings $ \s -> s { toolSettings_opt_windres = f : toolSettings_opt_windres s } -  , make_ord_flag defGhcFlag "split-objs"-      (NoArg $ addWarn "ignoring -split-objs")-     -- N.B. We may someday deprecate this in favor of -fsplit-sections,     -- which has the benefit of also having a negating -fno-split-sections.   , make_ord_flag defGhcFlag "split-sections"@@ -1326,6 +1322,13 @@   , make_ord_flag defFlag "fdiagnostics-color=never"       (NoArg (upd (\d -> d { useColor = Never }))) +  , make_ord_flag defFlag "fprint-error-index-links=auto"+      (NoArg (upd (\d -> d { useErrorLinks = Auto })))+  , make_ord_flag defFlag "fprint-error-index-links=always"+      (NoArg (upd (\d -> d { useErrorLinks = Always })))+  , make_ord_flag defFlag "fprint-error-index-links=never"+      (NoArg (upd (\d -> d { useErrorLinks = Never })))+   -- Suppress all that is suppressible in core dumps.   -- Except for uniques, as some simplifier phases introduce new variables that   -- have otherwise identical names.@@ -1466,10 +1469,16 @@         (setDumpFlag Opt_D_dump_call_arity)   , make_ord_flag defGhcFlag "ddump-exitify"         (setDumpFlag Opt_D_dump_exitify)-  , make_ord_flag defGhcFlag "ddump-stranal"-        (setDumpFlag Opt_D_dump_stranal)-  , make_ord_flag defGhcFlag "ddump-str-signatures"-        (setDumpFlag Opt_D_dump_str_signatures)+  , make_dep_flag defGhcFlag "ddump-stranal"+        (setDumpFlag Opt_D_dump_dmdanal)+        "Use `-ddump-dmdanal` instead"+  , make_dep_flag defGhcFlag "ddump-str-signatures"+        (setDumpFlag Opt_D_dump_dmd_signatures)+        "Use `-ddump-dmd-signatures` instead"+  , make_ord_flag defGhcFlag "ddump-dmdanal"+        (setDumpFlag Opt_D_dump_dmdanal)+  , make_ord_flag defGhcFlag "ddump-dmd-signatures"+        (setDumpFlag Opt_D_dump_dmd_signatures)   , make_ord_flag defGhcFlag "ddump-cpranal"         (setDumpFlag Opt_D_dump_cpranal)   , make_ord_flag defGhcFlag "ddump-cpr-signatures"@@ -1578,15 +1587,15 @@         (NoArg (setGeneralFlag Opt_NoTypeableBinds))   , make_ord_flag defGhcFlag "ddump-debug"         (setDumpFlag Opt_D_dump_debug)-  , make_ord_flag defGhcFlag "ddump-json"-        (setDumpFlag Opt_D_dump_json )+  , make_dep_flag defGhcFlag "ddump-json"+        (setDumpFlag Opt_D_dump_json)+        "Use `-fdiagnostics-as-json` instead"   , make_ord_flag defGhcFlag "dppr-debug"         (setDumpFlag Opt_D_ppr_debug)   , make_ord_flag defGhcFlag "ddebug-output"         (noArg (flip dopt_unset Opt_D_no_debug_output))   , make_ord_flag defGhcFlag "dno-debug-output"         (setDumpFlag Opt_D_no_debug_output)-   , make_ord_flag defGhcFlag "ddump-faststrings"         (setDumpFlag Opt_D_dump_faststrings) @@ -1893,6 +1902,7 @@       ------ JavaScript flags -----------------------------------------------  ++ [ make_ord_flag defFlag "ddisable-js-minifier" (NoArg (setGeneralFlag Opt_DisableJsMinifier))+    , make_ord_flag defFlag "ddisable-js-c-sources" (NoArg (setGeneralFlag Opt_DisableJsCsources))     ]       ------ Language flags -------------------------------------------------@@ -2173,12 +2183,11 @@ wWarningFlagsDeps = [minBound..maxBound] >>= \x -> case x of -- See Note [Updating flag description in the User's Guide] -- See Note [Supporting CLI completion]--- Please keep the list of flags below sorted alphabetically   Opt_WarnAlternativeLayoutRuleTransitional -> warnSpec x   Opt_WarnAmbiguousFields -> warnSpec x-  Opt_WarnAutoOrphans-    -> depWarnSpec x  "it has no effect"+  Opt_WarnAutoOrphans -> depWarnSpec x "it has no effect"   Opt_WarnCPPUndef -> warnSpec x+  Opt_WarnBadlyStagedTypes -> warnSpec x   Opt_WarnUnbangedStrictPatterns -> warnSpec x   Opt_WarnDeferredTypeErrors -> warnSpec x   Opt_WarnDeferredOutOfScopeVariables -> warnSpec x@@ -2197,26 +2206,25 @@     -> depWarnSpec x "it is not used, and was never implemented"   Opt_WarnInaccessibleCode -> warnSpec x   Opt_WarnImplicitPrelude -> warnSpec x-  Opt_WarnImplicitKindVars-    -> depWarnSpec x "it is now an error"+  Opt_WarnImplicitKindVars -> depWarnSpec x "it is now an error"   Opt_WarnIncompletePatterns -> warnSpec x   Opt_WarnIncompletePatternsRecUpd -> warnSpec x   Opt_WarnIncompleteUniPatterns -> warnSpec x   Opt_WarnInconsistentFlags -> warnSpec x   Opt_WarnInlineRuleShadowing -> warnSpec x   Opt_WarnIdentities -> warnSpec x-  Opt_WarnLoopySuperclassSolve -> warnSpec x+  Opt_WarnLoopySuperclassSolve -> depWarnSpec x "it is now an error"   Opt_WarnMissingFields -> warnSpec x   Opt_WarnMissingImportList -> warnSpec x   Opt_WarnMissingExportList -> warnSpec x   Opt_WarnMissingLocalSignatures     -> subWarnSpec "missing-local-sigs" x-                 "it is replaced by -Wmissing-local-signatures"+                   "it is replaced by -Wmissing-local-signatures"        ++ warnSpec x   Opt_WarnMissingMethods -> warnSpec x   Opt_WarnMissingMonadFailInstances     -> depWarnSpec x "fail is no longer a method of Monad"-  Opt_WarnSemigroup -> warnSpec x+  Opt_WarnSemigroup -> depWarnSpec x "Semigroup is now a superclass of Monoid"   Opt_WarnMissingSignatures -> warnSpec x   Opt_WarnMissingKindSignatures -> warnSpec x   Opt_WarnMissingPolyKindSignatures -> warnSpec x@@ -2227,7 +2235,8 @@   Opt_WarnMonomorphism -> warnSpec x   Opt_WarnNameShadowing -> warnSpec x   Opt_WarnNonCanonicalMonadInstances -> warnSpec x-  Opt_WarnNonCanonicalMonadFailInstances -> depWarnSpec x "fail is no longer a method of Monad"+  Opt_WarnNonCanonicalMonadFailInstances+    -> depWarnSpec x "fail is no longer a method of Monad"   Opt_WarnNonCanonicalMonoidInstances -> warnSpec x   Opt_WarnOrphans -> warnSpec x   Opt_WarnOverflowedLiterals -> warnSpec x@@ -2280,7 +2289,8 @@   Opt_WarnOperatorWhitespace -> warnSpec x   Opt_WarnImplicitLift -> warnSpec x   Opt_WarnMissingExportedPatternSynonymSignatures -> warnSpec x-  Opt_WarnForallIdentifier -> warnSpec x+  Opt_WarnForallIdentifier+    -> depWarnSpec x "forall is no longer a valid identifier"   Opt_WarnUnicodeBidirectionalFormatCharacters -> warnSpec x   Opt_WarnGADTMonoLocalBinds -> warnSpec x   Opt_WarnTypeEqualityOutOfScope -> warnSpec x@@ -2289,6 +2299,10 @@   Opt_WarnMissingRoleAnnotations -> warnSpec x   Opt_WarnImplicitRhsQuantification -> warnSpec x   Opt_WarnIncompleteExportWarnings -> warnSpec x+  Opt_WarnIncompleteRecordSelectors -> warnSpec x+  Opt_WarnDataKindsTC -> warnSpec x+  Opt_WarnDeprecatedTypeAbstractions -> warnSpec x+  Opt_WarnDefaultedExceptionContext -> warnSpec x  warningGroupsDeps :: [(Deprecation, FlagSpec WarningGroup)] warningGroupsDeps = map mk warningGroups@@ -2356,6 +2370,7 @@   flagSpec "defer-typed-holes"                Opt_DeferTypedHoles,   flagSpec "defer-out-of-scope-variables"     Opt_DeferOutOfScopeVariables,   flagSpec "diagnostics-show-caret"           Opt_DiagnosticsShowCaret,+  flagSpec "diagnostics-as-json"              Opt_DiagnosticsAsJSON,   -- With-ways needs to be reversible hence why its made via flagSpec unlike   -- other debugging flags.   flagSpec "dump-with-ways"                   Opt_DumpWithWays,@@ -2365,13 +2380,16 @@       Opt_DmdTxDictSel "effect is now unconditionally enabled",   flagSpec "do-eta-reduction"                 Opt_DoEtaReduction,   flagSpec "do-lambda-eta-expansion"          Opt_DoLambdaEtaExpansion,+  flagSpec "do-clever-arg-eta-expansion"      Opt_DoCleverArgEtaExpansion, -- See Note [Eta expansion of arguments in CorePrep]   flagSpec "eager-blackholing"                Opt_EagerBlackHoling,+  flagSpec "orig-thunk-info"                  Opt_OrigThunkInfo,   flagSpec "embed-manifest"                   Opt_EmbedManifest,   flagSpec "enable-rewrite-rules"             Opt_EnableRewriteRules,   flagSpec "enable-th-splice-warnings"        Opt_EnableThSpliceWarnings,   flagSpec "error-spans"                      Opt_ErrorSpans,   flagSpec "excess-precision"                 Opt_ExcessPrecision,   flagSpec "expose-all-unfoldings"            Opt_ExposeAllUnfoldings,+  flagSpec "keep-auto-rules"                  Opt_KeepAutoRules,   flagSpec "expose-internal-symbols"          Opt_ExposeInternalSymbols,   flagSpec "external-dynamic-refs"            Opt_ExternalDynamicRefs,   flagSpec "external-interpreter"             Opt_ExternalInterpreter,@@ -2402,7 +2420,6 @@   flagSpec "late-dmd-anal"                    Opt_LateDmdAnal,   flagSpec "late-specialise"                  Opt_LateSpecialise,   flagSpec "liberate-case"                    Opt_LiberateCase,-  flagHiddenSpec "llvm-tbaa"                  Opt_LlvmTBAA,   flagHiddenSpec "llvm-fill-undef-with-garbage" Opt_LlvmFillUndefWithGarbage,   flagSpec "loopification"                    Opt_Loopification,   flagSpec "block-layout-cfg"                 Opt_CfgBlocklayout,@@ -2429,6 +2446,8 @@   flagSpec "prof-cafs"                        Opt_AutoSccsOnIndividualCafs,   flagSpec "prof-count-entries"               Opt_ProfCountEntries,   flagSpec "prof-late"                        Opt_ProfLateCcs,+  flagSpec "prof-late-overloaded"             Opt_ProfLateOverloadedCcs,+  flagSpec "prof-late-overloaded-calls"       Opt_ProfLateoverloadedCallsCCs,   flagSpec "prof-manual"                      Opt_ProfManualCcs,   flagSpec "prof-late-inline"                 Opt_ProfLateInlineCcs,   flagSpec "regs-graph"                       Opt_RegsGraph,@@ -2570,12 +2589,12 @@       -- the rationale       | isAIX, flagSpecFlag flg == LangExt.TemplateHaskell  = [noName]       | isAIX, flagSpecFlag flg == LangExt.QuasiQuotes      = [noName]-      -- "JavaScriptFFI" is only supported on the JavaScript backend-      | notJS, flagSpecFlag flg == LangExt.JavaScriptFFI    = [noName]+      -- "JavaScriptFFI" is only supported on the JavaScript/Wasm backend+      | notJSOrWasm, flagSpecFlag flg == LangExt.JavaScriptFFI = [noName]       | otherwise = [name, noName]       where         isAIX = os == OSAIX-        notJS = arch /= ArchJavaScript+        notJSOrWasm = not $ arch `elem` [ ArchJavaScript, ArchWasm32 ]         noName = "No" ++ name         name = flagSpecName flg @@ -2588,7 +2607,8 @@ languageFlagsDeps = [   flagSpec "Haskell98"   Haskell98,   flagSpec "Haskell2010" Haskell2010,-  flagSpec "GHC2021"     GHC2021+  flagSpec "GHC2021"     GHC2021,+  flagSpec "GHC2024"     GHC2024   ]  -- | These -X<blah> flags cannot be reversed with -XNo<blah>@@ -2682,6 +2702,7 @@   flagSpec "LexicalNegation"                  LangExt.LexicalNegation,   flagSpec "LiberalTypeSynonyms"              LangExt.LiberalTypeSynonyms,   flagSpec "LinearTypes"                      LangExt.LinearTypes,+  flagSpec "ListTuplePuns"                    LangExt.ListTuplePuns,   flagSpec "MagicHash"                        LangExt.MagicHash,   flagSpec "MonadComprehensions"              LangExt.MonadComprehensions,   flagSpec "MonoLocalBinds"                   LangExt.MonoLocalBinds,@@ -2732,6 +2753,7 @@   depFlagSpecCond "RelaxedPolyRec"            LangExt.RelaxedPolyRec     not          "You can't turn off RelaxedPolyRec any more",+  flagSpec "RequiredTypeArguments"            LangExt.RequiredTypeArguments,   flagSpec "RoleAnnotations"                  LangExt.RoleAnnotations,   flagSpec "ScopedTypeVariables"              LangExt.ScopedTypeVariables,   flagSpec "StandaloneDeriving"               LangExt.StandaloneDeriving,@@ -2859,9 +2881,10 @@     -- The extensions needed to declare an H98 unlifted data type     , (LangExt.UnliftedDatatypes, turnOn, LangExt.DataKinds)     , (LangExt.UnliftedDatatypes, turnOn, LangExt.StandaloneKindSignatures)-  ] -+    -- See Note [Non-variable pattern bindings aren't linear] in GHC.Tc.Gen.Bind+    , (LangExt.LinearTypes, turnOn, LangExt.MonoLocalBinds)+  ]  -- | Things you get with `-dlint`. enableDLint :: DynP ()@@ -3734,49 +3757,7 @@   -- -------------------------------------------------------------------------------- SSE, AVX, FMA -isSse4_2Enabled :: DynFlags -> Bool-isSse4_2Enabled dflags = sseVersion dflags >= Just SSE42--isAvxEnabled :: DynFlags -> Bool-isAvxEnabled dflags = avx dflags || avx2 dflags || avx512f dflags--isAvx2Enabled :: DynFlags -> Bool-isAvx2Enabled dflags = avx2 dflags || avx512f dflags--isAvx512cdEnabled :: DynFlags -> Bool-isAvx512cdEnabled dflags = avx512cd dflags--isAvx512erEnabled :: DynFlags -> Bool-isAvx512erEnabled dflags = avx512er dflags--isAvx512fEnabled :: DynFlags -> Bool-isAvx512fEnabled dflags = avx512f dflags--isAvx512pfEnabled :: DynFlags -> Bool-isAvx512pfEnabled dflags = avx512pf dflags--isFmaEnabled :: DynFlags -> Bool-isFmaEnabled dflags = fma dflags---- -------------------------------------------------------------------------------- BMI2--isBmiEnabled :: DynFlags -> Bool-isBmiEnabled dflags = case platformArch (targetPlatform dflags) of-    ArchX86_64 -> bmiVersion dflags >= Just BMI1-    ArchX86    -> bmiVersion dflags >= Just BMI1-    _          -> False--isBmi2Enabled :: DynFlags -> Bool-isBmi2Enabled dflags = case platformArch (targetPlatform dflags) of-    ArchX86_64 -> bmiVersion dflags >= Just BMI2-    ArchX86    -> bmiVersion dflags >= Just BMI2-    _          -> False---- ------------------------------------------------------------------------------ -- | Indicate if cost-centre profiling is enabled sccProfilingEnabled :: DynFlags -> Bool sccProfilingEnabled dflags = profileIsProfiling (targetProfile dflags)@@ -3785,6 +3766,10 @@ needSourceNotes :: DynFlags -> Bool needSourceNotes dflags = debugLevel dflags > 0                        || gopt Opt_InfoTableMap dflags++                       -- Source ticks are used to approximate the location of+                       -- overloaded call cost centers+                       || gopt Opt_ProfLateoverloadedCallsCCs dflags  -- ----------------------------------------------------------------------------- -- Linker/compiler information
compiler/GHC/Hs.hs view
@@ -60,7 +60,7 @@ import GHC.Utils.Outputable import GHC.Types.Fixity         ( Fixity ) import GHC.Types.SrcLoc-import GHC.Unit.Module.Warnings ( WarningTxt )+import GHC.Unit.Module.Warnings  -- libraries: import Data.Data hiding ( Fixity )@@ -69,10 +69,10 @@ data XModulePs   = XModulePs {       hsmodAnn :: EpAnn AnnsModule,-      hsmodLayout :: LayoutInfo GhcPs,+      hsmodLayout :: EpLayout,         -- ^ Layout info for the module.-        -- For incomplete modules (e.g. the output of parseHeader), it is NoLayoutInfo.-      hsmodDeprecMessage :: Maybe (LocatedP (WarningTxt GhcPs)),+        -- For incomplete modules (e.g. the output of parseHeader), it is EpNoLayout.+      hsmodDeprecMessage :: Maybe (LWarningTxt GhcPs),         -- ^ reason\/explanation for warning/deprecation of this module         --         --  - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnOpen'@@ -102,9 +102,14 @@ data AnnsModule   = AnnsModule {     am_main :: [AddEpAnn],-    am_decls :: [TrailingAnn],-    am_eof :: Maybe (RealSrcSpan, RealSrcSpan) -- End of file and end of prior token+    am_decls :: [TrailingAnn],                 -- ^ Semis before the start of top decls+    am_cs :: [LEpaComment],                    -- ^ Comments before start of top decl,+                                               --   used in exact printing only+    am_eof :: Maybe (RealSrcSpan, RealSrcSpan) -- ^ End of file and end of prior token     } deriving (Data, Eq)++instance NoAnn AnnsModule where+  noAnn = AnnsModule [] [] [] Nothing  instance Outputable (HsModule GhcPs) where     ppr (HsModule { hsmodExt = XModulePs { hsmodHaddockModHeader = mbDoc }
compiler/GHC/Hs/Binds.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE AllowAmbiguousTypes #-} -- used to pass the phase to ppr_mult_ann since MultAnn is a type family {-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-}@@ -53,6 +54,7 @@  import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.Utils.Misc ((<||>))  import Data.Function import Data.List (sortBy)@@ -85,7 +87,7 @@       [(RecFlag, LHsBinds idL)]       [LSig GhcRn] -type instance XValBinds    (GhcPass pL) (GhcPass pR) = AnnSortKey+type instance XValBinds    (GhcPass pL) (GhcPass pR) = AnnSortKey BindTag type instance XXValBindsLR (GhcPass pL) pR             = NHsValBindsLR (GhcPass pL) @@ -114,7 +116,7 @@ -- type         Int -> forall a'. a' -> a' -- Notice that the coercion captures the free a'. -type instance XPatBind    GhcPs (GhcPass pR) = EpAnn [AddEpAnn]+type instance XPatBind    GhcPs (GhcPass pR) = NoExtField type instance XPatBind    GhcRn (GhcPass pR) = NameSet -- See Note [Bind free vars] type instance XPatBind    GhcTc (GhcPass pR) =     ( Type                  -- Type of the GRHSs@@ -132,12 +134,36 @@ type instance XXHsBindsLR GhcRn pR = DataConCantHappen type instance XXHsBindsLR GhcTc pR = AbsBinds -type instance XPSB         (GhcPass idL) GhcPs = EpAnn [AddEpAnn]+type instance XPSB         (GhcPass idL) GhcPs = [AddEpAnn] type instance XPSB         (GhcPass idL) GhcRn = NameSet -- Post renaming, FVs. See Note [Bind free vars] type instance XPSB         (GhcPass idL) GhcTc = NameSet  type instance XXPatSynBind (GhcPass idL) (GhcPass idR) = DataConCantHappen +type instance XNoMultAnn GhcPs = NoExtField+type instance XNoMultAnn GhcRn = NoExtField+type instance XNoMultAnn GhcTc = Mult++type instance XPct1Ann   GhcPs = EpToken "%1"+type instance XPct1Ann   GhcRn = NoExtField+type instance XPct1Ann   GhcTc = Mult++type instance XMultAnn   GhcPs = EpToken "%"+type instance XMultAnn   GhcRn = NoExtField+type instance XMultAnn   GhcTc = Mult++type instance XXMultAnn  (GhcPass _) = DataConCantHappen++setTcMultAnn :: Mult -> HsMultAnn GhcRn -> HsMultAnn GhcTc+setTcMultAnn mult (HsPct1Ann _)   = HsPct1Ann mult+setTcMultAnn mult (HsMultAnn _ p) = HsMultAnn mult p+setTcMultAnn mult (HsNoMultAnn _) = HsNoMultAnn mult++getTcMultAnn :: HsMultAnn GhcTc -> Mult+getTcMultAnn (HsPct1Ann mult)   = mult+getTcMultAnn (HsMultAnn mult _) = mult+getTcMultAnn (HsNoMultAnn mult) = mult+ -- ---------------------------------------------------------------------  -- | Typechecked, generalised bindings, used in the output to the type checker.@@ -508,6 +534,13 @@ plusHsValBinds _ _   = panic "HsBinds.plusHsValBinds" +-- Used to print, for instance, let bindings:+--   let %1 x = …+pprHsMultAnn :: forall id. OutputableBndrId id => HsMultAnn (GhcPass id) -> SDoc+pprHsMultAnn (HsNoMultAnn _) = empty+pprHsMultAnn (HsPct1Ann _) = text "%1"+pprHsMultAnn (HsMultAnn _ p) = text "%" <> ppr p+ instance (OutputableBndrId pl, OutputableBndrId pr)          => Outputable (HsBindLR (GhcPass pl) (GhcPass pr)) where     ppr mbind = ppr_monobind mbind@@ -516,8 +549,9 @@                 (OutputableBndrId idL, OutputableBndrId idR)              => HsBindLR (GhcPass idL) (GhcPass idR) -> SDoc -ppr_monobind (PatBind { pat_lhs = pat, pat_rhs = grhss })-  = pprPatBind pat grhss+ppr_monobind (PatBind { pat_lhs = pat, pat_mult = mult_ann, pat_rhs = grhss })+  = pprHsMultAnn @idL mult_ann+    <+> pprPatBind pat grhss ppr_monobind (VarBind { var_id = var, var_rhs = rhs })   = sep [pprBndr CasePatBind var, nest 2 $ equals <+> pprExpr (unLoc rhs)] ppr_monobind (FunBind { fun_id = fun,@@ -545,10 +579,6 @@  ppr_monobind (PatSynBind _ psb) = ppr psb ppr_monobind (XHsBindsLR b) = case ghcPass @idL of-#if __GLASGOW_HASKELL__ <= 900-  GhcPs -> dataConCantHappen b-  GhcRn -> dataConCantHappen b-#endif   GhcTc -> ppr_absbinds b     where       ppr_absbinds (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars@@ -650,7 +680,7 @@ isEmptyIPBindsTc (IPBinds ds is) = null is && isEmptyTcEvBinds ds  -- EPA annotations in GhcPs, dictionary Id in GhcTc-type instance XCIPBind GhcPs = EpAnn [AddEpAnn]+type instance XCIPBind GhcPs = [AddEpAnn] type instance XCIPBind GhcRn = NoExtField type instance XCIPBind GhcTc = Id type instance XXIPBind    (GhcPass p) = DataConCantHappen@@ -675,24 +705,67 @@ ************************************************************************ -} -type instance XTypeSig          (GhcPass p) = EpAnn AnnSig-type instance XPatSynSig        (GhcPass p) = EpAnn AnnSig-type instance XClassOpSig       (GhcPass p) = EpAnn AnnSig-type instance XFixSig           (GhcPass p) = EpAnn [AddEpAnn]-type instance XInlineSig        (GhcPass p) = EpAnn [AddEpAnn]-type instance XSpecSig          (GhcPass p) = EpAnn [AddEpAnn]-type instance XSpecInstSig      (GhcPass p) = (EpAnn [AddEpAnn], SourceText)-type instance XMinimalSig       (GhcPass p) = (EpAnn [AddEpAnn], SourceText)-type instance XSCCFunSig        (GhcPass p) = (EpAnn [AddEpAnn], SourceText)-type instance XCompleteMatchSig (GhcPass p) = (EpAnn [AddEpAnn], SourceText)+type instance XTypeSig          (GhcPass p) = AnnSig+type instance XPatSynSig        (GhcPass p) = AnnSig+type instance XClassOpSig       (GhcPass p) = AnnSig+type instance XFixSig           (GhcPass p) = [AddEpAnn]+type instance XInlineSig        (GhcPass p) = [AddEpAnn]+type instance XSpecSig          (GhcPass p) = [AddEpAnn]+type instance XSpecInstSig      (GhcPass p) = ([AddEpAnn], SourceText)+type instance XMinimalSig       (GhcPass p) = ([AddEpAnn], SourceText)+type instance XSCCFunSig        (GhcPass p) = ([AddEpAnn], SourceText)+type instance XCompleteMatchSig (GhcPass p) = ([AddEpAnn], SourceText)     -- SourceText: Note [Pragma source text] in "GHC.Types.SourceText" type instance XXSig             GhcPs = DataConCantHappen type instance XXSig             GhcRn = IdSig type instance XXSig             GhcTc = IdSig -type instance XFixitySig  (GhcPass p) = NoExtField+type instance XFixitySig  GhcPs = NamespaceSpecifier+type instance XFixitySig  GhcRn = NamespaceSpecifier+type instance XFixitySig  GhcTc = NoExtField type instance XXFixitySig (GhcPass p) = DataConCantHappen +-- | Optional namespace specifier for fixity signatures,+--  WARNINIG and DEPRECATED pragmas.+--+-- Examples:+--+--   {-# WARNING in "x-partial" data Head "don't use this pattern synonym" #-}+--                            -- ↑ DataNamespaceSpecifier+--+--   {-# DEPRECATED type D "This type was deprecated" #-}+--                -- ↑ TypeNamespaceSpecifier+--+--   infixr 6 data $+--          -- ↑ DataNamespaceSpecifier+data NamespaceSpecifier+  = NoNamespaceSpecifier+  | TypeNamespaceSpecifier (EpToken "type")+  | DataNamespaceSpecifier (EpToken "data")+  deriving (Eq, Data)++-- | Check if namespace specifiers overlap, i.e. if they are equal or+-- if at least one of them doesn't specify a namespace+overlappingNamespaceSpecifiers :: NamespaceSpecifier -> NamespaceSpecifier -> Bool+overlappingNamespaceSpecifiers NoNamespaceSpecifier _ = True+overlappingNamespaceSpecifiers _ NoNamespaceSpecifier = True+overlappingNamespaceSpecifiers TypeNamespaceSpecifier{} TypeNamespaceSpecifier{} = True+overlappingNamespaceSpecifiers DataNamespaceSpecifier{} DataNamespaceSpecifier{} = True+overlappingNamespaceSpecifiers _ _ = False++-- | Check if namespace is covered by a namespace specifier:+--     * NoNamespaceSpecifier covers both namespaces+--     * TypeNamespaceSpecifier covers the type namespace only+--     * DataNamespaceSpecifier covers the data namespace only+coveredByNamespaceSpecifier :: NamespaceSpecifier -> NameSpace -> Bool+coveredByNamespaceSpecifier NoNamespaceSpecifier = const True+coveredByNamespaceSpecifier TypeNamespaceSpecifier{} = isTcClsNameSpace <||> isTvNameSpace+coveredByNamespaceSpecifier DataNamespaceSpecifier{} = isValNameSpace+instance Outputable NamespaceSpecifier where+  ppr NoNamespaceSpecifier = empty+  ppr TypeNamespaceSpecifier{} = text "type"+  ppr DataNamespaceSpecifier{} = text "data"+ -- | A type signature in generated code, notably the code -- generated for record selectors. We simply record the desired Id -- itself, replete with its name, type and IdDetails. Otherwise it's@@ -706,6 +779,8 @@       asRest   :: [AddEpAnn]       } deriving Data +instance NoAnn AnnSig where+  noAnn = AnnSig noAnn noAnn  -- | Type checker Specialisation Pragmas --@@ -778,7 +853,7 @@           GhcTc -> ppr fn ppr_sig (CompleteMatchSig (_, src) cs mty)   = pragSrcBrackets src "{-# COMPLETE"-      ((hsep (punctuate comma (map ppr_n (unLoc cs))))+      ((hsep (punctuate comma (map ppr_n cs)))         <+> opt_sig)   where     opt_sig = maybe empty ((\t -> dcolon <+> ppr t) . unLoc) mty@@ -871,14 +946,6 @@ type instance Anno (IPBind (GhcPass p)) = SrcSpanAnnA type instance Anno (Sig (GhcPass p)) = SrcSpanAnnA --- For CompleteMatchSig-type instance Anno [LocatedN RdrName] = SrcSpan-type instance Anno [LocatedN Name]    = SrcSpan-type instance Anno [LocatedN Id]      = SrcSpan- type instance Anno (FixitySig (GhcPass p)) = SrcSpanAnnA -type instance Anno StringLiteral = SrcAnn NoEpAnns-type instance Anno (LocatedN RdrName) = SrcSpan-type instance Anno (LocatedN Name) = SrcSpan-type instance Anno (LocatedN Id) = SrcSpan+type instance Anno StringLiteral = EpAnnCO
compiler/GHC/Hs/Decls.hs view
@@ -6,10 +6,12 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]                                       -- in module Language.Haskell.Syntax.Extension  {-# OPTIONS_GHC -Wno-orphans #-} -- Outputable+{-# LANGUAGE InstanceSigs #-}  {- (c) The University of Glasgow 2006@@ -49,7 +51,7 @@   TyFamDefltDecl, LTyFamDefltDecl,   DataFamInstDecl(..), LDataFamInstDecl,   pprDataFamInstFlavour, pprTyFamInstDecl, pprHsFamInstLHS,-  FamEqn(..), TyFamInstEqn, LTyFamInstEqn, HsTyPats,+  FamEqn(..), TyFamInstEqn, LTyFamInstEqn, HsFamEqnPats,   LClsInstDecl, ClsInstDecl(..),    -- ** Standalone deriving declarations@@ -79,7 +81,7 @@   -- ** Document comments   DocDecl(..), LDocDecl, docDeclDoc,   -- ** Deprecations-  WarnDecl(..),  LWarnDecl,+  WarnDecl(..), LWarnDecl,   WarnDecls(..), LWarnDecls,   -- ** Annotations   AnnDecl(..), LAnnDecl,@@ -125,7 +127,7 @@ import GHC.Types.SourceText import GHC.Core.Type import GHC.Types.ForeignCall-import GHC.Unit.Module.Warnings (WarningTxt(..))+import GHC.Unit.Module.Warnings  import GHC.Data.Bag import GHC.Data.Maybe@@ -336,11 +338,11 @@  type instance XFamDecl      (GhcPass _) = NoExtField -type instance XSynDecl      GhcPs = EpAnn [AddEpAnn]+type instance XSynDecl      GhcPs = [AddEpAnn] type instance XSynDecl      GhcRn = NameSet -- FVs type instance XSynDecl      GhcTc = NameSet -- FVs -type instance XDataDecl     GhcPs = EpAnn [AddEpAnn]+type instance XDataDecl     GhcPs = [AddEpAnn] type instance XDataDecl     GhcRn = DataDeclRn type instance XDataDecl     GhcTc = DataDeclRn @@ -350,15 +352,17 @@              , tcdFVs      :: NameSet }   deriving Data -type instance XClassDecl    GhcPs = (EpAnn [AddEpAnn], AnnSortKey)+type instance XClassDecl    GhcPs =+  ( [AddEpAnn]+  , EpLayout              -- See Note [Class EpLayout]+  , AnnSortKey DeclTag )  -- TODO:AZ:tidy up AnnSortKey -  -- TODO:AZ:tidy up AnnSortKey above type instance XClassDecl    GhcRn = NameSet -- FVs type instance XClassDecl    GhcTc = NameSet -- FVs  type instance XXTyClDecl    (GhcPass _) = DataConCantHappen -type instance XCTyFamInstDecl (GhcPass _) = EpAnn [AddEpAnn]+type instance XCTyFamInstDecl (GhcPass _) = [AddEpAnn] type instance XXTyFamInstDecl (GhcPass _) = DataConCantHappen  ------------- Pretty printing FamilyDecls -----------@@ -508,7 +512,7 @@ instance OutputableBndrId p => Outputable (FunDep (GhcPass p)) where   ppr = pprFunDep -type instance XCFunDep    (GhcPass _) = EpAnn [AddEpAnn]+type instance XCFunDep    (GhcPass _) = [AddEpAnn] type instance XXFunDep    (GhcPass _) = DataConCantHappen  pprFundeps :: OutputableBndrId p => [FunDep (GhcPass p)] -> SDoc@@ -542,7 +546,7 @@ type instance XTyVarSig         (GhcPass _) = NoExtField type instance XXFamilyResultSig (GhcPass _) = DataConCantHappen -type instance XCFamilyDecl    (GhcPass _) = EpAnn [AddEpAnn]+type instance XCFamilyDecl    (GhcPass _) = [AddEpAnn] type instance XXFamilyDecl    (GhcPass _) = DataConCantHappen  @@ -569,7 +573,7 @@  ------------- Pretty printing FamilyDecls ----------- -type instance XCInjectivityAnn  (GhcPass _) = EpAnn [AddEpAnn]+type instance XCInjectivityAnn  (GhcPass _) = [AddEpAnn] type instance XXInjectivityAnn  (GhcPass _) = DataConCantHappen  instance OutputableBndrId p@@ -616,7 +620,7 @@ type instance XCHsDataDefn    (GhcPass _) = NoExtField type instance XXHsDataDefn    (GhcPass _) = DataConCantHappen -type instance XCHsDerivingClause    (GhcPass _) = EpAnn [AddEpAnn]+type instance XCHsDerivingClause    (GhcPass _) = [AddEpAnn] type instance XXHsDerivingClause    (GhcPass _) = DataConCantHappen  instance OutputableBndrId p@@ -652,7 +656,7 @@   ppr (DctSingle _ ty) = ppr ty   ppr (DctMulti _ tys) = parens (interpp'SP tys) -type instance XStandaloneKindSig GhcPs = EpAnn [AddEpAnn]+type instance XStandaloneKindSig GhcPs = [AddEpAnn] type instance XStandaloneKindSig GhcRn = NoExtField type instance XStandaloneKindSig GhcTc = NoExtField @@ -661,11 +665,24 @@ standaloneKindSigName :: StandaloneKindSig (GhcPass p) -> IdP (GhcPass p) standaloneKindSigName (StandaloneKindSig _ lname _) = unLoc lname -type instance XConDeclGADT (GhcPass _) = EpAnn [AddEpAnn]-type instance XConDeclH98  (GhcPass _) = EpAnn [AddEpAnn]+type instance XConDeclGADT GhcPs = (EpUniToken "::" "∷", [AddEpAnn])+type instance XConDeclGADT GhcRn = NoExtField+type instance XConDeclGADT GhcTc = NoExtField +type instance XConDeclH98  GhcPs = [AddEpAnn]+type instance XConDeclH98  GhcRn = NoExtField+type instance XConDeclH98  GhcTc = NoExtField+ type instance XXConDecl (GhcPass _) = DataConCantHappen +type instance XPrefixConGADT       (GhcPass _) = NoExtField++type instance XRecConGADT          GhcPs = EpUniToken "->" "→"+type instance XRecConGADT          GhcRn = NoExtField+type instance XRecConGADT          GhcTc = NoExtField++type instance XXConDeclGADTDetails (GhcPass _) = DataConCantHappen+ -- Codomain could be 'NonEmpty', but at the moment all users need a list. getConNames :: ConDecl GhcRn -> [LocatedN Name] getConNames ConDeclH98  {con_name  = name}  = [name]@@ -681,7 +698,7 @@   InfixCon{}  -> Nothing getRecConArgs_maybe (ConDeclGADT{con_g_args = args}) = case args of   PrefixConGADT{} -> Nothing-  RecConGADT flds _ -> Just flds+  RecConGADT _ flds -> Just flds  hsConDeclTheta :: Maybe (LHsContext (GhcPass p)) -> [LHsType (GhcPass p)] hsConDeclTheta Nothing            = []@@ -770,8 +787,8 @@     <+> (sep [pprHsOuterSigTyVarBndrs outer_bndrs <+> pprLHsContext mcxt,               sep (ppr_args args ++ [ppr res_ty]) ])   where-    ppr_args (PrefixConGADT args) = map (\(HsScaled arr t) -> ppr t <+> ppr_arr arr) args-    ppr_args (RecConGADT fields _) = [pprConDeclFields (unLoc fields) <+> arrow]+    ppr_args (PrefixConGADT _ args) = map (\(HsScaled arr t) -> ppr t <+> ppr_arr arr) args+    ppr_args (RecConGADT _ fields) = [pprConDeclFields (unLoc fields) <+> arrow]      -- Display linear arrows as unrestricted with -XNoLinearTypes     -- (cf. dataConDisplayType in Note [Displaying linear fields] in GHC.Core.DataCon)@@ -790,15 +807,24 @@ ************************************************************************ -} -type instance XCFamEqn    (GhcPass _) r = EpAnn [AddEpAnn]+type instance XCFamEqn    (GhcPass _) r = [AddEpAnn] type instance XXFamEqn    (GhcPass _) r = DataConCantHappen  type instance Anno (FamEqn (GhcPass p) _) = SrcSpanAnnA  ----------------- Class instances ------------- -type instance XCClsInstDecl    GhcPs = (EpAnn [AddEpAnn], AnnSortKey) -- TODO:AZ:tidy up-type instance XCClsInstDecl    GhcRn = NoExtField+type instance XCClsInstDecl    GhcPs = ( Maybe (LWarningTxt GhcPs)+                                             -- The warning of the deprecated instance+                                             -- See Note [Implementation of deprecated instances]+                                             -- in GHC.Tc.Solver.Dict+                                       , [AddEpAnn]+                                       , AnnSortKey DeclTag) -- For sorting the additional annotations+                                        -- TODO:AZ:tidy up+type instance XCClsInstDecl    GhcRn = Maybe (LWarningTxt GhcRn)+                                           -- The warning of the deprecated instance+                                           -- See Note [Implementation of deprecated instances]+                                           -- in GHC.Tc.Solver.Dict type instance XCClsInstDecl    GhcTc = NoExtField  type instance XXClsInstDecl    (GhcPass _) = DataConCantHappen@@ -815,6 +841,19 @@  type instance XXInstDecl    (GhcPass _) = DataConCantHappen +cidDeprecation :: forall p. IsPass p+               => ClsInstDecl (GhcPass p)+               -> Maybe (WarningTxt (GhcPass p))+cidDeprecation = fmap unLoc . decl_deprecation (ghcPass @p)+  where+    decl_deprecation :: GhcPass p  -> ClsInstDecl (GhcPass p)+                     -> Maybe (LocatedP (WarningTxt (GhcPass p)))+    decl_deprecation GhcPs (ClsInstDecl{ cid_ext = (depr, _, _) } )+      = depr+    decl_deprecation GhcRn (ClsInstDecl{ cid_ext = depr })+      = depr+    decl_deprecation _ _ = Nothing+ instance OutputableBndrId p        => Outputable (TyFamInstDecl (GhcPass p)) where   ppr = pprTyFamInstDecl TopLevel@@ -867,7 +906,7 @@ pprHsFamInstLHS :: (OutputableBndrId p)    => IdP (GhcPass p)    -> HsOuterFamEqnTyVarBndrs (GhcPass p)-   -> HsTyPats (GhcPass p)+   -> HsFamEqnPats (GhcPass p)    -> LexicalFixity    -> Maybe (LHsContext (GhcPass p))    -> SDoc@@ -878,10 +917,10 @@  instance OutputableBndrId p        => Outputable (ClsInstDecl (GhcPass p)) where-    ppr (ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = binds-                     , cid_sigs = sigs, cid_tyfam_insts = ats-                     , cid_overlap_mode = mbOverlap-                     , cid_datafam_insts = adts })+    ppr (cid@ClsInstDecl { cid_poly_ty = inst_ty, cid_binds = binds+                         , cid_sigs = sigs, cid_tyfam_insts = ats+                         , cid_overlap_mode = mbOverlap+                         , cid_datafam_insts = adts })       | null sigs, null ats, null adts, isEmptyBag binds  -- No "where" part       = top_matter @@ -892,8 +931,9 @@                map (pprDataFamInstDecl NotTopLevel . unLoc) adts ++                pprLHsBindsForUser binds sigs ]       where-        top_matter = text "instance" <+> ppOverlapPragma mbOverlap-                                             <+> ppr inst_ty+        top_matter = text "instance" <+> maybe empty ppr (cidDeprecation cid)+                                     <+> ppOverlapPragma mbOverlap+                                     <+> ppr inst_ty  ppDerivStrategy :: OutputableBndrId p                 => Maybe (LDerivStrategy (GhcPass p)) -> SDoc@@ -959,19 +999,43 @@ ************************************************************************ -} -type instance XCDerivDecl    (GhcPass _) = EpAnn [AddEpAnn]+type instance XCDerivDecl    GhcPs = ( Maybe (LWarningTxt GhcPs)+                                           -- The warning of the deprecated derivation+                                           -- See Note [Implementation of deprecated instances]+                                           -- in GHC.Tc.Solver.Dict+                                     , [AddEpAnn] )+type instance XCDerivDecl    GhcRn = ( Maybe (LWarningTxt GhcRn)+                                           -- The warning of the deprecated derivation+                                           -- See Note [Implementation of deprecated instances]+                                           -- in GHC.Tc.Solver.Dict+                                     , [AddEpAnn] )+type instance XCDerivDecl    GhcTc = [AddEpAnn] type instance XXDerivDecl    (GhcPass _) = DataConCantHappen +derivDeprecation :: forall p. IsPass p+               => DerivDecl (GhcPass p)+               -> Maybe (WarningTxt (GhcPass p))+derivDeprecation = fmap unLoc . decl_deprecation (ghcPass @p)+  where+    decl_deprecation :: GhcPass p  -> DerivDecl (GhcPass p)+                     -> Maybe (LocatedP (WarningTxt (GhcPass p)))+    decl_deprecation GhcPs (DerivDecl{ deriv_ext = (depr, _) })+      = depr+    decl_deprecation GhcRn (DerivDecl{ deriv_ext = (depr, _) })+      = depr+    decl_deprecation _ _ = Nothing+ type instance Anno OverlapMode = SrcSpanAnnP  instance OutputableBndrId p        => Outputable (DerivDecl (GhcPass p)) where-    ppr (DerivDecl { deriv_type = ty+    ppr (deriv@DerivDecl { deriv_type = ty                    , deriv_strategy = ds                    , deriv_overlap_mode = o })         = hsep [ text "deriving"                , ppDerivStrategy ds                , text "instance"+               , maybe empty ppr (derivDeprecation deriv)                , ppOverlapPragma o                , ppr ty ] @@ -983,15 +1047,15 @@ ************************************************************************ -} -type instance XStockStrategy    GhcPs = EpAnn [AddEpAnn]+type instance XStockStrategy    GhcPs = [AddEpAnn] type instance XStockStrategy    GhcRn = NoExtField type instance XStockStrategy    GhcTc = NoExtField -type instance XAnyClassStrategy GhcPs = EpAnn [AddEpAnn]+type instance XAnyClassStrategy GhcPs = [AddEpAnn] type instance XAnyClassStrategy GhcRn = NoExtField type instance XAnyClassStrategy GhcTc = NoExtField -type instance XNewtypeStrategy  GhcPs = EpAnn [AddEpAnn]+type instance XNewtypeStrategy  GhcPs = [AddEpAnn] type instance XNewtypeStrategy  GhcRn = NoExtField type instance XNewtypeStrategy  GhcTc = NoExtField @@ -999,7 +1063,7 @@ type instance XViaStrategy GhcRn = LHsSigType GhcRn type instance XViaStrategy GhcTc = Type -data XViaStrategyPs = XViaStrategyPs (EpAnn [AddEpAnn]) (LHsSigType GhcPs)+data XViaStrategyPs = XViaStrategyPs [AddEpAnn] (LHsSigType GhcPs)  instance OutputableBndrId p         => Outputable (DerivStrategy (GhcPass p)) where@@ -1038,7 +1102,7 @@ ************************************************************************ -} -type instance XCDefaultDecl    GhcPs = EpAnn [AddEpAnn]+type instance XCDefaultDecl    GhcPs = [AddEpAnn] type instance XCDefaultDecl    GhcRn = NoExtField type instance XCDefaultDecl    GhcTc = NoExtField @@ -1057,20 +1121,20 @@ ************************************************************************ -} -type instance XForeignImport   GhcPs = EpAnn [AddEpAnn]+type instance XForeignImport   GhcPs = [AddEpAnn] type instance XForeignImport   GhcRn = NoExtField type instance XForeignImport   GhcTc = Coercion -type instance XForeignExport   GhcPs = EpAnn [AddEpAnn]+type instance XForeignExport   GhcPs = [AddEpAnn] type instance XForeignExport   GhcRn = NoExtField type instance XForeignExport   GhcTc = Coercion  type instance XXForeignDecl    (GhcPass _) = DataConCantHappen -type instance XCImport (GhcPass _) = Located SourceText -- original source text for the C entity+type instance XCImport (GhcPass _) = LocatedE SourceText -- original source text for the C entity type instance XXForeignImport  (GhcPass _) = DataConCantHappen -type instance XCExport (GhcPass _) = Located SourceText -- original source text for the C entity+type instance XCExport (GhcPass _) = LocatedE SourceText -- original source text for the C entity type instance XXForeignExport  (GhcPass _) = DataConCantHappen  -- pretty printing of foreign declarations@@ -1126,13 +1190,13 @@ ************************************************************************ -} -type instance XCRuleDecls    GhcPs = (EpAnn [AddEpAnn], SourceText)+type instance XCRuleDecls    GhcPs = ([AddEpAnn], SourceText) type instance XCRuleDecls    GhcRn = SourceText type instance XCRuleDecls    GhcTc = SourceText  type instance XXRuleDecls    (GhcPass _) = DataConCantHappen -type instance XHsRule       GhcPs = (EpAnn HsRuleAnn, SourceText)+type instance XHsRule       GhcPs = (HsRuleAnn, SourceText) type instance XHsRule       GhcRn = (HsRuleRn, SourceText) type instance XHsRule       GhcTc = (HsRuleRn, SourceText) @@ -1152,11 +1216,14 @@        , ra_rest :: [AddEpAnn]        } deriving (Data, Eq) +instance NoAnn HsRuleAnn where+  noAnn = HsRuleAnn Nothing Nothing []+ flattenRuleDecls :: [LRuleDecls (GhcPass p)] -> [LRuleDecl (GhcPass p)] flattenRuleDecls decls = concatMap (rds_rules . unLoc) decls -type instance XCRuleBndr    (GhcPass _) = EpAnn [AddEpAnn]-type instance XRuleBndrSig  (GhcPass _) = EpAnn [AddEpAnn]+type instance XCRuleBndr    (GhcPass _) = [AddEpAnn]+type instance XRuleBndrSig  (GhcPass _) = [AddEpAnn] type instance XXRuleBndr    (GhcPass _) = DataConCantHappen  instance (OutputableBndrId p) => Outputable (RuleDecls (GhcPass p)) where@@ -1207,13 +1274,13 @@ ************************************************************************ -} -type instance XWarnings      GhcPs = (EpAnn [AddEpAnn], SourceText)+type instance XWarnings      GhcPs = ([AddEpAnn], SourceText) type instance XWarnings      GhcRn = SourceText type instance XWarnings      GhcTc = SourceText  type instance XXWarnDecls    (GhcPass _) = DataConCantHappen -type instance XWarning      (GhcPass _) = EpAnn [AddEpAnn]+type instance XWarning      (GhcPass _) = (NamespaceSpecifier, [AddEpAnn]) type instance XXWarnDecl    (GhcPass _) = DataConCantHappen  @@ -1229,8 +1296,9 @@  instance OutputableBndrId p        => Outputable (WarnDecl (GhcPass p)) where-    ppr (Warning _ thing txt)+    ppr (Warning (ns_spec, _) thing txt)       = ppr_category+              <+> ppr ns_spec               <+> hsep (punctuate comma (map ppr thing))               <+> ppr txt       where@@ -1246,7 +1314,7 @@ ************************************************************************ -} -type instance XHsAnnotation (GhcPass _) = (EpAnn AnnPragma, SourceText)+type instance XHsAnnotation (GhcPass _) = (AnnPragma, SourceText) type instance XXAnnDecl     (GhcPass _) = DataConCantHappen  instance (OutputableBndrId p) => Outputable (AnnDecl (GhcPass p)) where@@ -1268,13 +1336,13 @@ ************************************************************************ -} -type instance XCRoleAnnotDecl GhcPs = EpAnn [AddEpAnn]+type instance XCRoleAnnotDecl GhcPs = [AddEpAnn] type instance XCRoleAnnotDecl GhcRn = NoExtField type instance XCRoleAnnotDecl GhcTc = NoExtField  type instance XXRoleAnnotDecl (GhcPass _) = DataConCantHappen -type instance Anno (Maybe Role) = SrcAnn NoEpAnns+type instance Anno (Maybe Role) = EpAnnCO  instance OutputableBndr (IdP (GhcPass p))        => Outputable (RoleAnnotDecl (GhcPass p)) where@@ -1300,15 +1368,15 @@ type instance Anno (SpliceDecl (GhcPass p)) = SrcSpanAnnA type instance Anno (TyClDecl (GhcPass p)) = SrcSpanAnnA type instance Anno (FunDep (GhcPass p)) = SrcSpanAnnA-type instance Anno (FamilyResultSig (GhcPass p)) = SrcAnn NoEpAnns+type instance Anno (FamilyResultSig (GhcPass p)) = EpAnnCO type instance Anno (FamilyDecl (GhcPass p)) = SrcSpanAnnA-type instance Anno (InjectivityAnn (GhcPass p)) = SrcAnn NoEpAnns+type instance Anno (InjectivityAnn (GhcPass p)) = EpAnnCO type instance Anno CType = SrcSpanAnnP-type instance Anno (HsDerivingClause (GhcPass p)) = SrcAnn NoEpAnns+type instance Anno (HsDerivingClause (GhcPass p)) = EpAnnCO type instance Anno (DerivClauseTys (GhcPass _)) = SrcSpanAnnC type instance Anno (StandaloneKindSig (GhcPass p)) = SrcSpanAnnA type instance Anno (ConDecl (GhcPass p)) = SrcSpanAnnA-type instance Anno Bool = SrcAnn NoEpAnns+type instance Anno Bool = EpAnnCO type instance Anno [LocatedA (ConDeclField (GhcPass _))] = SrcSpanAnnL type instance Anno (FamEqn p (LocatedA (HsType p))) = SrcSpanAnnA type instance Anno (TyFamInstDecl (GhcPass p)) = SrcSpanAnnA@@ -1319,18 +1387,18 @@ type instance Anno (DocDecl (GhcPass p)) = SrcSpanAnnA type instance Anno (DerivDecl (GhcPass p)) = SrcSpanAnnA type instance Anno OverlapMode = SrcSpanAnnP-type instance Anno (DerivStrategy (GhcPass p)) = SrcAnn NoEpAnns+type instance Anno (DerivStrategy (GhcPass p)) = EpAnnCO type instance Anno (DefaultDecl (GhcPass p)) = SrcSpanAnnA type instance Anno (ForeignDecl (GhcPass p)) = SrcSpanAnnA type instance Anno (RuleDecls (GhcPass p)) = SrcSpanAnnA type instance Anno (RuleDecl (GhcPass p)) = SrcSpanAnnA-type instance Anno (SourceText, RuleName) = SrcAnn NoEpAnns-type instance Anno (RuleBndr (GhcPass p)) = SrcAnn NoEpAnns+type instance Anno (SourceText, RuleName) = EpAnnCO+type instance Anno (RuleBndr (GhcPass p)) = EpAnnCO type instance Anno (WarnDecls (GhcPass p)) = SrcSpanAnnA type instance Anno (WarnDecl (GhcPass p)) = SrcSpanAnnA type instance Anno (AnnDecl (GhcPass p)) = SrcSpanAnnA type instance Anno (RoleAnnotDecl (GhcPass p)) = SrcSpanAnnA-type instance Anno (Maybe Role) = SrcAnn NoEpAnns-type instance Anno CCallConv   = SrcSpan-type instance Anno Safety      = SrcSpan-type instance Anno CExportSpec = SrcSpan+type instance Anno (Maybe Role) = EpAnnCO+type instance Anno CCallConv   = EpaLocation+type instance Anno Safety      = EpaLocation+type instance Anno CExportSpec = EpaLocation
compiler/GHC/Hs/Doc.hs view
@@ -196,6 +196,8 @@ data Docs = Docs   { docs_mod_hdr      :: Maybe (HsDoc GhcRn)     -- ^ Module header.+  , docs_exports      :: UniqMap Name (HsDoc GhcRn)+     -- ^ Docs attached to module exports.   , docs_decls        :: UniqMap Name [HsDoc GhcRn]     -- ^ Docs for declarations: functions, data types, instances, methods etc.     -- A list because sometimes subsequent haddock comments can be combined into one@@ -216,14 +218,15 @@   }  instance NFData Docs where-  rnf (Docs mod_hdr decls args structure named_chunks haddock_opts language extentions)-    = rnf mod_hdr `seq` rnf decls `seq` rnf args `seq` rnf structure `seq` rnf named_chunks+  rnf (Docs mod_hdr exps decls args structure named_chunks haddock_opts language extentions)+    = rnf mod_hdr `seq` rnf exps `seq` rnf decls `seq` rnf args `seq` rnf structure `seq` rnf named_chunks     `seq` rnf haddock_opts `seq` rnf language `seq` rnf extentions     `seq` ()  instance Binary Docs where   put_ bh docs = do     put_ bh (docs_mod_hdr docs)+    put_ bh (sortBy (\a b -> (fst a) `stableNameCmp` fst b) $ nonDetUniqMapToList $ docs_exports docs)     put_ bh (sortBy (\a b -> (fst a) `stableNameCmp` fst b) $ nonDetUniqMapToList $ docs_decls docs)     put_ bh (sortBy (\a b -> (fst a) `stableNameCmp` fst b) $ nonDetUniqMapToList $ docs_args docs)     put_ bh (docs_structure docs)@@ -233,6 +236,7 @@     put_ bh (docs_extensions docs)   get bh = do     mod_hdr <- get bh+    exports <- listToUniqMap <$> get bh     decls <- listToUniqMap <$> get bh     args <- listToUniqMap <$> get bh     structure <- get bh@@ -241,7 +245,8 @@     language <- get bh     exts <- get bh     pure Docs { docs_mod_hdr = mod_hdr-              , docs_decls =  decls+              , docs_exports = exports+              , docs_decls = decls               , docs_args = args               , docs_structure = structure               , docs_named_chunks = named_chunks@@ -254,6 +259,7 @@   ppr docs =       vcat         [ pprField (pprMaybe pprHsDocDebug) "module header" docs_mod_hdr+        , pprField (ppr . fmap pprHsDocDebug) "export docs" docs_exports         , pprField (ppr . fmap (ppr . map pprHsDocDebug)) "declaration docs" docs_decls         , pprField (ppr . fmap (pprIntMap ppr pprHsDocDebug)) "arg docs" docs_args         , pprField (vcat . map ppr) "documentation structure" docs_structure@@ -283,6 +289,7 @@ emptyDocs :: Docs emptyDocs = Docs   { docs_mod_hdr = Nothing+  , docs_exports = emptyUniqMap   , docs_decls = emptyUniqMap   , docs_args = emptyUniqMap   , docs_structure = []
compiler/GHC/Hs/DocString.hs view
@@ -21,6 +21,7 @@   , renderHsDocStrings   , exactPrintHsDocString   , pprWithDocString+  , printDecorator   ) where  import GHC.Prelude
compiler/GHC/Hs/Dump.hs view
@@ -57,6 +57,7 @@     showAstData' =       generic               `ext1Q` list+              `extQ` list_addEpAnn               `extQ` string `extQ` fastString `extQ` srcSpan `extQ` realSrcSpan               `extQ` annotation               `extQ` annotationModule@@ -70,6 +71,7 @@               `extQ` annotationEpaLocation               `extQ` annotationNoEpAnns               `extQ` addEpAnn+              `extQ` annParen               `extQ` lit `extQ` litr `extQ` litt               `extQ` sourceText               `extQ` deltaPos@@ -101,6 +103,12 @@             bytestring :: B.ByteString -> SDoc             bytestring = text . normalize_newlines . show +            list_addEpAnn :: [AddEpAnn] -> SDoc+            list_addEpAnn ls = case ba of+              BlankEpAnnotations -> parens+                                       $ text "blanked:" <+> text "[AddEpAnn]"+              NoBlankEpAnnotations -> list ls+             list []    = brackets empty             list [x]   = brackets (showAstData' x)             list (x1 : x2 : xs) =  (text "[" <> showAstData' x1)@@ -144,7 +152,7 @@               _                -> parens $ text "SourceText" <+> text "blanked"              epaAnchor :: EpaLocation -> SDoc-            epaAnchor (EpaSpan r _) = parens $ text "EpaSpan" <+> realSrcSpan r+            epaAnchor (EpaSpan s) = parens $ text "EpaSpan" <+> srcSpan s             epaAnchor (EpaDelta d cs) = case ba of               NoBlankEpAnnotations -> parens $ text "EpaDelta" <+> deltaPos d <+> showAstData' cs               BlankEpAnnotations -> parens $ text "EpaDelta" <+> deltaPos d <+> text "blanked"@@ -166,27 +174,21 @@             srcSpan :: SrcSpan -> SDoc             srcSpan ss = case bs of              BlankSrcSpan -> text "{ ss }"-             NoBlankSrcSpan -> braces $ char ' ' <>-                             (hang (ppr ss) 1-                                   -- TODO: show annotations here-                                   (text ""))-             BlankSrcSpanFile -> braces $ char ' ' <>-                             (hang (pprUserSpan False ss) 1-                                   -- TODO: show annotations here-                                   (text ""))+             NoBlankSrcSpan -> braces $ char ' ' <> (ppr ss) <> char ' '+             BlankSrcSpanFile -> braces $ char ' ' <> (pprUserSpan False ss) <> char ' '              realSrcSpan :: RealSrcSpan -> SDoc             realSrcSpan ss = case bs of              BlankSrcSpan -> text "{ ss }"-             NoBlankSrcSpan -> braces $ char ' ' <>-                             (hang (ppr ss) 1-                                   -- TODO: show annotations here-                                   (text ""))-             BlankSrcSpanFile -> braces $ char ' ' <>-                             (hang (pprUserRealSpan False ss) 1-                                   -- TODO: show annotations here-                                   (text ""))+             NoBlankSrcSpan -> braces $ char ' ' <> (ppr ss) <> char ' '+             BlankSrcSpanFile -> braces $ char ' ' <> (pprUserRealSpan False ss) <> char ' ' +            annParen :: AnnParen -> SDoc+            annParen (AnnParen a o c) = case ba of+             BlankEpAnnotations -> parens $ text "blanked:" <+> text "AnnParen"+             NoBlankEpAnnotations ->+              parens $ text "AnnParen"+                        $$ vcat [ppr a, epaAnchor o, epaAnchor c]              addEpAnn :: AddEpAnn -> SDoc             addEpAnn (AddEpAnn a s) = case ba of@@ -275,32 +277,32 @@              -- ------------------------- -            srcSpanAnnA :: SrcSpanAnn' (EpAnn AnnListItem) -> SDoc+            srcSpanAnnA :: EpAnn AnnListItem -> SDoc             srcSpanAnnA = locatedAnn'' (text "SrcSpanAnnA") -            srcSpanAnnL :: SrcSpanAnn' (EpAnn AnnList) -> SDoc+            srcSpanAnnL :: EpAnn AnnList -> SDoc             srcSpanAnnL = locatedAnn'' (text "SrcSpanAnnL") -            srcSpanAnnP :: SrcSpanAnn' (EpAnn AnnPragma) -> SDoc+            srcSpanAnnP :: EpAnn AnnPragma -> SDoc             srcSpanAnnP = locatedAnn'' (text "SrcSpanAnnP") -            srcSpanAnnC :: SrcSpanAnn' (EpAnn AnnContext) -> SDoc+            srcSpanAnnC :: EpAnn AnnContext -> SDoc             srcSpanAnnC = locatedAnn'' (text "SrcSpanAnnC") -            srcSpanAnnN :: SrcSpanAnn' (EpAnn NameAnn) -> SDoc+            srcSpanAnnN :: EpAnn NameAnn -> SDoc             srcSpanAnnN = locatedAnn'' (text "SrcSpanAnnN")              locatedAnn'' :: forall a. (Typeable a, Data a)-              => SDoc -> SrcSpanAnn' a -> SDoc+              => SDoc -> EpAnn a -> SDoc             locatedAnn'' tag ss = parens $               case cast ss of-                Just ((SrcSpanAnn ann s) :: SrcSpanAnn' a) ->+                Just (ann :: EpAnn a) ->                   case ba of                     BlankEpAnnotations                       -> parens (text "blanked:" <+> tag)                     NoBlankEpAnnotations-                      -> text "SrcSpanAnn" <+> showAstData' ann-                              <+> srcSpan s+                      -> text (showConstr (toConstr ann))+                                          $$ vcat (gmapQ showAstData' ann)                 Nothing -> text "locatedAnn:unmatched" <+> tag                            <+> (parens $ text (showConstr (toConstr ss)))
compiler/GHC/Hs/Expr.hs view
@@ -59,7 +59,6 @@ import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Utils.Panic.Plain import GHC.Data.FastString import GHC.Core.Type import GHC.Builtin.Types (mkTupleStr)@@ -75,9 +74,8 @@ import qualified Data.Kind import Data.Maybe (isJust) import Data.Foldable ( toList )-import Data.List (uncons) import Data.List.NonEmpty (NonEmpty)-import Data.Bifunctor (first)+import Data.Void (Void)  {- ********************************************************************* *                                                                      *@@ -131,7 +129,7 @@ -- | This is used for rebindable-syntax pieces that are too polymorphic -- for tcSyntaxOp (trS_fmap and the mzip in ParStmt) noExpr :: HsExpr (GhcPass p)-noExpr = HsLit noComments (HsString (SourceText $ fsLit "noExpr") (fsLit "noExpr"))+noExpr = HsLit noExtField (HsString (SourceText $ fsLit "noExpr") (fsLit "noExpr"))  noSyntaxExpr :: forall p. IsPass p => SyntaxExpr (GhcPass p)                               -- Before renaming, and sometimes after@@ -187,10 +185,10 @@                                         -- pasted back in by the desugarer   } -type instance XTypedBracket GhcPs = EpAnn [AddEpAnn]+type instance XTypedBracket GhcPs = [AddEpAnn] type instance XTypedBracket GhcRn = NoExtField type instance XTypedBracket GhcTc = HsBracketTc-type instance XUntypedBracket GhcPs = EpAnn [AddEpAnn]+type instance XUntypedBracket GhcPs = [AddEpAnn] type instance XUntypedBracket GhcRn = [PendingRnSplice] -- See Note [Pending Splices]                                                         -- Output of the renamer is the *original* renamed expression,                                                         -- plus _renamed_ splices to be type checked@@ -206,32 +204,31 @@       , hsCaseAnnsRest :: [AddEpAnn]       } deriving Data +instance NoAnn EpAnnHsCase where+  noAnn = EpAnnHsCase noAnn noAnn noAnn+ data EpAnnUnboundVar = EpAnnUnboundVar      { hsUnboundBackquotes :: (EpaLocation, EpaLocation)      , hsUnboundHole       :: EpaLocation      } deriving Data -type instance XVar           (GhcPass _) = NoExtField- -- Record selectors at parse time are HsVar; they convert to HsRecSel -- on renaming. type instance XRecSel              GhcPs = DataConCantHappen type instance XRecSel              GhcRn = NoExtField type instance XRecSel              GhcTc = NoExtField -type instance XLam           (GhcPass _) = NoExtField- -- OverLabel not present in GhcTc pass; see GHC.Rename.Expr -- Note [Handling overloaded and rebindable constructs]-type instance XOverLabel     GhcPs = EpAnnCO-type instance XOverLabel     GhcRn = EpAnnCO+type instance XOverLabel     GhcPs = NoExtField+type instance XOverLabel     GhcRn = NoExtField type instance XOverLabel     GhcTc = DataConCantHappen  -- ---------------------------------------------------------------------  type instance XVar           (GhcPass _) = NoExtField -type instance XUnboundVar    GhcPs = EpAnn EpAnnUnboundVar+type instance XUnboundVar    GhcPs = Maybe EpAnnUnboundVar type instance XUnboundVar    GhcRn = NoExtField type instance XUnboundVar    GhcTc = HoleExprRef   -- We really don't need the whole HoleExprRef; just the IORef EvTerm@@ -239,73 +236,71 @@   -- Much, much easier just to define HoleExprRef with a Data instance and   -- store the whole structure. -type instance XIPVar         GhcPs = EpAnnCO-type instance XIPVar         GhcRn = EpAnnCO+type instance XIPVar         GhcPs = NoExtField+type instance XIPVar         GhcRn = NoExtField type instance XIPVar         GhcTc = DataConCantHappen-type instance XOverLitE      (GhcPass _) = EpAnnCO-type instance XLitE          (GhcPass _) = EpAnnCO--type instance XLam           (GhcPass _) = NoExtField--type instance XLamCase       (GhcPass _) = EpAnn [AddEpAnn]--type instance XApp           (GhcPass _) = EpAnnCO+type instance XOverLitE      (GhcPass _) = NoExtField+type instance XLitE          (GhcPass _) = NoExtField+type instance XLam           (GhcPass _) = [AddEpAnn]+type instance XApp           (GhcPass _) = NoExtField -type instance XAppTypeE      GhcPs = NoExtField+type instance XAppTypeE      GhcPs = EpToken "@" type instance XAppTypeE      GhcRn = NoExtField type instance XAppTypeE      GhcTc = Type  -- OpApp not present in GhcTc pass; see GHC.Rename.Expr -- Note [Handling overloaded and rebindable constructs]-type instance XOpApp         GhcPs = EpAnn [AddEpAnn]+type instance XOpApp         GhcPs = [AddEpAnn] type instance XOpApp         GhcRn = Fixity type instance XOpApp         GhcTc = DataConCantHappen  -- SectionL, SectionR not present in GhcTc pass; see GHC.Rename.Expr -- Note [Handling overloaded and rebindable constructs]-type instance XSectionL      GhcPs = EpAnnCO-type instance XSectionR      GhcPs = EpAnnCO-type instance XSectionL      GhcRn = EpAnnCO-type instance XSectionR      GhcRn = EpAnnCO+type instance XSectionL      GhcPs = NoExtField+type instance XSectionR      GhcPs = NoExtField+type instance XSectionL      GhcRn = NoExtField+type instance XSectionR      GhcRn = NoExtField type instance XSectionL      GhcTc = DataConCantHappen type instance XSectionR      GhcTc = DataConCantHappen  -type instance XNegApp        GhcPs = EpAnn [AddEpAnn]+type instance XNegApp        GhcPs = [AddEpAnn] type instance XNegApp        GhcRn = NoExtField type instance XNegApp        GhcTc = NoExtField -type instance XPar           (GhcPass _) = EpAnnCO+type instance XPar           GhcPs = (EpToken "(", EpToken ")")+type instance XPar           GhcRn = NoExtField+type instance XPar           GhcTc = NoExtField -type instance XExplicitTuple GhcPs = EpAnn [AddEpAnn]+type instance XExplicitTuple GhcPs = [AddEpAnn] type instance XExplicitTuple GhcRn = NoExtField type instance XExplicitTuple GhcTc = NoExtField -type instance XExplicitSum   GhcPs = EpAnn AnnExplicitSum+type instance XExplicitSum   GhcPs = AnnExplicitSum type instance XExplicitSum   GhcRn = NoExtField type instance XExplicitSum   GhcTc = [Type] -type instance XCase          GhcPs = EpAnn EpAnnHsCase-type instance XCase          GhcRn = HsMatchContext GhcTc-type instance XCase          GhcTc = HsMatchContext GhcTc+type instance XCase          GhcPs = EpAnnHsCase+type instance XCase          GhcRn = HsMatchContextRn+type instance XCase          GhcTc = HsMatchContextRn -type instance XIf            GhcPs = EpAnn AnnsIf+type instance XIf            GhcPs = AnnsIf type instance XIf            GhcRn = NoExtField type instance XIf            GhcTc = NoExtField -type instance XMultiIf       GhcPs = EpAnn [AddEpAnn]+type instance XMultiIf       GhcPs = [AddEpAnn] type instance XMultiIf       GhcRn = NoExtField type instance XMultiIf       GhcTc = Type -type instance XLet           GhcPs = EpAnnCO+type instance XLet           GhcPs = (EpToken "let", EpToken "in") type instance XLet           GhcRn = NoExtField type instance XLet           GhcTc = NoExtField -type instance XDo            GhcPs = EpAnn AnnList+type instance XDo            GhcPs = AnnList type instance XDo            GhcRn = NoExtField type instance XDo            GhcTc = Type -type instance XExplicitList  GhcPs = EpAnn AnnList+type instance XExplicitList  GhcPs = AnnList type instance XExplicitList  GhcRn = NoExtField type instance XExplicitList  GhcTc = Type -- GhcPs: ExplicitList includes all source-level@@ -316,11 +311,11 @@ -- See Note [Handling overloaded and rebindable constructs] -- in  GHC.Rename.Expr -type instance XRecordCon     GhcPs = EpAnn [AddEpAnn]+type instance XRecordCon     GhcPs = [AddEpAnn] type instance XRecordCon     GhcRn = NoExtField type instance XRecordCon     GhcTc = PostTcExpr   -- Instantiated constructor function -type instance XRecordUpd     GhcPs = EpAnn [AddEpAnn]+type instance XRecordUpd     GhcPs = [AddEpAnn] type instance XRecordUpd     GhcRn = NoExtField type instance XRecordUpd     GhcTc = DataConCantHappen   -- We desugar record updates in the typechecker.@@ -352,34 +347,40 @@  type instance XLHsOLRecUpdLabels p = NoExtField -type instance XGetField     GhcPs = EpAnnCO+type instance XGetField     GhcPs = NoExtField type instance XGetField     GhcRn = NoExtField type instance XGetField     GhcTc = DataConCantHappen -- HsGetField is eliminated by the renamer. See [Handling overloaded -- and rebindable constructs]. -type instance XProjection     GhcPs = EpAnn AnnProjection+type instance XProjection     GhcPs = AnnProjection type instance XProjection     GhcRn = NoExtField type instance XProjection     GhcTc = DataConCantHappen -- HsProjection is eliminated by the renamer. See [Handling overloaded -- and rebindable constructs]. -type instance XExprWithTySig GhcPs = EpAnn [AddEpAnn]+type instance XExprWithTySig GhcPs = [AddEpAnn] type instance XExprWithTySig GhcRn = NoExtField type instance XExprWithTySig GhcTc = NoExtField -type instance XArithSeq      GhcPs = EpAnn [AddEpAnn]+type instance XArithSeq      GhcPs = [AddEpAnn] type instance XArithSeq      GhcRn = NoExtField type instance XArithSeq      GhcTc = PostTcExpr -type instance XProc          (GhcPass _) = EpAnn [AddEpAnn]+type instance XProc          (GhcPass _) = [AddEpAnn] -type instance XStatic        GhcPs = EpAnn [AddEpAnn]+type instance XStatic        GhcPs = [AddEpAnn] type instance XStatic        GhcRn = NameSet type instance XStatic        GhcTc = (NameSet, Type)   -- Free variables and type of expression, this is stored for convenience as wiring in   -- StaticPtr is a bit tricky (see #20150) +type instance XEmbTy         GhcPs = EpToken "type"+type instance XEmbTy         GhcRn = NoExtField+type instance XEmbTy         GhcTc = DataConCantHappen+  -- A free-standing HsEmbTy is an error.+  -- Valid usages are immediately desugared into Type.+ type instance XPragE         (GhcPass _) = NoExtField  type instance Anno [LocatedA ((StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (body (GhcPass pr)))))] = SrcSpanAnnL@@ -393,17 +394,26 @@       aesClose      :: EpaLocation       } deriving Data +instance NoAnn AnnExplicitSum where+  noAnn = AnnExplicitSum noAnn noAnn noAnn noAnn+ data AnnFieldLabel   = AnnFieldLabel {       afDot :: Maybe EpaLocation       } deriving Data +instance NoAnn AnnFieldLabel where+  noAnn = AnnFieldLabel Nothing+ data AnnProjection   = AnnProjection {       apOpen  :: EpaLocation, -- ^ '('       apClose :: EpaLocation  -- ^ ')'       } deriving Data +instance NoAnn AnnProjection where+  noAnn = AnnProjection noAnn noAnn+ data AnnsIf   = AnnsIf {       aiIf       :: EpaLocation,@@ -413,17 +423,20 @@       aiElseSemi :: Maybe EpaLocation       } deriving Data +instance NoAnn AnnsIf where+  noAnn = AnnsIf noAnn noAnn noAnn Nothing Nothing+ -- --------------------------------------------------------------------- -type instance XSCC           (GhcPass _) = (EpAnn AnnPragma, SourceText)+type instance XSCC           (GhcPass _) = (AnnPragma, SourceText) type instance XXPragE        (GhcPass _) = DataConCantHappen -type instance XCDotFieldOcc (GhcPass _) = EpAnn AnnFieldLabel+type instance XCDotFieldOcc (GhcPass _) = AnnFieldLabel type instance XXDotFieldOcc (GhcPass _) = DataConCantHappen -type instance XPresent         (GhcPass _) = EpAnn [AddEpAnn]+type instance XPresent         (GhcPass _) = NoExtField -type instance XMissing         GhcPs = EpAnn EpaLocation+type instance XMissing         GhcPs = EpAnn Bool -- True for empty last comma type instance XMissing         GhcRn = NoExtField type instance XMissing         GhcTc = Scaled Type @@ -433,7 +446,14 @@ tupArgPresent (Present {}) = True tupArgPresent (Missing {}) = False +tupArgPresent_maybe :: HsTupArg (GhcPass p) -> Maybe (LHsExpr (GhcPass p))+tupArgPresent_maybe (Present _ e) = Just e+tupArgPresent_maybe (Missing {})  = Nothing +tupArgsPresent_maybe :: [HsTupArg (GhcPass p)] -> Maybe [LHsExpr (GhcPass p)]+tupArgsPresent_maybe = traverse tupArgPresent_maybe++ {- ********************************************************************* *                                                                      *             XXExpr: the extension constructor of HsExpr@@ -441,17 +461,104 @@ ********************************************************************* -}  type instance XXExpr GhcPs = DataConCantHappen-type instance XXExpr GhcRn = HsExpansion (HsExpr GhcRn) (HsExpr GhcRn)+type instance XXExpr GhcRn = XXExprGhcRn type instance XXExpr GhcTc = XXExprGhcTc--- HsExpansion: see Note [Rebindable syntax and HsExpansion] below+-- XXExprGhcRn: see Note [Rebindable syntax and XXExprGhcRn] below  +{- *********************************************************************+*                                                                      *+              Generating code for ExpandedThingRn+      See Note [Handling overloaded and rebindable constructs]+*                                                                      *+********************************************************************* -}++-- | The different source constructs that we use to instantiate the "original" field+--   in an `XXExprGhcRn original expansion`+data HsThingRn = OrigExpr (HsExpr GhcRn)+               | OrigStmt (ExprLStmt GhcRn)+               | OrigPat  (LPat GhcRn)++isHsThingRnExpr, isHsThingRnStmt, isHsThingRnPat :: HsThingRn -> Bool+isHsThingRnExpr (OrigExpr{}) = True+isHsThingRnExpr _ = False++isHsThingRnStmt (OrigStmt{}) = True+isHsThingRnStmt _ = False++isHsThingRnPat (OrigPat{}) = True+isHsThingRnPat _ = False++data XXExprGhcRn+  = ExpandedThingRn { xrn_orig     :: HsThingRn       -- The original source thing+                    , xrn_expanded :: HsExpr GhcRn }  -- The compiler generated expanded thing++  | PopErrCtxt                                     -- A hint for typechecker to pop+    {-# UNPACK #-} !(LHsExpr GhcRn)                -- the top of the error context stack+                                                   -- Does not presist post renaming phase+                                                   -- See Part 3. of Note [Expanding HsDo with XXExprGhcRn]+                                                   -- in `GHC.Tc.Gen.Do`+++-- | Wrap a located expression with a `PopErrCtxt`+mkPopErrCtxtExpr :: LHsExpr GhcRn -> HsExpr GhcRn+mkPopErrCtxtExpr a = XExpr (PopErrCtxt a)++-- | Wrap a located expression with a PopSrcExpr with an appropriate location+mkPopErrCtxtExprAt :: SrcSpanAnnA ->  LHsExpr GhcRn -> LHsExpr GhcRn+mkPopErrCtxtExprAt loc a = L loc $ mkPopErrCtxtExpr a++-- | Build an expression using the extension constructor `XExpr`,+--   and the two components of the expansion: original expression and+--   expanded expressions.+mkExpandedExpr+  :: HsExpr GhcRn         -- ^ source expression+  -> HsExpr GhcRn         -- ^ expanded expression+  -> HsExpr GhcRn         -- ^ suitably wrapped 'XXExprGhcRn'+mkExpandedExpr oExpr eExpr = XExpr (ExpandedThingRn (OrigExpr oExpr) eExpr)++-- | Build an expression using the extension constructor `XExpr`,+--   and the two components of the expansion: original do stmt and+--   expanded expression+mkExpandedStmt+  :: ExprLStmt GhcRn      -- ^ source statement+  -> HsExpr GhcRn         -- ^ expanded expression+  -> HsExpr GhcRn         -- ^ suitably wrapped 'XXExprGhcRn'+mkExpandedStmt oStmt eExpr = XExpr (ExpandedThingRn (OrigStmt oStmt) eExpr)++mkExpandedPatRn+  :: LPat   GhcRn      -- ^ source pattern+  -> HsExpr GhcRn      -- ^ expanded expression+  -> HsExpr GhcRn      -- ^ suitably wrapped 'XXExprGhcRn'+mkExpandedPatRn oPat eExpr = XExpr (ExpandedThingRn (OrigPat oPat) eExpr)++-- | Build an expression using the extension constructor `XExpr`,+--   and the two components of the expansion: original do stmt and+--   expanded expression an associate with a provided location+mkExpandedStmtAt+  :: SrcSpanAnnA          -- ^ Location for the expansion expression+  -> ExprLStmt GhcRn      -- ^ source statement+  -> HsExpr GhcRn         -- ^ expanded expression+  -> LHsExpr GhcRn        -- ^ suitably wrapped located 'XXExprGhcRn'+mkExpandedStmtAt loc oStmt eExpr = L loc $ mkExpandedStmt oStmt eExpr++-- | Wrap the expanded version of the expression with a pop.+mkExpandedStmtPopAt+  :: SrcSpanAnnA          -- ^ Location for the expansion statement+  -> ExprLStmt GhcRn      -- ^ source statement+  -> HsExpr GhcRn         -- ^ expanded expression+  -> LHsExpr GhcRn        -- ^ suitably wrapped 'XXExprGhcRn'+mkExpandedStmtPopAt loc oStmt eExpr = mkPopErrCtxtExprAt loc $ mkExpandedStmtAt loc oStmt eExpr++ data XXExprGhcTc   = WrapExpr        -- Type and evidence application and abstractions       {-# UNPACK #-} !(HsWrap HsExpr) -  | ExpansionExpr   -- See Note [Rebindable syntax and HsExpansion] below-      {-# UNPACK #-} !(HsExpansion (HsExpr GhcRn) (HsExpr GhcTc))+  | ExpandedThingTc                         -- See Note [Rebindable syntax and XXExprGhcRn]+                                            -- See Note [Expanding HsDo with XXExprGhcRn] in `GHC.Tc.Gen.Do`+         { xtc_orig     :: HsThingRn        -- The original user written thing+         , xtc_expanded :: HsExpr GhcTc }   -- The expanded typechecked expression    | ConLikeTc      -- Result of typechecking a data-con                    -- See Note [Typechecking data constructors] in@@ -472,7 +579,24 @@      Int                                -- module-local tick number for False      (LHsExpr GhcTc)                    -- sub-expression +-- | Build a 'XXExprGhcRn' out of an extension constructor,+--   and the two components of the expansion: original and+--   expanded typechecked expressions.+mkExpandedExprTc+  :: HsExpr GhcRn           -- ^ source expression+  -> HsExpr GhcTc           -- ^ expanded typechecked expression+  -> HsExpr GhcTc           -- ^ suitably wrapped 'XXExprGhcRn'+mkExpandedExprTc oExpr eExpr = XExpr (ExpandedThingTc (OrigExpr oExpr) eExpr) +-- | Build a 'XXExprGhcRn' out of an extension constructor.+--   The two components of the expansion are: original statement and+--   expanded typechecked expression.+mkExpandedStmtTc+  :: ExprLStmt GhcRn        -- ^ source do statement+  -> HsExpr GhcTc           -- ^ expanded typechecked expression+  -> HsExpr GhcTc           -- ^ suitably wrapped 'XXExprGhcRn'+mkExpandedStmtTc oStmt eExpr = XExpr (ExpandedThingTc (OrigStmt oStmt) eExpr)+ {- ********************************************************************* *                                                                      *             Pretty-printing expressions@@ -522,7 +646,7 @@                                              SourceText src -> ftext src ppr_expr (HsLit _ lit)       = ppr lit ppr_expr (HsOverLit _ lit)   = ppr lit-ppr_expr (HsPar _ _ e _)     = parens (ppr_lexpr e)+ppr_expr (HsPar _ e)         = parens (ppr_lexpr e)  ppr_expr (HsPragE _ prag e) = sep [ppr prag, ppr_lexpr e] @@ -596,12 +720,11 @@   where     ppr_bars n = hsep (replicate n (char '|')) -ppr_expr (HsLam _ matches)-  = pprMatches matches--ppr_expr (HsLamCase _ lc_variant matches)-  = sep [ sep [lamCaseKeyword lc_variant],-          nest 2 (pprMatches matches) ]+ppr_expr (HsLam _ lam_variant matches)+  = case lam_variant of+       LamSingle -> pprMatches matches+       _         -> sep [ sep [lamCaseKeyword lam_variant]+                        , nest 2 (pprMatches matches) ]  ppr_expr (HsCase _ expr matches@(MG { mg_alts = L _ alts }))   = sep [ sep [text "case", nest 4 (ppr expr), text "of"],@@ -628,11 +751,11 @@         ppr_alt (L _ (XGRHS x)) = ppr x  -- special case: let ... in let ...-ppr_expr (HsLet _ _ binds _ expr@(L _ (HsLet _ _ _ _ _)))+ppr_expr (HsLet _ binds expr@(L _ (HsLet _ _ _)))   = sep [hang (text "let") 2 (hsep [pprBinds binds, text "in"]),          ppr_lexpr expr] -ppr_expr (HsLet _ _ binds _ expr)+ppr_expr (HsLet _ binds expr)   = sep [hang (text "let") 2 (pprBinds binds),          hang (text "in")  2 (ppr expr)] @@ -702,21 +825,35 @@ ppr_expr (HsStatic _ e)   = hsep [text "static", ppr e] +ppr_expr (HsEmbTy _ ty)+  = hsep [text "type", ppr ty]+ ppr_expr (XExpr x) = case ghcPass @p of-#if __GLASGOW_HASKELL__ < 811-  GhcPs -> ppr x-#endif   GhcRn -> ppr x   GhcTc -> ppr x +instance Outputable HsThingRn where+  ppr thing+    = case thing of+        OrigExpr x -> ppr_builder "<OrigExpr>:" x+        OrigStmt x -> ppr_builder "<OrigStmt>:" x+        OrigPat x  -> ppr_builder "<OrigPat>:" x+    where ppr_builder prefix x = ifPprDebug (braces (text prefix <+> parens (ppr x))) (ppr x)++instance Outputable XXExprGhcRn where+  ppr (ExpandedThingRn o e) = ifPprDebug (braces $ vcat [ppr o, ppr e]) (ppr o)+  ppr (PopErrCtxt e)        = ifPprDebug (braces (text "<PopErrCtxt>" <+> ppr e)) (ppr e)+ instance Outputable XXExprGhcTc where   ppr (WrapExpr (HsWrap co_fn e))     = pprHsWrapper co_fn (\_parens -> pprExpr e) -  ppr (ExpansionExpr e)-    = ppr e -- e is an HsExpansion, we print the original-            -- expression (LHsExpr GhcPs), not the-            -- desugared one (LHsExpr GhcTc).+  ppr (ExpandedThingTc o e)+    = ifPprDebug (braces $ vcat [ppr o, ppr e]) (ppr o)+            -- e is the expanded expression, we print the original+            -- expression (HsExpr GhcRn), not the+            -- expanded typechecked one (HsExpr GhcTc),+            -- unless we are in ppr's debug mode printed both    ppr (ConLikeTc con _ _) = pprPrefixOcc con    -- Used in error messages generated by@@ -740,30 +877,32 @@ ppr_infix_expr (HsRecSel _ f)       = Just (pprInfixOcc f) ppr_infix_expr (HsUnboundVar _ occ) = Just (pprInfixOcc occ) ppr_infix_expr (XExpr x)            = case ghcPass @p of-#if __GLASGOW_HASKELL__ < 901-                                        GhcPs -> Nothing-#endif                                         GhcRn -> ppr_infix_expr_rn x                                         GhcTc -> ppr_infix_expr_tc x ppr_infix_expr _ = Nothing -ppr_infix_expr_rn :: HsExpansion (HsExpr GhcRn) (HsExpr GhcRn) -> Maybe SDoc-ppr_infix_expr_rn (HsExpanded a _) = ppr_infix_expr a+ppr_infix_expr_rn :: XXExprGhcRn -> Maybe SDoc+ppr_infix_expr_rn (ExpandedThingRn thing _) = ppr_infix_hs_expansion thing+ppr_infix_expr_rn (PopErrCtxt (L _ a)) = ppr_infix_expr a  ppr_infix_expr_tc :: XXExprGhcTc -> Maybe SDoc-ppr_infix_expr_tc (WrapExpr (HsWrap _ e))          = ppr_infix_expr e-ppr_infix_expr_tc (ExpansionExpr (HsExpanded a _)) = ppr_infix_expr a-ppr_infix_expr_tc (ConLikeTc {})                   = Nothing-ppr_infix_expr_tc (HsTick {})                      = Nothing-ppr_infix_expr_tc (HsBinTick {})                   = Nothing+ppr_infix_expr_tc (WrapExpr (HsWrap _ e))    = ppr_infix_expr e+ppr_infix_expr_tc (ExpandedThingTc thing _)  = ppr_infix_hs_expansion thing+ppr_infix_expr_tc (ConLikeTc {})             = Nothing+ppr_infix_expr_tc (HsTick {})                = Nothing+ppr_infix_expr_tc (HsBinTick {})             = Nothing +ppr_infix_hs_expansion :: HsThingRn -> Maybe SDoc+ppr_infix_hs_expansion (OrigExpr e) = ppr_infix_expr e+ppr_infix_hs_expansion _            = Nothing+ ppr_apps :: (OutputableBndrId p)          => HsExpr (GhcPass p)          -> [Either (LHsExpr (GhcPass p)) (LHsWcType (NoGhcTc (GhcPass p)))]          -> SDoc ppr_apps (HsApp _ (L _ fun) arg)        args   = ppr_apps fun (Left arg : args)-ppr_apps (HsAppType _ (L _ fun) _ arg)  args+ppr_apps (HsAppType _ (L _ fun) arg)    args   = ppr_apps fun (Right arg : args) ppr_apps fun args = hang (ppr_expr fun) 2 (fsep (map pp args))   where@@ -773,7 +912,6 @@     pp (Right arg)       = text "@" <> ppr arg - pprDebugParendExpr :: (OutputableBndrId p)                    => PprPrec -> LHsExpr (GhcPass p) -> SDoc pprDebugParendExpr p expr@@ -820,7 +958,6 @@     go (ExplicitTuple{})              = False     go (ExplicitSum{})                = False     go (HsLam{})                      = prec > topPrec-    go (HsLamCase{})                  = prec > topPrec     go (HsCase{})                     = prec > topPrec     go (HsIf{})                       = prec > topPrec     go (HsMultiIf{})                  = prec > topPrec@@ -843,27 +980,34 @@     go (HsRecSel{})                   = False     go (HsProjection{})               = True     go (HsGetField{})                 = False+    go (HsEmbTy{})                    = prec > topPrec     go (XExpr x) = case ghcPass @p of                      GhcTc -> go_x_tc x                      GhcRn -> go_x_rn x-#if __GLASGOW_HASKELL__ <= 900-                     GhcPs -> True-#endif      go_x_tc :: XXExprGhcTc -> Bool     go_x_tc (WrapExpr (HsWrap _ e))          = hsExprNeedsParens prec e-    go_x_tc (ExpansionExpr (HsExpanded a _)) = hsExprNeedsParens prec a+    go_x_tc (ExpandedThingTc thing _)        = hsExpandedNeedsParens thing     go_x_tc (ConLikeTc {})                   = False     go_x_tc (HsTick _ (L _ e))               = hsExprNeedsParens prec e     go_x_tc (HsBinTick _ _ (L _ e))          = hsExprNeedsParens prec e -    go_x_rn :: HsExpansion (HsExpr GhcRn) (HsExpr GhcRn) -> Bool-    go_x_rn (HsExpanded a _) = hsExprNeedsParens prec a+    go_x_rn :: XXExprGhcRn -> Bool+    go_x_rn (ExpandedThingRn thing _)    = hsExpandedNeedsParens thing+    go_x_rn (PopErrCtxt (L _ a))         = hsExprNeedsParens prec a +    hsExpandedNeedsParens :: HsThingRn -> Bool+    hsExpandedNeedsParens (OrigExpr e) = hsExprNeedsParens prec e+    hsExpandedNeedsParens _            = False  -- | Parenthesize an expression without token information-gHsPar :: LHsExpr (GhcPass id) -> HsExpr (GhcPass id)-gHsPar e = HsPar noAnn noHsTok e noHsTok+gHsPar :: forall p. IsPass p => LHsExpr (GhcPass p) -> HsExpr (GhcPass p)+gHsPar e = HsPar x e+  where+    x = case ghcPass @p of+      GhcPs -> noAnn+      GhcRn -> noExtField+      GhcTc -> noExtField  -- | @'parenthesizeHsExpr' p e@ checks if @'hsExprNeedsParens' p e@ is true, -- and if so, surrounds @e@ with an 'HsPar'. Otherwise, it simply returns @e@.@@ -873,11 +1017,11 @@   | otherwise             = le  stripParensLHsExpr :: LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)-stripParensLHsExpr (L _ (HsPar _ _ e _)) = stripParensLHsExpr e+stripParensLHsExpr (L _ (HsPar _ e)) = stripParensLHsExpr e stripParensLHsExpr e = e  stripParensHsExpr :: HsExpr (GhcPass p) -> HsExpr (GhcPass p)-stripParensHsExpr (HsPar _ _ (L _ e) _) = stripParensHsExpr e+stripParensHsExpr (HsPar _ (L _ e)) = stripParensHsExpr e stripParensHsExpr e = e  isAtomicHsExpr :: forall p. IsPass p => HsExpr (GhcPass p) -> Bool@@ -895,14 +1039,19 @@   where     go_x_tc :: XXExprGhcTc -> Bool     go_x_tc (WrapExpr      (HsWrap _ e))     = isAtomicHsExpr e-    go_x_tc (ExpansionExpr (HsExpanded a _)) = isAtomicHsExpr a+    go_x_tc (ExpandedThingTc thing _)        = isAtomicExpandedThingRn thing     go_x_tc (ConLikeTc {})                   = True     go_x_tc (HsTick {}) = False     go_x_tc (HsBinTick {}) = False -    go_x_rn :: HsExpansion (HsExpr GhcRn) (HsExpr GhcRn) -> Bool-    go_x_rn (HsExpanded a _) = isAtomicHsExpr a+    go_x_rn :: XXExprGhcRn -> Bool+    go_x_rn (ExpandedThingRn thing _)    = isAtomicExpandedThingRn thing+    go_x_rn (PopErrCtxt (L _ a))         = isAtomicHsExpr a +    isAtomicExpandedThingRn :: HsThingRn -> Bool+    isAtomicExpandedThingRn (OrigExpr e) = isAtomicHsExpr e+    isAtomicExpandedThingRn _            = False+ isAtomicHsExpr _ = False  instance Outputable (HsPragE (GhcPass p)) where@@ -915,11 +1064,11 @@  {- ********************************************************************* *                                                                      *-             HsExpansion and rebindable syntax+             XXExprGhcRn and rebindable syntax *                                                                      * ********************************************************************* -} -{- Note [Rebindable syntax and HsExpansion]+{- Note [Rebindable syntax and XXExprGhcRn] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We implement rebindable syntax (RS) support by performing a desugaring in the renamer. We transform GhcPs expressions and patterns affected by@@ -953,12 +1102,12 @@ node into mere applications of 'ifThenElse', we keep the original 'if' expression around too, using the TTG XExpr extension point to allow GHC to construct an-'HsExpansion' value that will keep track of the original+'XXExprGhcRn' value that will keep track of the original expression in its first field, and the desugared one in the second field. The resulting renamed AST would look like:      L locif (XExpr-      (HsExpanded+      (ExpandedThingRn         (HsIf (L loca 'a')               (L loctrue ())               (L locfalse True)@@ -980,7 +1129,7 @@ When comes the time to typecheck the program, we end up calling tcMonoExpr on the AST above. If this expression gives rise to a type error, then it will appear in a context line and GHC-will pretty-print it using the 'Outputable (HsExpansion a b)'+will pretty-print it using the 'Outputable (XXExprGhcRn a b)' instance defined below, which *only prints the original expression*. This is the gist of the idea, but is not quite enough to recover the error messages that we had with the@@ -1031,12 +1180,12 @@       HsVar/HsApp nodes, above) is set to 'generatedSrcSpan'     - take both the original node and that rebound-and-renamed result and wrap       them into an expansion construct:-        for expressions, XExpr (HsExpanded <original node> <desugared>)+        for expressions, XExpr (ExpandedThingRn <original node> <desugared>)         for patterns, XPat (HsPatExpanded <original node> <desugared>)  - At typechecking-time:     - remove any logic that was previously dealing with your rebindable       construct, typically involving [tc]SyntaxOp, SyntaxExpr and friends.-    - the XExpr (HsExpanded ... ...) case in tcExpr already makes sure that we+    - the XExpr (ExpandedThingRn ... ...) case in tcExpr already makes sure that we       typecheck the desugared expression while reporting the original one in       errors -}@@ -1049,16 +1198,16 @@ The language extensions @OverloadedRecordDot@ and @OverloadedRecordUpdate@ (providing "record dot syntax") are implemented using the techniques of Note [Rebindable syntax and-HsExpansion].+XXExprGhcRn].  When OverloadedRecordDot is enabled: - Field selection expressions   - e.g. foo.bar.baz   - Have abstract syntax HsGetField-  - After renaming are XExpr (HsExpanded (HsGetField ...) (getField @"..."...)) expressions+  - After renaming are XExpr (ExpandedThingRn (HsGetField ...) (getField @"..."...)) expressions - Field selector expressions e.g. (.x.y)   - Have abstract syntax HsProjection-  - After renaming are XExpr (HsExpanded (HsProjection ...) ((getField @"...") . (getField @"...") . ...) expressions+  - After renaming are XExpr (ExpandedThingRn (HsProjection ...) ((getField @"...") . (getField @"...") . ...) expressions  When OverloadedRecordUpdate is enabled: - Record update expressions@@ -1066,7 +1215,7 @@   - Have abstract syntax RecordUpd     - With rupd_flds containting a Right     - See Note [RecordDotSyntax field updates] (in Language.Haskell.Syntax.Expr)-  - After renaming are XExpr (HsExpanded (RecordUpd ...) (setField@"..." ...) expressions+  - After renaming are XExpr (ExpandedThingRn (RecordUpd ...) (setField@"..." ...) expressions     - Note that this is true for all record updates even for those that do not involve '.'  When OverloadedRecordDot is enabled and RebindableSyntax is not@@ -1082,18 +1231,7 @@ names 'getField' and 'setField' are whatever in-scope names they are. -} --- See Note [Rebindable syntax and HsExpansion] just above.-data HsExpansion orig expanded-  = HsExpanded orig expanded-  deriving Data --- | Just print the original expression (the @a@).-instance (Outputable a, Outputable b) => Outputable (HsExpansion a b) where-  ppr (HsExpanded orig expanded)-    = ifPprDebug (vcat [ppr orig, braces (text "Expansion:" <+> ppr expanded)])-                 (ppr orig)-- {- ************************************************************************ *                                                                      *@@ -1102,33 +1240,36 @@ ************************************************************************ -} -type instance XCmdArrApp  GhcPs = EpAnn AddEpAnn+type instance XCmdArrApp  GhcPs = AddEpAnn type instance XCmdArrApp  GhcRn = NoExtField type instance XCmdArrApp  GhcTc = Type -type instance XCmdArrForm GhcPs = EpAnn AnnList+type instance XCmdArrForm GhcPs = AnnList type instance XCmdArrForm GhcRn = NoExtField type instance XCmdArrForm GhcTc = NoExtField -type instance XCmdApp     (GhcPass _) = EpAnnCO+type instance XCmdApp     (GhcPass _) = NoExtField type instance XCmdLam     (GhcPass _) = NoExtField-type instance XCmdPar     (GhcPass _) = EpAnnCO -type instance XCmdCase    GhcPs = EpAnn EpAnnHsCase+type instance XCmdPar     GhcPs = (EpToken "(", EpToken ")")+type instance XCmdPar     GhcRn = NoExtField+type instance XCmdPar     GhcTc = NoExtField++type instance XCmdCase    GhcPs = EpAnnHsCase type instance XCmdCase    GhcRn = NoExtField type instance XCmdCase    GhcTc = NoExtField -type instance XCmdLamCase (GhcPass _) = EpAnn [AddEpAnn]+type instance XCmdLamCase (GhcPass _) = [AddEpAnn] -type instance XCmdIf      GhcPs = EpAnn AnnsIf+type instance XCmdIf      GhcPs = AnnsIf type instance XCmdIf      GhcRn = NoExtField type instance XCmdIf      GhcTc = NoExtField -type instance XCmdLet     GhcPs = EpAnnCO+type instance XCmdLet     GhcPs = (EpToken "let", EpToken "in") type instance XCmdLet     GhcRn = NoExtField type instance XCmdLet     GhcTc = NoExtField -type instance XCmdDo      GhcPs = EpAnn AnnList+type instance XCmdDo      GhcPs = AnnList type instance XCmdDo      GhcRn = NoExtField type instance XCmdDo      GhcTc = Type @@ -1225,7 +1366,7 @@  ppr_cmd :: forall p. (OutputableBndrId p                      ) => HsCmd (GhcPass p) -> SDoc-ppr_cmd (HsCmdPar _ _ c _) = parens (ppr_lcmd c)+ppr_cmd (HsCmdPar _ c) = parens (ppr_lcmd c)  ppr_cmd (HsCmdApp _ c e)   = let (fun, args) = collect_args c [e] in@@ -1234,16 +1375,15 @@     collect_args (L _ (HsCmdApp _ fun arg)) args = collect_args fun (arg:args)     collect_args fun args = (fun, args) -ppr_cmd (HsCmdLam _ matches)+ppr_cmd (HsCmdLam _ LamSingle matches)   = pprMatches matches+ppr_cmd (HsCmdLam _ lam_variant matches)+  = sep [ lamCaseKeyword lam_variant, nest 2 (pprMatches matches) ]  ppr_cmd (HsCmdCase _ expr matches)   = sep [ sep [text "case", nest 4 (ppr expr), text "of"],           nest 2 (pprMatches matches) ] -ppr_cmd (HsCmdLamCase _ lc_variant matches)-  = sep [ lamCaseKeyword lc_variant, nest 2 (pprMatches matches) ]- ppr_cmd (HsCmdIf _ _ e ct ce)   = sep [hsep [text "if", nest 2 (ppr e), text "then"],          nest 4 (ppr ct),@@ -1251,11 +1391,11 @@          nest 4 (ppr ce)]  -- special case: let ... in let ...-ppr_cmd (HsCmdLet _ _ binds _ cmd@(L _ (HsCmdLet {})))+ppr_cmd (HsCmdLet _ binds cmd@(L _ (HsCmdLet {})))   = sep [hang (text "let") 2 (hsep [pprBinds binds, text "in"]),          ppr_lcmd cmd] -ppr_cmd (HsCmdLet _ _ binds _ cmd)+ppr_cmd (HsCmdLet _ binds cmd)   = sep [hang (text "let") 2 (pprBinds binds),          hang (text "in")  2 (ppr cmd)] @@ -1292,10 +1432,6 @@       = fall_through  ppr_cmd (XCmd x) = case ghcPass @p of-#if __GLASGOW_HASKELL__ < 811-  GhcPs -> ppr x-  GhcRn -> ppr x-#endif   GhcTc -> case x of     HsWrap w cmd -> pprHsWrapper w (\_ -> parens (ppr_cmd cmd)) @@ -1315,7 +1451,7 @@ -}  type instance XMG         GhcPs b = Origin-type instance XMG         GhcRn b = Origin+type instance XMG         GhcRn b = Origin -- See Note [Generated code and pattern-match checking] type instance XMG         GhcTc b = MatchGroupTc  data MatchGroupTc@@ -1327,7 +1463,7 @@  type instance XXMatchGroup (GhcPass _) b = DataConCantHappen -type instance XCMatch (GhcPass _) b = EpAnn [AddEpAnn]+type instance XCMatch (GhcPass _) b = [AddEpAnn] type instance XXMatch (GhcPass _) b = DataConCantHappen  instance (OutputableBndrId pr, Outputable body)@@ -1350,9 +1486,10 @@ -- Precondition: MatchGroup is non-empty -- This is called before type checking, when mg_arg_tys is not set matchGroupArity (MG { mg_alts = alts })-  | L _ (alt1:_) <- alts = length (hsLMatchPats alt1)-  | otherwise        = panic "matchGroupArity"+  | L _ (alt1:_) <- alts = count (isVisArgPat . unLoc) (hsLMatchPats alt1)+  | otherwise            = panic "matchGroupArity" + hsLMatchPats :: LMatch (GhcPass id) body -> [LPat (GhcPass id)] hsLMatchPats (L _ (Match { m_pats = pats })) = pats @@ -1370,6 +1507,9 @@       ga_sep  :: AddEpAnn -- ^ Match separator location       } deriving (Data) +instance NoAnn GrhsAnn where+  noAnn = GrhsAnn Nothing noAnn+ type instance XCGRHS (GhcPass _) _ = EpAnn GrhsAnn                                    -- Location of matchSeparator                                    -- TODO:AZ does this belong on the GRHS, or GRHSs?@@ -1393,7 +1533,7 @@            => LPat (GhcPass bndr) -> GRHSs (GhcPass p) (LHsExpr (GhcPass p)) -> SDoc pprPatBind pat grhss  = sep [ppr pat,-       nest 2 (pprGRHSs (PatBindRhs :: HsMatchContext (GhcPass p)) grhss)]+       nest 2 (pprGRHSs (PatBindRhs :: HsMatchContext Void) grhss)]  pprMatch :: (OutputableBndrId idR, Outputable body)          => Match (GhcPass idR) body -> SDoc@@ -1401,6 +1541,12 @@   = sep [ sep (herald : map (nest 2 . pprParendLPat appPrec) other_pats)         , nest 2 (pprGRHSs ctxt grhss) ]   where+    -- lam_cases_result: we don't simply return (empty, pats) to avoid+    -- introducing an additional `nest 2` via the empty herald+    lam_cases_result = case pats of+                          []     -> (empty, [])+                          (p:ps) -> (pprParendLPat appPrec p, ps)+     (herald, other_pats)         = case ctxt of             FunRhs {mc_fun=L _ fun, mc_fixity=fixity, mc_strictness=strictness}@@ -1423,17 +1569,10 @@                                      <+> pprParendLPat opPrec p2                      _ -> pprPanic "pprMatch" (ppr ctxt $$ ppr pats) -            LambdaExpr -> (char '\\', pats)--            -- We don't simply return (empty, pats) to avoid introducing an-            -- additional `nest 2` via the empty herald-            LamCaseAlt LamCases ->-              maybe (empty, []) (first $ pprParendLPat appPrec) (uncons pats)--            ArrowMatchCtxt (ArrowLamCaseAlt LamCases) ->-              maybe (empty, []) (first $ pprParendLPat appPrec) (uncons pats)--            ArrowMatchCtxt KappaExpr -> (char '\\', pats)+            LamAlt LamSingle                       -> (char '\\', pats)+            ArrowMatchCtxt (ArrowLamAlt LamSingle) -> (char '\\', pats)+            LamAlt LamCases                        -> lam_cases_result+            ArrowMatchCtxt (ArrowLamAlt LamCases)  -> lam_cases_result              ArrowMatchCtxt ProcExpr -> (text "proc", pats) @@ -1443,7 +1582,7 @@                    _     -> pprPanic "pprMatch" (ppr ctxt $$ ppr pats)  pprGRHSs :: (OutputableBndrId idR, Outputable body)-         => HsMatchContext passL -> GRHSs (GhcPass idR) body -> SDoc+         => HsMatchContext fn -> GRHSs (GhcPass idR) body -> SDoc pprGRHSs ctxt (GRHSs _ grhss binds)   = vcat (map (pprGRHS ctxt . unLoc) grhss)   -- Print the "where" even if the contents of the binds is empty. Only@@ -1452,16 +1591,31 @@       (text "where" $$ nest 4 (pprBinds binds))  pprGRHS :: (OutputableBndrId idR, Outputable body)-        => HsMatchContext passL -> GRHS (GhcPass idR) body -> SDoc+        => HsMatchContext fn -> GRHS (GhcPass idR) body -> SDoc pprGRHS ctxt (GRHS _ [] body)  =  pp_rhs ctxt body  pprGRHS ctxt (GRHS _ guards body)  = sep [vbar <+> interpp'SP guards, pp_rhs ctxt body] -pp_rhs :: Outputable body => HsMatchContext passL -> body -> SDoc+pp_rhs :: Outputable body => HsMatchContext fn -> body -> SDoc pp_rhs ctxt rhs = matchSeparator ctxt <+> pprDeeper (ppr rhs) +matchSeparator :: HsMatchContext fn -> SDoc+matchSeparator FunRhs{}         = text "="+matchSeparator CaseAlt          = text "->"+matchSeparator LamAlt{}         = text "->"+matchSeparator IfAlt            = text "->"+matchSeparator ArrowMatchCtxt{} = text "->"+matchSeparator PatBindRhs       = text "="+matchSeparator PatBindGuards    = text "="+matchSeparator StmtCtxt{}       = text "<-"+matchSeparator RecUpd           = text "="  -- This can be printed by the pattern+matchSeparator PatSyn           = text "<-" -- match checker trace+matchSeparator LazyPatCtx       = panic "unused"+matchSeparator ThPatSplice      = panic "unused"+matchSeparator ThPatQuote       = panic "unused"+ instance Outputable GrhsAnn where   ppr (GrhsAnn v s) = text "GrhsAnn" <+> ppr v <+> ppr s @@ -1496,7 +1650,7 @@  type instance XLastStmt        (GhcPass _) (GhcPass _) b = NoExtField -type instance XBindStmt        (GhcPass _) GhcPs b = EpAnn [AddEpAnn]+type instance XBindStmt        (GhcPass _) GhcPs b = [AddEpAnn] type instance XBindStmt        (GhcPass _) GhcRn b = XBindStmtRn type instance XBindStmt        (GhcPass _) GhcTc b = XBindStmtTc @@ -1520,17 +1674,17 @@ type instance XBodyStmt        (GhcPass _) GhcRn b = NoExtField type instance XBodyStmt        (GhcPass _) GhcTc b = Type -type instance XLetStmt         (GhcPass _) (GhcPass _) b = EpAnn [AddEpAnn]+type instance XLetStmt         (GhcPass _) (GhcPass _) b = [AddEpAnn]  type instance XParStmt         (GhcPass _) GhcPs b = NoExtField type instance XParStmt         (GhcPass _) GhcRn b = NoExtField type instance XParStmt         (GhcPass _) GhcTc b = Type -type instance XTransStmt       (GhcPass _) GhcPs b = EpAnn [AddEpAnn]+type instance XTransStmt       (GhcPass _) GhcPs b = [AddEpAnn] type instance XTransStmt       (GhcPass _) GhcRn b = NoExtField type instance XTransStmt       (GhcPass _) GhcTc b = Type -type instance XRecStmt         (GhcPass _) GhcPs b = EpAnn AnnList+type instance XRecStmt         (GhcPass _) GhcPs b = AnnList type instance XRecStmt         (GhcPass _) GhcRn b = NoExtField type instance XRecStmt         (GhcPass _) GhcTc b = RecStmtTc @@ -1739,17 +1893,17 @@       }   | HsUntypedSpliceNested SplicePointName -- A unique name to identify this splice point -type instance XTypedSplice   GhcPs = (EpAnnCO, EpAnn [AddEpAnn])+type instance XTypedSplice   GhcPs = [AddEpAnn] type instance XTypedSplice   GhcRn = SplicePointName type instance XTypedSplice   GhcTc = DelayedSplice -type instance XUntypedSplice GhcPs = EpAnnCO+type instance XUntypedSplice GhcPs = NoExtField type instance XUntypedSplice GhcRn = HsUntypedSpliceResult (HsExpr GhcRn) type instance XUntypedSplice GhcTc = DataConCantHappen  -- HsUntypedSplice-type instance XUntypedSpliceExpr GhcPs = EpAnn [AddEpAnn]-type instance XUntypedSpliceExpr GhcRn = EpAnn [AddEpAnn]+type instance XUntypedSpliceExpr GhcPs = [AddEpAnn]+type instance XUntypedSpliceExpr GhcRn = [AddEpAnn] type instance XUntypedSpliceExpr GhcTc = DataConCantHappen  type instance XQuasiQuote        p = NoExtField@@ -1864,10 +2018,6 @@       pprHsQuote (VarBr _ False n)         = text "''" <> pprPrefixOcc (unLoc n)       pprHsQuote (XQuote b)  = case ghcPass @p of-#if __GLASGOW_HASKELL__ <= 900-          GhcPs -> dataConCantHappen b-          GhcRn -> dataConCantHappen b-#endif           GhcTc -> pprPanic "pprHsQuote: `HsQuote GhcTc` shouldn't exist" (ppr b)                    -- See Note [The life cycle of a TH quotation] @@ -1915,11 +2065,15 @@ ************************************************************************ -} -instance OutputableBndrId p => Outputable (HsMatchContext (GhcPass p)) where+type HsMatchContextPs = HsMatchContext (LIdP GhcPs)+type HsMatchContextRn = HsMatchContext (LIdP GhcRn)++type HsStmtContextRn = HsStmtContext (LIdP GhcRn)++instance Outputable fn => Outputable (HsMatchContext fn) where   ppr m@(FunRhs{})            = text "FunRhs" <+> ppr (mc_fun m) <+> ppr (mc_fixity m)-  ppr LambdaExpr              = text "LambdaExpr"   ppr CaseAlt                 = text "CaseAlt"-  ppr (LamCaseAlt lc_variant) = text "LamCaseAlt" <+> ppr lc_variant+  ppr (LamAlt lam_variant)    = text "LamAlt" <+> ppr lam_variant   ppr IfAlt                   = text "IfAlt"   ppr (ArrowMatchCtxt c)      = text "ArrowMatchCtxt" <+> ppr c   ppr PatBindRhs              = text "PatBindRhs"@@ -1929,25 +2083,27 @@   ppr ThPatSplice             = text "ThPatSplice"   ppr ThPatQuote              = text "ThPatQuote"   ppr PatSyn                  = text "PatSyn"+  ppr LazyPatCtx              = text "LazyPatCtx" -instance Outputable LamCaseVariant where+instance Outputable HsLamVariant where   ppr = text . \case-    LamCase  -> "LamCase"-    LamCases -> "LamCases"+    LamSingle -> "LamSingle"+    LamCase   -> "LamCase"+    LamCases  -> "LamCases" -lamCaseKeyword :: LamCaseVariant -> SDoc-lamCaseKeyword LamCase  = text "\\case"-lamCaseKeyword LamCases = text "\\cases"+lamCaseKeyword :: HsLamVariant -> SDoc+lamCaseKeyword LamSingle = text "lambda"+lamCaseKeyword LamCase   = text "\\case"+lamCaseKeyword LamCases  = text "\\cases"  pprExternalSrcLoc :: (StringLiteral,(Int,Int),(Int,Int)) -> SDoc pprExternalSrcLoc (StringLiteral _ src _,(n1,n2),(n3,n4))   = ppr (src,(n1,n2),(n3,n4))  instance Outputable HsArrowMatchContext where-  ppr ProcExpr                     = text "ProcExpr"-  ppr ArrowCaseAlt                 = text "ArrowCaseAlt"-  ppr (ArrowLamCaseAlt lc_variant) = parens $ text "ArrowLamCaseAlt" <+> ppr lc_variant-  ppr KappaExpr                    = text "KappaExpr"+  ppr ProcExpr                  = text "ProcExpr"+  ppr ArrowCaseAlt              = text "ArrowCaseAlt"+  ppr (ArrowLamAlt lam_variant) = parens $ text "ArrowLamCaseAlt" <+> ppr lam_variant  pprHsArrType :: HsArrAppType -> SDoc pprHsArrType HsHigherOrderApp = text "higher order arrow application"@@ -1955,21 +2111,18 @@  ----------------- -instance OutputableBndrId p-      => Outputable (HsStmtContext (GhcPass p)) where+instance Outputable fn => Outputable (HsStmtContext fn) where     ppr = pprStmtContext  -- Used to generate the string for a *runtime* error message-matchContextErrString :: OutputableBndrId p-                      => HsMatchContext (GhcPass p) -> SDoc-matchContextErrString (FunRhs{mc_fun=L _ fun})      = text "function" <+> ppr fun+matchContextErrString :: Outputable fn => HsMatchContext fn -> SDoc+matchContextErrString (FunRhs{mc_fun=fun})          = text "function" <+> ppr fun matchContextErrString CaseAlt                       = text "case"-matchContextErrString (LamCaseAlt lc_variant)       = lamCaseKeyword lc_variant+matchContextErrString (LamAlt lam_variant)          = lamCaseKeyword lam_variant matchContextErrString IfAlt                         = text "multi-way if" matchContextErrString PatBindRhs                    = text "pattern binding" matchContextErrString PatBindGuards                 = text "pattern binding guards" matchContextErrString RecUpd                        = text "record update"-matchContextErrString LambdaExpr                    = text "lambda" matchContextErrString (ArrowMatchCtxt c)            = matchArrowContextErrString c matchContextErrString ThPatSplice                   = panic "matchContextErrString"  -- Not used at runtime matchContextErrString ThPatQuote                    = panic "matchContextErrString"  -- Not used at runtime@@ -1979,12 +2132,13 @@ matchContextErrString (StmtCtxt (PatGuard _))       = text "pattern guard" matchContextErrString (StmtCtxt (ArrowExpr))        = text "'do' block" matchContextErrString (StmtCtxt (HsDoStmt flavour)) = matchDoContextErrString flavour+matchContextErrString LazyPatCtx                    = text "irrefutable pattern"  matchArrowContextErrString :: HsArrowMatchContext -> SDoc-matchArrowContextErrString ProcExpr                     = text "proc"-matchArrowContextErrString ArrowCaseAlt                 = text "case"-matchArrowContextErrString (ArrowLamCaseAlt lc_variant) = lamCaseKeyword lc_variant-matchArrowContextErrString KappaExpr                    = text "kappa"+matchArrowContextErrString ProcExpr                  = text "proc"+matchArrowContextErrString ArrowCaseAlt              = text "case"+matchArrowContextErrString (ArrowLamAlt LamSingle)   = text "kappa"+matchArrowContextErrString (ArrowLamAlt lam_variant) = lamCaseKeyword lam_variant  matchDoContextErrString :: HsDoFlavour -> SDoc matchDoContextErrString GhciStmtCtxt = text "interactive GHCi command"@@ -2001,10 +2155,10 @@  pprStmtInCtxt :: (OutputableBndrId idL,                   OutputableBndrId idR,-                  OutputableBndrId ctx,+                  Outputable fn,                   Outputable body,                  Anno (StmtLR (GhcPass idL) (GhcPass idR) body) ~ SrcSpanAnnA)-              => HsStmtContext (GhcPass ctx)+              => HsStmtContext fn               -> StmtLR (GhcPass idL) (GhcPass idR) body               -> SDoc pprStmtInCtxt ctxt (LastStmt _ e _ _)@@ -2020,38 +2174,22 @@                         , trS_form = form }) = pprTransStmt by using form     ppr_stmt stmt = pprStmt stmt -matchSeparator :: HsMatchContext p -> SDoc-matchSeparator FunRhs{}         = text "="-matchSeparator CaseAlt          = text "->"-matchSeparator LamCaseAlt{}     = text "->"-matchSeparator IfAlt            = text "->"-matchSeparator LambdaExpr       = text "->"-matchSeparator ArrowMatchCtxt{} = text "->"-matchSeparator PatBindRhs       = text "="-matchSeparator PatBindGuards    = text "="-matchSeparator StmtCtxt{}       = text "<-"-matchSeparator RecUpd           = text "="  -- This can be printed by the pattern-matchSeparator PatSyn           = text "<-" -- match checker trace-matchSeparator ThPatSplice  = panic "unused"-matchSeparator ThPatQuote   = panic "unused"--pprMatchContext :: (Outputable (IdP (NoGhcTc p)), UnXRec (NoGhcTc p))-                => HsMatchContext p -> SDoc+pprMatchContext :: Outputable fn => HsMatchContext fn -> SDoc pprMatchContext ctxt   | want_an ctxt = text "an" <+> pprMatchContextNoun ctxt   | otherwise    = text "a"  <+> pprMatchContextNoun ctxt   where-    want_an (FunRhs {})                = True  -- Use "an" in front-    want_an (ArrowMatchCtxt ProcExpr)  = True-    want_an (ArrowMatchCtxt KappaExpr) = True-    want_an _                          = False+    want_an (FunRhs {})                              = True  -- Use "an" in front+    want_an (ArrowMatchCtxt ProcExpr)                = True+    want_an (ArrowMatchCtxt (ArrowLamAlt LamSingle)) = True+    want_an LazyPatCtx                               = True+    want_an _                                        = False -pprMatchContextNoun :: forall p. (Outputable (IdP (NoGhcTc p)), UnXRec (NoGhcTc p))-                    => HsMatchContext p -> SDoc-pprMatchContextNoun (FunRhs {mc_fun=fun})   = text "equation for"-                                                <+> quotes (ppr (unXRec @(NoGhcTc p) fun))+pprMatchContextNoun :: Outputable fn => HsMatchContext fn -> SDoc+pprMatchContextNoun (FunRhs {mc_fun=fun})   = text "equation for" <+> quotes (ppr fun) pprMatchContextNoun CaseAlt                 = text "case alternative"-pprMatchContextNoun (LamCaseAlt lc_variant) = lamCaseKeyword lc_variant+pprMatchContextNoun (LamAlt LamSingle)      = text "lambda abstraction"+pprMatchContextNoun (LamAlt lam_variant)    = lamCaseKeyword lam_variant                                               <+> text "alternative" pprMatchContextNoun IfAlt                   = text "multi-way if alternative" pprMatchContextNoun RecUpd                  = text "record update"@@ -2059,16 +2197,14 @@ pprMatchContextNoun ThPatQuote              = text "Template Haskell pattern quotation" pprMatchContextNoun PatBindRhs              = text "pattern binding" pprMatchContextNoun PatBindGuards           = text "pattern binding guards"-pprMatchContextNoun LambdaExpr              = text "lambda abstraction" pprMatchContextNoun (ArrowMatchCtxt c)      = pprArrowMatchContextNoun c pprMatchContextNoun (StmtCtxt ctxt)         = text "pattern binding in"                                               $$ pprAStmtContext ctxt pprMatchContextNoun PatSyn                  = text "pattern synonym declaration"+pprMatchContextNoun LazyPatCtx              = text "irrefutable pattern" -pprMatchContextNouns :: forall p. (Outputable (IdP (NoGhcTc p)), UnXRec (NoGhcTc p))-                     => HsMatchContext p -> SDoc-pprMatchContextNouns (FunRhs {mc_fun=fun})   = text "equations for"-                                               <+> quotes (ppr (unXRec @(NoGhcTc p) fun))+pprMatchContextNouns :: Outputable fn => HsMatchContext fn -> SDoc+pprMatchContextNouns (FunRhs {mc_fun=fun})   = text "equations for" <+> quotes (ppr fun) pprMatchContextNouns PatBindGuards           = text "pattern binding guards" pprMatchContextNouns (ArrowMatchCtxt c)      = pprArrowMatchContextNouns c pprMatchContextNouns (StmtCtxt ctxt)         = text "pattern bindings in"@@ -2078,19 +2214,19 @@ pprArrowMatchContextNoun :: HsArrowMatchContext -> SDoc pprArrowMatchContextNoun ProcExpr                     = text "arrow proc pattern" pprArrowMatchContextNoun ArrowCaseAlt                 = text "case alternative within arrow notation"-pprArrowMatchContextNoun (ArrowLamCaseAlt lc_variant) = lamCaseKeyword lc_variant-                                                        <+> text "alternative within arrow notation"-pprArrowMatchContextNoun KappaExpr                    = text "arrow kappa abstraction"+pprArrowMatchContextNoun (ArrowLamAlt LamSingle)   = text "arrow kappa abstraction"+pprArrowMatchContextNoun (ArrowLamAlt lam_variant) = lamCaseKeyword lam_variant+                                                     <+> text "alternative within arrow notation"  pprArrowMatchContextNouns :: HsArrowMatchContext -> SDoc-pprArrowMatchContextNouns ArrowCaseAlt                 = text "case alternatives within arrow notation"-pprArrowMatchContextNouns (ArrowLamCaseAlt lc_variant) = lamCaseKeyword lc_variant-                                                         <+> text "alternatives within arrow notation"-pprArrowMatchContextNouns ctxt                         = pprArrowMatchContextNoun ctxt <> char 's'+pprArrowMatchContextNouns ArrowCaseAlt              = text "case alternatives within arrow notation"+pprArrowMatchContextNouns (ArrowLamAlt LamSingle)   = text "arrow kappa abstractions"+pprArrowMatchContextNouns (ArrowLamAlt lam_variant) = lamCaseKeyword lam_variant+                                                      <+> text "alternatives within arrow notation"+pprArrowMatchContextNouns ctxt                      = pprArrowMatchContextNoun ctxt <> char 's'  ------------------pprAStmtContext, pprStmtContext :: (Outputable (IdP (NoGhcTc p)), UnXRec (NoGhcTc p))-                                => HsStmtContext p -> SDoc+pprAStmtContext, pprStmtContext :: Outputable fn => HsStmtContext fn -> SDoc pprAStmtContext (HsDoStmt flavour) = pprAHsDoFlavour flavour pprAStmtContext ctxt = text "a" <+> pprStmtContext ctxt @@ -2187,27 +2323,27 @@  type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsCmd (GhcPass pr))))]   = SrcSpanAnnL-type instance Anno (HsCmdTop (GhcPass p)) = SrcAnn NoEpAnns+type instance Anno (HsCmdTop (GhcPass p)) = EpAnnCO type instance Anno [LocatedA (Match (GhcPass p) (LocatedA (HsExpr (GhcPass p))))] = SrcSpanAnnL type instance Anno [LocatedA (Match (GhcPass p) (LocatedA (HsCmd  (GhcPass p))))] = SrcSpanAnnL type instance Anno (Match (GhcPass p) (LocatedA (HsExpr (GhcPass p)))) = SrcSpanAnnA type instance Anno (Match (GhcPass p) (LocatedA (HsCmd  (GhcPass p)))) = SrcSpanAnnA-type instance Anno (GRHS (GhcPass p) (LocatedA (HsExpr (GhcPass p)))) = SrcAnn NoEpAnns-type instance Anno (GRHS (GhcPass p) (LocatedA (HsCmd  (GhcPass p)))) = SrcAnn NoEpAnns+type instance Anno (GRHS (GhcPass p) (LocatedA (HsExpr (GhcPass p)))) = EpAnnCO+type instance Anno (GRHS (GhcPass p) (LocatedA (HsCmd  (GhcPass p)))) = EpAnnCO type instance Anno (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (body (GhcPass pr)))) = SrcSpanAnnA  type instance Anno (HsUntypedSplice (GhcPass p)) = SrcSpanAnnA  type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (body (GhcPass pr))))] = SrcSpanAnnL -type instance Anno (FieldLabelStrings (GhcPass p)) = SrcAnn NoEpAnns+type instance Anno (FieldLabelStrings (GhcPass p)) = EpAnnCO type instance Anno FieldLabelString                = SrcSpanAnnN -type instance Anno FastString                      = SrcAnn NoEpAnns+type instance Anno FastString                      = EpAnnCO   -- Used in HsQuasiQuote and perhaps elsewhere -type instance Anno (DotFieldOcc (GhcPass p))       = SrcAnn NoEpAnns+type instance Anno (DotFieldOcc (GhcPass p))       = EpAnnCO -instance (Anno a ~ SrcSpanAnn' (EpAnn an))+instance (HasAnnotation (Anno a))    => WrapXRec (GhcPass p) a where   wrapXRec = noLocA
compiler/GHC/Hs/Extension.hs view
@@ -25,10 +25,7 @@  import GHC.Prelude -import GHC.TypeLits (KnownSymbol, symbolVal)- import Data.Data hiding ( Fixity )-import Language.Haskell.Syntax.Concrete import Language.Haskell.Syntax.Extension import GHC.Types.Name import GHC.Types.Name.Reader@@ -107,7 +104,8 @@ type instance Anno Name    = SrcSpanAnnN type instance Anno Id      = SrcSpanAnnN -type IsSrcSpanAnn p a = ( Anno (IdGhcP p) ~ SrcSpanAnn' (EpAnn a),+type IsSrcSpanAnn p a = ( Anno (IdGhcP p) ~ EpAnn a,+                          NoAnn a,                           IsPass p)  instance UnXRec (GhcPass p) where@@ -236,16 +234,6 @@ pprIfTc pp = case ghcPass @p of GhcTc -> pp                                 _     -> empty -type instance Anno (HsToken tok) = TokenLocation--noHsTok :: GenLocated TokenLocation (HsToken tok)-noHsTok = L NoTokenLoc HsTok--type instance Anno (HsUniToken tok utok) = TokenLocation--noHsUniTok :: GenLocated TokenLocation (HsUniToken tok utok)-noHsUniTok = L NoTokenLoc HsNormalTok- --- Outputable  instance Outputable NoExtField where@@ -253,12 +241,3 @@  instance Outputable DataConCantHappen where   ppr = dataConCantHappen--instance KnownSymbol tok => Outputable (HsToken tok) where-   ppr _ = text (symbolVal (Proxy :: Proxy tok))--instance (KnownSymbol tok, KnownSymbol utok) => Outputable (HsUniToken tok utok) where-   ppr HsNormalTok  = text (symbolVal (Proxy :: Proxy tok))-   ppr HsUnicodeTok = text (symbolVal (Proxy :: Proxy utok))--deriving instance Typeable p => Data (LayoutInfo (GhcPass p))
compiler/GHC/Hs/ImpExp.hs view
@@ -38,10 +38,11 @@ import GHC.Utils.Outputable import GHC.Utils.Panic -import GHC.Unit.Module.Warnings (WarningTxt)+import GHC.Unit.Module.Warnings  import Data.Data import Data.Maybe+import GHC.Hs.Doc (LHsDoc)   {-@@ -119,6 +120,8 @@   , importDeclAnnAs        :: Maybe EpaLocation   } deriving (Data) +instance NoAnn EpAnnImportDecl where+  noAnn = EpAnnImportDecl noAnn  Nothing  Nothing  Nothing  Nothing  Nothing -- ---------------------------------------------------------------------  simpleImportDecl :: ModuleName -> ImportDecl GhcPs@@ -203,36 +206,36 @@ -- The additional field of type 'Maybe (WarningTxt pass)' holds information -- about export deprecation annotations and is thus set to Nothing when `IE` -- is used in an import list (since export deprecation can only be used in exports)-type instance XIEVar       GhcPs = Maybe (LocatedP (WarningTxt GhcPs))-type instance XIEVar       GhcRn = Maybe (LocatedP (WarningTxt GhcRn))+type instance XIEVar       GhcPs = Maybe (LWarningTxt GhcPs)+type instance XIEVar       GhcRn = Maybe (LWarningTxt GhcRn) type instance XIEVar       GhcTc = NoExtField  -- The additional field of type 'Maybe (WarningTxt pass)' holds information -- about export deprecation annotations and is thus set to Nothing when `IE` -- is used in an import list (since export deprecation can only be used in exports)-type instance XIEThingAbs  GhcPs = (Maybe (LocatedP (WarningTxt GhcPs)), EpAnn [AddEpAnn])-type instance XIEThingAbs  GhcRn = (Maybe (LocatedP (WarningTxt GhcRn)), EpAnn [AddEpAnn])-type instance XIEThingAbs  GhcTc = EpAnn [AddEpAnn]+type instance XIEThingAbs  GhcPs = (Maybe (LWarningTxt GhcPs), [AddEpAnn])+type instance XIEThingAbs  GhcRn = (Maybe (LWarningTxt GhcRn), [AddEpAnn])+type instance XIEThingAbs  GhcTc = [AddEpAnn]  -- The additional field of type 'Maybe (WarningTxt pass)' holds information -- about export deprecation annotations and is thus set to Nothing when `IE` -- is used in an import list (since export deprecation can only be used in exports)-type instance XIEThingAll  GhcPs = (Maybe (LocatedP (WarningTxt GhcPs)), EpAnn [AddEpAnn])-type instance XIEThingAll  GhcRn = (Maybe (LocatedP (WarningTxt GhcRn)), EpAnn [AddEpAnn])-type instance XIEThingAll  GhcTc = EpAnn [AddEpAnn]+type instance XIEThingAll  GhcPs = (Maybe (LWarningTxt GhcPs), [AddEpAnn])+type instance XIEThingAll  GhcRn = (Maybe (LWarningTxt GhcRn), [AddEpAnn])+type instance XIEThingAll  GhcTc = [AddEpAnn]  -- The additional field of type 'Maybe (WarningTxt pass)' holds information -- about export deprecation annotations and is thus set to Nothing when `IE` -- is used in an import list (since export deprecation can only be used in exports)-type instance XIEThingWith GhcPs = (Maybe (LocatedP (WarningTxt GhcPs)), EpAnn [AddEpAnn])-type instance XIEThingWith GhcRn = (Maybe (LocatedP (WarningTxt GhcRn)), EpAnn [AddEpAnn])-type instance XIEThingWith GhcTc = EpAnn [AddEpAnn]+type instance XIEThingWith GhcPs = (Maybe (LWarningTxt GhcPs), [AddEpAnn])+type instance XIEThingWith GhcRn = (Maybe (LWarningTxt GhcRn), [AddEpAnn])+type instance XIEThingWith GhcTc = [AddEpAnn]  -- The additional field of type 'Maybe (WarningTxt pass)' holds information -- about export deprecation annotations and is thus set to Nothing when `IE` -- is used in an import list (since export deprecation can only be used in exports)-type instance XIEModuleContents  GhcPs = (Maybe (LocatedP (WarningTxt GhcPs)), EpAnn [AddEpAnn])-type instance XIEModuleContents  GhcRn = Maybe (LocatedP (WarningTxt GhcRn))+type instance XIEModuleContents  GhcPs = (Maybe (LWarningTxt GhcPs), [AddEpAnn])+type instance XIEModuleContents  GhcRn = Maybe (LWarningTxt GhcRn) type instance XIEModuleContents  GhcTc = NoExtField  type instance XIEGroup           (GhcPass _) = NoExtField@@ -243,18 +246,17 @@ type instance Anno (LocatedA (IE (GhcPass p))) = SrcSpanAnnA  ieName :: IE (GhcPass p) -> IdP (GhcPass p)-ieName (IEVar _ (L _ n))            = ieWrappedName n-ieName (IEThingAbs  _ (L _ n))      = ieWrappedName n-ieName (IEThingWith _ (L _ n) _ _)  = ieWrappedName n-ieName (IEThingAll  _ (L _ n))      = ieWrappedName n+ieName (IEVar _ (L _ n) _)           = ieWrappedName n+ieName (IEThingAbs  _ (L _ n) _)     = ieWrappedName n+ieName (IEThingWith _ (L _ n) _ _ _) = ieWrappedName n+ieName (IEThingAll  _ (L _ n) _)     = ieWrappedName n ieName _ = panic "ieName failed pattern match!"  ieNames :: IE (GhcPass p) -> [IdP (GhcPass p)]-ieNames (IEVar       _ (L _ n)   )   = [ieWrappedName n]-ieNames (IEThingAbs  _ (L _ n)   )   = [ieWrappedName n]-ieNames (IEThingAll  _ (L _ n)   )   = [ieWrappedName n]-ieNames (IEThingWith _ (L _ n) _ ns) = ieWrappedName n-                                     : map (ieWrappedName . unLoc) ns+ieNames (IEVar       _ (L _ n) _)      = [ieWrappedName n]+ieNames (IEThingAbs  _ (L _ n) _)      = [ieWrappedName n]+ieNames (IEThingAll  _ (L _ n) _)      = [ieWrappedName n]+ieNames (IEThingWith _ (L _ n) _ ns _) = ieWrappedName n : map (ieWrappedName . unLoc) ns -- NB the above case does not include names of field selectors ieNames (IEModuleContents {})     = [] ieNames (IEGroup          {})     = []@@ -264,16 +266,16 @@ ieDeprecation :: forall p. IsPass p => IE (GhcPass p) -> Maybe (WarningTxt (GhcPass p)) ieDeprecation = fmap unLoc . ie_deprecation (ghcPass @p)   where-    ie_deprecation :: GhcPass p -> IE (GhcPass p) -> Maybe (LocatedP (WarningTxt (GhcPass p)))-    ie_deprecation GhcPs (IEVar xie _) = xie-    ie_deprecation GhcPs (IEThingAbs (xie, _) _) = xie-    ie_deprecation GhcPs (IEThingAll (xie, _) _) = xie-    ie_deprecation GhcPs (IEThingWith (xie, _) _ _ _) = xie+    ie_deprecation :: GhcPass p -> IE (GhcPass p) -> Maybe (LWarningTxt (GhcPass p))+    ie_deprecation GhcPs (IEVar xie _ _) = xie+    ie_deprecation GhcPs (IEThingAbs (xie, _) _ _) = xie+    ie_deprecation GhcPs (IEThingAll (xie, _) _ _) = xie+    ie_deprecation GhcPs (IEThingWith (xie, _) _ _ _ _) = xie     ie_deprecation GhcPs (IEModuleContents (xie, _) _) = xie-    ie_deprecation GhcRn (IEVar xie _) = xie-    ie_deprecation GhcRn (IEThingAbs (xie, _) _) = xie-    ie_deprecation GhcRn (IEThingAll (xie, _) _) = xie-    ie_deprecation GhcRn (IEThingWith (xie, _) _ _ _) = xie+    ie_deprecation GhcRn (IEVar xie _ _) = xie+    ie_deprecation GhcRn (IEThingAbs (xie, _) _ _) = xie+    ie_deprecation GhcRn (IEThingAll (xie, _) _ _) = xie+    ie_deprecation GhcRn (IEThingWith (xie, _) _ _ _ _) = xie     ie_deprecation GhcRn (IEModuleContents xie _) = xie     ie_deprecation _ _ = Nothing @@ -300,12 +302,31 @@ replaceLWrappedName :: LIEWrappedName GhcPs -> IdP GhcRn -> LIEWrappedName GhcRn replaceLWrappedName (L l n) n' = L l (replaceWrappedName n n') +exportDocstring :: LHsDoc pass -> SDoc+exportDocstring doc = braces (text "docstring: " <> ppr doc)+ instance OutputableBndrId p => Outputable (IE (GhcPass p)) where-    ppr ie@(IEVar       _     var) = sep $ catMaybes [ppr <$> ieDeprecation ie, Just $ ppr (unLoc var)]-    ppr ie@(IEThingAbs  _   thing) = sep $ catMaybes [ppr <$> ieDeprecation ie, Just $ ppr (unLoc thing)]-    ppr ie@(IEThingAll  _   thing) = sep $ catMaybes [ppr <$> ieDeprecation ie, Just $ hcat [ppr (unLoc thing), text "(..)"]]-    ppr ie@(IEThingWith _ thing wc withs)-        = sep $ catMaybes [ppr <$> ieDeprecation ie, Just $ ppr (unLoc thing) <> parens (fsep (punctuate comma ppWiths))]+    ppr ie@(IEVar       _     var doc) =+      sep $ catMaybes [ ppr <$> ieDeprecation ie+                      , Just $ ppr (unLoc var)+                      , exportDocstring <$> doc+                      ]+    ppr ie@(IEThingAbs  _   thing doc) =+      sep $ catMaybes [ ppr <$> ieDeprecation ie+                      , Just $ ppr (unLoc thing)+                      , exportDocstring <$> doc+                      ]+    ppr ie@(IEThingAll  _   thing doc) =+      sep $ catMaybes [ ppr <$> ieDeprecation ie+                      , Just $ hcat [ppr (unLoc thing)+                      , text "(..)"]+                      , exportDocstring <$> doc+                      ]+    ppr ie@(IEThingWith _ thing wc withs doc) =+      sep $ catMaybes [ ppr <$> ieDeprecation ie+                      , Just $ ppr (unLoc thing) <> parens (fsep (punctuate comma ppWiths))+                      , exportDocstring <$> doc+                      ]       where         ppWiths =           case wc of
compiler/GHC/Hs/Instances.hs view
@@ -108,6 +108,9 @@ deriving instance Data (HsPatSynDir GhcRn) deriving instance Data (HsPatSynDir GhcTc) +deriving instance Data (HsMultAnn GhcPs)+deriving instance Data (HsMultAnn GhcRn)+deriving instance Data (HsMultAnn GhcTc) -- --------------------------------------------------------------------- -- Data derivations from GHC.Hs.Decls ---------------------------------- @@ -379,17 +382,10 @@ deriving instance Data (ApplicativeArg GhcRn) deriving instance Data (ApplicativeArg GhcTc) -deriving instance Data (HsStmtContext GhcPs)-deriving instance Data (HsStmtContext GhcRn)-deriving instance Data (HsStmtContext GhcTc)- deriving instance Data HsArrowMatchContext -deriving instance Data HsDoFlavour--deriving instance Data (HsMatchContext GhcPs)-deriving instance Data (HsMatchContext GhcRn)-deriving instance Data (HsMatchContext GhcTc)+deriving instance Data fn => Data (HsStmtContext fn)+deriving instance Data fn => Data (HsMatchContext fn)  -- deriving instance (DataIdLR p p) => Data (HsUntypedSplice p) deriving instance Data (HsUntypedSplice GhcPs)@@ -488,6 +484,11 @@ deriving instance Data (HsPatSigType GhcRn) deriving instance Data (HsPatSigType GhcTc) +-- deriving instance (DataIdLR p p) => Data (HsTyPat p)+deriving instance Data (HsTyPat GhcPs)+deriving instance Data (HsTyPat GhcRn)+deriving instance Data (HsTyPat GhcTc)+ -- deriving instance (DataIdLR p p) => Data (HsForAllTelescope p) deriving instance Data (HsForAllTelescope GhcPs) deriving instance Data (HsForAllTelescope GhcRn)@@ -508,11 +509,6 @@ deriving instance Data (HsTyLit GhcRn) deriving instance Data (HsTyLit GhcTc) --- deriving instance Data (HsLinearArrowTokens p)-deriving instance Data (HsLinearArrowTokens GhcPs)-deriving instance Data (HsLinearArrowTokens GhcRn)-deriving instance Data (HsLinearArrowTokens GhcTc)- -- deriving instance (DataIdLR p p) => Data (HsArrow p) deriving instance Data (HsArrow GhcPs) deriving instance Data (HsArrow GhcRn)@@ -561,6 +557,8 @@  -- --------------------------------------------------------------------- +deriving instance Data HsThingRn+deriving instance Data XXExprGhcRn deriving instance Data XXExprGhcTc deriving instance Data XXPatGhcTc
compiler/GHC/Hs/Pat.hs view
@@ -8,6 +8,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]                                       -- in module Language.Haskell.Syntax.Extension @@ -22,13 +23,14 @@  module GHC.Hs.Pat (         Pat(..), LPat,+        isInvisArgPat, isVisArgPat,         EpAnnSumPat(..),         ConPatTc (..),         ConLikeP,         HsPatExpansion(..),         XXPatGhcTc(..), -        HsConPatDetails, hsConPatArgs,+        HsConPatDetails, hsConPatArgs, hsConPatTyArgs,         HsConPatTyArg(..),         HsRecFields(..), HsFieldBind(..), LHsFieldBind,         HsRecField, LHsRecField,@@ -39,11 +41,11 @@          mkPrefixConPat, mkCharLitPat, mkNilPat, -        isSimplePat,+        isSimplePat, isPatSyn,         looksLazyPatBind,         isBangedLPat,         gParPat, patNeedsParens, parenthesizePat,-        isIrrefutableHsPat, isBoringHsPat,+        isIrrefutableHsPatHelper, isIrrefutableHsPatHelperM, isBoringHsPat,          collectEvVarsPat, collectEvVarsPats, @@ -84,6 +86,7 @@ import GHC.Types.Name (Name, dataName) import Data.Data +import Data.Functor.Identity  type instance XWildPat GhcPs = NoExtField type instance XWildPat GhcRn = NoExtField@@ -91,21 +94,23 @@  type instance XVarPat  (GhcPass _) = NoExtField -type instance XLazyPat GhcPs = EpAnn [AddEpAnn] -- For '~'+type instance XLazyPat GhcPs = [AddEpAnn] -- For '~' type instance XLazyPat GhcRn = NoExtField type instance XLazyPat GhcTc = NoExtField -type instance XAsPat   GhcPs = EpAnnCO+type instance XAsPat   GhcPs = EpToken "@" type instance XAsPat   GhcRn = NoExtField type instance XAsPat   GhcTc = NoExtField -type instance XParPat (GhcPass _) = EpAnnCO+type instance XParPat  GhcPs = (EpToken "(", EpToken ")")+type instance XParPat  GhcRn = NoExtField+type instance XParPat  GhcTc = NoExtField -type instance XBangPat GhcPs = EpAnn [AddEpAnn] -- For '!'+type instance XBangPat GhcPs = [AddEpAnn] -- For '!' type instance XBangPat GhcRn = NoExtField type instance XBangPat GhcTc = NoExtField -type instance XListPat GhcPs = EpAnn AnnList+type instance XListPat GhcPs = AnnList   -- After parsing, ListPat can refer to a built-in Haskell list pattern   -- or an overloaded list pattern. type instance XListPat GhcRn = NoExtField@@ -115,19 +120,19 @@ type instance XListPat GhcTc = Type   -- List element type, for use in hsPatType. -type instance XTuplePat GhcPs = EpAnn [AddEpAnn]+type instance XTuplePat GhcPs = [AddEpAnn] type instance XTuplePat GhcRn = NoExtField type instance XTuplePat GhcTc = [Type] -type instance XSumPat GhcPs = EpAnn EpAnnSumPat+type instance XSumPat GhcPs = EpAnnSumPat type instance XSumPat GhcRn = NoExtField type instance XSumPat GhcTc = [Type] -type instance XConPat GhcPs = EpAnn [AddEpAnn]+type instance XConPat GhcPs = [AddEpAnn] type instance XConPat GhcRn = NoExtField type instance XConPat GhcTc = ConPatTc -type instance XViewPat GhcPs = EpAnn [AddEpAnn]+type instance XViewPat GhcPs = [AddEpAnn] type instance XViewPat GhcRn = Maybe (HsExpr GhcRn)   -- The @HsExpr GhcRn@ gives an inverse to the view function.   -- This is used for overloaded lists in particular.@@ -143,33 +148,112 @@  type instance XLitPat    (GhcPass _) = NoExtField -type instance XNPat GhcPs = EpAnn [AddEpAnn]-type instance XNPat GhcRn = EpAnn [AddEpAnn]+type instance XNPat GhcPs = [AddEpAnn]+type instance XNPat GhcRn = [AddEpAnn] type instance XNPat GhcTc = Type -type instance XNPlusKPat GhcPs = EpAnn EpaLocation -- Of the "+"+type instance XNPlusKPat GhcPs = EpaLocation -- Of the "+" type instance XNPlusKPat GhcRn = NoExtField type instance XNPlusKPat GhcTc = Type -type instance XSigPat GhcPs = EpAnn [AddEpAnn]+type instance XSigPat GhcPs = [AddEpAnn] type instance XSigPat GhcRn = NoExtField type instance XSigPat GhcTc = Type +type instance XEmbTyPat GhcPs = EpToken "type"+type instance XEmbTyPat GhcRn = NoExtField+type instance XEmbTyPat GhcTc = Type+ type instance XXPat GhcPs = DataConCantHappen type instance XXPat GhcRn = HsPatExpansion (Pat GhcRn) (Pat GhcRn)   -- Original pattern and its desugaring/expansion.-  -- See Note [Rebindable syntax and HsExpansion].+  -- See Note [Rebindable syntax and XXExprGhcRn]. type instance XXPat GhcTc = XXPatGhcTc-  -- After typechecking, we add extra constructors: CoPat and HsExpansion.-  -- HsExpansion allows us to handle RebindableSyntax in pattern position:+  -- After typechecking, we add extra constructors: CoPat and XXExprGhcRn.+  -- XXExprGhcRn allows us to handle RebindableSyntax in pattern position:   -- see "XXExpr GhcTc" for the counterpart in expressions.  type instance ConLikeP GhcPs = RdrName -- IdP GhcPs type instance ConLikeP GhcRn = Name    -- IdP GhcRn type instance ConLikeP GhcTc = ConLike -type instance XHsFieldBind _ = EpAnn [AddEpAnn]+type instance XConPatTyArg GhcPs = EpToken "@"+type instance XConPatTyArg GhcRn = NoExtField+type instance XConPatTyArg GhcTc = NoExtField +type instance XHsFieldBind _ = [AddEpAnn]++type instance XInvisPat GhcPs = EpToken "@"+type instance XInvisPat GhcRn = NoExtField+type instance XInvisPat GhcTc = Type+++{- Note [Invisible binders in functions]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+GHC Proposal #448 (section 1.5 Type arguments in lambda patterns) introduces+binders for invisible type arguments (@a-binders) in function equations and+lambdas, e.g.++  1.  {-# LANGUAGE TypeAbstractions #-}+      id1 :: a -> a+      id1 @t x = x :: t     -- @t-binder on the LHS of a function equation++  2.  {-# LANGUAGE TypeAbstractions #-}+      ex :: (Int8, Int16)+      ex = higherRank (\ @a x -> maxBound @a - x )+                            -- @a-binder in a lambda pattern in an argument+                            -- to a higher-order function+      higherRank :: (forall a. (Num a, Bounded a) => a -> a) -> (Int8, Int16)+      higherRank f = (f 42, f 42)++In the AST, invisible patterns are represented as InvisPat constructor inside of Pat:+    data Pat p+      = ...+      | InvisPat (LHsType p)+      ...++Just like `BangPat`, the `Pat` data type allows `InvisPat` to appear in+nested positions. But this is often not allowed; e.g.++   f @a x = rhs    -- YES+   f (@a,x) = rhs  -- NO++   g = do { @a <- e1; e2 }         -- NO+   h x = case x of { @a -> rhs }   -- NO++Rather than excluding these things syntactically, we reject them in the renamer+(see `rn_pats_general`).  This actually gives a better error message than we+would get if they were rejected in the parser.++Each pattern is either visible (not prefixed with @) or invisible (prefixed with @):+    f :: forall a. forall b -> forall c. Int -> ...+    f @a b @c x  = ...++In this example, the arg-patterns are+    1. InvisPat @a     -- in the type sig: forall a.+    2. VarPat b        -- in the type sig: forall b ->+    3. InvisPat @c     -- in the type sig: forall c.+    4. VarPat x        -- in the type sig: Int ->++Invisible patterns are always type patterns, i.e. they are matched with+forall-bound type variables in the signature. Consequently, those variables (and+their binders) are erased during compilation, having no effect on program+execution at runtime.++Visible patterns, on the other hand, may be matched with ordinary function+arguments (Int ->) as well as required type arguments (forall b ->). This means+that a visible pattern may either be erased or retained, and we only find out in+the type checker, namely in tcMatchPats, where we match up all arg-patterns with+quantifiers from the type signature.++In other words, invisible patterns are always /erased/, while visible patterns+are sometimes /erased/ and sometimes /retained/.++The desugarer has no use for erased patterns, as the type checker generates+HsWrappers to bind the corresponding type variables. Erased patterns are simply+discarded inside tcMatchPats, where we know if visible pattern retained or erased.+-}+ -- ---------------------------------------------------------------------  -- API Annotations types@@ -180,6 +264,9 @@       , sumPatVbarsAfter  :: [EpaLocation]       } deriving Data +instance NoAnn EpAnnSumPat where+  noAnn = EpAnnSumPat [] [] []+ -- ---------------------------------------------------------------------  -- | Extension constructor for Pat, added after typechecking.@@ -202,11 +289,11 @@       }   -- | Pattern expansion: original pattern, and desugared pattern,   -- for RebindableSyntax and other overloaded syntax such as OverloadedLists.-  -- See Note [Rebindable syntax and HsExpansion].+  -- See Note [Rebindable syntax and XXExprGhcRn].   | ExpansionPat (Pat GhcRn) (Pat GhcTc)  --- See Note [Rebindable syntax and HsExpansion].+-- See Note [Rebindable syntax and XXExprGhcRn]. data HsPatExpansion a b   = HsPatExpanded a b   deriving Data@@ -260,10 +347,10 @@ ************************************************************************ -} -instance Outputable (HsPatSigType p) => Outputable (HsConPatTyArg p) where+instance Outputable (HsTyPat p) => Outputable (HsConPatTyArg p) where   ppr (HsConPatTyArg _ ty) = char '@' <> ppr ty -instance (Outputable arg, Outputable (XRec p (HsRecField p arg)), XRec p RecFieldsDotDot ~ Located RecFieldsDotDot)+instance (Outputable arg, Outputable (XRec p (HsRecField p arg)), XRec p RecFieldsDotDot ~ LocatedE RecFieldsDotDot)       => Outputable (HsRecFields p arg) where   ppr (HsRecFields { rec_flds = flds, rec_dotdot = Nothing })         = braces (fsep (punctuate comma (map ppr flds)))@@ -281,7 +368,7 @@ instance OutputableBndrId p => Outputable (Pat (GhcPass p)) where     ppr = pprPat --- See Note [Rebindable syntax and HsExpansion].+-- See Note [Rebindable syntax and XXExprGhcRn]. instance (Outputable a, Outputable b) => Outputable (HsPatExpansion a b) where   ppr (HsPatExpanded a b) = ifPprDebug (vcat [ppr a, ppr b]) (ppr a) @@ -326,10 +413,10 @@ pprPat (WildPat _)              = char '_' pprPat (LazyPat _ pat)          = char '~' <> pprParendLPat appPrec pat pprPat (BangPat _ pat)          = char '!' <> pprParendLPat appPrec pat-pprPat (AsPat _ name _ pat)     = hcat [pprPrefixOcc (unLoc name), char '@',+pprPat (AsPat _ name pat)       = hcat [pprPrefixOcc (unLoc name), char '@',                                         pprParendLPat appPrec pat] pprPat (ViewPat _ expr pat)     = hcat [pprLExpr expr, text " -> ", ppr pat]-pprPat (ParPat _ _ pat _)      = parens (ppr pat)+pprPat (ParPat _ pat)           = parens (ppr pat) pprPat (LitPat _ s)             = ppr s pprPat (NPat _ l Nothing  _)    = ppr l pprPat (NPat _ l (Just _) _)    = char '-' <> ppr l@@ -376,11 +463,10 @@                        , cpt_dicts = dicts                        , cpt_binds = binds                        } = ext+pprPat (EmbTyPat _ tp) = text "type" <+> ppr tp+pprPat (InvisPat _ tp) = char '@' <> ppr tp  pprPat (XPat ext) = case ghcPass @p of-#if __GLASGOW_HASKELL__ < 811-  GhcPs -> dataConCantHappen ext-#endif   GhcRn -> case ext of     HsPatExpanded orig _ -> pprPat orig   GhcTc -> case ext of@@ -472,7 +558,7 @@ isBangedLPat = isBangedPat . unLoc  isBangedPat :: Pat (GhcPass p) -> Bool-isBangedPat (ParPat _ _ p _) = isBangedLPat p+isBangedPat (ParPat _ p) = isBangedLPat p isBangedPat (BangPat {}) = True isBangedPat _            = False @@ -493,14 +579,13 @@ looksLazyLPat = looksLazyPat . unLoc  looksLazyPat :: Pat (GhcPass p) -> Bool-looksLazyPat (ParPat _ _ p _)  = looksLazyLPat p-looksLazyPat (AsPat _ _ _ p)   = looksLazyLPat p+looksLazyPat (ParPat _ p)  = looksLazyLPat p+looksLazyPat (AsPat _ _ p) = looksLazyLPat p looksLazyPat (BangPat {})  = False looksLazyPat (VarPat {})   = False looksLazyPat (WildPat {})  = False looksLazyPat _             = True - {- Note [-XStrict and irrefutability] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -526,6 +611,21 @@  See also Note [decideBangHood] in GHC.HsToCore.Utils. -}++type ConLikePIrrefutableCheck m p+  = Bool                       -- ^ Are we in a @-XStrict@ context?+                               -- See Note [-XStrict and irrefutability]+    -> XRec p (ConLikeP p)     -- ^ ConLikeThing+    -> HsConPatDetails p       -- ^ ConPattern details+    -> m Bool                  -- ^ is it Irrefutable?++type LPatIrrefutableCheck m p+  = Bool                              -- ^ Are we in a @-XStrict@ context?+                                      -- See Note [-XStrict and irrefutability]+    -> ConLikePIrrefutableCheck m p   -- How should I check ConLikeP things+    -> LPat p                         -- The LPat thing+    -> m Bool                         -- Is it irrefutable?+ -- | (isIrrefutableHsPat p) is true if matching against p cannot fail -- in the sense of falling through to the next pattern. --      (NB: this is not quite the same as the (silly) defn@@ -538,55 +638,72 @@ -- tuple patterns are considered irrefutable at the renamer stage. -- -- But if it returns True, the pattern is definitely irrefutable-isIrrefutableHsPat :: forall p. (OutputableBndrId p)-                    => Bool -- ^ Are we in a @-XStrict@ context?-                            -- See Note [-XStrict and irrefutability]-                    -> LPat (GhcPass p) -> Bool-isIrrefutableHsPat is_strict = goL+-- Instantiates `isIrrefutableHsPatHelperM` with a trivial identity monad+isIrrefutableHsPatHelper :: forall p. (OutputableBndrId p)+                         => Bool -- ^ Are we in a @-XStrict@ context?+                                 -- See Note [-XStrict and irrefutability]+                         -> LPat (GhcPass p) -> Bool+isIrrefutableHsPatHelper is_strict pat = runIdentity $ doWork is_strict pat   where-    goL :: LPat (GhcPass p) -> Bool-    goL = go . unLoc+  doWork :: forall p. (OutputableBndrId p) => Bool -> LPat (GhcPass p) -> Identity Bool+  doWork is_strict = isIrrefutableHsPatHelperM is_strict isConLikeIrr -    go :: Pat (GhcPass p) -> Bool-    go (WildPat {})        = True-    go (VarPat {})         = True+  isConLikeIrr :: forall p. (OutputableBndrId p) => ConLikePIrrefutableCheck Identity (GhcPass p)+  isConLikeIrr is_strict con details+    = case ghcPass @p of+        GhcPs -> return False                   -- Conservative+        GhcRn -> return False                   -- Conservative+        GhcTc -> case con of+          L _ (PatSynCon _pat)  -> return False -- Conservative+          L _ (RealDataCon con) ->+            do let b = isJust (tyConSingleDataCon_maybe (dataConTyCon con))+               bs <- mapM (doWork is_strict) (hsConPatArgs details)+               return $ b && and bs+++-- This function abstracts 2 things+-- 1. How to compute irrefutability for a `ConLikeP` thing+-- 2. The wrapper monad+isIrrefutableHsPatHelperM :: forall m p. (Monad m, OutputableBndrId p)+                          => LPatIrrefutableCheck m (GhcPass p)+isIrrefutableHsPatHelperM is_strict isConLikeIrr pat = go (unLoc pat)+  where+    goL = isIrrefutableHsPatHelperM is_strict isConLikeIrr++    go :: Pat (GhcPass p) -> m Bool+    go (WildPat {})        = return True+    go (VarPat {})         = return True     go (LazyPat _ p')       | is_strict-      = isIrrefutableHsPat False p'-      | otherwise          = True+      = isIrrefutableHsPatHelperM False isConLikeIrr p'+      | otherwise          = return True     go (BangPat _ pat)     = goL pat-    go (ParPat _ _ pat _)  = goL pat-    go (AsPat _ _ _ pat)   = goL pat+    go (ParPat _ pat)      = goL pat+    go (AsPat _ _ pat)     = goL pat     go (ViewPat _ _ pat)   = goL pat     go (SigPat _ pat _)    = goL pat-    go (TuplePat _ pats _) = all goL pats-    go (SumPat {})         = False+    go (TuplePat _ pats _) = do { bs <- mapM goL pats; return $ and bs }+    go (SumPat {})         = return False                     -- See Note [Unboxed sum patterns aren't irrefutable]-    go (ListPat {})        = False+    go (ListPat {})        = return False      go (ConPat         { pat_con  = con-        , pat_args = details })-                           = case ghcPass @p of-       GhcPs -> False -- Conservative-       GhcRn -> False -- Conservative-       GhcTc -> case con of-         L _ (PatSynCon _pat)  -> False -- Conservative-         L _ (RealDataCon con) ->-           isJust (tyConSingleDataCon_maybe (dataConTyCon con))-           && all goL (hsConPatArgs details)-    go (LitPat {})         = False-    go (NPat {})           = False-    go (NPlusKPat {})      = False+        , pat_args = details }) = isConLikeIrr is_strict con details+    go (LitPat {})         = return False+    go (NPat {})           = return False+    go (NPlusKPat {})      = return False      -- We conservatively assume that no TH splices are irrefutable     -- since we cannot know until the splice is evaluated.-    go (SplicePat {})      = False+    go (SplicePat {})      = return False +    -- The behavior of this case is unimportant, as GHC will throw an error shortly+    -- after reaching this case for other reasons (see TcRnIllegalTypePattern).+    go (EmbTyPat {})       = return True+    go (InvisPat {})       = return True+     go (XPat ext)          = case ghcPass @p of-#if __GLASGOW_HASKELL__ < 811-      GhcPs -> dataConCantHappen ext-#endif       GhcRn -> case ext of         HsPatExpanded _ pat -> go pat       GhcTc -> case ext of@@ -602,7 +719,7 @@ -- - x (variable) isSimplePat :: LPat (GhcPass x) -> Maybe (IdP (GhcPass x)) isSimplePat p = case unLoc p of-  ParPat _ _ x _ -> isSimplePat x+  ParPat _ x -> isSimplePat x   SigPat _ x _ -> isSimplePat x   LazyPat _ x -> isSimplePat x   BangPat _ x -> isSimplePat x@@ -610,7 +727,7 @@   _ -> Nothing  -- | Is this pattern boring from the perspective of pattern-match checking,--- i.e. introduces no new pieces of long-dinstance information+-- i.e. introduces no new pieces of long-distance information -- which could influence pattern-match checking? -- -- See Note [Boring patterns].@@ -628,7 +745,7 @@       VarPat  {} -> True       LazyPat {} -> True       BangPat _ pat     -> goL pat-      ParPat _ _ pat _  -> goL pat+      ParPat _ pat      -> goL pat       AsPat {} -> False -- the pattern x@y links x and y together,                         -- which is a nontrivial piece of information       ViewPat _ _ pat   -> goL pat@@ -651,6 +768,8 @@       NPat {}       -> True       NPlusKPat {}  -> True       SplicePat {}  -> False+      EmbTyPat {}   -> True+      InvisPat {}   -> True       XPat ext ->         case ghcPass @p of          GhcRn -> case ext of@@ -659,6 +778,10 @@            CoPat _ pat _      -> go pat            ExpansionPat _ pat -> go pat +isPatSyn :: LPat GhcTc -> Bool+isPatSyn (L _ (ConPat {pat_con = L _ (PatSynCon{})})) = True+isPatSyn _ = False+ {- Note [Unboxed sum patterns aren't irrefutable] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Unlike unboxed tuples, unboxed sums are *not* irrefutable when used as@@ -747,10 +870,9 @@                          = conPatNeedsParens p ds     go (SigPat {})       = p >= sigPrec     go (ViewPat {})      = True+    go (EmbTyPat {})     = True+    go (InvisPat{})      = False     go (XPat ext)        = case ghcPass @q of-#if __GLASGOW_HASKELL__ < 901-      GhcPs -> dataConCantHappen ext-#endif       GhcRn -> case ext of         HsPatExpanded orig _ -> go orig       GhcTc -> case ext of@@ -786,8 +908,13 @@   -- | Parenthesize a pattern without token information-gParPat :: LPat (GhcPass pass) -> Pat (GhcPass pass)-gParPat p = ParPat noAnn noHsTok p noHsTok+gParPat :: forall p. IsPass p => LPat (GhcPass p) -> Pat (GhcPass p)+gParPat pat = ParPat x pat+  where+    x = case ghcPass @p of+      GhcPs -> noAnn+      GhcRn -> noExtField+      GhcTc -> noExtField  -- | @'parenthesizePat' p pat@ checks if @'patNeedsParens' p pat@ is true, and -- if so, surrounds @pat@ with a 'ParPat'. Otherwise, it simply returns @pat@.@@ -799,6 +926,7 @@   | patNeedsParens p pat = L loc (gParPat lpat)   | otherwise            = lpat + {- % Collect all EvVars from all constructor patterns -}@@ -814,8 +942,8 @@ collectEvVarsPat pat =   case pat of     LazyPat _ p      -> collectEvVarsLPat p-    AsPat _ _ _ p    -> collectEvVarsLPat p-    ParPat  _ _ p _  -> collectEvVarsLPat p+    AsPat _ _ p      -> collectEvVarsLPat p+    ParPat  _ p      -> collectEvVarsLPat p     BangPat _ p      -> collectEvVarsLPat p     ListPat _ ps     -> unionManyBags $ map collectEvVarsLPat ps     TuplePat _ ps _  -> unionManyBags $ map collectEvVarsLPat ps@@ -845,7 +973,7 @@ -}  type instance Anno (Pat (GhcPass p)) = SrcSpanAnnA-type instance Anno (HsOverLit (GhcPass p)) = SrcAnn NoEpAnns+type instance Anno (HsOverLit (GhcPass p)) = EpAnnCO type instance Anno ConLike = SrcSpanAnnN type instance Anno (HsFieldBind lhs rhs) = SrcSpanAnnA-type instance Anno RecFieldsDotDot = SrcSpan+type instance Anno RecFieldsDotDot = EpaLocation
compiler/GHC/Hs/Type.hs view
@@ -26,7 +26,7 @@         Mult, HsScaled(..),         hsMult, hsScaledThing,         HsArrow(..), arrowToHsType,-        HsLinearArrowTokens(..),+        EpLinearArrow(..),         hsLinear, hsUnrestricted, isUnrestricted,         pprHsArrow, @@ -37,6 +37,7 @@         HsOuterTyVarBndrs(..), HsOuterFamEqnTyVarBndrs, HsOuterSigTyVarBndrs,         HsWildCardBndrs(..),         HsPatSigType(..), HsPSRn(..),+        HsTyPat(..), HsTyPatRn(..),         HsSigType(..), LHsSigType, LHsSigWcType, LHsWcType,         HsTupleSort(..),         HsContext, LHsContext, fromMaybeContext,@@ -68,14 +69,15 @@         hsOuterTyVarNames, hsOuterExplicitBndrs, mapHsOuterImplicit,         mkHsOuterImplicit, mkHsOuterExplicit,         mkHsImplicitSigType, mkHsExplicitSigType,-        mkHsWildCardBndrs, mkHsPatSigType,+        mkHsWildCardBndrs, mkHsPatSigType, mkHsTyPat,         mkEmptyWildCardBndrs,         mkHsForAllVisTele, mkHsForAllInvisTele,         mkHsQTvs, hsQTvExplicit, emptyLHsQTvs,         isHsKindedTyVar, hsTvbAllKinded,         hsScopedTvs, hsScopedKvs, hsWcScopedTvs, dropWildCards,         hsTyVarName, hsAllLTyVarNames, hsLTyVarLocNames,-        hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsExplicitLTyVarNames,+        hsLTyVarName, hsLTyVarNames, hsForAllTelescopeNames,+        hsLTyVarLocName, hsExplicitLTyVarNames,         splitLHsInstDeclTy, getLHsInstDeclHead, getLHsInstDeclClass_maybe,         splitLHsPatSynTy,         splitLHsForAllTyInvis, splitLHsForAllTyInvis_KP, splitLHsQualTy,@@ -99,7 +101,6 @@  import {-# SOURCE #-} GHC.Hs.Expr ( pprUntypedSplice, HsUntypedSpliceResult(..) ) -import Language.Haskell.Syntax.Concrete import Language.Haskell.Syntax.Extension import GHC.Core.DataCon( SrcStrictness(..), SrcUnpackedness(..), HsImplBang(..) ) import GHC.Hs.Extension@@ -218,6 +219,10 @@ type instance XHsPS GhcRn = HsPSRn type instance XHsPS GhcTc = HsPSRn +type instance XHsTP GhcPs = NoExtField+type instance XHsTP GhcRn = HsTyPatRn+type instance XHsTP GhcTc = DataConCantHappen+ -- | The extension field for 'HsPatSigType', which is only used in the -- renamer onwards. See @Note [Pattern signature binders and scoping]@. data HsPSRn = HsPSRn@@ -226,7 +231,22 @@   }   deriving Data +-- HsTyPatRn is the extension field for `HsTyPat`, after renaming+-- E.g. pattern K @(Maybe (_x, a, b::Proxy k)+-- In the type pattern @(Maybe ...):+--    '_x' is a named wildcard+--    'a'  is explicitly bound+--    'k'  is implicitly bound+-- See Note [Implicit and explicit type variable binders] in GHC.Rename.Pat+data HsTyPatRn = HsTPRn+  { hstp_nwcs    :: [Name] -- ^ Wildcard names+  , hstp_imp_tvs :: [Name] -- ^ Implicitly bound variable names+  , hstp_exp_tvs :: [Name] -- ^ Explicitly bound variable names+  }+  deriving Data+ type instance XXHsPatSigType (GhcPass _) = DataConCantHappen+type instance XXHsTyPat      (GhcPass _) = DataConCantHappen  type instance XHsSig (GhcPass _) = NoExtField type instance XXHsSigType (GhcPass _) = DataConCantHappen@@ -275,14 +295,18 @@ mkHsPatSigType ann x = HsPS { hsps_ext  = ann                             , hsps_body = x } +mkHsTyPat :: LHsType GhcPs -> HsTyPat GhcPs+mkHsTyPat x = HsTP { hstp_ext  = noExtField+                   , hstp_body = x }+ mkEmptyWildCardBndrs :: thing -> HsWildCardBndrs GhcRn thing mkEmptyWildCardBndrs x = HsWC { hswc_body = x                               , hswc_ext  = [] }  -------------------------------------------------- -type instance XUserTyVar    (GhcPass _) = EpAnn [AddEpAnn]-type instance XKindedTyVar  (GhcPass _) = EpAnn [AddEpAnn]+type instance XUserTyVar    (GhcPass _) = [AddEpAnn]+type instance XKindedTyVar  (GhcPass _) = [AddEpAnn]  type instance XXTyVarBndr   (GhcPass _) = DataConCantHappen @@ -315,38 +339,48 @@   getName (UserTyVar _ _ v) = unLoc v   getName (KindedTyVar _ _ v _) = unLoc v +type instance XBndrRequired (GhcPass _) = NoExtField++type instance XBndrInvisible GhcPs = EpToken "@"+type instance XBndrInvisible GhcRn = NoExtField+type instance XBndrInvisible GhcTc = NoExtField++type instance XXBndrVis (GhcPass _) = DataConCantHappen+ type instance XForAllTy        (GhcPass _) = NoExtField type instance XQualTy          (GhcPass _) = NoExtField-type instance XTyVar           (GhcPass _) = EpAnn [AddEpAnn]+type instance XTyVar           (GhcPass _) = [AddEpAnn] type instance XAppTy           (GhcPass _) = NoExtField-type instance XFunTy           (GhcPass _) = EpAnnCO-type instance XListTy          (GhcPass _) = EpAnn AnnParen-type instance XTupleTy         (GhcPass _) = EpAnn AnnParen-type instance XSumTy           (GhcPass _) = EpAnn AnnParen-type instance XOpTy            (GhcPass _) = EpAnn [AddEpAnn]-type instance XParTy           (GhcPass _) = EpAnn AnnParen-type instance XIParamTy        (GhcPass _) = EpAnn [AddEpAnn]+type instance XFunTy           (GhcPass _) = NoExtField+type instance XListTy          (GhcPass _) = AnnParen+type instance XTupleTy         (GhcPass _) = AnnParen+type instance XSumTy           (GhcPass _) = AnnParen+type instance XOpTy            (GhcPass _) = [AddEpAnn]+type instance XParTy           (GhcPass _) = AnnParen+type instance XIParamTy        (GhcPass _) = [AddEpAnn] type instance XStarTy          (GhcPass _) = NoExtField-type instance XKindSig         (GhcPass _) = EpAnn [AddEpAnn]+type instance XKindSig         (GhcPass _) = [AddEpAnn] -type instance XAppKindTy       (GhcPass _) = NoExtField+type instance XAppKindTy       GhcPs = EpToken "@"+type instance XAppKindTy       GhcRn = NoExtField+type instance XAppKindTy       GhcTc = NoExtField  type instance XSpliceTy        GhcPs = NoExtField type instance XSpliceTy        GhcRn = HsUntypedSpliceResult (LHsType GhcRn) type instance XSpliceTy        GhcTc = Kind -type instance XDocTy           (GhcPass _) = EpAnn [AddEpAnn]-type instance XBangTy          (GhcPass _) = EpAnn [AddEpAnn]+type instance XDocTy           (GhcPass _) = [AddEpAnn]+type instance XBangTy          (GhcPass _) = [AddEpAnn] -type instance XRecTy           GhcPs = EpAnn AnnList+type instance XRecTy           GhcPs = AnnList type instance XRecTy           GhcRn = NoExtField type instance XRecTy           GhcTc = NoExtField -type instance XExplicitListTy  GhcPs = EpAnn [AddEpAnn]+type instance XExplicitListTy  GhcPs = [AddEpAnn] type instance XExplicitListTy  GhcRn = NoExtField type instance XExplicitListTy  GhcTc = Kind -type instance XExplicitTupleTy GhcPs = EpAnn [AddEpAnn]+type instance XExplicitTupleTy GhcPs = [AddEpAnn] type instance XExplicitTupleTy GhcRn = NoExtField type instance XExplicitTupleTy GhcTc = [Kind] @@ -369,18 +403,49 @@ type instance XCharTy        (GhcPass _) = SourceText type instance XXTyLit        (GhcPass _) = DataConCantHappen +data EpLinearArrow+  = EpPct1 !(EpToken "%1") !(EpUniToken "->" "→")+  | EpLolly !(EpToken "⊸")+  deriving Data +instance NoAnn EpLinearArrow where+  noAnn = EpPct1 noAnn noAnn++type instance XUnrestrictedArrow GhcPs = EpUniToken "->" "→"+type instance XUnrestrictedArrow GhcRn = NoExtField+type instance XUnrestrictedArrow GhcTc = NoExtField++type instance XLinearArrow       GhcPs = EpLinearArrow+type instance XLinearArrow       GhcRn = NoExtField+type instance XLinearArrow       GhcTc = NoExtField++type instance XExplicitMult      GhcPs = (EpToken "%", EpUniToken "->" "→")+type instance XExplicitMult      GhcRn = NoExtField+type instance XExplicitMult      GhcTc = NoExtField++type instance XXArrow            (GhcPass _) = DataConCantHappen+ oneDataConHsTy :: HsType GhcRn oneDataConHsTy = HsTyVar noAnn NotPromoted (noLocA oneDataConName)  manyDataConHsTy :: HsType GhcRn manyDataConHsTy = HsTyVar noAnn NotPromoted (noLocA manyDataConName) -hsLinear :: a -> HsScaled (GhcPass p) a-hsLinear = HsScaled (HsLinearArrow (HsPct1 noHsTok noHsUniTok))+hsLinear :: forall p a. IsPass p => a -> HsScaled (GhcPass p) a+hsLinear = HsScaled (HsLinearArrow x)+  where+    x = case ghcPass @p of+      GhcPs -> noAnn+      GhcRn -> noExtField+      GhcTc -> noExtField -hsUnrestricted :: a -> HsScaled (GhcPass p) a-hsUnrestricted = HsScaled (HsUnrestrictedArrow noHsUniTok)+hsUnrestricted :: forall p a. IsPass p => a -> HsScaled (GhcPass p) a+hsUnrestricted = HsScaled (HsUnrestrictedArrow x)+  where+    x = case ghcPass @p of+      GhcPs -> noAnn+      GhcRn -> noExtField+      GhcTc -> noExtField  isUnrestricted :: HsArrow GhcRn -> Bool isUnrestricted (arrowToHsType -> L _ (HsTyVar _ _ (L _ n))) = n == manyDataConName@@ -392,7 +457,7 @@ arrowToHsType :: HsArrow GhcRn -> LHsType GhcRn arrowToHsType (HsUnrestrictedArrow _) = noLocA manyDataConHsTy arrowToHsType (HsLinearArrow _) = noLocA oneDataConHsTy-arrowToHsType (HsExplicitMult _ p _) = p+arrowToHsType (HsExplicitMult _ p) = p  instance       (OutputableBndrId pass) =>@@ -403,9 +468,9 @@ pprHsArrow :: (OutputableBndrId pass) => HsArrow (GhcPass pass) -> SDoc pprHsArrow (HsUnrestrictedArrow _) = pprArrowWithMultiplicity visArgTypeLike (Left False) pprHsArrow (HsLinearArrow _)       = pprArrowWithMultiplicity visArgTypeLike (Left True)-pprHsArrow (HsExplicitMult _ p _)  = pprArrowWithMultiplicity visArgTypeLike (Right (ppr p))+pprHsArrow (HsExplicitMult _ p)    = pprArrowWithMultiplicity visArgTypeLike (Right (ppr p)) -type instance XConDeclField  (GhcPass _) = EpAnn [AddEpAnn]+type instance XConDeclField  (GhcPass _) = [AddEpAnn] type instance XXConDeclField (GhcPass _) = DataConCantHappen  instance OutputableBndrId p@@ -452,6 +517,10 @@ hsLTyVarNames :: [LHsTyVarBndr flag (GhcPass p)] -> [IdP (GhcPass p)] hsLTyVarNames = map hsLTyVarName +hsForAllTelescopeNames :: HsForAllTelescope (GhcPass p) -> [IdP (GhcPass p)]+hsForAllTelescopeNames (HsForAllVis _ bndrs) = hsLTyVarNames bndrs+hsForAllTelescopeNames (HsForAllInvis _ bndrs) = hsLTyVarNames bndrs+ hsExplicitLTyVarNames :: LHsQTyVars (GhcPass p) -> [IdP (GhcPass p)] -- Explicit variables only hsExplicitLTyVarNames qtvs = map hsLTyVarName (hsQTvExplicit qtvs)@@ -511,17 +580,16 @@ mkHsOpTy prom ty1 op ty2 = HsOpTy noAnn prom ty1 op ty2  mkHsAppTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)-mkHsAppTy t1 t2-  = addCLocAA t1 t2 (HsAppTy noExtField t1 (parenthesizeHsType appPrec t2))+mkHsAppTy t1 t2 = addCLocA t1 t2 (HsAppTy noExtField t1 t2)  mkHsAppTys :: LHsType (GhcPass p) -> [LHsType (GhcPass p)]            -> LHsType (GhcPass p) mkHsAppTys = foldl' mkHsAppTy -mkHsAppKindTy :: LHsType (GhcPass p) -> LHsToken "@" (GhcPass p) -> LHsType (GhcPass p)+mkHsAppKindTy :: XAppKindTy (GhcPass p)+              -> LHsType (GhcPass p) -> LHsType (GhcPass p)               -> LHsType (GhcPass p)-mkHsAppKindTy ty at k-  = addCLocAA ty k (HsAppKindTy noExtField ty at k)+mkHsAppKindTy at ty k = addCLocA ty k (HsAppKindTy at ty k)  {- ************************************************************************@@ -547,15 +615,12 @@       = let           (anns, cs, args, res) = splitHsFunType ty           anns' = anns ++ annParen2AddEpAnn an-          cs' = cs S.<> epAnnComments (ann l) S.<> epAnnComments an+          cs' = cs S.<> epAnnComments l         in (anns', cs', args, res) -    go (L ll (HsFunTy (EpAnn _ _ cs) mult x y))+    go (L ll (HsFunTy _ mult x y))       | (anns, csy, args, res) <- splitHsFunType y-      = (anns, csy S.<> epAnnComments (ann ll), HsScaled mult x':args, res)-      where-        L l t = x-        x' = L (addCommentsToSrcAnn l cs) t+      = (anns, csy S.<> epAnnComments ll, HsScaled mult x:args, res)      go other = ([], emptyComments, [], other) @@ -570,7 +635,7 @@   where     go (L _ (HsTyVar _ _ ln))          = Just ln     go (L _ (HsAppTy _ l _))           = go l-    go (L _ (HsAppKindTy _ t _ _))     = go t+    go (L _ (HsAppKindTy _ t _))       = go t     go (L _ (HsOpTy _ _ _ ln _))       = Just ln     go (L _ (HsParTy _ t))             = go t     go (L _ (HsKindSig _ t _))         = go t@@ -578,19 +643,29 @@  ------------------------------------------------------------ +type instance XValArg (GhcPass _) = NoExtField++type instance XTypeArg GhcPs = EpToken "@"+type instance XTypeArg GhcRn = NoExtField+type instance XTypeArg GhcTc = NoExtField++type instance XArgPar (GhcPass _) = SrcSpan++type instance XXArg (GhcPass _) = DataConCantHappen+ -- | Compute the 'SrcSpan' associated with an 'LHsTypeArg'.-lhsTypeArgSrcSpan :: LHsTypeArg (GhcPass pass) -> SrcSpan+lhsTypeArgSrcSpan :: LHsTypeArg GhcPs -> SrcSpan lhsTypeArgSrcSpan arg = case arg of-  HsValArg  tm    -> getLocA tm-  HsTypeArg at ty -> getTokenSrcSpan (getLoc at) `combineSrcSpans` getLocA ty+  HsValArg  _  tm -> getLocA tm+  HsTypeArg at ty -> getEpTokenSrcSpan at `combineSrcSpans` getLocA ty   HsArgPar  sp    -> sp  --------------------------------  numVisibleArgs :: [HsArg p tm ty] -> Arity numVisibleArgs = count is_vis-  where is_vis (HsValArg _) = True-        is_vis _            = False+  where is_vis (HsValArg _ _) = True+        is_vis _              = False  -------------------------------- @@ -605,7 +680,7 @@ -- pprHsArgsApp (++) Infix [HsValArg Char, HsValArg Double, HsVarArg Ordering] = (Char ++ Double) Ordering -- @ pprHsArgsApp :: (OutputableBndr id, Outputable tm, Outputable ty)-             => id -> LexicalFixity -> [HsArg p tm ty] -> SDoc+             => id -> LexicalFixity -> [HsArg (GhcPass p) tm ty] -> SDoc pprHsArgsApp thing fixity (argl:argr:args)   | Infix <- fixity   = let pp_op_app = hsep [ ppr_single_hs_arg argl@@ -620,7 +695,7 @@  -- | Pretty-print a prefix identifier to a list of 'HsArg's. ppr_hs_args_prefix_app :: (Outputable tm, Outputable ty)-                        => SDoc -> [HsArg p tm ty] -> SDoc+                        => SDoc -> [HsArg (GhcPass p) tm ty] -> SDoc ppr_hs_args_prefix_app acc []         = acc ppr_hs_args_prefix_app acc (arg:args) =   case arg of@@ -630,8 +705,8 @@  -- | Pretty-print an 'HsArg' in isolation. ppr_single_hs_arg :: (Outputable tm, Outputable ty)-                  => HsArg p tm ty -> SDoc-ppr_single_hs_arg (HsValArg tm)    = ppr tm+                  => HsArg (GhcPass p) tm ty -> SDoc+ppr_single_hs_arg (HsValArg _ tm)  = ppr tm ppr_single_hs_arg (HsTypeArg _ ty) = char '@' <> ppr ty -- GHC shouldn't be constructing ASTs such that this case is ever reached. -- Still, it's possible some wily user might construct their own AST that@@ -641,8 +716,8 @@ -- | This instance is meant for debug-printing purposes. If you wish to -- pretty-print an application of 'HsArg's, use 'pprHsArgsApp' instead. instance (Outputable tm, Outputable ty) => Outputable (HsArg (GhcPass p) tm ty) where-  ppr (HsValArg tm)     = text "HsValArg"  <+> ppr tm-  ppr (HsTypeArg at ty) = text "HsTypeArg" <+> ppr at <+> ppr ty+  ppr (HsValArg _ tm)   = text "HsValArg"  <+> ppr tm+  ppr (HsTypeArg _ ty)  = text "HsTypeArg" <+> ppr ty   ppr (HsArgPar sp)     = text "HsArgPar"  <+> ppr sp  --------------------------------@@ -672,10 +747,10 @@         HsOuterImplicit{}                      -> ([], ignoreParens body)         HsOuterExplicit{hso_bndrs = exp_bndrs} -> (exp_bndrs, body) -    (univs,       ty1) = split_sig_ty ty-    (reqs,        ty2) = splitLHsQualTy ty1-    ((_an, exis), ty3) = splitLHsForAllTyInvis ty2-    (provs,       ty4) = splitLHsQualTy ty3+    (univs, ty1) = split_sig_ty ty+    (reqs,  ty2) = splitLHsQualTy ty1+    (exis,  ty3) = splitLHsForAllTyInvis ty2+    (provs, ty4) = splitLHsQualTy ty3  -- | Decompose a sigma type (of the form @forall <tvs>. context => body@) -- into its constituent parts.@@ -695,8 +770,8 @@                      -> ([LHsTyVarBndr Specificity (GhcPass p)]                         , Maybe (LHsContext (GhcPass p)), LHsType (GhcPass p)) splitLHsSigmaTyInvis ty-  | ((_an,tvs), ty1) <- splitLHsForAllTyInvis ty-  , (ctxt,      ty2) <- splitLHsQualTy ty1+  | (tvs,  ty1) <- splitLHsForAllTyInvis ty+  , (ctxt, ty2) <- splitLHsQualTy ty1   = (tvs, ctxt, ty2)  -- | Decompose a GADT type into its constituent parts.@@ -741,11 +816,11 @@ -- Unlike 'splitLHsSigmaTyInvis', this function does not look through -- parentheses, hence the suffix @_KP@ (short for \"Keep Parentheses\"). splitLHsForAllTyInvis ::-  LHsType (GhcPass pass) -> ( (EpAnnForallTy, [LHsTyVarBndr Specificity (GhcPass pass)])+  LHsType (GhcPass pass) -> ( [LHsTyVarBndr Specificity (GhcPass pass)]                             , LHsType (GhcPass pass)) splitLHsForAllTyInvis ty   | ((mb_tvbs), body) <- splitLHsForAllTyInvis_KP (ignoreParens ty)-  = (fromMaybe (EpAnnNotUsed,[]) mb_tvbs, body)+  = (fromMaybe [] mb_tvbs, body)  -- | Decompose a type of the form @forall <tvs>. body@ into its constituent -- parts. Only splits type variable binders that@@ -759,14 +834,13 @@ -- Unlike 'splitLHsForAllTyInvis', this function does not look through -- parentheses, hence the suffix @_KP@ (short for \"Keep Parentheses\"). splitLHsForAllTyInvis_KP ::-  LHsType (GhcPass pass) -> (Maybe (EpAnnForallTy, [LHsTyVarBndr Specificity (GhcPass pass)])+  LHsType (GhcPass pass) -> (Maybe ([LHsTyVarBndr Specificity (GhcPass pass)])                             , LHsType (GhcPass pass)) splitLHsForAllTyInvis_KP lty@(L _ ty) =   case ty of-    HsForAllTy { hst_tele = HsForAllInvis { hsf_xinvis = an-                                          , hsf_invis_bndrs = tvs }+    HsForAllTy { hst_tele = HsForAllInvis {hsf_invis_bndrs = tvs }                , hst_body = body }-      -> (Just (an, tvs), body)+      -> (Just tvs, body)     _ -> (Nothing, lty)  -- | Decompose a type of the form @context => body@ into its constituent parts.@@ -1014,13 +1088,13 @@     pprTyVarBndr (KindedTyVar _ SpecifiedSpec n k) = parens $ hsep [ppr n, dcolon, ppr k]     pprTyVarBndr (KindedTyVar _ InferredSpec n k)  = braces $ hsep [ppr n, dcolon, ppr k] -instance OutputableBndrFlag (HsBndrVis p') p where+instance OutputableBndrFlag (HsBndrVis (GhcPass p')) p where     pprTyVarBndr (UserTyVar _ vis n) = pprHsBndrVis vis $ ppr n     pprTyVarBndr (KindedTyVar _ vis n k) =       pprHsBndrVis vis $ parens $ hsep [ppr n, dcolon, ppr k] -pprHsBndrVis :: HsBndrVis pass -> SDoc -> SDoc-pprHsBndrVis HsBndrRequired d = d+pprHsBndrVis :: HsBndrVis (GhcPass p) -> SDoc -> SDoc+pprHsBndrVis (HsBndrRequired _) d = d pprHsBndrVis (HsBndrInvisible _) d = char '@' <> d  instance OutputableBndrId p => Outputable (HsSigType (GhcPass p)) where@@ -1067,6 +1141,11 @@   instance (OutputableBndrId p)+       => Outputable (HsTyPat (GhcPass p)) where+    ppr (HsTP { hstp_body = ty }) = ppr ty+++instance (OutputableBndrId p)        => Outputable (HsTyLit (GhcPass p)) where     ppr = ppr_tylit @@ -1231,9 +1310,9 @@     -- Special-case unary boxed tuples so that they are pretty-printed as     -- `'MkSolo x`, not `'(x)`   | [ty] <- tys-  = quote $ sep [text (mkTupleStr Boxed dataName 1), ppr_mono_lty ty]+  = quoteIfPunsEnabled $ sep [text (mkTupleStr Boxed dataName 1), ppr_mono_lty ty]   | otherwise-  = quote $ parens (maybeAddSpace tys $ interpp'SP tys)+  = quoteIfPunsEnabled $ parens (maybeAddSpace tys $ interpp'SP tys) ppr_mono_ty (HsTyLit _ t)       = ppr t ppr_mono_ty (HsWildCardTy {})   = char '_' @@ -1241,7 +1320,7 @@  ppr_mono_ty (HsAppTy _ fun_ty arg_ty)   = hsep [ppr_mono_lty fun_ty, ppr_mono_lty arg_ty]-ppr_mono_ty (HsAppKindTy _ ty _ k)+ppr_mono_ty (HsAppKindTy _ ty k)   = ppr_mono_lty ty <+> char '@' <> ppr_mono_lty k ppr_mono_ty (HsOpTy _ prom ty1 (L _ op) ty2)   = sep [ ppr_mono_lty ty1@@ -1356,7 +1435,7 @@     go (HsWildCardTy{})      = False     go (HsStarTy{})          = False     go (HsAppTy _ t _)       = goL t-    go (HsAppKindTy _ t _ _) = goL t+    go (HsAppKindTy _ t _)   = goL t     go (HsParTy{})           = False     go (HsDocTy _ t _)       = goL t     go (XHsType{})           = False@@ -1401,8 +1480,8 @@ type instance Anno (HsTyVarBndr _flag GhcTc) = SrcSpanAnnA  type instance Anno (HsOuterTyVarBndrs _ (GhcPass _)) = SrcSpanAnnA-type instance Anno HsIPName = SrcAnn NoEpAnns+type instance Anno HsIPName = EpAnnCO type instance Anno (ConDeclField (GhcPass p)) = SrcSpanAnnA -type instance Anno (FieldOcc (GhcPass p)) = SrcAnn NoEpAnns-type instance Anno (AmbiguousFieldOcc (GhcPass p)) = SrcAnn NoEpAnns+type instance Anno (FieldOcc (GhcPass p)) = SrcSpanAnnA+type instance Anno (AmbiguousFieldOcc (GhcPass p)) = SrcSpanAnnA
compiler/GHC/Hs/Utils.hs view
@@ -4,7 +4,7 @@ {-| Module      : GHC.Hs.Utils Description : Generic helpers for the HsSyn type.-Copyright   : (c) The University of Glasgow, 1992-2006+Copyright   : (c) The University of Glasgow, 1992-2023  Here we collect a variety of helper functions that construct or analyse HsSyn.  All these functions deal with generic HsSyn; functions@@ -35,18 +35,21 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE NamedFieldPuns #-}  {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}+{-# LANGUAGE RecordWildCards #-}  module GHC.Hs.Utils(   -- * Terms-  mkHsPar, mkHsApp, mkHsAppWith, mkHsApps, mkHsAppsWith,+  mkHsPar, mkHsApp, mkHsAppWith, mkHsApps, mkHsAppsWith, mkHsSyntaxApps,   mkHsAppType, mkHsAppTypes, mkHsCaseAlt,   mkSimpleMatch, unguardedGRHSs, unguardedRHS,   mkMatchGroup, mkLamCaseMatchGroup, mkMatch, mkPrefixFunRhs, mkHsLam, mkHsIf,   mkHsWrap, mkLHsWrap, mkHsWrapCo, mkHsWrapCoR, mkLHsWrapCo,   mkHsDictLet, mkHsLams,-  mkHsOpApp, mkHsDo, mkHsDoAnns, mkHsComp, mkHsCompAnns, mkHsWrapPat, mkHsWrapPatCo,+  mkHsOpApp, mkHsDo, mkHsDoAnns, mkHsComp, mkHsCompAnns,+  mkHsWrapPat, mkLHsWrapPat, mkHsWrapPatCo,   mkLHsPar, mkHsCmdWrap, mkLHsCmdWrap,   mkHsCmdIf, mkConLikeTc, @@ -105,7 +108,9 @@   hsForeignDeclsBinders, hsGroupBinders, hsDataFamInstBinders,    -- * Collecting implicit binders-  lStmtsImplicits, hsValBindsImplicits, lPatImplicits+  ImplicitFieldBinders(..),+  lStmtsImplicits, hsValBindsImplicits, lPatImplicits,+  lHsRecFieldsImplicits   ) where  import GHC.Prelude hiding (head, init, last, tail)@@ -151,7 +156,6 @@ import GHC.Utils.Panic  import Control.Arrow ( first )-import Data.Either ( partitionEithers ) import Data.Foldable ( toList ) import Data.List ( partition ) import Data.List.NonEmpty ( nonEmpty )@@ -175,14 +179,14 @@ -}  -- | @e => (e)@-mkHsPar :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)+mkHsPar :: IsPass p => LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) mkHsPar e = L (getLoc e) (gHsPar e)  mkSimpleMatch :: (Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))                         ~ SrcSpanAnnA,                   Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))-                        ~ SrcAnn NoEpAnns)-              => HsMatchContext (GhcPass p)+                        ~ EpAnn NoEpAnns)+              => HsMatchContext (LIdP (NoGhcTc (GhcPass p)))               -> [LPat (GhcPass p)] -> LocatedA (body (GhcPass p))               -> LMatch (GhcPass p) (LocatedA (body (GhcPass p))) mkSimpleMatch ctxt pats rhs@@ -195,14 +199,14 @@                 (pat:_) -> combineSrcSpansA (getLoc pat) (getLoc rhs)  unguardedGRHSs :: Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))-                     ~ SrcAnn NoEpAnns+                     ~ EpAnn NoEpAnns                => SrcSpan -> LocatedA (body (GhcPass p)) -> EpAnn GrhsAnn                -> GRHSs (GhcPass p) (LocatedA (body (GhcPass p))) unguardedGRHSs loc rhs an   = GRHSs emptyComments (unguardedRHS an loc rhs) emptyLocalBinds  unguardedRHS :: Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))-                     ~ SrcAnn NoEpAnns+                     ~ EpAnn NoEpAnns              => EpAnn GrhsAnn -> SrcSpan -> LocatedA (body (GhcPass p))              -> [LGRHS (GhcPass p) (LocatedA (body (GhcPass p)))] unguardedRHS an loc rhs = [L (noAnnSrcSpan loc) (GRHS an [] rhs)]@@ -222,32 +226,32 @@  mkLamCaseMatchGroup :: AnnoBody p body                     => Origin-                    -> LamCaseVariant+                    -> HsLamVariant                     -> LocatedL [LocatedA (Match (GhcPass p) (LocatedA (body (GhcPass p))))]                     -> MatchGroup (GhcPass p) (LocatedA (body (GhcPass p)))-mkLamCaseMatchGroup origin lc_variant (L l matches)+mkLamCaseMatchGroup origin lam_variant (L l matches)   = mkMatchGroup origin (L l $ map fixCtxt matches)-  where fixCtxt (L a match) = L a match{m_ctxt = LamCaseAlt lc_variant}+  where fixCtxt (L a match) = L a match{m_ctxt = LamAlt lam_variant} -mkLocatedList :: Semigroup a-  => [GenLocated (SrcAnn a) e2] -> LocatedAn an [GenLocated (SrcAnn a) e2]+mkLocatedList :: (Semigroup a, NoAnn an)+  => [GenLocated (EpAnn a) e2] -> LocatedAn an [GenLocated (EpAnn a) e2] mkLocatedList ms = case nonEmpty ms of     Nothing -> noLocA []     Just ms1 -> L (noAnnSrcSpan $ locA $ combineLocsA (NE.head ms1) (NE.last ms1)) ms  mkHsApp :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)-mkHsApp e1 e2 = addCLocAA e1 e2 (HsApp noComments e1 e2)+mkHsApp e1 e2 = addCLocA e1 e2 (HsApp noExtField e1 e2)  mkHsAppWith   :: (LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> HsExpr (GhcPass id) -> LHsExpr (GhcPass id))   -> LHsExpr (GhcPass id)   -> LHsExpr (GhcPass id)   -> LHsExpr (GhcPass id)-mkHsAppWith mkLocated e1 e2 = mkLocated e1 e2 (HsApp noAnn e1 e2)+mkHsAppWith mkLocated e1 e2 = mkLocated e1 e2 (HsApp noExtField e1 e2)  mkHsApps   :: LHsExpr (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)-mkHsApps = mkHsAppsWith addCLocAA+mkHsApps = mkHsAppsWith addCLocA  mkHsAppsWith  :: (LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> HsExpr (GhcPass id) -> LHsExpr (GhcPass id))@@ -257,10 +261,10 @@ mkHsAppsWith mkLocated = foldl' (mkHsAppWith mkLocated)  mkHsAppType :: LHsExpr GhcRn -> LHsWcType GhcRn -> LHsExpr GhcRn-mkHsAppType e t = addCLocAA t_body e (HsAppType noExtField e noHsTok paren_wct)+mkHsAppType e t = addCLocA t_body e (HsAppType noExtField e paren_wct)   where     t_body    = hswc_body t-    paren_wct = t { hswc_body = parenthesizeHsType appPrec t_body }+    paren_wct = t { hswc_body = t_body }  mkHsAppTypes :: LHsExpr GhcRn -> [LHsWcType GhcRn] -> LHsExpr GhcRn mkHsAppTypes = foldl' mkHsAppType@@ -269,20 +273,31 @@         => [LPat (GhcPass p)]         -> LHsExpr (GhcPass p)         -> LHsExpr (GhcPass p)-mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam noExtField matches))+mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam noAnn LamSingle matches))   where-    matches = mkMatchGroup (Generated SkipPmc)-                           (noLocA [mkSimpleMatch LambdaExpr pats' body])+    matches = mkMatchGroup (Generated OtherExpansion SkipPmc)+                           (noLocA [mkSimpleMatch (LamAlt LamSingle) pats' body])     pats' = map (parenthesizePat appPrec) pats  mkHsLams :: [TyVar] -> [EvVar] -> LHsExpr GhcTc -> LHsExpr GhcTc mkHsLams tyvars dicts expr = mkLHsWrap (mkWpTyLams tyvars                                        <.> mkWpEvLams dicts) expr +mkHsSyntaxApps :: SrcSpanAnnA -> SyntaxExprTc -> [LHsExpr GhcTc]+               -> LHsExpr GhcTc+mkHsSyntaxApps ann (SyntaxExprTc { syn_expr      = fun+                                 , syn_arg_wraps = arg_wraps+                                 , syn_res_wrap  = res_wrap }) args+  = mkLHsWrap res_wrap (foldl' mkHsApp (L ann fun) (zipWithEqual "mkHsSyntaxApps"+                                                     mkLHsWrap arg_wraps args))+mkHsSyntaxApps _ NoSyntaxExprTc args = pprPanic "mkHsSyntaxApps" (ppr args)+  -- this function should never be called in scenarios where there is no+  -- syntax expr+ -- |A simple case alternative with a single pattern, no binds, no guards; -- pre-typechecking mkHsCaseAlt :: (Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))-                     ~ SrcAnn NoEpAnns,+                     ~ EpAnn NoEpAnns,                  Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))                         ~ SrcSpanAnnA)             => LPat (GhcPass p) -> (LocatedA (body (GhcPass p)))@@ -306,7 +321,7 @@ mkParPat :: IsPass p => LPat (GhcPass p) -> LPat (GhcPass p) mkParPat = parenthesizePat appPrec -nlParPat :: LPat (GhcPass name) -> LPat (GhcPass name)+nlParPat :: IsPass p => LPat (GhcPass p) -> LPat (GhcPass p) nlParPat p = noLocA (gParPat p)  -------------------------------@@ -317,16 +332,16 @@ mkHsFractional :: FractionalLit -> HsOverLit GhcPs mkHsIsString   :: SourceText -> FastString -> HsOverLit GhcPs mkHsDo         :: HsDoFlavour -> LocatedL [ExprLStmt GhcPs] -> HsExpr GhcPs-mkHsDoAnns     :: HsDoFlavour -> LocatedL [ExprLStmt GhcPs] -> EpAnn AnnList -> HsExpr GhcPs+mkHsDoAnns     :: HsDoFlavour -> LocatedL [ExprLStmt GhcPs] -> AnnList -> HsExpr GhcPs mkHsComp       :: HsDoFlavour -> [ExprLStmt GhcPs] -> LHsExpr GhcPs                -> HsExpr GhcPs mkHsCompAnns   :: HsDoFlavour -> [ExprLStmt GhcPs] -> LHsExpr GhcPs-               -> EpAnn AnnList+               -> AnnList                -> HsExpr GhcPs -mkNPat      :: LocatedAn NoEpAnns (HsOverLit GhcPs) -> Maybe (SyntaxExpr GhcPs) -> EpAnn [AddEpAnn]+mkNPat      :: LocatedAn NoEpAnns (HsOverLit GhcPs) -> Maybe (SyntaxExpr GhcPs) -> [AddEpAnn]             -> Pat GhcPs-mkNPlusKPat :: LocatedN RdrName -> LocatedAn NoEpAnns (HsOverLit GhcPs) -> EpAnn EpaLocation+mkNPlusKPat :: LocatedN RdrName -> LocatedAn NoEpAnns (HsOverLit GhcPs) -> EpaLocation             -> Pat GhcPs  -- NB: The following functions all use noSyntaxExpr: the generated expressions@@ -335,7 +350,7 @@            -> StmtLR (GhcPass idL) (GhcPass idR) (LocatedA (bodyR (GhcPass idR))) mkBodyStmt :: LocatedA (bodyR GhcPs)            -> StmtLR (GhcPass idL) GhcPs (LocatedA (bodyR GhcPs))-mkPsBindStmt :: EpAnn [AddEpAnn] -> LPat GhcPs -> LocatedA (bodyR GhcPs)+mkPsBindStmt :: [AddEpAnn] -> LPat GhcPs -> LocatedA (bodyR GhcPs)              -> StmtLR GhcPs GhcPs (LocatedA (bodyR GhcPs)) mkRnBindStmt :: LPat GhcRn -> LocatedA (bodyR GhcRn)              -> StmtLR GhcRn GhcRn (LocatedA (bodyR GhcRn))@@ -359,7 +374,7 @@                              (Anno (StmtLR (GhcPass idL) GhcPs bodyR))                              (StmtLR (GhcPass idL) GhcPs bodyR)]                         ~ SrcSpanAnnL)-                 => EpAnn AnnList+                 => AnnList                  -> LocatedL [LStmtLR (GhcPass idL) GhcPs bodyR]                  -> StmtLR (GhcPass idL) GhcPs bodyR mkRecStmt anns stmts  = (emptyRecStmt' anns :: StmtLR (GhcPass idL) GhcPs bodyR)@@ -373,18 +388,21 @@ mkHsDo     ctxt stmts      = HsDo noAnn ctxt stmts mkHsDoAnns ctxt stmts anns = HsDo anns  ctxt stmts mkHsComp ctxt stmts expr = mkHsCompAnns ctxt stmts expr noAnn-mkHsCompAnns ctxt stmts expr anns = mkHsDoAnns ctxt (mkLocatedList (stmts ++ [last_stmt])) anns+mkHsCompAnns ctxt stmts expr@(L l e) anns = mkHsDoAnns ctxt (L loc (stmts ++ [last_stmt])) anns   where-    -- Strip the annotations from the location, they are in the embedded expr-    last_stmt = L (noAnnSrcSpan $ getLocA expr) $ mkLastStmt expr+    -- Move the annotations to the top of the last_stmt+    last = mkLastStmt (L (noAnnSrcSpan $ getLocA expr) e)+    last_stmt = L l last+    -- last_stmt actually comes first in a list comprehension, consider all spans+    loc  = noAnnSrcSpan $ getHasLocList (last_stmt:stmts)  -- restricted to GhcPs because other phases might need a SyntaxExpr-mkHsIf :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> EpAnn AnnsIf+mkHsIf :: LHsExpr GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs -> AnnsIf        -> HsExpr GhcPs mkHsIf c a b anns = HsIf anns c a b  -- restricted to GhcPs because other phases might need a SyntaxExpr-mkHsCmdIf :: LHsExpr GhcPs -> LHsCmd GhcPs -> LHsCmd GhcPs -> EpAnn AnnsIf+mkHsCmdIf :: LHsExpr GhcPs -> LHsCmd GhcPs -> LHsCmd GhcPs -> AnnsIf        -> HsCmd GhcPs mkHsCmdIf c a b anns = HsCmdIf anns noSyntaxExpr c a b @@ -392,17 +410,17 @@ mkNPlusKPat id lit anns   = NPlusKPat anns id lit (unLoc lit) noSyntaxExpr noSyntaxExpr -mkTransformStmt    :: EpAnn [AddEpAnn] -> [ExprLStmt GhcPs] -> LHsExpr GhcPs+mkTransformStmt    :: [AddEpAnn] -> [ExprLStmt GhcPs] -> LHsExpr GhcPs                    -> StmtLR GhcPs GhcPs (LHsExpr GhcPs)-mkTransformByStmt  :: EpAnn [AddEpAnn] -> [ExprLStmt GhcPs] -> LHsExpr GhcPs+mkTransformByStmt  :: [AddEpAnn] -> [ExprLStmt GhcPs] -> LHsExpr GhcPs                    -> LHsExpr GhcPs -> StmtLR GhcPs GhcPs (LHsExpr GhcPs)-mkGroupUsingStmt   :: EpAnn [AddEpAnn] -> [ExprLStmt GhcPs] -> LHsExpr GhcPs+mkGroupUsingStmt   :: [AddEpAnn] -> [ExprLStmt GhcPs] -> LHsExpr GhcPs                    -> StmtLR GhcPs GhcPs (LHsExpr GhcPs)-mkGroupByUsingStmt :: EpAnn [AddEpAnn] -> [ExprLStmt GhcPs] -> LHsExpr GhcPs+mkGroupByUsingStmt :: [AddEpAnn] -> [ExprLStmt GhcPs] -> LHsExpr GhcPs                    -> LHsExpr GhcPs                    -> StmtLR GhcPs GhcPs (LHsExpr GhcPs) -emptyTransStmt :: EpAnn [AddEpAnn] -> StmtLR GhcPs GhcPs (LHsExpr GhcPs)+emptyTransStmt :: [AddEpAnn] -> StmtLR GhcPs GhcPs (LHsExpr GhcPs) emptyTransStmt anns = TransStmt { trS_ext = anns                                 , trS_form = panic "emptyTransStmt: form"                                 , trS_stmts = [], trS_bndrs = []@@ -451,7 +469,7 @@ emptyRecStmtId   = emptyRecStmt' unitRecStmtTc                                         -- a panic might trigger during zonking -mkLetStmt :: EpAnn [AddEpAnn] -> HsLocalBinds GhcPs -> StmtLR GhcPs GhcPs (LocatedA b)+mkLetStmt :: [AddEpAnn] -> HsLocalBinds GhcPs -> StmtLR GhcPs GhcPs (LocatedA b) mkLetStmt anns binds = LetStmt anns binds  -------------------------------@@ -496,10 +514,10 @@ nlHsDataCon con = noLocA (mkConLikeTc (RealDataCon con))  nlHsLit :: HsLit (GhcPass p) -> LHsExpr (GhcPass p)-nlHsLit n = noLocA (HsLit noComments n)+nlHsLit n = noLocA (HsLit noExtField n)  nlHsIntLit :: Integer -> LHsExpr (GhcPass p)-nlHsIntLit n = noLocA (HsLit noComments (HsInt noExtField (mkIntegralLit n)))+nlHsIntLit n = noLocA (HsLit noExtField (HsInt noExtField (mkIntegralLit n)))  nlVarPat :: IsSrcSpanAnn p a         => IdP (GhcPass p) -> LPat (GhcPass p)@@ -509,18 +527,11 @@ nlLitPat l = noLocA (LitPat noExtField l)  nlHsApp :: IsPass id => LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)-nlHsApp f x = noLocA (HsApp noComments f (mkLHsPar x))+nlHsApp f x = noLocA (HsApp noExtField f (mkLHsPar x))  nlHsSyntaxApps :: SyntaxExprTc -> [LHsExpr GhcTc]                -> LHsExpr GhcTc-nlHsSyntaxApps (SyntaxExprTc { syn_expr      = fun-                             , syn_arg_wraps = arg_wraps-                             , syn_res_wrap  = res_wrap }) args-  = mkLHsWrap res_wrap (foldl' nlHsApp (noLocA fun) (zipWithEqual "nlHsSyntaxApps"-                                                     mkLHsWrap arg_wraps args))-nlHsSyntaxApps NoSyntaxExprTc args = pprPanic "nlHsSyntaxApps" (ppr args)-  -- this function should never be called in scenarios where there is no-  -- syntax expr+nlHsSyntaxApps = mkHsSyntaxApps noSrcSpanA  nlHsApps :: IsSrcSpanAnn p a          => IdP (GhcPass p) -> [LHsExpr (GhcPass p)] -> LHsExpr (GhcPass p)@@ -531,7 +542,7 @@ nlHsVarApps f xs = noLocA (foldl' mk (HsVar noExtField (noLocA f))                                          (map ((HsVar noExtField) . noLocA) xs))                  where-                   mk f a = HsApp noComments (noLocA f) (noLocA a)+                   mk f a = HsApp noExtField (noLocA f) (noLocA a)  nlConVarPat :: RdrName -> [RdrName] -> LPat GhcPs nlConVarPat con vars = nlConPat con (map nlVarPat vars)@@ -593,14 +604,15 @@ nlHsOpApp e1 op e2 = noLocA (mkHsOpApp e1 op e2)  nlHsLam  :: LMatch GhcPs (LHsExpr GhcPs) -> LHsExpr GhcPs-nlHsPar  :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)+nlHsPar  :: IsPass p => LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) nlHsCase :: LHsExpr GhcPs -> [LMatch GhcPs (LHsExpr GhcPs)]          -> LHsExpr GhcPs nlList   :: [LHsExpr GhcPs] -> LHsExpr GhcPs  -- AZ:Is this used?-nlHsLam match = noLocA $ HsLam noExtField-              $ mkMatchGroup (Generated SkipPmc) (noLocA [match])+nlHsLam match = noLocA $ HsLam noAnn LamSingle+                  $ mkMatchGroup (Generated OtherExpansion SkipPmc) (noLocA [match])+ nlHsPar e     = noLocA (gHsPar e)  -- nlHsIf should generate if-expressions which are NOT subject to@@ -609,42 +621,52 @@ nlHsIf cond true false = noLocA (HsIf noAnn cond true false)  nlHsCase expr matches-  = noLocA (HsCase noAnn expr (mkMatchGroup (Generated SkipPmc) (noLocA matches)))+  = noLocA (HsCase noAnn expr (mkMatchGroup (Generated OtherExpansion SkipPmc) (noLocA matches))) nlList exprs          = noLocA (ExplicitList noAnn exprs)  nlHsAppTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) nlHsTyVar :: IsSrcSpanAnn p a           => PromotionFlag -> IdP (GhcPass p)           -> LHsType (GhcPass p)-nlHsFunTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)+nlHsFunTy :: forall p. IsPass p+          => LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p) nlHsParTy :: LHsType (GhcPass p)                        -> LHsType (GhcPass p) -nlHsAppTy f t = noLocA (HsAppTy noExtField f (parenthesizeHsType appPrec t))+nlHsAppTy f t = noLocA (HsAppTy noExtField f t) nlHsTyVar p x = noLocA (HsTyVar noAnn p (noLocA x))-nlHsFunTy a b = noLocA (HsFunTy noAnn (HsUnrestrictedArrow noHsUniTok) (parenthesizeHsType funPrec a) b)+nlHsFunTy a b = noLocA (HsFunTy noExtField (HsUnrestrictedArrow x) a b)+  where+    x = case ghcPass @p of+      GhcPs -> noAnn+      GhcRn -> noExtField+      GhcTc -> noExtField nlHsParTy t   = noLocA (HsParTy noAnn t) -nlHsTyConApp :: IsSrcSpanAnn p a+nlHsTyConApp :: forall p a. IsSrcSpanAnn p a              => PromotionFlag              -> LexicalFixity -> IdP (GhcPass p)              -> [LHsTypeArg (GhcPass p)] -> LHsType (GhcPass p) nlHsTyConApp prom fixity tycon tys   | Infix <- fixity-  , HsValArg ty1 : HsValArg ty2 : rest <- tys+  , HsValArg _ ty1 : HsValArg _ ty2 : rest <- tys   = foldl' mk_app (noLocA $ HsOpTy noAnn prom ty1 (noLocA tycon) ty2) rest   | otherwise   = foldl' mk_app (nlHsTyVar prom tycon) tys   where     mk_app :: LHsType (GhcPass p) -> LHsTypeArg (GhcPass p) -> LHsType (GhcPass p)-    mk_app fun@(L _ (HsOpTy {})) arg = mk_app (noLocA $ HsParTy noAnn fun) arg+    mk_app fun@(L _ (HsOpTy {})) arg = mk_app (nlHsParTy fun) arg       -- parenthesize things like `(A + B) C`-    mk_app fun (HsValArg ty) = noLocA (HsAppTy noExtField fun (parenthesizeHsType appPrec ty))-    mk_app fun (HsTypeArg at ki) = noLocA (HsAppKindTy noExtField fun at (parenthesizeHsType appPrec ki))-    mk_app fun (HsArgPar _) = noLocA (HsParTy noAnn fun)+    mk_app fun (HsValArg _ ty) = nlHsAppTy fun ty+    mk_app fun (HsTypeArg _ ki) = nlHsAppKindTy fun ki+    mk_app fun (HsArgPar _) = nlHsParTy fun -nlHsAppKindTy ::+nlHsAppKindTy :: forall p. IsPass p =>   LHsType (GhcPass p) -> LHsKind (GhcPass p) -> LHsType (GhcPass p)-nlHsAppKindTy f k-  = noLocA (HsAppKindTy noExtField f noHsTok (parenthesizeHsType appPrec k))+nlHsAppKindTy f k = noLocA (HsAppKindTy x f k)+  where+    x = case ghcPass @p of+      GhcPs -> noAnn+      GhcRn -> noExtField+      GhcTc -> noExtField  {- Tuples.  All these functions are *pre-typechecker* because they lack@@ -656,7 +678,7 @@ -- Makes a pre-typechecker boxed tuple, deals with 1 case mkLHsTupleExpr [e] _ = e mkLHsTupleExpr es ext-  = noLocA $ ExplicitTuple ext (map (Present noAnn) es) Boxed+  = noLocA $ ExplicitTuple ext (map (Present noExtField) es) Boxed  mkLHsVarTuple :: IsSrcSpanAnn p a                => [IdP (GhcPass p)]  -> XExplicitTuple (GhcPass p)@@ -666,7 +688,7 @@ nlTuplePat :: [LPat GhcPs] -> Boxity -> LPat GhcPs nlTuplePat pats box = noLocA (TuplePat noAnn pats box) -missingTupArg :: EpAnn EpaLocation -> HsTupArg GhcPs+missingTupArg :: EpAnn Bool -> HsTupArg GhcPs missingTupArg ann = Missing ann  mkLHsPatTup :: [LPat GhcRn] -> LPat GhcRn@@ -700,12 +722,12 @@  -- | Convert an 'LHsType' to an 'LHsSigType'. hsTypeToHsSigType :: LHsType GhcPs -> LHsSigType GhcPs-hsTypeToHsSigType lty@(L loc ty) = L loc $ case ty of+hsTypeToHsSigType lty@(L loc ty) = case ty of   HsForAllTy { hst_tele = HsForAllInvis { hsf_xinvis = an                                         , hsf_invis_bndrs = bndrs }              , hst_body = body }-    -> mkHsExplicitSigType an bndrs body-  _ -> mkHsImplicitSigType lty+    -> L loc $ mkHsExplicitSigType an bndrs body+  _ -> L (l2l loc) $ mkHsImplicitSigType lty -- The annotations are in lty, erase them from loc  -- | Convert an 'LHsType' to an 'LHsSigWcType'. hsTypeToHsSigWcType :: LHsType GhcPs -> LHsSigWcType GhcPs@@ -783,6 +805,9 @@ mkHsWrapPat co_fn p ty | isIdHsWrapper co_fn = p                        | otherwise           = XPat $ CoPat co_fn p ty +mkLHsWrapPat :: HsWrapper -> LPat GhcTc -> Type -> LPat GhcTc+mkLHsWrapPat co_fn (L loc p) ty = L loc (mkHsWrapPat co_fn p ty)+ mkHsWrapPatCo :: TcCoercionN -> Pat GhcTc -> Type -> Pat GhcTc mkHsWrapPatCo co pat ty | isReflCo co = pat                         | otherwise     = XPat $ CoPat (mkWpCastN co) pat ty@@ -826,7 +851,7 @@                               var_id = var, var_rhs = rhs }  mkPatSynBind :: LocatedN RdrName -> HsPatSynDetails GhcPs-             -> LPat GhcPs -> HsPatSynDir GhcPs -> EpAnn [AddEpAnn] -> HsBind GhcPs+             -> LPat GhcPs -> HsPatSynDir GhcPs -> [AddEpAnn] -> HsBind GhcPs mkPatSynBind name details lpat dir anns = PatSynBind noExtField psb   where     psb = PSB{ psb_ext = anns@@ -868,19 +893,21 @@ mkSimpleGeneratedFunBind :: SrcSpan -> RdrName -> [LPat GhcPs]                          -> LHsExpr GhcPs -> LHsBind GhcPs mkSimpleGeneratedFunBind loc fun pats expr-  = L (noAnnSrcSpan loc) $ mkFunBind (Generated SkipPmc) (L (noAnnSrcSpan loc) fun)-              [mkMatch (mkPrefixFunRhs (L (noAnnSrcSpan loc) fun)) pats expr-                       emptyLocalBinds]+  = L (noAnnSrcSpan loc) $ mkFunBind (Generated OtherExpansion SkipPmc) (L (noAnnSrcSpan loc) fun)+                                     [mkMatch ctxt pats expr emptyLocalBinds]+  where+    ctxt :: HsMatchContextPs+    ctxt = mkPrefixFunRhs (L (noAnnSrcSpan loc) fun)  -- | Make a prefix, non-strict function 'HsMatchContext'-mkPrefixFunRhs :: LIdP (NoGhcTc p) -> HsMatchContext p-mkPrefixFunRhs n = FunRhs { mc_fun = n-                          , mc_fixity = Prefix+mkPrefixFunRhs :: fn -> HsMatchContext fn+mkPrefixFunRhs n = FunRhs { mc_fun        = n+                          , mc_fixity     = Prefix                           , mc_strictness = NoSrcStrict }  ------------ mkMatch :: forall p. IsPass p-        => HsMatchContext (GhcPass p)+        => HsMatchContext (LIdP (NoGhcTc (GhcPass p)))         -> [LPat (GhcPass p)]         -> LHsExpr (GhcPass p)         -> HsLocalBinds (GhcPass p)@@ -888,7 +915,7 @@ mkMatch ctxt pats expr binds   = noLocA (Match { m_ext   = noAnn                   , m_ctxt  = ctxt-                  , m_pats  = map mkParPat pats+                  , m_pats  = pats                   , m_grhss = GRHSs emptyComments (unguardedRHS noAnn noSrcSpan expr) binds })  {-@@ -1182,14 +1209,18 @@     -> [IdP p] collectPatsBinders flag pats = foldr (collect_lpat flag) [] pats - ------------- --- | Indicate if evidence binders have to be collected.+-- | Indicate if evidence binders and type variable binders have+--   to be collected. ----- This type is used as a boolean (should we collect evidence binders or not?)--- but also to pass an evidence that the AST has been typechecked when we do--- want to collect evidence binders, otherwise these binders are not available.+-- This type enumerates the modes of collecting bound variables+--                     | evidence |   type    |   term    |  ghc  |+--                     | binders  | variables | variables |  pass |+--                     --------------------------------------------+-- CollNoDictBinders   |  no      |    no     |    yes    |  any  |+-- CollWithDictBinders |  yes     |    no     |    yes    | GhcTc |+-- CollVarTyVarBinders |  no      |    yes    |    yes    | GhcRn | -- -- See Note [Dictionary binders in ConPatOut] data CollectFlag p where@@ -1197,7 +1228,10 @@     CollNoDictBinders   :: CollectFlag p     -- | Collect evidence binders     CollWithDictBinders :: CollectFlag GhcTc+    -- | Collect variable and type variable binders, but no evidence binders+    CollVarTyVarBinders :: CollectFlag GhcRn + collect_lpat :: forall p. CollectPass p              => CollectFlag p              -> LPat p@@ -1215,28 +1249,50 @@   WildPat _             -> bndrs   LazyPat _ pat         -> collect_lpat flag pat bndrs   BangPat _ pat         -> collect_lpat flag pat bndrs-  AsPat _ a _ pat       -> unXRec @p a : collect_lpat flag pat bndrs+  AsPat _ a pat         -> unXRec @p a : collect_lpat flag pat bndrs   ViewPat _ _ pat       -> collect_lpat flag pat bndrs-  ParPat _ _ pat _      -> collect_lpat flag pat bndrs+  ParPat _ pat          -> collect_lpat flag pat bndrs   ListPat _ pats        -> foldr (collect_lpat flag) bndrs pats   TuplePat _ pats _     -> foldr (collect_lpat flag) bndrs pats   SumPat _ pat _ _      -> collect_lpat flag pat bndrs   LitPat _ _            -> bndrs   NPat {}               -> bndrs   NPlusKPat _ n _ _ _ _ -> unXRec @p n : bndrs-  SigPat _ pat _        -> collect_lpat flag pat bndrs+  SigPat _ pat sig      -> case flag of+    CollNoDictBinders   -> collect_lpat flag pat bndrs+    CollWithDictBinders -> collect_lpat flag pat bndrs+    CollVarTyVarBinders -> collect_lpat flag pat bndrs ++ collectPatSigBndrs sig   XPat ext              -> collectXXPat @p flag ext bndrs   SplicePat ext _       -> collectXSplicePat @p flag ext bndrs+  EmbTyPat _ tp         -> collect_ty_pat_bndrs flag tp bndrs+  InvisPat _ tp         -> collect_ty_pat_bndrs flag tp bndrs+   -- See Note [Dictionary binders in ConPatOut]   ConPat {pat_args=ps}  -> case flag of     CollNoDictBinders   -> foldr (collect_lpat flag) bndrs (hsConPatArgs ps)     CollWithDictBinders -> foldr (collect_lpat flag) bndrs (hsConPatArgs ps)                            ++ collectEvBinders (cpt_binds (pat_con_ext pat))+    CollVarTyVarBinders -> foldr (collect_lpat flag) bndrs (hsConPatArgs ps)+                           ++ concatMap collectConPatTyArgBndrs (hsConPatTyArgs ps)  collectEvBinders :: TcEvBinds -> [Id] collectEvBinders (EvBinds bs)   = foldr add_ev_bndr [] bs collectEvBinders (TcEvBinds {}) = panic "ToDo: collectEvBinders" +collectConPatTyArgBndrs :: HsConPatTyArg GhcRn -> [Name]+collectConPatTyArgBndrs (HsConPatTyArg _ tp) = collectTyPatBndrs tp++collect_ty_pat_bndrs :: CollectFlag p -> HsTyPat (NoGhcTc p) -> [IdP p] -> [IdP p]+collect_ty_pat_bndrs CollNoDictBinders _ bndrs = bndrs+collect_ty_pat_bndrs CollWithDictBinders _ bndrs = bndrs+collect_ty_pat_bndrs CollVarTyVarBinders tp bndrs = collectTyPatBndrs tp ++ bndrs++collectTyPatBndrs :: HsTyPat GhcRn -> [Name]+collectTyPatBndrs (HsTP (HsTPRn nwcs imp_tvs exp_tvs) _) = nwcs ++ imp_tvs ++ exp_tvs++collectPatSigBndrs :: HsPatSigType GhcRn -> [Name]+collectPatSigBndrs (HsPS (HsPSRn nwcs imp_tvs) _) = nwcs ++ imp_tvs+ add_ev_bndr :: EvBind -> [Id] -> [Id] add_ev_bndr (EvBind { eb_lhs = b }) bs | isId b    = b:bs                                        | otherwise = bs@@ -1581,8 +1637,8 @@      get_flds_gadt :: FieldIndices p -> HsConDeclGADTDetails (GhcPass p)                   -> (Maybe [Located Int], FieldIndices p)-    get_flds_gadt seen (RecConGADT flds _) = first Just $ get_flds seen flds-    get_flds_gadt seen (PrefixConGADT []) = (Just [], seen)+    get_flds_gadt seen (RecConGADT _ flds) = first Just $ get_flds seen flds+    get_flds_gadt seen (PrefixConGADT _ []) = (Just [], seen)     get_flds_gadt seen _ = (Nothing, seen)      get_flds :: FieldIndices p -> LocatedL [LConDeclField (GhcPass p)]@@ -1651,32 +1707,69 @@ *                                                                      * ************************************************************************ -The job of this family of functions is to run through binding sites and find the set of all Names-that were defined "implicitly", without being explicitly written by the user.+The job of the following family of functions is to run through binding sites and find+the set of all Names that were defined "implicitly", without being explicitly written+by the user. -The main purpose is to find names introduced by record wildcards so that we can avoid-warning the user when they don't use those names (#4404)+Note [Collecting implicit binders]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We collect all the RHS Names that are implicitly introduced by record wildcards,+so that we can: -Since the addition of -Wunused-record-wildcards, this function returns a pair-of [(SrcSpan, [Name])]. Each element of the list is one set of implicit-binders, the first component of the tuple is the document describes the possible-fix to the problem (by removing the ..).+  - avoid warning the user when they don't use those names (#4404),+  - report deprecation warnings for deprecated fields that are used (#23382). -This means there is some unfortunate coupling between this function and where it-is used but it's only used for one specific purpose in one place so it seemed-easier.+The functions that collect implicit binders return a collection of 'ImplicitFieldBinders',+which associates each implicitly-introduced record field with the bound variables in the+RHS of the record field pattern, e.g. in++  data R = MkR { fld :: Int }+  foo (MkR { .. }) = fld++the renamer will elaborate this to++  foo (MkR { fld = fld_var }) = fld_var++and the implicit binders function will return++  [ ImplicitFieldBinders { implFlBndr_field = fld+                         , implFlBndr_binders = [fld_var] } ]++This information is then used:++  - in the calls to GHC.Rename.Utils.checkUnusedRecordWildcard, to emit+    a warning when a record wildcard binds no new variables (redundant record wildcard)+    or none of the bound variables are used (unused record wildcard).+  - in GHC.Rename.Utils.deprecateUsedRecordWildcard, to emit a warning+    when the field is deprecated and any of the binders are used.++NOTE: the implFlBndr_binders field should always be a singleton+      (since the RHS of an implicit binding should always be a VarPat,+      created in rnHsRecPatsAndThen.mkVarPat)+ -} +-- | All binders corresponding to a single implicit record field pattern.+--+-- See Note [Collecting implicit binders].+data ImplicitFieldBinders+  = ImplicitFieldBinders { implFlBndr_field :: Name+                             -- ^ The 'Name' of the record field+                         , implFlBndr_binders :: [Name]+                             -- ^ The binders of the RHS of the record field pattern+                             -- (in practice, always a singleton: see Note [Collecting implicit binders])+                         }+ lStmtsImplicits :: [LStmtLR GhcRn (GhcPass idR) (LocatedA (body (GhcPass idR)))]-                -> [(SrcSpan, [Name])]+                -> [(SrcSpan, [ImplicitFieldBinders])] lStmtsImplicits = hs_lstmts   where     hs_lstmts :: [LStmtLR GhcRn (GhcPass idR) (LocatedA (body (GhcPass idR)))]-              -> [(SrcSpan, [Name])]+              -> [(SrcSpan, [ImplicitFieldBinders])]     hs_lstmts = concatMap (hs_stmt . unLoc)      hs_stmt :: StmtLR GhcRn (GhcPass idR) (LocatedA (body (GhcPass idR)))-            -> [(SrcSpan, [Name])]+            -> [(SrcSpan, [ImplicitFieldBinders])]     hs_stmt (BindStmt _ pat _) = lPatImplicits pat     hs_stmt (ApplicativeStmt _ args _) = concatMap do_arg args       where do_arg (_, ApplicativeArgOne { app_arg_pattern = pat }) = lPatImplicits pat@@ -1693,19 +1786,26 @@     hs_local_binds (HsIPBinds {})           = []     hs_local_binds (EmptyLocalBinds _)      = [] -hsValBindsImplicits :: HsValBindsLR GhcRn (GhcPass idR) -> [(SrcSpan, [Name])]+hsValBindsImplicits :: HsValBindsLR GhcRn (GhcPass idR)+                    -> [(SrcSpan, [ImplicitFieldBinders])] hsValBindsImplicits (XValBindsLR (NValBinds binds _))   = concatMap (lhsBindsImplicits . snd) binds hsValBindsImplicits (ValBinds _ binds _)   = lhsBindsImplicits binds -lhsBindsImplicits :: LHsBindsLR GhcRn idR -> [(SrcSpan, [Name])]+lhsBindsImplicits :: LHsBindsLR GhcRn idR -> [(SrcSpan, [ImplicitFieldBinders])] lhsBindsImplicits = foldBag (++) (lhs_bind . unLoc) []   where     lhs_bind (PatBind { pat_lhs = lpat }) = lPatImplicits lpat     lhs_bind _ = [] -lPatImplicits :: LPat GhcRn -> [(SrcSpan, [Name])]+-- | Collect all record wild card binders in the given pattern.+--+-- These are all the variables bound in all (possibly nested) record wildcard patterns+-- appearing inside the pattern.+--+-- See Note [Collecting implicit binders].+lPatImplicits :: LPat GhcRn -> [(SrcSpan, [ImplicitFieldBinders])] lPatImplicits = hs_lpat   where     hs_lpat lpat = hs_pat (unLoc lpat)@@ -1714,33 +1814,44 @@      hs_pat (LazyPat _ pat)      = hs_lpat pat     hs_pat (BangPat _ pat)      = hs_lpat pat-    hs_pat (AsPat _ _ _ pat)    = hs_lpat pat+    hs_pat (AsPat _ _ pat)      = hs_lpat pat     hs_pat (ViewPat _ _ pat)    = hs_lpat pat-    hs_pat (ParPat _ _ pat _)   = hs_lpat pat+    hs_pat (ParPat _ pat)       = hs_lpat pat     hs_pat (ListPat _ pats)     = hs_lpats pats     hs_pat (TuplePat _ pats _)  = hs_lpats pats-     hs_pat (SigPat _ pat _)     = hs_lpat pat -    hs_pat (ConPat {pat_con=con, pat_args=ps}) = details con ps+    hs_pat (ConPat {pat_args=ps}) = details ps      hs_pat _ = [] -    details :: LocatedN Name -> HsConPatDetails GhcRn -> [(SrcSpan, [Name])]-    details _ (PrefixCon _ ps) = hs_lpats ps-    details n (RecCon fs)      =-      [(err_loc, collectPatsBinders CollNoDictBinders implicit_pats) | Just{} <- [rec_dotdot fs] ]-        ++ hs_lpats explicit_pats+    details :: HsConPatDetails GhcRn -> [(SrcSpan, [ImplicitFieldBinders])]+    details (PrefixCon _ ps) = hs_lpats ps+    details (RecCon (HsRecFields { rec_dotdot = Nothing, rec_flds }))+      = hs_lpats $ map (hfbRHS . unLoc) rec_flds+    details (RecCon (HsRecFields { rec_dotdot = Just (L err_loc rec_dotdot), rec_flds }))+          = [(l2l err_loc, implicit_field_binders)]+          ++ hs_lpats explicit_pats -      where implicit_pats = map (hfbRHS . unLoc) implicit-            explicit_pats = map (hfbRHS . unLoc) explicit+          where (explicit_pats, implicit_field_binders)+                  = rec_field_expl_impl rec_flds rec_dotdot +    details (InfixCon p1 p2) = hs_lpat p1 ++ hs_lpat p2 -            (explicit, implicit) = partitionEithers [if pat_explicit then Left fld else Right fld-                                                    | (i, fld) <- [0..] `zip` rec_flds fs-                                                    ,  let  pat_explicit =-                                                              maybe True ((i<) . unRecFieldsDotDot . unLoc)-                                                                         (rec_dotdot fs)]-            err_loc = maybe (getLocA n) getLoc (rec_dotdot fs)+lHsRecFieldsImplicits :: [LHsRecField GhcRn (LPat GhcRn)]+                      -> RecFieldsDotDot+                      -> [ImplicitFieldBinders]+lHsRecFieldsImplicits rec_flds rec_dotdot+  = snd $ rec_field_expl_impl rec_flds rec_dotdot -    details _ (InfixCon p1 p2) = hs_lpat p1 ++ hs_lpat p2+rec_field_expl_impl :: [LHsRecField GhcRn (LPat GhcRn)]+                    -> RecFieldsDotDot+                    -> ([LPat GhcRn], [ImplicitFieldBinders])+rec_field_expl_impl rec_flds (RecFieldsDotDot { .. })+  = ( map (hfbRHS . unLoc) explicit_binds+    , map implicit_field_binders implicit_binds )+  where (explicit_binds, implicit_binds) = splitAt unRecFieldsDotDot rec_flds+        implicit_field_binders (L _ (HsFieldBind { hfbLHS = L _ fld, hfbRHS = rhs }))+          = ImplicitFieldBinders+              { implFlBndr_field   = foExt fld+              , implFlBndr_binders = collectPatBinders CollNoDictBinders rhs }
compiler/GHC/HsToCore/Errors/Ppr.hs view
@@ -15,7 +15,7 @@ import GHC.Prelude import GHC.Types.Basic (pprRuleName) import GHC.Types.Error-import GHC.Types.Error.Codes ( constructorCode )+import GHC.Types.Error.Codes import GHC.Types.Id (idType) import GHC.Types.SrcLoc import GHC.Utils.Misc@@ -207,6 +207,10 @@                           <+> text "for"<+> quotes (ppr lhs_id)                           <+> text "might fire first")                 ]+    DsIncompleteRecordSelector name cons_wo_field not_full_examples -> mkSimpleDecorated $+      text "The application of the record field" <+> quotes (ppr name)+      <+> text "may fail for the following constructors:"+      <+> vcat (map ppr cons_wo_field ++ [text "..." | not_full_examples])    diagnosticReason = \case     DsUnknownMessage m          -> diagnosticReason m@@ -237,6 +241,7 @@     DsRecBindsNotAllowedForUnliftedTys{}        -> ErrorWithoutFlag     DsRuleMightInlineFirst{}                    -> WarningWithFlag Opt_WarnInlineRuleShadowing     DsAnotherRuleMightFireFirst{}               -> WarningWithFlag Opt_WarnInlineRuleShadowing+    DsIncompleteRecordSelector{}                -> WarningWithFlag Opt_WarnIncompleteRecordSelectors    diagnosticHints = \case     DsUnknownMessage m          -> diagnosticHints m@@ -273,6 +278,7 @@     DsRecBindsNotAllowedForUnliftedTys{}        -> noHints     DsRuleMightInlineFirst _ lhs_id rule_act    -> [SuggestAddInlineOrNoInlinePragma lhs_id rule_act]     DsAnotherRuleMightFireFirst _ bad_rule _    -> [SuggestAddPhaseToCompetingRule bad_rule]+    DsIncompleteRecordSelector{}                -> noHints    diagnosticCode = constructorCode @@ -298,11 +304,11 @@        2 (quotes (ppr elt_ty))  -- Print a single clause (for redundant/with-inaccessible-rhs)-pprEqn :: HsMatchContext GhcTc -> SDoc -> String -> SDoc+pprEqn :: HsMatchContextRn -> SDoc -> String -> SDoc pprEqn ctx q txt = pprContext True ctx (text txt) $ \f ->   f (q <+> matchSeparator ctx <+> text "...") -pprContext :: Bool -> HsMatchContext GhcTc -> SDoc -> ((SDoc -> SDoc) -> SDoc) -> SDoc+pprContext :: Bool -> HsMatchContextRn -> SDoc -> ((SDoc -> SDoc) -> SDoc) -> SDoc pprContext singular kind msg rest_of_msg_fun   = vcat [text txt <+> msg,           sep [ text "In" <+> ppr_match <> char ':'
compiler/GHC/HsToCore/Errors/Types.hs view
@@ -8,6 +8,7 @@  import GHC.Core (CoreRule, CoreExpr, RuleName) import GHC.Core.DataCon+import GHC.Core.ConLike import GHC.Core.Type import GHC.Driver.DynFlags (DynFlags, xopt) import GHC.Driver.Flags (WarningFlag)@@ -85,18 +86,18 @@    -- FIXME(adn) Use a proper type instead of 'SDoc', but unfortunately   -- 'SrcInfo' gives us an 'SDoc' to begin with.-  | DsRedundantBangPatterns !(HsMatchContext GhcTc) !SDoc+  | DsRedundantBangPatterns !HsMatchContextRn !SDoc    -- FIXME(adn) Use a proper type instead of 'SDoc', but unfortunately   -- 'SrcInfo' gives us an 'SDoc' to begin with.-  | DsOverlappingPatterns !(HsMatchContext GhcTc) !SDoc+  | DsOverlappingPatterns !HsMatchContextRn !SDoc    -- FIXME(adn) Use a proper type instead of 'SDoc'-  | DsInaccessibleRhs !(HsMatchContext GhcTc) !SDoc+  | DsInaccessibleRhs !HsMatchContextRn !SDoc    | DsMaxPmCheckModelsReached !MaxPmCheckModels -  | DsNonExhaustivePatterns !(HsMatchContext GhcTc)+  | DsNonExhaustivePatterns !HsMatchContextRn                             !ExhaustivityCheckType                             !MaxUncoveredPatterns                             [Id]@@ -146,6 +147,23 @@   | DsAnotherRuleMightFireFirst !RuleName                                 !RuleName -- the \"bad\" rule                                 !Var++  {-| DsIncompleteRecordSelector is a warning triggered when we are not certain whether+      a record selector application will be successful. Currently, this means that+      the warning is triggered when there is a record selector of a data type that+      does not have that field in all its constructors.++      Example(s):+      data T = T1 | T2 {x :: Bool}+      f :: T -> Bool+      f a = x a++     Test cases:+       DsIncompleteRecSel1+       DsIncompleteRecSel2+       DsIncompleteRecSel3+  -}+  | DsIncompleteRecordSelector !Name ![ConLike] !Bool    deriving Generic
compiler/GHC/HsToCore/Pmc/Ppr.hs view
@@ -20,7 +20,6 @@ import GHC.Builtin.Types import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Utils.Panic.Plain import Control.Monad.Trans.RWS.CPS import GHC.Data.Maybe import Data.List.NonEmpty (NonEmpty, nonEmpty, toList)
compiler/GHC/HsToCore/Pmc/Types.hs view
@@ -21,7 +21,8 @@         SrcInfo(..), PmGrd(..), GrdVec(..),          -- ** Guard tree language-        PmMatchGroup(..), PmMatch(..), PmGRHSs(..), PmGRHS(..), PmPatBind(..), PmEmptyCase(..),+        PmMatchGroup(..), PmMatch(..), PmGRHSs(..), PmGRHS(..),+        PmPatBind(..), PmEmptyCase(..), PmRecSel(..),          -- * Coverage Checking types         RedSets (..), Precision (..), CheckResult (..),@@ -43,6 +44,7 @@ import GHC.Types.Var (EvVar) import GHC.Types.SrcLoc import GHC.Utils.Outputable+import GHC.Core.ConLike import GHC.Core.Type import GHC.Core @@ -130,6 +132,8 @@   -- rather than on the pattern bindings.   PmPatBind (PmGRHS p) +-- A guard tree denoting a record selector application+data PmRecSel v = PmRecSel { pr_arg_var :: v, pr_arg :: CoreExpr, pr_cons :: [ConLike] } instance Outputable SrcInfo where   ppr (SrcInfo (L (RealSrcSpan rss _) _)) = ppr (srcSpanStartLine rss)   ppr (SrcInfo (L s                   _)) = ppr s
compiler/GHC/Iface/Errors/Ppr.hs view
@@ -31,7 +31,7 @@  import GHC.Types.Error import GHC.Types.Hint.Ppr () -- Outputable GhcHint-import GHC.Types.Error.Codes ( constructorCode )+import GHC.Types.Error.Codes import GHC.Types.Name import GHC.Types.TyThing
compiler/GHC/Iface/Syntax.hs view
@@ -12,7 +12,7 @@          IfaceDecl(..), IfaceFamTyConFlav(..), IfaceClassOp(..), IfaceAT(..),         IfaceConDecl(..), IfaceConDecls(..), IfaceEqSpec,-        IfaceExpr(..), IfaceAlt(..), IfaceLetBndr(..), IfaceJoinInfo(..), IfaceBinding,+        IfaceExpr(..), IfaceAlt(..), IfaceLetBndr(..), IfaceBinding,         IfaceBindingX(..), IfaceMaybeRhs(..), IfaceConAlt(..),         IfaceIdInfo, IfaceIdDetails(..), IfaceUnfolding(..), IfGuidance(..),         IfaceInfoItem(..), IfaceRule(..), IfaceAnnotation(..), IfaceAnnTarget,@@ -35,6 +35,7 @@         ifaceDeclFingerprints,         fromIfaceBooleanFormula,         fromIfaceWarnings,+        fromIfaceWarningTxt,          -- Free Names         freeNamesIfDecl, freeNamesIfRule, freeNamesIfFamInst,@@ -315,7 +316,11 @@                    ifInstTys  :: [Maybe IfaceTyCon],       -- the defn of ClsInst                    ifDFun     :: IfExtName,                -- The dfun                    ifOFlag    :: OverlapFlag,              -- Overlap flag-                   ifInstOrph :: IsOrphan }                -- See Note [Orphans] in GHC.Core.InstEnv+                   ifInstOrph :: IsOrphan,                 -- See Note [Orphans] in GHC.Core.InstEnv+                   ifInstWarn :: Maybe IfaceWarningTxt }+                     -- Warning emitted when the instance is used+                     -- See Note [Implementation of deprecated instances]+                     -- in GHC.Tc.Solver.Dict         -- There's always a separate IfaceDecl for the DFun, which gives         -- its IdInfo with its full type and version number.         -- The instance declarations taken together have a version number,@@ -590,8 +595,8 @@  fromIfaceWarningTxt :: IfaceWarningTxt -> WarningTxt GhcRn fromIfaceWarningTxt = \case-    IfWarningTxt mb_cat src strs -> WarningTxt (noLoc . fromWarningCategory <$> mb_cat) (noLoc src) (noLoc <$> map fromIfaceStringLiteralWithNames strs)-    IfDeprecatedTxt src strs -> DeprecatedTxt (noLoc src) (noLoc <$> map fromIfaceStringLiteralWithNames strs)+    IfWarningTxt mb_cat src strs -> WarningTxt (noLocA . fromWarningCategory <$> mb_cat) src (noLocA <$> map fromIfaceStringLiteralWithNames strs)+    IfDeprecatedTxt src strs -> DeprecatedTxt src (noLocA <$> map fromIfaceStringLiteralWithNames strs)  fromIfaceStringLiteralWithNames :: (IfaceStringLiteral, [IfExtName]) -> WithHsDocIdentifiers StringLiteral GhcRn fromIfaceStringLiteralWithNames (str, names) = WithHsDocIdentifiers (fromIfaceStringLiteral str) (map noLoc names)@@ -627,10 +632,10 @@   | IfaceTick   IfaceTickish IfaceExpr    -- from Tick tickish E  data IfaceTickish-  = IfaceHpcTick Module Int                -- from HpcTick x-  | IfaceSCC     CostCentre Bool Bool      -- from ProfNote-  | IfaceSource  RealSrcSpan FastString        -- from SourceNote-  -- no breakpoints: we never export these into interface files+  = IfaceHpcTick    Module Int               -- from HpcTick x+  | IfaceSCC        CostCentre Bool Bool     -- from ProfNote+  | IfaceSource  RealSrcSpan FastString      -- from SourceNote+  | IfaceBreakpoint Int [IfaceExpr] Module   -- from Breakpoint  data IfaceAlt = IfaceAlt IfaceConAlt [IfLclName] IfaceExpr         -- Note: IfLclName, not IfaceBndr (and same with the case binder)@@ -651,7 +656,7 @@ -- IfaceLetBndr is like IfaceIdBndr, but has IdInfo too -- It's used for *non-top-level* let/rec binders -- See Note [IdInfo on nested let-bindings]-data IfaceLetBndr = IfLetBndr IfLclName IfaceType IfaceIdInfo IfaceJoinInfo+data IfaceLetBndr = IfLetBndr IfLclName IfaceType IfaceIdInfo JoinPointHood  data IfaceTopBndrInfo = IfLclTopBndr IfLclName IfaceType IfaceIdInfo IfaceIdDetails                       | IfGblTopBndr IfaceTopBndr@@ -659,9 +664,6 @@ -- See Note [Interface File with Core: Sharing RHSs] data IfaceMaybeRhs = IfUseUnfoldingRhs | IfRhs IfaceExpr -data IfaceJoinInfo = IfaceNotJoinPoint-                   | IfaceJoinPoint JoinArity- {- Note [Empty case alternatives] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -834,10 +836,13 @@ everything unqualified, so we can just print the OccName directly. -} +-- | Show a declaration but not its RHS. showToHeader :: ShowSub showToHeader = ShowSub { ss_how_much = ShowHeader $ AltPpr Nothing                        , ss_forall = ShowForAllWhen } +-- | Show declaration and its RHS, including GHc-internal information (e.g.+-- for @--show-iface@). showToIface :: ShowSub showToIface = ShowSub { ss_how_much = ShowIface                       , ss_forall = ShowForAllWhen }@@ -848,18 +853,20 @@  -- show if all sub-components or the complete interface is shown ppShowAllSubs :: ShowSub -> SDoc -> SDoc -- See Note [Minimal complete definition]-ppShowAllSubs (ShowSub { ss_how_much = ShowSome [] _ }) doc = doc-ppShowAllSubs (ShowSub { ss_how_much = ShowIface })     doc = doc-ppShowAllSubs _                                         _   = Outputable.empty+ppShowAllSubs (ShowSub { ss_how_much = ShowSome Nothing _ }) doc+                                                        = doc+ppShowAllSubs (ShowSub { ss_how_much = ShowIface }) doc = doc+ppShowAllSubs _                                     _   = Outputable.empty  ppShowRhs :: ShowSub -> SDoc -> SDoc ppShowRhs (ShowSub { ss_how_much = ShowHeader _ }) _   = Outputable.empty ppShowRhs _                                        doc = doc  showSub :: HasOccName n => ShowSub -> n -> Bool-showSub (ShowSub { ss_how_much = ShowHeader _ })     _     = False-showSub (ShowSub { ss_how_much = ShowSome (n:_) _ }) thing = n == occName thing-showSub (ShowSub { ss_how_much = _ })              _     = True+showSub (ShowSub { ss_how_much = ShowHeader _ }) _     = False+showSub (ShowSub { ss_how_much = ShowSome (Just f) _ }) thing+                                                       = f (occName thing)+showSub (ShowSub { ss_how_much = _ })            _     = True  ppr_trim :: [Maybe SDoc] -> [SDoc] -- Collapse a group of Nothings to a single "..."@@ -920,12 +927,7 @@     cons       = visibleIfConDecls condecls     pp_where   = ppWhen (gadt && not (null cons)) $ text "where"     pp_cons    = ppr_trim (map show_con cons) :: [SDoc]-    pp_kind    = ppUnless (if ki_sig_printable-                              then isIfaceRhoType kind-                                      -- Even in the presence of a standalone kind signature, a non-tau-                                      -- result kind annotation cannot be discarded as it determines the arity.-                                      -- See Note [Arity inference in kcCheckDeclHeader_sig] in GHC.Tc.Gen.HsType-                              else isIfaceLiftedTypeKind kind)+    pp_kind    = ppUnless (ki_sig_printable || isIfaceLiftedTypeKind kind)                           (dcolon <+> ppr kind)      pp_lhs = case parent of@@ -1065,8 +1067,9 @@   = vcat [ pprStandaloneKindSig name_doc (mkIfaceTyConKind binders res_kind)          , hang (text "type family"                    <+> pprIfaceDeclHead suppress_bndr_sig [] ss tycon binders+                   <+> pp_inj res_var inj                    <+> ppShowRhs ss (pp_where rhs))-              2 (pp_inj res_var inj <+> ppShowRhs ss (pp_rhs rhs))+              2 (ppShowRhs ss (pp_rhs rhs))            $$            nest 2 (ppShowRhs ss (pp_branches rhs))          ]@@ -1537,6 +1540,8 @@   = braces (pprCostCentreCore cc <+> ppr tick <+> ppr scope) pprIfaceTickish (IfaceSource src _names)   = braces (pprUserRealSpan True src)+pprIfaceTickish (IfaceBreakpoint m ix fvs)+  = braces (text "break" <+> ppr m <+> ppr ix <+> ppr fvs)  ------------------ pprIfaceApp :: IfaceExpr -> [SDoc] -> SDoc@@ -1572,10 +1577,6 @@   ppr (HsLFInfo lf_info)    = text "LambdaFormInfo:" <+> ppr lf_info   ppr (HsTagSig tag_sig)    = text "TagSig:" <+> ppr tag_sig -instance Outputable IfaceJoinInfo where-  ppr IfaceNotJoinPoint   = empty-  ppr (IfaceJoinPoint ar) = angleBrackets (text "join" <+> ppr ar)- instance Outputable IfaceUnfolding where   ppr (IfCoreUnfold src _ guide e)     = sep [ text "Core:" <+> ppr src <+> ppr guide, ppr e ]@@ -1764,7 +1765,7 @@   = freeNamesIfTc tc &&& fnList freeNamesIfCoercion cos freeNamesIfCoercion (IfaceAppCo c1 c2)   = freeNamesIfCoercion c1 &&& freeNamesIfCoercion c2-freeNamesIfCoercion (IfaceForAllCo _ kind_co co)+freeNamesIfCoercion (IfaceForAllCo _tcv _visL _visR kind_co co)   = freeNamesIfCoercion kind_co &&& freeNamesIfCoercion co freeNamesIfCoercion (IfaceFreeCoVar _) = emptyNameSet freeNamesIfCoercion (IfaceCoVarCo _)   = emptyNameSet@@ -1795,7 +1796,6 @@ freeNamesIfProv (IfacePhantomProv co)    = freeNamesIfCoercion co freeNamesIfProv (IfaceProofIrrelProv co) = freeNamesIfCoercion co freeNamesIfProv (IfacePluginProv _)      = emptyNameSet-freeNamesIfProv (IfaceCorePrepProv _)    = emptyNameSet  freeNamesIfVarBndr :: VarBndr IfaceBndr vis -> NameSet freeNamesIfVarBndr (Bndr bndr _) = freeNamesIfBndr bndr@@ -1845,7 +1845,7 @@ freeNamesIfExpr (IfaceLam (b,_) body) = freeNamesIfBndr b &&& freeNamesIfExpr body freeNamesIfExpr (IfaceApp f a)        = freeNamesIfExpr f &&& freeNamesIfExpr a freeNamesIfExpr (IfaceCast e co)      = freeNamesIfExpr e &&& freeNamesIfCoercion co-freeNamesIfExpr (IfaceTick _ e)       = freeNamesIfExpr e+freeNamesIfExpr (IfaceTick t e)       = freeNamesIfTickish t &&& freeNamesIfExpr e freeNamesIfExpr (IfaceECase e ty)     = freeNamesIfExpr e &&& freeNamesIfType ty freeNamesIfExpr (IfaceCase s _ alts)   = freeNamesIfExpr s &&& fnList fn_alt alts &&& fn_cons alts@@ -1892,6 +1892,11 @@ freeNamesIfaceTyConParent (IfDataInstance ax tc tys)   = unitNameSet ax &&& freeNamesIfTc tc &&& freeNamesIfAppArgs tys +freeNamesIfTickish :: IfaceTickish -> NameSet+freeNamesIfTickish (IfaceBreakpoint _ fvs _) =+  fnList freeNamesIfExpr fvs+freeNamesIfTickish _ = emptyNameSet+ -- helpers (&&&) :: NameSet -> NameSet -> NameSet (&&&) = unionNameSet@@ -2274,19 +2279,21 @@          return (IfSrcBang a1 a2)  instance Binary IfaceClsInst where-    put_ bh (IfaceClsInst cls tys dfun flag orph) = do+    put_ bh (IfaceClsInst cls tys dfun flag orph warn) = do         put_ bh cls         put_ bh tys         put_ bh dfun         put_ bh flag         put_ bh orph+        put_ bh warn     get bh = do         cls  <- get bh         tys  <- get bh         dfun <- get bh         flag <- get bh         orph <- get bh-        return (IfaceClsInst cls tys dfun flag orph)+        warn <- get bh+        return (IfaceClsInst cls tys dfun flag orph warn)  instance Binary IfaceFamInst where     put_ bh (IfaceFamInst fam tys name orph) = do@@ -2594,6 +2601,11 @@         put_ bh (srcSpanEndLine src)         put_ bh (srcSpanEndCol src)         put_ bh name+    put_ bh (IfaceBreakpoint m ix fvs) = do+        putByte bh 3+        put_ bh m+        put_ bh ix+        put_ bh fvs      get bh = do         h <- getByte bh@@ -2614,6 +2626,10 @@                         end = mkRealSrcLoc file el ec                     name <- get bh                     return (IfaceSource (mkRealSrcSpan start end) name)+            3 -> do m <- get bh+                    ix <- get bh+                    fvs <- get bh+                    return (IfaceBreakpoint m ix fvs)             _ -> panic ("get IfaceTickish " ++ show h)  instance Binary IfaceConAlt where@@ -2678,19 +2694,6 @@       1 -> IfRhs <$> get bh       _ -> pprPanic "IfaceMaybeRhs" (intWithCommas b) ---instance Binary IfaceJoinInfo where-    put_ bh IfaceNotJoinPoint = putByte bh 0-    put_ bh (IfaceJoinPoint ar) = do-        putByte bh 1-        put_ bh ar-    get bh = do-        h <- getByte bh-        case h of-            0 -> return IfaceNotJoinPoint-            _ -> liftM IfaceJoinPoint $ get bh- instance Binary IfaceTyConParent where     put_ bh IfNoParent = putByte bh 0     put_ bh (IfDataInstance ax pr ty) = do@@ -2870,14 +2873,12 @@     IfaceAbstractClosedSynFamilyTyCon -> ()     IfaceBuiltInSynFamTyCon -> () -instance NFData IfaceJoinInfo where-  rnf x = x `seq` ()- instance NFData IfaceTickish where   rnf = \case     IfaceHpcTick m i -> rnf m `seq` rnf i     IfaceSCC cc b1 b2 -> cc `seq` rnf b1 `seq` rnf b2     IfaceSource src str -> src `seq` rnf str+    IfaceBreakpoint m i fvs -> rnf m `seq` rnf i `seq` rnf fvs  instance NFData IfaceConAlt where   rnf = \case@@ -2897,8 +2898,8 @@     rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` f4 `seq` ()  instance NFData IfaceClsInst where-  rnf (IfaceClsInst f1 f2 f3 f4 f5) =-    f1 `seq` rnf f2 `seq` rnf f3 `seq` f4 `seq` f5 `seq` ()+  rnf (IfaceClsInst f1 f2 f3 f4 f5 f6) =+    f1 `seq` rnf f2 `seq` rnf f3 `seq` f4 `seq` f5 `seq` rnf f6  instance NFData IfaceWarnings where   rnf = \case
compiler/GHC/Iface/Type.hs view
@@ -7,11 +7,7 @@ -}  -{-# LANGUAGE FlexibleInstances #-}-  -- FlexibleInstances for Binary (DefMethSpec IfaceType)-{-# LANGUAGE BangPatterns #-} {-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE TupleSections #-} {-# LANGUAGE LambdaCase #-}  module GHC.Iface.Type (@@ -75,7 +71,8 @@                                  , tupleTyConName                                  , tupleDataConName                                  , manyDataConTyCon-                                 , liftedRepTyCon, liftedDataConTyCon )+                                 , liftedRepTyCon, liftedDataConTyCon+                                 , sumTyCon ) import GHC.Core.Type ( isRuntimeRepTy, isMultiplicityTy, isLevityTy, funTyFlagTyCon ) import GHC.Core.TyCo.Rep( CoSel ) import GHC.Core.TyCo.Compare( eqForAllVis )@@ -134,7 +131,7 @@ type IfaceLamBndr = (IfaceBndr, IfaceOneShot)  data IfaceOneShot    -- See Note [Preserve OneShotInfo] in "GHC.Core.Tidy"-  = IfaceNoOneShot   -- and Note [The oneShot function] in "GHC.Types.Id.Make"+  = IfaceNoOneShot   -- and Note [oneShot magic] in "GHC.Types.Id.Make"   | IfaceOneShot  instance Outputable IfaceOneShot where@@ -381,7 +378,7 @@   | IfaceFunCo        Role IfaceCoercion IfaceCoercion IfaceCoercion   | IfaceTyConAppCo   Role IfaceTyCon [IfaceCoercion]   | IfaceAppCo        IfaceCoercion IfaceCoercion-  | IfaceForAllCo     IfaceBndr IfaceCoercion IfaceCoercion+  | IfaceForAllCo     IfaceBndr !ForAllTyFlag !ForAllTyFlag IfaceCoercion IfaceCoercion   | IfaceCoVarCo      IfLclName   | IfaceAxiomInstCo  IfExtName BranchIndex [IfaceCoercion]   | IfaceAxiomRuleCo  IfLclName [IfaceCoercion]@@ -403,7 +400,6 @@   = IfacePhantomProv IfaceCoercion   | IfaceProofIrrelProv IfaceCoercion   | IfacePluginProv String-  | IfaceCorePrepProv Bool  -- See defn of CorePrepProv  {- Note [Holes in IfaceCoercion] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -625,7 +621,6 @@     go_prov (IfacePhantomProv co)    = IfacePhantomProv (go_co co)     go_prov (IfaceProofIrrelProv co) = IfaceProofIrrelProv (go_co co)     go_prov co@(IfacePluginProv _)   = co-    go_prov co@(IfaceCorePrepProv _) = co  substIfaceAppArgs :: IfaceTySubst -> IfaceAppArgs -> IfaceAppArgs substIfaceAppArgs env args@@ -849,7 +844,7 @@ Normally, we pretty-print    `TYPE       'LiftedRep` as `Type` (or `*`)    `CONSTRAINT 'LiftedRep` as `Constraint`-   `FUN 'Many`             as `(->)`.+   `FUN 'Many`             as `(->)` This way, error messages don't refer to representation polymorphism or linearity if it is not necessary.  Normally we'd would represent these types using their synonyms (see GHC.Core.Type@@ -974,7 +969,7 @@ ppr_ty _         (IfaceFreeTyVar tyvar) = ppr tyvar  -- This is the main reason for IfaceFreeTyVar! ppr_ty _         (IfaceTyVar tyvar)     = ppr tyvar  -- See Note [Free tyvars in IfaceType] ppr_ty ctxt_prec (IfaceTyConApp tc tys) = pprTyTcApp ctxt_prec tc tys-ppr_ty ctxt_prec (IfaceTupleTy i p tys) = pprTuple ctxt_prec i p tys -- always fully saturated+ppr_ty ctxt_prec (IfaceTupleTy i p tys) = ppr_tuple ctxt_prec i p tys -- always fully saturated ppr_ty _         (IfaceLitTy n)         = pprIfaceTyLit n          -- Function types@@ -1282,7 +1277,8 @@ pprIfaceForAllPartMust tvs ctxt sdoc   = ppr_iface_forall_part ShowForAllMust tvs ctxt sdoc -pprIfaceForAllCoPart :: [(IfLclName, IfaceCoercion)] -> SDoc -> SDoc+pprIfaceForAllCoPart :: [(IfLclName, IfaceCoercion, ForAllTyFlag, ForAllTyFlag)]+                     -> SDoc -> SDoc pprIfaceForAllCoPart tvs sdoc   = sep [ pprIfaceForAllCo tvs, sdoc ] @@ -1321,11 +1317,11 @@   | otherwise              = (all_bndrs, []) ppr_itv_bndrs [] _ = ([], []) -pprIfaceForAllCo :: [(IfLclName, IfaceCoercion)] -> SDoc+pprIfaceForAllCo :: [(IfLclName, IfaceCoercion, ForAllTyFlag, ForAllTyFlag)] -> SDoc pprIfaceForAllCo []  = empty pprIfaceForAllCo tvs = text "forall" <+> pprIfaceForAllCoBndrs tvs <> dot -pprIfaceForAllCoBndrs :: [(IfLclName, IfaceCoercion)] -> SDoc+pprIfaceForAllCoBndrs :: [(IfLclName, IfaceCoercion, ForAllTyFlag, ForAllTyFlag)] -> SDoc pprIfaceForAllCoBndrs bndrs = hsep $ map pprIfaceForAllCoBndr bndrs  pprIfaceForAllBndr :: IfaceForAllBndr -> SDoc@@ -1340,9 +1336,15 @@     -- See Note [Suppressing binder signatures]     suppress_sig = SuppressBndrSig False -pprIfaceForAllCoBndr :: (IfLclName, IfaceCoercion) -> SDoc-pprIfaceForAllCoBndr (tv, kind_co)-  = parens (ppr tv <+> dcolon <+> pprIfaceCoercion kind_co)+pprIfaceForAllCoBndr :: (IfLclName, IfaceCoercion, ForAllTyFlag, ForAllTyFlag) -> SDoc+pprIfaceForAllCoBndr (tv, kind_co, visL, visR)+  = parens (ppr tv <> pp_vis <+> dcolon <+> pprIfaceCoercion kind_co)+  where+    pp_vis | visL == coreTyLamForAllTyFlag+           , visR == coreTyLamForAllTyFlag+           = empty+           | otherwise+           = ppr visL <> char '~' <> ppr visR    -- "[spec]~[reqd]"  -- | Show forall flag --@@ -1361,21 +1363,18 @@ newtype AltPpr = AltPpr (Maybe (OccName -> SDoc))  data ShowHowMuch-  = ShowHeader AltPpr -- ^Header information only, not rhs-  | ShowSome [OccName] AltPpr-  -- ^ Show only some sub-components. Specifically,-  ---  -- [@\[\]@] Print all sub-components.-  -- [@(n:ns)@] Print sub-component @n@ with @ShowSub = ns@;-  -- elide other sub-components to @...@-  -- May 14: the list is max 1 element long at the moment+  = ShowHeader AltPpr -- ^ Header information only, not rhs+  | ShowSome (Maybe (OccName -> Bool)) AltPpr+  -- ^ Show the declaration and its RHS. The @Maybe@ predicate+  -- allows filtering of the sub-components which should be printing;+  -- any sub-components filtered out will be elided with @...@.   | ShowIface-  -- ^Everything including GHC-internal information (used in --show-iface)+  -- ^ Everything including GHC-internal information (used in --show-iface)  instance Outputable ShowHowMuch where-  ppr (ShowHeader _)    = text "ShowHeader"-  ppr ShowIface         = text "ShowIface"-  ppr (ShowSome occs _) = text "ShowSome" <+> ppr occs+  ppr (ShowHeader _) = text "ShowHeader"+  ppr ShowIface      = text "ShowIface"+  ppr (ShowSome _ _) = text "ShowSome"  pprIfaceSigmaType :: ShowForAllFlag -> IfaceType -> SDoc pprIfaceSigmaType show_forall ty@@ -1576,14 +1575,14 @@        | IfaceTupleTyCon arity sort <- ifaceTyConSort info        , not debug        , arity == ifaceVisAppArgsLength tys-       -> pprTuple ctxt_prec sort (ifaceTyConIsPromoted info) tys-           -- NB: pprTuple requires a saturated tuple.+       -> ppr_tuple ctxt_prec sort (ifaceTyConIsPromoted info) tys+           -- NB: ppr_tuple requires a saturated tuple.         | IfaceSumTyCon arity <- ifaceTyConSort info        , not debug        , arity == ifaceVisAppArgsLength tys-       -> pprSum (ifaceTyConIsPromoted info) tys-           -- NB: pprSum requires a saturated unboxed sum.+       -> ppr_sum ctxt_prec (ifaceTyConIsPromoted info) tys+           -- NB: ppr_sum requires a saturated unboxed sum.         | tc `ifaceTyConHasKey` consDataConKey        , False <- print_kinds@@ -1752,69 +1751,105 @@      | otherwise      -> pprIfacePrefixApp ctxt_prec (parens (ppr tc)) (map (pp appPrec) tys) --- | Pretty-print an unboxed sum type. The sum should be saturated:--- as many visible arguments as the arity of the sum.------ NB: this always strips off the invisible 'RuntimeRep' arguments,--- even with `-fprint-explicit-runtime-reps` and `-fprint-explicit-kinds`.-pprSum :: PromotionFlag -> IfaceAppArgs -> SDoc-pprSum is_promoted args-  =   -- drop the RuntimeRep vars.-      -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon-    let tys   = appArgsIfaceTypes args-        args' = drop (length tys `div` 2) tys-    in pprPromotionQuoteI is_promoted-       <> sumParens (pprWithBars (ppr_ty topPrec) args')+data TupleOrSum = IsSum | IsTuple TupleSort+  deriving (Eq) --- | Pretty-print a tuple type (boxed tuple, constraint tuple, unboxed tuple).--- The tuple should be saturated: as many visible arguments as the arity of--- the tuple.+-- | Pretty-print a boxed tuple datacon in regular tuple syntax.+-- Used when -XListTuplePuns is disabled.+ppr_tuple_no_pun :: PprPrec -> [IfaceType] -> SDoc+ppr_tuple_no_pun ctxt_prec = \case+  [t] -> maybeParen ctxt_prec appPrec (text "MkSolo" <+> pprPrecIfaceType appPrec t)+  tys -> tupleParens BoxedTuple (pprWithCommas pprIfaceType tys)++-- | Pretty-print an unboxed tuple or sum type in its parenthesized, punned, form.+-- Used when -XListTuplePuns is enabled. --+-- The tycon should be saturated:+-- as many visible arguments as the arity of the sum or tuple.+-- -- NB: this always strips off the invisible 'RuntimeRep' arguments, -- even with `-fprint-explicit-runtime-reps` and `-fprint-explicit-kinds`.-pprTuple :: PprPrec -> TupleSort -> PromotionFlag -> IfaceAppArgs -> SDoc-pprTuple ctxt_prec sort promoted args =-  case promoted of-    IsPromoted-      -> let tys = appArgsIfaceTypes args-             args' = drop (length tys `div` 2) tys-         in ppr_tuple_app args' $-            pprPromotionQuoteI IsPromoted <>-            tupleParens sort (spaceIfSingleQuote (pprWithCommas pprIfaceType args'))+ppr_tuple_sum_pun :: PprPrec -> TupleOrSum -> PromotionFlag -> IfaceType -> Arity -> [IfaceType] -> SDoc+ppr_tuple_sum_pun ctxt_prec sort promoted tc arity tys+  | IsSum <- sort+  = sumParens (pprWithBars (ppr_ty topPrec) tys) -    NotPromoted-      |  ConstraintTuple <- sort-      ,  IA_Nil <- args-      -> maybeParen ctxt_prec sigPrec $-         text "() :: Constraint"+  |  IsTuple ConstraintTuple <- sort+  ,  NotPromoted <- promoted+  ,  arity == 0+  = maybeParen ctxt_prec sigPrec $+    text "() :: Constraint" -      | otherwise-      ->   -- drop the RuntimeRep vars.-           -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon-         let tys   = appArgsIfaceTypes args-             args' = case sort of-                       UnboxedTuple -> drop (length tys `div` 2) tys-                       _            -> tys-         in-         ppr_tuple_app args' $-         pprPromotionQuoteI promoted <>-         tupleParens sort (pprWithCommas pprIfaceType args')+  -- Special-case unary boxed tuples so that they are pretty-printed as+  -- `Solo x`, not `(x)`+  | IsTuple BoxedTuple <- sort+  , arity == 1+  = pprPrecIfaceType ctxt_prec tc++  | IsTuple tupleSort <- sort+  = pprPromotionQuoteI promoted <>+    tupleParens tupleSort (quote_space (pprWithCommas pprIfaceType tys))   where-    ppr_tuple_app :: [IfaceType] -> SDoc -> SDoc-    ppr_tuple_app args_wo_runtime_reps ppr_args_w_parens-        -- Special-case unary boxed tuples so that they are pretty-printed as-        -- `Solo x`, not `(x)`-      | [_] <- args_wo_runtime_reps-      , BoxedTuple <- sort-      = let solo_tc_info = mkIfaceTyConInfo promoted IfaceNormalTyCon-            tupleName = case promoted of-              IsPromoted -> tupleDataConName (tupleSortBoxity sort)-              NotPromoted -> tupleTyConName sort-            solo_tc = IfaceTyCon (tupleName 1) solo_tc_info in-        pprPrecIfaceType ctxt_prec $ IfaceTyConApp solo_tc args+    quote_space = case promoted of+      IsPromoted -> spaceIfSingleQuote+      NotPromoted -> id++-- | Pretty-print an unboxed tuple or sum type either in the punned or unpunned form,+-- depending on whether -XListTuplePuns is enabled.+ppr_tuple_sum :: PprPrec -> TupleOrSum -> PromotionFlag -> IfaceAppArgs -> SDoc+ppr_tuple_sum ctxt_prec sort is_promoted args =+  sdocOption sdocListTuplePuns $ \case+    True -> ppr_tuple_sum_pun ctxt_prec sort is_promoted prefix_tc arity non_rep_tys+    False+      | IsPromoted <- is_promoted+      , IsTuple BoxedTuple <- sort+      -> ppr_tuple_no_pun ctxt_prec non_rep_tys       | otherwise-      = ppr_args_w_parens+      -> pprPrecIfaceType ctxt_prec prefix_tc+  where+    -- This tycon is used to print in prefix notation for the punned Solo+    -- case and the unabbreviated case.+    prefix_tc = IfaceTyConApp (IfaceTyCon (mk_name arity) info) args +    info = mkIfaceTyConInfo NotPromoted IfaceNormalTyCon++    mk_name = case (sort, is_promoted) of+      (IsTuple BoxedTuple, IsPromoted) -> tupleDataConName Boxed+      (IsTuple s, _) -> tupleTyConName s+      (IsSum, _) -> tyConName . sumTyCon++    -- drop the RuntimeRep vars.+    -- See Note [Unboxed tuple RuntimeRep vars] in GHC.Core.TyCon+    non_rep_tys = if strip_reps then drop arity all_tys else all_tys++    arity = if strip_reps then count `div` 2 else count++    count = length all_tys++    all_tys = appArgsIfaceTypes args++    strip_reps = case is_promoted of+      IsPromoted -> True+      NotPromoted -> strip_reps_sort++    strip_reps_sort = case sort of+      IsTuple BoxedTuple -> False+      IsTuple UnboxedTuple -> True+      IsTuple ConstraintTuple -> False+      IsSum -> True++-- | Pretty-print an unboxed sum type.+-- The sum should be saturated: as many visible arguments as the arity of+-- the sum.+ppr_sum :: PprPrec -> PromotionFlag -> IfaceAppArgs -> SDoc+ppr_sum ctxt_prec = ppr_tuple_sum ctxt_prec IsSum++-- | Pretty-print a tuple type (boxed tuple, constraint tuple, unboxed tuple).+-- The tuple should be saturated: as many visible arguments as the arity of+-- the tuple.+ppr_tuple :: PprPrec -> TupleSort -> PromotionFlag -> IfaceAppArgs -> SDoc+ppr_tuple ctxt_prec sort = ppr_tuple_sum ctxt_prec (IsTuple sort)+ pprIfaceTyLit :: IfaceTyLit -> SDoc pprIfaceTyLit (IfaceNumTyLit n) = integer n pprIfaceTyLit (IfaceStrTyLit n) = text (show n)@@ -1853,14 +1888,15 @@     ppr_co funPrec co1 <+> pprParendIfaceCoercion co2 ppr_co ctxt_prec co@(IfaceForAllCo {})   = maybeParen ctxt_prec funPrec $+    -- FIXME: collect and pretty-print visibility info?     pprIfaceForAllCoPart tvs (pprIfaceCoercion inner_co)   where     (tvs, inner_co) = split_co co -    split_co (IfaceForAllCo (IfaceTvBndr (name, _)) kind_co co')-      = let (tvs, co'') = split_co co' in ((name,kind_co):tvs,co'')-    split_co (IfaceForAllCo (IfaceIdBndr (_, name, _)) kind_co co')-      = let (tvs, co'') = split_co co' in ((name,kind_co):tvs,co'')+    split_co (IfaceForAllCo (IfaceTvBndr (name, _)) visL visR kind_co co')+      = let (tvs, co'') = split_co co' in ((name,kind_co,visL,visR):tvs,co'')+    split_co (IfaceForAllCo (IfaceIdBndr (_, name, _)) visL visR kind_co co')+      = let (tvs, co'') = split_co co' in ((name,kind_co,visL,visR):tvs,co'')     split_co co' = ([], co')  -- Why these three? See Note [Free tyvars in IfaceType]@@ -1920,8 +1956,6 @@   = text "irrel" <+> pprParendIfaceCoercion co pprIfaceUnivCoProv (IfacePluginProv s)   = text "plugin" <+> doubleQuotes (text s)-pprIfaceUnivCoProv (IfaceCorePrepProv _)-  = text "CorePrep"  ------------------- instance Outputable IfaceTyCon where@@ -2166,9 +2200,11 @@           putByte bh 5           put_ bh a           put_ bh b-  put_ bh (IfaceForAllCo a b c) = do+  put_ bh (IfaceForAllCo a visL visR b c) = do           putByte bh 6           put_ bh a+          put_ bh visL+          put_ bh visR           put_ bh b           put_ bh c   put_ bh (IfaceCoVarCo a) = do@@ -2242,9 +2278,11 @@                    b <- get bh                    return $ IfaceAppCo a b            6 -> do a <- get bh+                   visL <- get bh+                   visR <- get bh                    b <- get bh                    c <- get bh-                   return $ IfaceForAllCo a b c+                   return $ IfaceForAllCo a visL visR b c            7 -> do a <- get bh                    return $ IfaceCoVarCo a            8 -> do a <- get bh@@ -2289,9 +2327,6 @@   put_ bh (IfacePluginProv a) = do           putByte bh 3           put_ bh a-  put_ bh (IfaceCorePrepProv a) = do-          putByte bh 4-          put_ bh a    get bh = do       tag <- getByte bh@@ -2302,8 +2337,6 @@                    return $ IfaceProofIrrelProv a            3 -> do a <- get bh                    return $ IfacePluginProv a-           4 -> do a <- get bh-                   return (IfaceCorePrepProv a)            _ -> panic ("get IfaceUnivCoProv " ++ show tag)  @@ -2342,7 +2375,7 @@     IfaceFunCo f1 f2 f3 f4 -> f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4     IfaceTyConAppCo f1 f2 f3 -> f1 `seq` rnf f2 `seq` rnf f3     IfaceAppCo f1 f2 -> rnf f1 `seq` rnf f2-    IfaceForAllCo f1 f2 f3 -> rnf f1 `seq` rnf f2 `seq` rnf f3+    IfaceForAllCo f1 f2 f3 f4 f5 -> rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` rnf f5     IfaceCoVarCo f1 -> rnf f1     IfaceAxiomInstCo f1 f2 f3 -> rnf f1 `seq` rnf f2 `seq` rnf f3     IfaceAxiomRuleCo f1 f2 -> rnf f1 `seq` rnf f2
+ compiler/GHC/JS/Ident.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE DerivingStrategies          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving  #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  GHC.JS.Ident+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  Jeffrey Young  <jeffrey.young@iohk.io>+--                Luite Stegeman <luite.stegeman@iohk.io>+--                Sylvain Henry  <sylvain.henry@iohk.io>+--                Josh Meredith  <josh.meredith@iohk.io>+-- Stability   :  experimental+--+--+-- * Domain and Purpose+--+--     GHC.JS.Ident defines identifiers for the JS backend. We keep this module+--     separate to prevent coupling between GHC and the backend and between+--     unrelated modules is the JS backend.+--+-- * Consumers+--+--     The entire JavaScript Backend consumes this module including modules in+--     GHC.JS.\* and modules in GHC.StgToJS.\*+--+-- * Additional Notes+--+--     This module should be kept as small as possible. Anything added to it+--     will be coupled to the JS backend EDSL and the JS Backend including the+--     linker and rts. You have been warned.+--+-----------------------------------------------------------------------------++module GHC.JS.Ident+  ( Ident(..)+  , global+  ) where++import Prelude++import GHC.Data.FastString+import GHC.Types.Unique++--------------------------------------------------------------------------------+--                            Identifiers+--------------------------------------------------------------------------------+-- We use FastString for identifiers in JS backend++-- | A newtype wrapper around 'FastString' for JS identifiers.+newtype Ident = TxtI { identFS :: FastString }+ deriving stock   (Show, Eq)+ deriving newtype (Uniquable)++-- | A not-so-smart constructor for @Ident@s, used to indicate that this name is+-- expected to be top-level+global :: FastString -> Ident+global = TxtI
+ compiler/GHC/JS/JStg/Monad.hs view
@@ -0,0 +1,111 @@+{-# LANGUAGE DerivingStrategies         #-}+{-# LANGUAGE OverloadedStrings          #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  GHC.JS.JStg.Monad+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  Jeffrey Young  <jeffrey.young@iohk.io>+--                Luite Stegeman <luite.stegeman@iohk.io>+--                Sylvain Henry  <sylvain.henry@iohk.io>+--                Josh Meredith  <josh.meredith@iohk.io>+-- Stability   :  experimental+--+--+-- * Domain and Purpose+--+--     GHC.JS.JStg.Monad defines the computational environment for the eDSL that+--     we use to write the JS Backend's RTS. Its purpose is to ensure unique+--     identifiers are generated throughout the backend and that we can use the+--     host language to ensure references are not mixed.+--+-- * Strategy+--+--     The monad is a straightforward state monad which holds an environment+--     holds a pointer to a prefix to tag identifiers with and an infinite+--     stream of identifiers.+--+-- * Usage+--+--     One should almost never need to directly use the functions in this+--     module. Instead one should opt to use the combinators in 'GHC.JS.Make',+--     the sole exception to this is the @withTag@ function which is used to+--     change the prefix of identifiers for a given computation. For example,+--     the rts uses this function to tag all identifiers generated by the RTS+--     code as RTS_N, where N is some unique.+-----------------------------------------------------------------------------+module GHC.JS.JStg.Monad+  ( runJSM+  , JSM+  , withTag+  , newIdent+  , initJSM+  ) where++import Prelude++import GHC.JS.Ident++import GHC.Types.Unique+import GHC.Types.Unique.Supply+import Control.Monad.Trans.State.Strict+import GHC.Data.FastString++--------------------------------------------------------------------------------+--                            JSM Monad+--------------------------------------------------------------------------------++-- | Environment for the JSM Monad. We maintain the prefix of each ident in the+-- environment to allow consumers to tag idents with a new prefix. See @withTag@+data JEnv = JEnv { prefix :: !FastString -- ^ prefix for generated names, e.g.,+                                         -- prefix = "RTS" will generate names+                                         -- such as 'h$RTS_jUt'+                 , ids    :: UniqSupply  -- ^ The supply of uniques for names+                                         -- generated by the JSM monad.+                 }++type JSM a = State JEnv a++runJSM :: JEnv -> JSM a -> a+runJSM env m = evalState m env++-- | create a new environment using the input tag.+initJSMState :: FastString -> UniqSupply -> JEnv+initJSMState tag supply = JEnv { prefix = tag+                               , ids    = supply+                               }+initJSM :: IO JEnv+initJSM = do supply <- mkSplitUniqSupply 'j'+             return (initJSMState "js" supply)++update_stream :: UniqSupply -> JSM ()+update_stream new = modify' $ \env -> env {ids = new}++-- | generate a fresh Ident+newIdent :: JSM Ident+newIdent = do env <- get+              let tag    = prefix env+                  supply = ids    env+                  (id,rest) = takeUniqFromSupply supply+              update_stream rest+              return  $ mk_ident tag id++mk_ident :: FastString -> Unique -> Ident+mk_ident t i = global (mconcat [t, "_", mkFastString (show i)])++-- | Set the tag for @Ident@s for all remaining computations.+tag_names :: FastString -> JSM ()+tag_names tag = modify' (\env -> env {prefix = tag})++-- | tag the name generater with a prefix for the monadic action.+withTag+  :: FastString -- ^ new name to tag with+  -> JSM a      -- ^ action to run with new tags+  -> JSM a      -- ^ result+withTag tag go = do+  old <- gets prefix+  tag_names tag+  result <- go+  tag_names old+  return result
+ compiler/GHC/JS/JStg/Syntax.hs view
@@ -0,0 +1,333 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE PatternSynonyms #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  GHC.JS.JStg.Syntax+-- Copyright   :  (c) The University of Glasgow 2001+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  Jeffrey Young  <jeffrey.young@iohk.io>+--                Luite Stegeman <luite.stegeman@iohk.io>+--                Sylvain Henry  <sylvain.henry@iohk.io>+--                Josh Meredith  <josh.meredith@iohk.io>+-- Stability   :  experimental+--+--+-- * Domain and Purpose+--+--     GHC.JS.JStg.Syntax defines the eDSL that the JS backend's runtime system+--     is written in. Nothing fancy, its just a straightforward deeply embedded+--     DSL.+--+-----------------------------------------------------------------------------+module GHC.JS.JStg.Syntax+  ( -- * Deeply embedded JS datatypes+    JStgStat(..)+  , JStgExpr(..)+  , JVal(..)+  , Op(..)+  , AOp(..)+  , UOp(..)+  , JsLabel+  -- * pattern synonyms over JS operators+  , pattern New+  , pattern Not+  , pattern Negate+  , pattern Add+  , pattern Sub+  , pattern Mul+  , pattern Div+  , pattern Mod+  , pattern BOr+  , pattern BAnd+  , pattern BXor+  , pattern BNot+  , pattern LOr+  , pattern LAnd+  , pattern Int+  , pattern String+  , pattern Var+  , pattern PreInc+  , pattern PostInc+  , pattern PreDec+  , pattern PostDec+  -- * Utility+  , SaneDouble(..)+  , pattern Func+  , var+  ) where++import GHC.Prelude+import GHC.Utils.Outputable++import GHC.JS.Ident++import Control.DeepSeq++import Data.Data+import qualified Data.Semigroup as Semigroup++import GHC.Generics++import GHC.Data.FastString+import GHC.Types.Unique.Map+import GHC.Types.SaneDouble++--------------------------------------------------------------------------------+--                            Statements+--------------------------------------------------------------------------------+-- | JavaScript statements, see the [ECMA262+-- Reference](https://tc39.es/ecma262/#sec-ecmascript-language-statements-and-declarations)+-- for details+data JStgStat+  = DeclStat   !Ident !(Maybe JStgExpr)         -- ^ Variable declarations: var foo [= e]+  | ReturnStat JStgExpr                         -- ^ Return+  | IfStat     JStgExpr JStgStat JStgStat       -- ^ If+  | WhileStat  Bool JStgExpr JStgStat           -- ^ While, bool is "do" when True+  | ForStat    JStgStat JStgExpr JStgStat JStgStat -- ^ For+  | ForInStat  Bool Ident JStgExpr JStgStat     -- ^ For-in, bool is "each' when True+  | SwitchStat JStgExpr [(JStgExpr, JStgStat)] JStgStat  -- ^ Switch+  | TryStat    JStgStat Ident JStgStat JStgStat          -- ^ Try+  | BlockStat  [JStgStat]                       -- ^ Blocks+  | ApplStat   JStgExpr [JStgExpr]              -- ^ Application+  | UOpStat UOp JStgExpr                        -- ^ Unary operators+  | AssignStat JStgExpr AOp JStgExpr            -- ^ Binding form: @foo = bar@+  | LabelStat JsLabel JStgStat                  -- ^ Statement Labels, makes me nostalgic for qbasic+  | BreakStat (Maybe JsLabel)                   -- ^ Break+  | ContinueStat (Maybe JsLabel)                -- ^ Continue+  | FuncStat   !Ident [Ident] JStgStat          -- ^ an explicit function definition+  deriving (Eq, Typeable, Generic)++-- | A Label used for 'JStgStat', specifically 'BreakStat', 'ContinueStat' and of+-- course 'LabelStat'+type JsLabel = LexicalFastString++instance Semigroup JStgStat where+  (<>) = appendJStgStat++instance Monoid JStgStat where+  mempty = BlockStat []++-- | Append a statement to another statement. 'appendJStgStat' only returns a+-- 'JStgStat' that is /not/ a 'BlockStat' when either @mx@ or @my is an empty+-- 'BlockStat'. That is:+-- > (BlockStat [] , y           ) = y+-- > (x            , BlockStat []) = x+appendJStgStat :: JStgStat -> JStgStat -> JStgStat+appendJStgStat mx my = case (mx,my) of+  (BlockStat [] , y           ) -> y+  (x            , BlockStat []) -> x+  (BlockStat xs , BlockStat ys) -> BlockStat $ xs ++ ys+  (BlockStat xs , ys          ) -> BlockStat $ xs ++ [ys]+  (xs           , BlockStat ys) -> BlockStat $ xs : ys+  (xs           , ys          ) -> BlockStat [xs,ys]+++--------------------------------------------------------------------------------+--                            Expressions+--------------------------------------------------------------------------------+-- | JavaScript Expressions+data JStgExpr+  = ValExpr    JVal                 -- ^ All values are trivially expressions+  | SelExpr    JStgExpr Ident       -- ^ Selection: Obj.foo, see 'GHC.JS.Make..^'+  | IdxExpr    JStgExpr JStgExpr    -- ^ Indexing:  Obj[foo], see 'GHC.JS.Make..!'+  | InfixExpr  Op JStgExpr JStgExpr -- ^ Infix Expressions, see 'JStgExpr' pattern synonyms+  | UOpExpr    UOp JStgExpr               -- ^ Unary Expressions+  | IfExpr     JStgExpr JStgExpr JStgExpr  -- ^ If-expression+  | ApplExpr   JStgExpr [JStgExpr]         -- ^ Application+  deriving (Eq, Typeable, Generic)++instance Outputable JStgExpr where+  ppr x = case x of+    ValExpr _ -> text ("ValExpr" :: String)+    SelExpr x' _ -> text ("SelExpr" :: String) <+> ppr x'+    IdxExpr x' y' -> text ("IdxExpr" :: String) <+> ppr (x', y')+    InfixExpr _ x' y' -> text ("InfixExpr" :: String) <+> ppr (x', y')+    UOpExpr _ x' -> text ("UOpExpr" :: String) <+> ppr x'+    IfExpr p t e -> text ("IfExpr" :: String) <+> ppr (p, t, e)+    ApplExpr x' xs -> text ("ApplExpr" :: String) <+> ppr (x', xs)++-- * Useful pattern synonyms to ease programming with the deeply embedded JS+--   AST. Each pattern wraps @UOp@ and @Op@ into a @JStgExpr@s to save typing and+--   for convienience. In addition we include a string wrapper for JS string+--   and Integer literals.++-- | pattern synonym for a unary operator new+pattern New :: JStgExpr -> JStgExpr+pattern New x = UOpExpr NewOp x++-- | pattern synonym for prefix increment @++x@+pattern PreInc :: JStgExpr -> JStgExpr+pattern PreInc x = UOpExpr PreIncOp x++-- | pattern synonym for postfix increment @x++@+pattern PostInc :: JStgExpr -> JStgExpr+pattern PostInc x = UOpExpr PostIncOp x++-- | pattern synonym for prefix decrement @--x@+pattern PreDec :: JStgExpr -> JStgExpr+pattern PreDec x = UOpExpr PreDecOp x++-- | pattern synonym for postfix decrement @--x@+pattern PostDec :: JStgExpr -> JStgExpr+pattern PostDec x = UOpExpr PostDecOp x++-- | pattern synonym for logical not @!@+pattern Not :: JStgExpr -> JStgExpr+pattern Not x = UOpExpr NotOp x++-- | pattern synonym for unary negation @-@+pattern Negate :: JStgExpr -> JStgExpr+pattern Negate x = UOpExpr NegOp x++-- | pattern synonym for addition @+@+pattern Add :: JStgExpr -> JStgExpr -> JStgExpr+pattern Add x y = InfixExpr AddOp x y++-- | pattern synonym for subtraction @-@+pattern Sub :: JStgExpr -> JStgExpr -> JStgExpr+pattern Sub x y = InfixExpr SubOp x y++-- | pattern synonym for multiplication @*@+pattern Mul :: JStgExpr -> JStgExpr -> JStgExpr+pattern Mul x y = InfixExpr MulOp x y++-- | pattern synonym for division @*@+pattern Div :: JStgExpr -> JStgExpr -> JStgExpr+pattern Div x y = InfixExpr DivOp x y++-- | pattern synonym for remainder @%@+pattern Mod :: JStgExpr -> JStgExpr -> JStgExpr+pattern Mod x y = InfixExpr ModOp x y++-- | pattern synonym for Bitwise Or @|@+pattern BOr :: JStgExpr -> JStgExpr -> JStgExpr+pattern BOr x y = InfixExpr BOrOp x y++-- | pattern synonym for Bitwise And @&@+pattern BAnd :: JStgExpr -> JStgExpr -> JStgExpr+pattern BAnd x y = InfixExpr BAndOp x y++-- | pattern synonym for Bitwise XOr @^@+pattern BXor :: JStgExpr -> JStgExpr -> JStgExpr+pattern BXor x y = InfixExpr BXorOp x y++-- | pattern synonym for Bitwise Not @~@+pattern BNot :: JStgExpr -> JStgExpr+pattern BNot x = UOpExpr BNotOp x++-- | pattern synonym for logical Or @||@+pattern LOr :: JStgExpr -> JStgExpr -> JStgExpr+pattern LOr x y = InfixExpr LOrOp x y++-- | pattern synonym for logical And @&&@+pattern LAnd :: JStgExpr -> JStgExpr -> JStgExpr+pattern LAnd x y = InfixExpr LAndOp x y+++-- | pattern synonym to create integer values+pattern Int :: Integer -> JStgExpr+pattern Int x = ValExpr (JInt x)++-- | pattern synonym to create string values+pattern String :: FastString -> JStgExpr+pattern String x = ValExpr (JStr x)++-- | pattern synonym to create a local variable reference+pattern Var :: Ident -> JStgExpr+pattern Var x = ValExpr (JVar x)++-- | pattern synonym to create an anonymous function+pattern Func :: [Ident] -> JStgStat -> JStgExpr+pattern Func args body = ValExpr (JFunc args body)++--------------------------------------------------------------------------------+--                            Values+--------------------------------------------------------------------------------+-- | JavaScript values+data JVal+  = JVar     Ident                      -- ^ A variable reference+  | JList    [JStgExpr]                 -- ^ A JavaScript list, or what JS+                                        --   calls an Array+  | JDouble  SaneDouble                 -- ^ A Double+  | JInt     Integer                    -- ^ A BigInt+  | JStr     FastString                 -- ^ A String+  | JRegEx   FastString                 -- ^ A Regex+  | JBool    Bool                       -- ^ A Boolean+  | JHash    (UniqMap FastString JStgExpr) -- ^ A JS HashMap: @{"foo": 0}@+  | JFunc    [Ident] JStgStat              -- ^ A function+  deriving (Eq, Typeable, Generic)++--------------------------------------------------------------------------------+--                            Operators+--------------------------------------------------------------------------------+-- | JS Binary Operators. We do not deeply embed the comma operator and the+-- assignment operators+data Op+  = EqOp            -- ^ Equality:              `==`+  | StrictEqOp      -- ^ Strict Equality:       `===`+  | NeqOp           -- ^ InEquality:            `!=`+  | StrictNeqOp     -- ^ Strict InEquality      `!==`+  | GtOp            -- ^ Greater Than:          `>`+  | GeOp            -- ^ Greater Than or Equal: `>=`+  | LtOp            -- ^ Less Than:              <+  | LeOp            -- ^ Less Than or Equal:     <=+  | AddOp           -- ^ Addition:               ++  | SubOp           -- ^ Subtraction:            -+  | MulOp           -- ^ Multiplication          \*+  | DivOp           -- ^ Division:               \/+  | ModOp           -- ^ Remainder:              %+  | LeftShiftOp     -- ^ Left Shift:             \<\<+  | RightShiftOp    -- ^ Right Shift:            \>\>+  | ZRightShiftOp   -- ^ Unsigned RightShift:    \>\>\>+  | BAndOp          -- ^ Bitwise And:            &+  | BOrOp           -- ^ Bitwise Or:             |+  | BXorOp          -- ^ Bitwise XOr:            ^+  | LAndOp          -- ^ Logical And:            &&+  | LOrOp           -- ^ Logical Or:             ||+  | InstanceofOp    -- ^ @instanceof@+  | InOp            -- ^ @in@+  deriving (Show, Eq, Ord, Enum, Data, Typeable, Generic)++instance NFData Op++-- | JS Unary Operators+data UOp+  = NotOp           -- ^ Logical Not: @!@+  | BNotOp          -- ^ Bitwise Not: @~@+  | NegOp           -- ^ Negation:    @-@+  | PlusOp          -- ^ Unary Plus:  @+x@+  | NewOp           -- ^ new    x+  | TypeofOp        -- ^ typeof x+  | DeleteOp        -- ^ delete x+  | YieldOp         -- ^ yield  x+  | VoidOp          -- ^ void   x+  | PreIncOp        -- ^ Prefix Increment:  @++x@+  | PostIncOp       -- ^ Postfix Increment: @x++@+  | PreDecOp        -- ^ Prefix Decrement:  @--x@+  | PostDecOp       -- ^ Postfix Decrement: @x--@+  deriving (Show, Eq, Ord, Enum, Data, Typeable, Generic)++instance NFData UOp++-- | JS Unary Operators+data AOp+  = AssignOp    -- ^ Vanilla  Assignment: =+  | AddAssignOp -- ^ Addition Assignment: +=+  | SubAssignOp -- ^ Subtraction Assignment: -=+  deriving (Show, Eq, Ord, Enum, Data, Typeable, Generic)++instance NFData AOp++-- | construct a JS variable reference+var :: FastString -> JStgExpr+var = Var . global
compiler/GHC/JS/Make.hs view
@@ -1,11 +1,14 @@+{-# LANGUAGE CPP               #-}+{-# LANGUAGE DataKinds         #-}+{-# LANGUAGE FlexibleContexts  #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs             #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE PatternSynonyms   #-}+{-# LANGUAGE RankNTypes        #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE GADTs #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -- only for Num, Fractional on JExpr+{-# OPTIONS_GHC -fno-warn-orphans #-} -- only for Num, Fractional on JStgExpr  ----------------------------------------------------------------------------- -- |@@ -41,15 +44,14 @@ --      * /Introduction/ functions -- --           We define various primitive helpers which /introduce/ terms in the---           EDSL, for example 'jVar', 'jLam', and 'var' and 'jString'. Notice---           that the type of each of these functions have the domain @isSat a---           => a -> ...@; indicating that they each take something that /can/---           be injected into the EDSL domain, and the range 'JExpr' or 'JStat';---           indicating the corresponding value in the EDSL domain. Similarly---           this module exports two typeclasses 'ToExpr' and 'ToSat', 'ToExpr'---           injects values as a JS expression into the EDSL. 'ToSat' ensures---           that terms introduced into the EDSL carry identifier information so---           terms in the EDSL must have meaning.+--           EDSL, for example 'jVar', 'jLam', and 'var' and 'jString'.+--           Similarly this module exports four typeclasses 'ToExpr', 'ToStat',+--           'JVarMagic', 'JSArgument'. 'ToExpr' injects values as a JS+--           expression into the EDSL. 'ToStat' injects values as JS statements+--           into the EDSL. @JVarMagic@ provides a polymorphic way to introduce+--           a new name into the EDSL and @JSArgument@ provides a polymorphic+--           way to bind variable names for use in JS functions with different+--           arities. -- --      * /Combinator/ functions --@@ -73,24 +75,30 @@ --     the JS EDSL domain to JS code. For example, @foo ||= bar ==> var foo; foo --     = bar;@ should be read as @foo ||= bar@ is in the EDSL domain and results --     in the JS code @var foo; foo = bar;@ when compiled.+--+--     In most cases functions prefixed with a 'j' are monadic because the+--     observably allocate. Notable exceptions are `jwhenS`, 'jString' and the+--     helpers for HashMaps. ----------------------------------------------------------------------------- module GHC.JS.Make   ( -- * Injection Type classes     -- $classes     ToJExpr(..)   , ToStat(..)+  , JVarMagic(..)+  , JSArgument(..)   -- * Introduction functions   -- $intro_funcs-  , var   , jString-  , jLam, jFun, jFunction, jVar, jFor, jForNoDecl, jForIn, jForEachIn, jTryCatchFinally+  , jLam, jLam', jFunction, jFunctionSized, jFunction'+  , jVar, jVars, jFor, jForIn, jForEachIn, jTryCatchFinally   -- * Combinators   -- $combinators   , (||=), (|=), (.==.), (.===.), (.!=.), (.!==.), (.!)   , (.>.), (.>=.), (.<.), (.<=.)   , (.<<.), (.>>.), (.>>>.)   , (.|.), (.||.), (.&&.)-  , if_, if10, if01, ifS, ifBlockS+  , if_, if10, if01, ifS, ifBlockS, jBlock, jIf   , jwhenS   , app, appS, returnS   , loop, loopBlockS@@ -125,20 +133,28 @@     math_atan, math_abs, math_pow, math_sqrt, math_asinh, math_acosh, math_atanh,     math_cosh, math_sinh, math_tanh, math_expm1, math_log1p, math_fround   -- * Statement helpers+  , Solo(..)   , decl+#if __GLASGOW_HASKELL__ < 905+  , pattern MkSolo+#endif   ) where  import GHC.Prelude hiding ((.|.)) -import GHC.JS.Unsat.Syntax+import GHC.JS.Ident+import GHC.JS.JStg.Syntax+import GHC.JS.JStg.Monad+import GHC.JS.Transform  import Control.Arrow ((***))+import Control.Monad (replicateM)+import Data.Tuple  import qualified Data.Map as M  import GHC.Data.FastString-import GHC.Utils.Monad.State.Strict import GHC.Utils.Misc import GHC.Types.Unique.Map @@ -152,14 +168,14 @@ -- | Things that can be marshalled into javascript values. -- Instantiate for any necessary data structures. class ToJExpr a where-    toJExpr         :: a   -> JExpr-    toJExprFromList :: [a] -> JExpr+    toJExpr         :: a   -> JStgExpr+    toJExprFromList :: [a] -> JStgExpr     toJExprFromList = ValExpr . JList . map toJExpr  instance ToJExpr a => ToJExpr [a] where     toJExpr = toJExprFromList -instance ToJExpr JExpr where+instance ToJExpr JStgExpr where     toJExpr = id  instance ToJExpr () where@@ -217,20 +233,29 @@ -- function 'GHC.JS.Make.expr2stat'. Instantiate for any necessary data -- structures. class ToStat a where-    toStat :: a -> JStat+    toStat :: a -> JStgStat -instance ToStat JStat where+instance ToStat JStgStat where     toStat = id -instance ToStat [JStat] where+instance ToStat [JStgStat] where     toStat = BlockStat -instance ToStat JExpr where+instance ToStat JStgExpr where     toStat = expr2stat -instance ToStat [JExpr] where+instance ToStat [JStgExpr] where     toStat = BlockStat . map expr2stat +-- | Convert A JS expression to a JS statement where applicable. This only+-- affects applications; 'ApplExpr', If-expressions; 'IfExpr', and Unary+-- expression; 'UOpExpr'.+expr2stat :: JStgExpr -> JStgStat+expr2stat (ApplExpr x y) = (ApplStat x y)+expr2stat (IfExpr x y z) = IfStat x (expr2stat y) (expr2stat z)+expr2stat (UOpExpr o x) = UOpStat o x+expr2stat _ = nullStat+ -------------------------------------------------------------------------------- --                        Introduction Functions --------------------------------------------------------------------------------@@ -244,52 +269,90 @@ -- -- > jLam $ \x -> jVar x + one_ -- > jLam $ \f -> (jLam $ \x -> (f `app` (x `app` x))) `app` (jLam $ \x -> (f `app` (x `app` x)))-jLam :: ToSat a => a -> JExpr-jLam f = ValExpr . UnsatVal . IS $ do-           (block,is) <- runIdentSupply $ toSat_ f []-           return $ JFunc is block+jLam :: JSArgument args => (args -> JSM JStgStat) -> JSM JStgExpr+jLam body = do xs <- args+               ValExpr . JFunc (argList xs) <$> body xs --- | Create a new function. The result is a 'GHC.JS.Syntax.JStat'.--- Usage:+-- | Special case of @jLam@ where the anonymous function requires no fresh+-- arguments.+jLam' :: JStgStat -> JStgExpr+jLam' body = ValExpr $ JFunc mempty body++-- | Introduce only one new variable into scope for the duration of the+-- enclosed expression. The result is a block statement. Usage: ----- > jFun fun_name $ \x -> ...-jFun :: ToSat a => Ident -> a -> JStat-jFun n f = UnsatBlock . IS $ do-           (block,is) <- runIdentSupply $ toSat_ f []-           return $ FuncStat n is block+-- 'jVar $ \x -> mconcat [jVar x ||= one_, ...'+jVar :: (JVarMagic t, ToJExpr t) => (t -> JSM JStgStat) -> JSM JStgStat+jVar f = jVars $ \(MkSolo only_one) -> f only_one --- | Introduce a new variable into scope for the duration--- of the enclosed expression. The result is a block statement.+-- | Introduce one or many new variables into scope for the duration of the+-- enclosed expression. This function reifies the number of arguments based on+-- the container of the input function. We intentionally avoid lists and instead+-- opt for tuples because lists are not sized in general. The result is a block+-- statement. Usage:+--+-- @jVars $ \(x,y) -> mconcat [ x |= one_,  y |= two_,  x + y]@+jVars :: (JSArgument args) => (args -> JSM JStgStat) -> JSM JStgStat+jVars f = do as   <- args+             body <- f as+             return $ mconcat $ fmap decl (argList as) ++ [body]++-- | Construct a top-level function subject to JS hoisting. This combinator is+-- polymorphic over function arity so you can you use to define a JS syntax+-- object in Haskell, which is a function in JS that takes 2 or 4 or whatever+-- arguments. For a singleton function use the @Solo@ constructor @MkSolo@. -- Usage: ----- @jVar $ \x y -> mconcat [x ||= one_, y ||= two_, x + y]@-jVar :: ToSat a => a -> JStat-jVar f = UnsatBlock . IS $ do-           (block, is) <- runIdentSupply $ toSat_ f []-           let addDecls (BlockStat ss) =-                  BlockStat $ map decl is ++ ss-               addDecls x = x-           return $ addDecls block+-- an example from the Rts that defines a 1-arity JS function+-- > jFunction (global "h$getReg") (\(MkSolo n) -> return $ SwitchStat n getRegCases mempty)+--+-- an example of a two argument function from the Rts+-- > jFunction (global "h$bh_lne") (\(x, frameSize) -> bhLneStats s x frameSize)+jFunction+  :: (JSArgument args)+  => Ident                  -- ^ global name+  -> (args -> JSM JStgStat) -- ^ function body, input is locally unique generated variables+  -> JSM JStgStat+jFunction name body = do+  func_args <- args+  FuncStat name (argList func_args) <$> (body func_args) -jFunction :: Ident -> [Ident] -> JStat -> JStat-jFunction name args body = FuncStat name args body+-- | Construct a top-level function subject to JS hoisting. Special case where+-- the arity cannot be deduced from the 'args' parameter (atleast not without+-- dependent types).+jFunctionSized+  :: Ident                        -- ^ global name+  -> Int                          -- ^ Arity+  -> ([JStgExpr] -> JSM JStgStat) -- ^ function body, input is locally unique generated variables+  -> JSM JStgStat+jFunctionSized name arity body = do+  func_args <- replicateM arity newIdent+  FuncStat name func_args <$> (body $ toJExpr <$> func_args) +-- | Construct a top-level function subject to JS hoisting. Special case where+-- the function binds no parameters+jFunction'+  :: Ident        -- ^ global name+  -> JSM JStgStat -- ^ function body, input is locally unique generated variables+  -> JSM JStgStat+jFunction' name body = FuncStat name mempty <$> body++jBlock :: Monoid a => [JSM a] -> JSM a+jBlock =  fmap mconcat . sequence+ -- | Create a 'for in' statement. -- Usage: -- -- @jForIn {expression} $ \x -> {block involving x}@-jForIn :: ToSat a => JExpr -> (JExpr -> a)  -> JStat-jForIn e f = UnsatBlock . IS $ do-               (block, is) <- runIdentSupply $ toSat_ f []-               let i = head is-               return $ decl i `mappend` ForInStat False i e block+jForIn :: JStgExpr -> (JStgExpr -> JStgStat) -> JSM JStgStat+jForIn e f = do+  i <- newIdent+  return $ decl i `mappend` ForInStat False i e (f (ValExpr $! JVar i))  -- | As with "jForIn" but creating a \"for each in\" statement.-jForEachIn :: ToSat a => JExpr -> (JExpr -> a) -> JStat-jForEachIn e f = UnsatBlock . IS $ do-               (block, is) <- runIdentSupply $ toSat_ f []-               let i = head is-               return $ decl i `mappend` ForInStat True i e block+jForEachIn :: JStgExpr -> (JStgExpr -> JStgStat) -> JSM JStgStat+jForEachIn e f = do i     <- newIdent+                    return $ decl i `mappend` ForInStat True i e (f (ValExpr $! JVar i))  -- | Create a 'for' statement given a function for initialization, a predicate -- to step to, a step and a body@@ -298,53 +361,47 @@ -- @ jFor (|= zero_) (.<. Int 65536) preIncrS --        (\j -> ...something with the counter j...)@ ---jFor :: (JExpr -> JStat)-     -> (JExpr -> JExpr)-     -> (JExpr -> JStat)-     -> (JExpr -> JStat)-     -> JStat-jFor init pred step body = jVar $ \i -> ForStat (init i) (pred i) (step i) (body i)--jForNoDecl :: Ident -> JExpr -> JExpr -> JStat -> JStat -> JStat-jForNoDecl i initial p step body = ForStat (toJExpr i |= initial) p step body+jFor :: (JStgExpr -> JStgStat) -- ^ initialization function+     -> (JStgExpr -> JStgExpr) -- ^ predicate+     -> (JStgExpr -> JStgStat) -- ^ step function+     -> (JStgExpr -> JStgStat) -- ^ body+     -> JSM JStgStat+jFor init pred step body = do id <- newIdent+                              let i = ValExpr (JVar id)+                              return+                                $ decl id `mappend` ForStat (init i) (pred i) (step i) (body i)  -- | As with "jForIn" but creating a \"for each in\" statement.-jTryCatchFinally :: (ToSat a) => JStat -> a -> JStat -> JStat-jTryCatchFinally s f s2 = UnsatBlock . IS $ do-                     (block, is) <- runIdentSupply $ toSat_ f []-                     let i = head is-                     return $ TryStat s i block s2---- | construct a JS variable reference-var :: FastString -> JExpr-var = ValExpr . JVar . TxtI+jTryCatchFinally :: (Ident -> JStgStat) -> (Ident -> JStgStat) -> (Ident -> JStgStat) -> JSM JStgStat+jTryCatchFinally c f f2 = do i <- newIdent+                             return $ TryStat (c i) i (f i) (f2 i)  -- | Convert a ShortText to a Javascript String-jString :: FastString -> JExpr+jString :: FastString -> JStgExpr jString = toJExpr  -- | construct a js declaration with the given identifier-decl :: Ident -> JStat+decl :: Ident -> JStgStat decl i = DeclStat i Nothing  -- | The empty JS HashMap-jhEmpty :: M.Map k JExpr+jhEmpty :: M.Map k JStgExpr jhEmpty = M.empty  -- | A singleton JS HashMap-jhSingle :: (Ord k, ToJExpr a) => k -> a -> M.Map k JExpr+jhSingle :: (Ord k, ToJExpr a) => k -> a -> M.Map k JStgExpr jhSingle k v = jhAdd k v jhEmpty  -- | insert a key-value pair into a JS HashMap-jhAdd :: (Ord k, ToJExpr a) => k -> a -> M.Map k JExpr -> M.Map k JExpr+jhAdd :: (Ord k, ToJExpr a) => k -> a -> M.Map k JStgExpr -> M.Map k JStgExpr jhAdd  k v m = M.insert k (toJExpr v) m  -- | Construct a JS HashMap from a list of key-value pairs-jhFromList :: [(FastString, JExpr)] -> JVal+jhFromList :: [(FastString, JStgExpr)] -> JVal jhFromList = JHash . listToUniqMap  -- | The empty JS statement-nullStat :: JStat+nullStat :: JStgStat nullStat = BlockStat []  @@ -356,7 +413,7 @@ -- EDSL domain.  -- | JS infix Equality operators-(.==.), (.===.), (.!=.), (.!==.) :: JExpr -> JExpr -> JExpr+(.==.), (.===.), (.!=.), (.!==.) :: JStgExpr -> JStgExpr -> JStgExpr (.==.)  = InfixExpr EqOp (.===.) = InfixExpr StrictEqOp (.!=.)  = InfixExpr NeqOp@@ -365,7 +422,7 @@ infixl 6 .==., .===., .!=., .!==.  -- | JS infix Ord operators-(.>.), (.>=.), (.<.), (.<=.) :: JExpr -> JExpr -> JExpr+(.>.), (.>=.), (.<.), (.<=.) :: JStgExpr -> JStgExpr -> JStgExpr (.>.)  = InfixExpr GtOp (.>=.) = InfixExpr GeOp (.<.)  = InfixExpr LtOp@@ -374,7 +431,7 @@ infixl 7 .>., .>=., .<., .<=.  -- | JS infix bit operators-(.|.), (.||.), (.&&.)  :: JExpr -> JExpr -> JExpr+(.|.), (.||.), (.&&.)  :: JStgExpr -> JStgExpr -> JStgExpr (.|.)   = InfixExpr BOrOp (.||.)  = InfixExpr LOrOp (.&&.)  = InfixExpr LAndOp@@ -382,146 +439,157 @@ infixl 8 .||., .&&.  -- | JS infix bit shift operators-(.<<.), (.>>.), (.>>>.) :: JExpr -> JExpr -> JExpr+(.<<.), (.>>.), (.>>>.) :: JStgExpr -> JStgExpr -> JStgExpr (.<<.)  = InfixExpr LeftShiftOp (.>>.)  = InfixExpr RightShiftOp (.>>>.) = InfixExpr ZRightShiftOp  infixl 9 .<<., .>>., .>>>. --- | Given a 'JExpr', return the its type.-typeof :: JExpr -> JExpr+-- | Given a 'JStgExpr', return the its type.+typeof :: JStgExpr -> JStgExpr typeof = UOpExpr TypeofOp  -- | JS if-expression -- -- > if_ e1 e2 e3 ==> e1 ? e2 : e3-if_ :: JExpr -> JExpr -> JExpr -> JExpr+if_ :: JStgExpr -> JStgExpr -> JStgExpr -> JStgExpr if_ e1 e2 e3 = IfExpr e1 e2 e3  -- | If-expression which returns statements, see related 'ifBlockS' -- -- > if e s1 s2 ==> if(e) { s1 } else { s2 }-ifS :: JExpr -> JStat -> JStat -> JStat+ifS :: JStgExpr -> JStgStat -> JStgStat -> JStgStat ifS e s1 s2 = IfStat e s1 s2 ++-- | Version of a JS if-expression which admits monadic actions in its branches+jIf :: JStgExpr -> JSM JStgStat -> JSM JStgStat -> JSM JStgStat+jIf e ma mb = do+  !a <- ma+  !b <- mb+  pure $ IfStat e a b+ -- | A when-statement as syntactic sugar via `ifS` -- -- > jwhenS cond block ==> if(cond) { block } else {  }-jwhenS :: JExpr -> JStat -> JStat-jwhenS cond block = ifS cond block mempty+jwhenS :: JStgExpr -> JStgStat -> JStgStat+jwhenS cond block = IfStat cond block mempty  -- | If-expression which returns blocks -- -- > ifBlockS e s1 s2 ==> if(e) { s1 } else { s2 }-ifBlockS :: JExpr -> [JStat] -> [JStat] -> JStat+ifBlockS :: JStgExpr -> [JStgStat] -> [JStgStat] -> JStgStat ifBlockS e s1 s2 = IfStat e (mconcat s1) (mconcat s2)  -- | if-expression that returns 1 if condition <=> true, 0 otherwise -- -- > if10 e ==> e ? 1 : 0-if10 :: JExpr -> JExpr+if10 :: JStgExpr -> JStgExpr if10 e = IfExpr e one_ zero_  -- | if-expression that returns 0 if condition <=> true, 1 otherwise -- -- > if01 e ==> e ? 0 : 1-if01 :: JExpr -> JExpr+if01 :: JStgExpr -> JStgExpr if01 e = IfExpr e zero_ one_  -- | an expression application, see related 'appS' -- -- > app f xs ==> f(xs)-app :: FastString -> [JExpr] -> JExpr+app :: FastString -> [JStgExpr] -> JStgExpr app f xs = ApplExpr (var f) xs  -- | A statement application, see the expression form 'app'-appS :: FastString -> [JExpr] -> JStat+appS :: FastString -> [JStgExpr] -> JStgStat appS f xs = ApplStat (var f) xs --- | Return a 'JExpr'-returnS :: JExpr -> JStat+-- | Return a 'JStgExpr'+returnS :: JStgExpr -> JStgStat returnS e = ReturnStat e  -- | "for" loop with increment at end of body-loop :: JExpr -> (JExpr -> JExpr) -> (JExpr -> JStat) -> JStat-loop initial test body = jVar $ \i ->-  mconcat [ i |= initial-          , WhileStat False (test i) (body i)-          ]+loop :: JStgExpr -> (JStgExpr -> JStgExpr) -> (JStgExpr -> JSM JStgStat) -> JSM JStgStat+loop initial test body_ = jVar $ \i ->+  do body <- body_ i+     return $+       mconcat [ i |= initial+               , WhileStat False (test i) body+               ]  -- | "for" loop with increment at end of body-loopBlockS :: JExpr -> (JExpr -> JExpr) -> (JExpr -> [JStat]) -> JStat+loopBlockS :: JStgExpr -> (JStgExpr -> JStgExpr) -> (JStgExpr -> [JStgStat]) -> JSM JStgStat loopBlockS initial test body = jVar $ \i ->+  return $   mconcat [ i |= initial           , WhileStat False (test i) (mconcat (body i))           ] --- | Prefix-increment a 'JExpr'-preIncrS :: JExpr -> JStat+-- | Prefix-increment a 'JStgExpr'+preIncrS :: JStgExpr -> JStgStat preIncrS x = UOpStat PreIncOp x --- | Postfix-increment a 'JExpr'-postIncrS :: JExpr -> JStat+-- | Postfix-increment a 'JStgExpr'+postIncrS :: JStgExpr -> JStgStat postIncrS x = UOpStat PostIncOp x --- | Prefix-decrement a 'JExpr'-preDecrS :: JExpr -> JStat+-- | Prefix-decrement a 'JStgExpr'+preDecrS :: JStgExpr -> JStgStat preDecrS x = UOpStat PreDecOp x --- | Postfix-decrement a 'JExpr'-postDecrS :: JExpr -> JStat+-- | Postfix-decrement a 'JStgExpr'+postDecrS :: JStgExpr -> JStgStat postDecrS x = UOpStat PostDecOp x  -- | Byte indexing of o with a 64-bit offset-off64 :: JExpr -> JExpr -> JExpr+off64 :: JStgExpr -> JStgExpr -> JStgExpr off64 o i = Add o (i .<<. three_)  -- | Byte indexing of o with a 32-bit offset-off32 :: JExpr -> JExpr -> JExpr+off32 :: JStgExpr -> JStgExpr -> JStgExpr off32 o i = Add o (i .<<. two_)  -- | Byte indexing of o with a 16-bit offset-off16 :: JExpr -> JExpr -> JExpr+off16 :: JStgExpr -> JStgExpr -> JStgExpr off16 o i = Add o (i .<<. one_)  -- | Byte indexing of o with a 8-bit offset-off8 :: JExpr -> JExpr -> JExpr+off8 :: JStgExpr -> JStgExpr -> JStgExpr off8 o i = Add o i  -- | a bit mask to retrieve the lower 8-bits-mask8 :: JExpr -> JExpr+mask8 :: JStgExpr -> JStgExpr mask8 x = BAnd x (Int 0xFF)  -- | a bit mask to retrieve the lower 16-bits-mask16 :: JExpr -> JExpr+mask16 :: JStgExpr -> JStgExpr mask16 x = BAnd x (Int 0xFFFF)  -- | Sign-extend/narrow a 8-bit value-signExtend8 :: JExpr -> JExpr+signExtend8 :: JStgExpr -> JStgExpr signExtend8 x = (BAnd x (Int 0x7F  )) `Sub` (BAnd x (Int 0x80))  -- | Sign-extend/narrow a 16-bit value-signExtend16 :: JExpr -> JExpr+signExtend16 :: JStgExpr -> JStgExpr signExtend16 x = (BAnd x (Int 0x7FFF)) `Sub` (BAnd x (Int 0x8000))  -- | Select a property 'prop', from and object 'obj' -- -- > obj .^ prop ==> obj.prop-(.^) :: JExpr -> FastString -> JExpr-obj .^ prop = SelExpr obj (TxtI prop)+(.^) :: JStgExpr -> FastString -> JStgExpr+obj .^ prop = SelExpr obj (global prop) infixl 8 .^  -- | Assign a variable to an expression -- -- > foo |= expr ==> var foo = expr;-(|=) :: JExpr -> JExpr -> JStat-(|=) = AssignStat+(|=) :: JStgExpr -> JStgExpr -> JStgStat+(|=) l r = AssignStat l AssignOp r  -- | Declare a variable and then Assign the variable to an expression -- -- > foo |= expr ==> var foo; foo = expr;-(||=) :: Ident -> JExpr -> JStat+(||=) :: Ident -> JStgExpr -> JStgStat i ||= ex = DeclStat i (Just ex)  infixl 2 ||=, |=@@ -529,24 +597,24 @@ -- | return the expression at idx of obj -- -- > obj .! idx ==> obj[idx]-(.!) :: JExpr -> JExpr -> JExpr+(.!) :: JStgExpr -> JStgExpr -> JStgExpr (.!) = IdxExpr  infixl 8 .! -assignAllEqual :: HasDebugCallStack => [JExpr] -> [JExpr] -> JStat+assignAllEqual :: HasDebugCallStack => [JStgExpr] -> [JStgExpr] -> JStgStat assignAllEqual xs ys = mconcat (zipWithEqual "assignAllEqual" (|=) xs ys) -assignAll :: [JExpr] -> [JExpr] -> JStat+assignAll :: [JStgExpr] -> [JStgExpr] -> JStgStat assignAll xs ys = mconcat (zipWith (|=) xs ys) -assignAllReverseOrder :: [JExpr] -> [JExpr] -> JStat+assignAllReverseOrder :: [JStgExpr] -> [JStgExpr] -> JStgStat assignAllReverseOrder xs ys = mconcat (reverse (zipWith (|=) xs ys)) -declAssignAll :: [Ident] -> [JExpr] -> JStat+declAssignAll :: [Ident] -> [JStgExpr] -> JStgStat declAssignAll xs ys = mconcat (zipWith (||=) xs ys) -trace :: ToJExpr a => a -> JStat+trace :: ToJExpr a => a -> JStgStat trace ex = appS "h$log" [toJExpr ex]  @@ -558,38 +626,38 @@ -- helper values and never change  -- | The JS literal 'null'-null_ :: JExpr+null_ :: JStgExpr null_ = var "null"  -- | The JS literal 0-zero_ :: JExpr+zero_ :: JStgExpr zero_ = Int 0  -- | The JS literal 1-one_ :: JExpr+one_ :: JStgExpr one_ = Int 1  -- | The JS literal 2-two_ :: JExpr+two_ :: JStgExpr two_ = Int 2  -- | The JS literal 3-three_ :: JExpr+three_ :: JStgExpr three_ = Int 3  -- | The JS literal 'undefined'-undefined_ :: JExpr+undefined_ :: JStgExpr undefined_ = var "undefined"  -- | The JS literal 'true'-true_ :: JExpr-true_ = var "true"+true_ :: JStgExpr+true_ = ValExpr (JBool True)  -- | The JS literal 'false'-false_ :: JExpr-false_ = var "false"+false_ :: JStgExpr+false_ = ValExpr (JBool False) -returnStack :: JStat+returnStack :: JStgStat returnStack = ReturnStat (ApplExpr (var "h$rs") [])  @@ -600,16 +668,16 @@ -- Math functions in the EDSL are literals, with the exception of 'math_' which -- is the sole math introduction function. -math :: JExpr+math :: JStgExpr math = var "Math" -math_ :: FastString -> [JExpr] -> JExpr+math_ :: FastString -> [JStgExpr] -> JStgExpr math_ op args = ApplExpr (math .^ op) args  math_log, math_sin, math_cos, math_tan, math_exp, math_acos, math_asin, math_atan,   math_abs, math_pow, math_sqrt, math_asinh, math_acosh, math_atanh, math_sign,   math_sinh, math_cosh, math_tanh, math_expm1, math_log1p, math_fround-  :: [JExpr] -> JExpr+  :: [JStgExpr] -> JStgExpr math_log   = math_ "log" math_sin   = math_ "sin" math_cos   = math_ "cos"@@ -632,7 +700,7 @@ math_log1p = math_ "log1p" math_fround = math_ "fround" -instance Num JExpr where+instance Num JStgExpr where     x + y = InfixExpr AddOp x y     x - y = InfixExpr SubOp x y     x * y = InfixExpr MulOp x y@@ -641,52 +709,138 @@     signum x = math_sign [x]     fromInteger x = ValExpr (JInt x) -instance Fractional JExpr where+instance Fractional JStgExpr where     x / y = InfixExpr DivOp x y     fromRational x = ValExpr (JDouble (realToFrac x))  +-- The Solo constructor was renamed to MkSolo in ghc 9.5+#if __GLASGOW_HASKELL__ < 905+pattern MkSolo :: a -> Solo a+pattern MkSolo a = Solo a+{-# COMPLETE MkSolo #-}+#endif+ -------------------------------------------------------------------------------- -- New Identifiers -------------------------------------------------------------------------------- --- | The 'ToSat' class is heavily used in the Introduction function. It ensures--- that all identifiers in the EDSL are tracked and named with an 'IdentSupply'.-class ToSat a where-    toSat_ :: a -> [Ident] -> IdentSupply (JStat, [Ident])+-- | Type class that generates fresh @a@'s for the JS backend. You should almost+-- never need to use this directly. Instead use @JSArgument@, for examples of+-- how to employ these classes please see @jVar@, @jFunction@ and call sites in+-- the Rts.+class JVarMagic a where+  fresh :: JSM a -instance ToSat [JStat] where-    toSat_ f vs = IS $ return $ (BlockStat f, reverse vs)+-- | Type class that finds the form of arguments required for a JS syntax+-- object. This class gives us a single interface to generate variables for+-- functions that have different arities. Thus with it, we can have only one+-- @jFunction@ which is polymorphic over its arity, instead of 'jFunction2',+-- 'jFunction3' and so on.+class JSArgument args where+  argList :: args -> [Ident]+  args :: JSM args -instance ToSat JStat where-    toSat_ f vs = IS $ return $ (f, reverse vs)+instance JVarMagic Ident where+  fresh = newIdent -instance ToSat JExpr where-    toSat_ f vs = IS $ return $ (toStat f, reverse vs)+instance JVarMagic JVal where+  fresh = JVar <$> fresh -instance ToSat [JExpr] where-    toSat_ f vs = IS $ return $ (BlockStat $ map expr2stat f, reverse vs)+instance JVarMagic JStgExpr where+  fresh = do i <- fresh+             return $ ValExpr $ JVar i -instance (ToSat a, b ~ JExpr) => ToSat (b -> a) where-    toSat_ f vs = IS $ do-      x <- takeOneIdent-      runIdentSupply $ toSat_ (f (ValExpr $ JVar x)) (x:vs)+instance (JVarMagic a, ToJExpr a) => JSArgument (Solo a) where+  argList (MkSolo a) = concatMap identsE [toJExpr a]+  args = do i <- fresh+            return $ MkSolo i --- | Convert A JS expression to a JS statement where applicable. This only--- affects applications; 'ApplExpr', If-expressions; 'IfExpr', and Unary--- expression; 'UOpExpr'.-expr2stat :: JExpr -> JStat-expr2stat (ApplExpr x y) = (ApplStat x y)-expr2stat (IfExpr x y z) = IfStat x (expr2stat y) (expr2stat z)-expr2stat (UOpExpr o x) = UOpStat o x-expr2stat _ = nullStat+instance (JVarMagic a, JVarMagic b, ToJExpr a, ToJExpr b) => JSArgument (a,b) where+  argList (a,b) = concatMap identsE [toJExpr a , toJExpr b]+  args = (,) <$> fresh <*> fresh -takeOneIdent :: State [Ident] Ident-takeOneIdent = do-  xxs <- get-  case xxs of-    (x:xs) -> do-      put xs-      return x-    _ -> error "takeOneIdent: empty list"+instance ( JVarMagic a, ToJExpr a+         , JVarMagic b, ToJExpr b+         , JVarMagic c, ToJExpr c+         ) => JSArgument (a,b,c) where+  argList (a,b,c) = concatMap identsE [toJExpr a , toJExpr b, toJExpr c]+  args = (,,) <$> fresh <*> fresh <*> fresh +instance ( JVarMagic a, ToJExpr a+         , JVarMagic b, ToJExpr b+         , JVarMagic c, ToJExpr c+         , JVarMagic d, ToJExpr d+         ) => JSArgument (a,b,c,d) where+  argList (a,b,c,d) = concatMap identsE [toJExpr a , toJExpr b, toJExpr c, toJExpr d]+  args = (,,,) <$> fresh <*> fresh <*> fresh <*> fresh++instance ( JVarMagic a, ToJExpr a+         , JVarMagic b, ToJExpr b+         , JVarMagic c, ToJExpr c+         , JVarMagic d, ToJExpr d+         , JVarMagic e, ToJExpr e+         ) => JSArgument (a,b,c,d,e) where+  argList (a,b,c,d,e) = concatMap identsE [toJExpr a , toJExpr b, toJExpr c, toJExpr d, toJExpr e]+  args = (,,,,) <$> fresh <*> fresh <*> fresh <*> fresh <*> fresh++instance ( JVarMagic a, ToJExpr a+         , JVarMagic b, ToJExpr b+         , JVarMagic c, ToJExpr c+         , JVarMagic d, ToJExpr d+         , JVarMagic e, ToJExpr e+         , JVarMagic f, ToJExpr f+         ) => JSArgument (a,b,c,d,e,f) where+  argList (a,b,c,d,e,f) =  concatMap identsE [toJExpr a , toJExpr b, toJExpr c, toJExpr d, toJExpr e, toJExpr f]+  args = (,,,,,) <$> fresh <*> fresh <*> fresh <*> fresh <*> fresh <*> fresh++instance ( JVarMagic a, ToJExpr a+         , JVarMagic b, ToJExpr b+         , JVarMagic c, ToJExpr c+         , JVarMagic d, ToJExpr d+         , JVarMagic e, ToJExpr e+         , JVarMagic f, ToJExpr f+         , JVarMagic g, ToJExpr g+         ) => JSArgument (a,b,c,d,e,f,g) where+  argList (a,b,c,d,e,f,g) = concatMap identsE [toJExpr a , toJExpr b, toJExpr c, toJExpr d, toJExpr e, toJExpr f, toJExpr g]+  args = (,,,,,,) <$> fresh <*> fresh <*> fresh <*> fresh <*> fresh <*> fresh <*> fresh++instance ( JVarMagic a, ToJExpr a+         , JVarMagic b, ToJExpr b+         , JVarMagic c, ToJExpr c+         , JVarMagic d, ToJExpr d+         , JVarMagic e, ToJExpr e+         , JVarMagic f, ToJExpr f+         , JVarMagic g, ToJExpr g+         , JVarMagic h, ToJExpr h+         ) => JSArgument (a,b,c,d,e,f,g,h) where+  argList (a,b,c,d,e,f,g,h) =  concatMap identsE [toJExpr a , toJExpr b, toJExpr c, toJExpr d, toJExpr e, toJExpr f, toJExpr g, toJExpr h]+  args = (,,,,,,,) <$> fresh <*> fresh <*> fresh <*> fresh <*> fresh <*> fresh <*> fresh <*> fresh++instance ( JVarMagic a, ToJExpr a+         , JVarMagic b, ToJExpr b+         , JVarMagic c, ToJExpr c+         , JVarMagic d, ToJExpr d+         , JVarMagic e, ToJExpr e+         , JVarMagic f, ToJExpr f+         , JVarMagic g, ToJExpr g+         , JVarMagic h, ToJExpr h+         , JVarMagic i, ToJExpr i+         ) => JSArgument (a,b,c,d,e,f,g,h,i) where+  argList (a,b,c,d,e,f,g,h,i) = concatMap identsE [toJExpr a , toJExpr b, toJExpr c, toJExpr d, toJExpr e, toJExpr f, toJExpr g, toJExpr h, toJExpr i]+  args = (,,,,,,,,) <$> fresh <*> fresh <*> fresh <*> fresh <*> fresh <*> fresh <*> fresh <*> fresh <*> fresh+++instance ( JVarMagic a, ToJExpr a+         , JVarMagic b, ToJExpr b+         , JVarMagic c, ToJExpr c+         , JVarMagic d, ToJExpr d+         , JVarMagic e, ToJExpr e+         , JVarMagic f, ToJExpr f+         , JVarMagic g, ToJExpr g+         , JVarMagic h, ToJExpr h+         , JVarMagic i, ToJExpr i+         , JVarMagic j, ToJExpr j+         ) => JSArgument (a,b,c,d,e,f,g,h,i,j) where+  argList (a,b,c,d,e,f,g,h,i,j) =  concatMap identsE [toJExpr a , toJExpr b, toJExpr c, toJExpr d, toJExpr e, toJExpr f, toJExpr g, toJExpr h, toJExpr i, toJExpr j]+  args = (,,,,,,,,,) <$> fresh <*> fresh <*> fresh <*> fresh <*> fresh <*> fresh <*> fresh <*> fresh <*> fresh <*> fresh
compiler/GHC/JS/Ppr.hs view
@@ -6,7 +6,6 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE BlockArguments #-}-{-# LANGUAGE TypeApplications #-}  -- For Outputable instances for JS syntax {-# OPTIONS_GHC -Wno-orphans #-}@@ -67,10 +66,9 @@  import GHC.Prelude +import GHC.JS.Ident import GHC.JS.Syntax-import GHC.JS.Transform - import Data.Char (isControl, ord) import Data.List (sortOn) @@ -117,10 +115,10 @@ -- | Render a syntax tree as a pretty-printable document, using a given prefix -- to all generated names. Use this with distinct prefixes to ensure distinct -- generated names between independent calls to render(Prefix)Js.-renderPrefixJs :: (JsToDoc a, JMacro a) => a -> SDoc+renderPrefixJs :: (JsToDoc a) => a -> SDoc renderPrefixJs = renderPrefixJs' defaultRenderJs -renderPrefixJs' :: (JsToDoc a, JMacro a, JsRender doc) => RenderJs doc -> a -> doc+renderPrefixJs' :: (JsToDoc a, JsRender doc) => RenderJs doc -> a -> doc renderPrefixJs' r = jsToDocR r  --------------------------------------------------------------------------------@@ -237,6 +235,7 @@     | otherwise -> integer i   JStr   s -> pprStringLit s   JRegEx s -> char '/' <> ftext s <> char '/'+  JBool b -> text (if b then "true" else "false")   JHash m     | isNullUniqMap m  -> text "{}"     | otherwise -> braceNest . foldl' (<+?>) empty . punctuate comma .@@ -247,7 +246,7 @@   JFunc is b -> parens $ hangBrace (text "function" <> parens (foldl' (<+?>) empty . punctuate comma . map (jsToDocR r) $ is)) (jsToDocR r b)  defRenderJsI :: JsRender doc => RenderJs doc -> Ident -> doc-defRenderJsI _ (TxtI t) = ftext t+defRenderJsI _  t = ftext (identFS t)  aOpText :: AOp -> FastString aOpText = \case
compiler/GHC/JS/Syntax.hs view
@@ -37,7 +37,7 @@ -- -- * Strategy -----     Nothing fancy in this module, this is a classic deeply embeded AST for+--     Nothing fancy in this module, this is a classic deeply embedded AST for --     JS. We define numerous ADTs and pattern synonyms to make pattern matching --     and constructing ASTs easier. --@@ -62,40 +62,41 @@   , Ident(..)   , JLabel   -- * pattern synonyms over JS operators-  , pattern JNew-  , pattern JNot-  , pattern JNegate-  , pattern JAdd-  , pattern JSub-  , pattern JMul-  , pattern JDiv-  , pattern JMod-  , pattern JBOr-  , pattern JBAnd-  , pattern JBXor-  , pattern JBNot-  , pattern JLOr-  , pattern JLAnd-  , pattern SatInt-  , pattern JString-  , pattern JPreInc-  , pattern JPostInc-  , pattern JPreDec-  , pattern JPostDec+  , pattern New+  , pattern Not+  , pattern Negate+  , pattern Add+  , pattern Sub+  , pattern Mul+  , pattern Div+  , pattern Mod+  , pattern BOr+  , pattern BAnd+  , pattern BXor+  , pattern BNot+  , pattern LOr+  , pattern LAnd+  , pattern Int+  , pattern String+  , pattern Var+  , pattern PreInc+  , pattern PostInc+  , pattern PreDec+  , pattern PostDec   -- * Utility   , SaneDouble(..)-  , jassignAll-  , jassignAllEqual-  , jvar+  , var+  , true_+  , false_   ) where  import GHC.Prelude -import GHC.JS.Unsat.Syntax (Ident(..))+import GHC.JS.Ident+ import GHC.Data.FastString import GHC.Types.Unique.Map import GHC.Types.SaneDouble-import GHC.Utils.Misc  import Control.DeepSeq @@ -170,90 +171,93 @@   deriving (Eq, Typeable, Generic)  -- * Useful pattern synonyms to ease programming with the deeply embedded JS---   AST. Each pattern wraps @JUOp@ and @JOp@ into a @JExpr@s to save typing and+--   AST. Each pattern wraps @UOp@ and @Op@ into a @JExpr@s to save typing and --   for convienience. In addition we include a string wrapper for JS string --   and Integer literals.  -- | pattern synonym for a unary operator new-pattern JNew :: JExpr -> JExpr-pattern JNew x = UOpExpr NewOp x+pattern New :: JExpr -> JExpr+pattern New x = UOpExpr NewOp x  -- | pattern synonym for prefix increment @++x@-pattern JPreInc :: JExpr -> JExpr-pattern JPreInc x = UOpExpr PreIncOp x+pattern PreInc :: JExpr -> JExpr+pattern PreInc x = UOpExpr PreIncOp x  -- | pattern synonym for postfix increment @x++@-pattern JPostInc :: JExpr -> JExpr-pattern JPostInc x = UOpExpr PostIncOp x+pattern PostInc :: JExpr -> JExpr+pattern PostInc x = UOpExpr PostIncOp x  -- | pattern synonym for prefix decrement @--x@-pattern JPreDec :: JExpr -> JExpr-pattern JPreDec x = UOpExpr PreDecOp x+pattern PreDec :: JExpr -> JExpr+pattern PreDec x = UOpExpr PreDecOp x  -- | pattern synonym for postfix decrement @--x@-pattern JPostDec :: JExpr -> JExpr-pattern JPostDec x = UOpExpr PostDecOp x+pattern PostDec :: JExpr -> JExpr+pattern PostDec x = UOpExpr PostDecOp x  -- | pattern synonym for logical not @!@-pattern JNot :: JExpr -> JExpr-pattern JNot x = UOpExpr NotOp x+pattern Not :: JExpr -> JExpr+pattern Not x = UOpExpr NotOp x  -- | pattern synonym for unary negation @-@-pattern JNegate :: JExpr -> JExpr-pattern JNegate x = UOpExpr NegOp x+pattern Negate :: JExpr -> JExpr+pattern Negate x = UOpExpr NegOp x  -- | pattern synonym for addition @+@-pattern JAdd :: JExpr -> JExpr -> JExpr-pattern JAdd x y = InfixExpr AddOp x y+pattern Add :: JExpr -> JExpr -> JExpr+pattern Add x y = InfixExpr AddOp x y  -- | pattern synonym for subtraction @-@-pattern JSub :: JExpr -> JExpr -> JExpr-pattern JSub x y = InfixExpr SubOp x y+pattern Sub :: JExpr -> JExpr -> JExpr+pattern Sub x y = InfixExpr SubOp x y  -- | pattern synonym for multiplication @*@-pattern JMul :: JExpr -> JExpr -> JExpr-pattern JMul x y = InfixExpr MulOp x y+pattern Mul :: JExpr -> JExpr -> JExpr+pattern Mul x y = InfixExpr MulOp x y  -- | pattern synonym for division @*@-pattern JDiv :: JExpr -> JExpr -> JExpr-pattern JDiv x y = InfixExpr DivOp x y+pattern Div :: JExpr -> JExpr -> JExpr+pattern Div x y = InfixExpr DivOp x y  -- | pattern synonym for remainder @%@-pattern JMod :: JExpr -> JExpr -> JExpr-pattern JMod x y = InfixExpr ModOp x y+pattern Mod :: JExpr -> JExpr -> JExpr+pattern Mod x y = InfixExpr ModOp x y  -- | pattern synonym for Bitwise Or @|@-pattern JBOr :: JExpr -> JExpr -> JExpr-pattern JBOr x y = InfixExpr BOrOp x y+pattern BOr :: JExpr -> JExpr -> JExpr+pattern BOr x y = InfixExpr BOrOp x y  -- | pattern synonym for Bitwise And @&@-pattern JBAnd :: JExpr -> JExpr -> JExpr-pattern JBAnd x y = InfixExpr BAndOp x y+pattern BAnd :: JExpr -> JExpr -> JExpr+pattern BAnd x y = InfixExpr BAndOp x y  -- | pattern synonym for Bitwise XOr @^@-pattern JBXor :: JExpr -> JExpr -> JExpr-pattern JBXor x y = InfixExpr BXorOp x y+pattern BXor :: JExpr -> JExpr -> JExpr+pattern BXor x y = InfixExpr BXorOp x y  -- | pattern synonym for Bitwise Not @~@-pattern JBNot :: JExpr -> JExpr-pattern JBNot x = UOpExpr BNotOp x+pattern BNot :: JExpr -> JExpr+pattern BNot x = UOpExpr BNotOp x  -- | pattern synonym for logical Or @||@-pattern JLOr :: JExpr -> JExpr -> JExpr-pattern JLOr x y = InfixExpr LOrOp x y+pattern LOr :: JExpr -> JExpr -> JExpr+pattern LOr x y = InfixExpr LOrOp x y  -- | pattern synonym for logical And @&&@-pattern JLAnd :: JExpr -> JExpr -> JExpr-pattern JLAnd x y = InfixExpr LAndOp x y+pattern LAnd :: JExpr -> JExpr -> JExpr+pattern LAnd x y = InfixExpr LAndOp x y  -- | pattern synonym to create integer values-pattern SatInt :: Integer -> JExpr-pattern SatInt x = ValExpr (JInt x)+pattern Int :: Integer -> JExpr+pattern Int x = ValExpr (JInt x)  -- | pattern synonym to create string values-pattern JString :: FastString -> JExpr-pattern JString x = ValExpr (JStr x)+pattern String :: FastString -> JExpr+pattern String x = ValExpr (JStr x) +-- | pattern synonym to create a local variable reference+pattern Var :: Ident -> JExpr+pattern Var x = ValExpr (JVar x)  -------------------------------------------------------------------------------- --                            Values@@ -267,6 +271,7 @@   | JInt     Integer      -- ^ A BigInt   | JStr     FastString   -- ^ A String   | JRegEx   FastString   -- ^ A Regex+  | JBool    Bool         -- ^ A Boolean   | JHash    (UniqMap FastString JExpr) -- ^ A JS HashMap: @{"foo": 0}@   | JFunc    [Ident] JStat             -- ^ A function   deriving (Eq, Typeable, Generic)@@ -334,18 +339,14 @@  instance NFData AOp ------------------------------------------------------------------------------------                            Helper Functions-----------------------------------------------------------------------------------jassignAllEqual :: [JExpr] -> [JExpr] -> JStat-jassignAllEqual xs ys = mconcat (zipWithEqual "assignAllEqual" go xs ys)-  where go l r = AssignStat l AssignOp r--jassignAll :: [JExpr] -> [JExpr] -> JStat-jassignAll xs ys = mconcat $ zipWith go xs ys-  where go l r = AssignStat l AssignOp r+-- | construct a JS variable reference+var :: FastString -> JExpr+var = Var . global -jvar :: FastString -> JExpr-jvar = ValExpr . JVar . TxtI+-- | The JS literal 'true'+true_ :: JExpr+true_ = ValExpr (JBool True) +-- | The JS literal 'false'+false_ :: JExpr+false_ = ValExpr (JBool False)
compiler/GHC/JS/Transform.hs view
@@ -1,6 +1,5 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -12,298 +11,168 @@   ( identsS   , identsV   , identsE-  -- * Saturation-  , satJStat-  , satJExpr-  -- * Generic traversal (via compos)-  , JMacro(..)-  , JMGadt(..)-  , Compos(..)-  , composOp-  , composOpM-  , composOpM_-  , composOpFold+  , jStgExprToJS+  , jStgStatToJS   ) where  import GHC.Prelude -import qualified GHC.JS.Syntax as Sat-import GHC.JS.Unsat.Syntax+import GHC.JS.Ident+import GHC.JS.JStg.Syntax+import qualified GHC.JS.Syntax as JS -import Data.Functor.Identity-import Control.Monad import Data.List (sortBy)  import GHC.Data.FastString-import GHC.Utils.Monad.State.Strict import GHC.Types.Unique.Map import GHC.Types.Unique.FM   {-# INLINE identsS #-}-identsS :: Sat.JStat -> [Ident]+identsS :: JStgStat -> [Ident] identsS = \case-  Sat.DeclStat i e       -> [i] ++ maybe [] identsE e-  Sat.ReturnStat e       -> identsE e-  Sat.IfStat e s1 s2     -> identsE e ++ identsS s1 ++ identsS s2-  Sat.WhileStat _ e s    -> identsE e ++ identsS s-  Sat.ForStat init p step body -> identsS init ++ identsE p ++ identsS step ++ identsS body-  Sat.ForInStat _ i e s  -> [i] ++ identsE e ++ identsS s-  Sat.SwitchStat e xs s  -> identsE e ++ concatMap traverseCase xs ++ identsS s-                               where traverseCase (e,s) = identsE e ++ identsS s-  Sat.TryStat s1 i s2 s3 -> identsS s1 ++ [i] ++ identsS s2 ++ identsS s3-  Sat.BlockStat xs       -> concatMap identsS xs-  Sat.ApplStat e es      -> identsE e ++ concatMap identsE es-  Sat.UOpStat _op e      -> identsE e-  Sat.AssignStat e1 _op e2 -> identsE e1 ++ identsE e2-  Sat.LabelStat _l s     -> identsS s-  Sat.BreakStat{}        -> []-  Sat.ContinueStat{}     -> []-  Sat.FuncStat i args body -> [i] ++ args ++ identsS body+  DeclStat i e       -> [i] ++ maybe [] identsE e+  ReturnStat e       -> identsE e+  IfStat e s1 s2     -> identsE e ++ identsS s1 ++ identsS s2+  WhileStat _ e s    -> identsE e ++ identsS s+  ForStat init p step body -> identsS init ++ identsE p ++ identsS step ++ identsS body+  ForInStat _ i e s  -> [i] ++ identsE e ++ identsS s+  SwitchStat e xs s  -> identsE e ++ concatMap traverseCase xs ++ identsS s+                           where traverseCase (e,s) = identsE e ++ identsS s+  TryStat s1 i s2 s3 -> identsS s1 ++ [i] ++ identsS s2 ++ identsS s3+  BlockStat xs       -> concatMap identsS xs+  ApplStat e es      -> identsE e ++ concatMap identsE es+  UOpStat _op e      -> identsE e+  AssignStat e1 _op e2 -> identsE e1 ++ identsE e2+  LabelStat _l s     -> identsS s+  BreakStat{}        -> []+  ContinueStat{}     -> []+  FuncStat i args body -> [i] ++ args ++ identsS body  {-# INLINE identsE #-}-identsE :: Sat.JExpr -> [Ident]+identsE :: JStgExpr -> [Ident] identsE = \case-  Sat.ValExpr v         -> identsV v-  Sat.SelExpr e _i      -> identsE e -- do not rename properties-  Sat.IdxExpr e1 e2     -> identsE e1 ++ identsE e2-  Sat.InfixExpr _ e1 e2 -> identsE e1 ++ identsE e2-  Sat.UOpExpr _ e       -> identsE e-  Sat.IfExpr e1 e2 e3   -> identsE e1 ++ identsE e2 ++ identsE e3-  Sat.ApplExpr e es     -> identsE e  ++ concatMap identsE es+  ValExpr v         -> identsV v+  SelExpr e _i      -> identsE e -- do not rename properties+  IdxExpr e1 e2     -> identsE e1 ++ identsE e2+  InfixExpr _ e1 e2 -> identsE e1 ++ identsE e2+  UOpExpr _ e       -> identsE e+  IfExpr e1 e2 e3   -> identsE e1 ++ identsE e2 ++ identsE e3+  ApplExpr e es     -> identsE e  ++ concatMap identsE es  {-# INLINE identsV #-}-identsV :: Sat.JVal -> [Ident]+identsV :: JVal -> [Ident] identsV = \case-  Sat.JVar i       -> [i]-  Sat.JList xs     -> concatMap identsE xs-  Sat.JDouble{}    -> []-  Sat.JInt{}       -> []-  Sat.JStr{}       -> []-  Sat.JRegEx{}     -> []-  Sat.JHash m      -> concatMap identsE (nonDetEltsUniqMap m)-  Sat.JFunc args s -> args ++ identsS s---{---------------------------------------------------------------------  Compos---------------------------------------------------------------------}--- | Compos and ops for generic traversal as defined over--- the JMacro ADT.---- | Utility class to coerce the ADT into a regular structure.--class JMacro a where-    jtoGADT :: a -> JMGadt a-    jfromGADT :: JMGadt a -> a--instance JMacro Ident where-    jtoGADT = JMGId-    jfromGADT (JMGId x) = x--instance JMacro JStat where-    jtoGADT = JMGStat-    jfromGADT (JMGStat x) = x--instance JMacro JExpr where-    jtoGADT = JMGExpr-    jfromGADT (JMGExpr x) = x--instance JMacro JVal where-    jtoGADT = JMGVal-    jfromGADT (JMGVal x) = x---- | Union type to allow regular traversal by compos.-data JMGadt a where-    JMGId   :: Ident -> JMGadt Ident-    JMGStat :: JStat -> JMGadt JStat-    JMGExpr :: JExpr -> JMGadt JExpr-    JMGVal  :: JVal  -> JMGadt JVal--composOp :: Compos t => (forall a. t a -> t a) -> t b -> t b-composOp f = runIdentity . composOpM (Identity . f)--composOpM :: (Compos t, Monad m) => (forall a. t a -> m (t a)) -> t b -> m (t b)-composOpM = compos return ap--composOpM_ :: (Compos t, Monad m) => (forall a. t a -> m ()) -> t b -> m ()-composOpM_ = composOpFold (return ()) (>>)--composOpFold :: Compos t => b -> (b -> b -> b) -> (forall a. t a -> b) -> t c -> b-composOpFold z c f = unC . compos (\_ -> C z) (\(C x) (C y) -> C (c x y)) (C . f)--newtype C b a = C { unC :: b }--class Compos t where-    compos :: (forall a. a -> m a) -> (forall a b. m (a -> b) -> m a -> m b)-           -> (forall a. t a -> m (t a)) -> t c -> m (t c)--instance Compos JMGadt where-    compos = jmcompos--jmcompos :: forall m c. (forall a. a -> m a) -> (forall a b. m (a -> b) -> m a -> m b) -> (forall a. JMGadt a -> m (JMGadt a)) -> JMGadt c -> m (JMGadt c)-jmcompos ret app f' v =-    case v of-     JMGId _ -> ret v-     JMGStat v' -> ret JMGStat `app` case v' of-           DeclStat i e -> ret DeclStat `app` f i `app` mapMaybeM' f e-           ReturnStat i -> ret ReturnStat `app` f i-           IfStat e s s' -> ret IfStat `app` f e `app` f s `app` f s'-           WhileStat b e s -> ret (WhileStat b) `app` f e `app` f s-           ForStat init p step body -> ret ForStat  `app` f init `app` f p-                                           `app` f step `app` f body-           ForInStat b i e s -> ret (ForInStat b) `app` f i `app` f e `app` f s-           SwitchStat e l d -> ret SwitchStat `app` f e `app` l' `app` f d-               where l' = mapM' (\(c,s) -> ret (,) `app` f c `app` f s) l-           BlockStat xs -> ret BlockStat `app` mapM' f xs-           ApplStat  e xs -> ret ApplStat `app` f e `app` mapM' f xs-           TryStat s i s1 s2 -> ret TryStat `app` f s `app` f i `app` f s1 `app` f s2-           UOpStat o e -> ret (UOpStat o) `app` f e-           AssignStat e e' -> ret AssignStat `app` f e `app` f e'-           UnsatBlock _ -> ret v'-           ContinueStat l -> ret (ContinueStat l)-           FuncStat i args body -> ret FuncStat `app` f i `app` mapM' f args `app` f body-           BreakStat l -> ret (BreakStat l)-           LabelStat l s -> ret (LabelStat l) `app` f s-     JMGExpr v' -> ret JMGExpr `app` case v' of-           ValExpr e -> ret ValExpr `app` f e-           SelExpr e e' -> ret SelExpr `app` f e `app` f e'-           IdxExpr e e' -> ret IdxExpr `app` f e `app` f e'-           InfixExpr o e e' -> ret (InfixExpr o) `app` f e `app` f e'-           UOpExpr o e -> ret (UOpExpr o) `app` f e-           IfExpr e e' e'' -> ret IfExpr `app` f e `app` f e' `app` f e''-           ApplExpr e xs -> ret ApplExpr `app` f e `app` mapM' f xs-           UnsatExpr _ -> ret v'-     JMGVal v' -> ret JMGVal `app` case v' of-           JVar i -> ret JVar `app` f i-           JList xs -> ret JList `app` mapM' f xs-           JDouble _ -> ret v'-           JInt    _ -> ret v'-           JStr    _ -> ret v'-           JRegEx  _ -> ret v'-           JHash   m -> ret JHash `app` m'-               -- nonDetEltsUniqMap doesn't introduce nondeterminism here because the-               -- elements are treated independently before being re-added to a UniqMap-               where (ls, vs) = unzip (nonDetUniqMapToList m)-                     m' = ret (listToUniqMap . zip ls) `app` mapM' f vs-           JFunc xs s -> ret JFunc `app` mapM' f xs `app` f s-           UnsatVal _ -> ret v'--  where-    mapM' :: forall a. (a -> m a) -> [a] -> m [a]-    mapM' g = foldr (app . app (ret (:)) . g) (ret [])-    mapMaybeM' :: forall a. (a -> m a) -> Maybe a -> m (Maybe a)-    mapMaybeM' g = \case-      Nothing -> ret Nothing-      Just a  -> app (ret Just) (g a)-    f :: forall b. JMacro b => b -> m b-    f x = ret jfromGADT `app` f' (jtoGADT x)--{---------------------------------------------------------------------  Saturation---------------------------------------------------------------------}---- | Given an optional prefix, fills in all free variable names with a supply--- of names generated by the prefix.-satJStat :: Maybe FastString -> JStat -> Sat.JStat-satJStat str x = evalState (jsSaturateS x) (newIdentSupply str)--satJExpr :: Maybe FastString -> JExpr -> Sat.JExpr-satJExpr str x = evalState (jsSaturateE x) (newIdentSupply str)+  JVar i       -> [i]+  JList xs     -> concatMap identsE xs+  JDouble{}    -> []+  JInt{}       -> []+  JStr{}       -> []+  JRegEx{}     -> []+  JBool{}      -> []+  JHash m      -> concatMap identsE (nonDetEltsUniqMap m)+  JFunc args s -> args ++ identsS s -jsSaturateS :: JStat -> State [Ident] Sat.JStat-jsSaturateS  = \case-  DeclStat i rhs        -> Sat.DeclStat i <$> mapM jsSaturateE rhs-  ReturnStat e          -> Sat.ReturnStat <$> jsSaturateE e-  IfStat c t e          -> Sat.IfStat <$> jsSaturateE c <*> jsSaturateS t <*> jsSaturateS e-  WhileStat is_do c e   -> Sat.WhileStat is_do <$> jsSaturateE c <*> jsSaturateS e-  ForStat init p step body -> Sat.ForStat <$> jsSaturateS init <*> jsSaturateE p-                                          <*> jsSaturateS step <*> jsSaturateS body-  ForInStat is_each i iter body -> Sat.ForInStat is_each i <$> jsSaturateE iter <*> jsSaturateS body-  SwitchStat struct ps def -> Sat.SwitchStat <$> jsSaturateE struct-                                             <*> mapM (\(p1, p2) -> (,) <$> jsSaturateE p1 <*> jsSaturateS p2) ps-                                             <*> jsSaturateS def-  TryStat t i c f       -> Sat.TryStat <$> jsSaturateS t <*> pure i <*> jsSaturateS c <*> jsSaturateS f-  BlockStat bs          -> fmap Sat.BlockStat $! mapM jsSaturateS bs-  ApplStat rator rand   -> Sat.ApplStat <$> jsSaturateE rator <*> mapM jsSaturateE rand-  UOpStat  rator rand   -> Sat.UOpStat (satJUOp rator) <$> jsSaturateE rand-  AssignStat lhs rhs    -> Sat.AssignStat <$> jsSaturateE lhs <*> pure Sat.AssignOp <*> jsSaturateE rhs-  LabelStat lbl stmt    -> Sat.LabelStat lbl <$> jsSaturateS stmt-  BreakStat m_l         -> return $ Sat.BreakStat $! m_l-  ContinueStat m_l      -> return $ Sat.ContinueStat $! m_l-  FuncStat i args body  -> Sat.FuncStat i args <$> jsSaturateS body-  UnsatBlock us         -> jsSaturateS =<< runIdentSupply us+--------------------------------------------------------------------------------+--                            Translation+--+--------------------------------------------------------------------------------+jStgStatToJS :: JStgStat -> JS.JStat+jStgStatToJS  = \case+  DeclStat i rhs        -> JS.DeclStat i $ fmap jStgExprToJS rhs+  ReturnStat e          -> JS.ReturnStat $ jStgExprToJS e+  IfStat c t e          -> JS.IfStat (jStgExprToJS c) (jStgStatToJS t) (jStgStatToJS e)+  WhileStat is_do c e   -> JS.WhileStat is_do (jStgExprToJS c) (jStgStatToJS e)+  ForStat init p step body -> JS.ForStat  (jStgStatToJS init) (jStgExprToJS p)+                                           (jStgStatToJS step) (jStgStatToJS body)+  ForInStat is_each i iter body -> JS.ForInStat (is_each) i (jStgExprToJS iter) (jStgStatToJS body)+  SwitchStat struct ps def -> JS.SwitchStat+                              (jStgExprToJS struct)+                              (map (\(p1, p2) -> (jStgExprToJS p1, jStgStatToJS p2)) ps)+                              (jStgStatToJS def)+  TryStat t i c f       -> JS.TryStat (jStgStatToJS t) i (jStgStatToJS c) (jStgStatToJS f)+  BlockStat bs          -> JS.BlockStat $ map jStgStatToJS bs+  ApplStat rator rand   -> JS.ApplStat (jStgExprToJS rator) $ map jStgExprToJS rand+  UOpStat  rator rand   -> JS.UOpStat (jStgUOpToJS rator) (jStgExprToJS rand)+  AssignStat lhs op rhs -> JS.AssignStat (jStgExprToJS lhs) (jStgAOpToJS op) (jStgExprToJS rhs)+  LabelStat lbl stmt    -> JS.LabelStat lbl (jStgStatToJS stmt)+  BreakStat m_l         -> JS.BreakStat $! m_l+  ContinueStat m_l      -> JS.ContinueStat $! m_l+  FuncStat i args body  -> JS.FuncStat i args $ jStgStatToJS body -jsSaturateE :: JExpr -> State [Ident] Sat.JExpr-jsSaturateE = \case-  ValExpr v            -> Sat.ValExpr <$> jsSaturateV v-  SelExpr obj i        -> Sat.SelExpr <$> jsSaturateE obj <*> pure i-  IdxExpr o i          -> Sat.IdxExpr <$> jsSaturateE o <*> jsSaturateE i-  InfixExpr op l r     -> Sat.InfixExpr (satJOp op) <$> jsSaturateE l <*> jsSaturateE r-  UOpExpr op r         -> Sat.UOpExpr (satJUOp op) <$> jsSaturateE r-  IfExpr c t e         -> Sat.IfExpr <$> jsSaturateE c <*> jsSaturateE t <*> jsSaturateE e-  ApplExpr rator rands -> Sat.ApplExpr <$> jsSaturateE rator <*> mapM jsSaturateE rands-  UnsatExpr us         -> jsSaturateE =<< runIdentSupply us+jStgExprToJS :: JStgExpr -> JS.JExpr+jStgExprToJS = \case+  ValExpr v            -> JS.ValExpr $ jStgValToJS v+  SelExpr obj i        -> JS.SelExpr (jStgExprToJS obj) i+  IdxExpr o i          -> JS.IdxExpr (jStgExprToJS o) (jStgExprToJS i)+  InfixExpr op l r     -> JS.InfixExpr (jStgOpToJS op) (jStgExprToJS l) (jStgExprToJS r)+  UOpExpr op r         -> JS.UOpExpr (jStgUOpToJS op) (jStgExprToJS r)+  IfExpr c t e         -> JS.IfExpr (jStgExprToJS c) (jStgExprToJS t) (jStgExprToJS e)+  ApplExpr rator rands -> JS.ApplExpr (jStgExprToJS rator) $ map jStgExprToJS rands -jsSaturateV :: JVal -> State [Ident] Sat.JVal-jsSaturateV = \case-  JVar i   -> return $ Sat.JVar i-  JList xs -> Sat.JList <$> mapM jsSaturateE xs-  JDouble d -> return $ Sat.JDouble (Sat.SaneDouble (unSaneDouble d))-  JInt i    -> return $ Sat.JInt   i-  JStr s    -> return $ Sat.JStr   s-  JRegEx f  -> return $ Sat.JRegEx f-  JHash m   -> Sat.JHash <$> mapUniqMapM satHash m+jStgValToJS :: JVal -> JS.JVal+jStgValToJS = \case+  JVar i   -> JS.JVar i+  JList xs -> JS.JList $ map jStgExprToJS xs+  JDouble d -> JS.JDouble d+  JInt i    -> JS.JInt   i+  JStr s    -> JS.JStr   s+  JRegEx f  -> JS.JRegEx f+  JBool b   -> JS.JBool  b+  JHash m   -> JS.JHash $ mapUniqMapM satHash m     where-      satHash (i, x) = (i,) . (i,) <$> jsSaturateE x+      satHash (i, x) = (i,) . (i,) $ jStgExprToJS x       compareHash (i,_) (j,_) = lexicalCompareFS i j       -- By lexically sorting the elements, the non-determinism introduced by nonDetEltsUFM is avoided-      mapUniqMapM f (UniqMap m) = UniqMap . listToUFM <$> (mapM f . sortBy compareHash $ nonDetEltsUFM m)-  JFunc args body   -> Sat.JFunc args <$> jsSaturateS body-  UnsatVal us       -> jsSaturateV =<< runIdentSupply us+      mapUniqMapM f (UniqMap m) = UniqMap . listToUFM $ (map f . sortBy compareHash $ nonDetEltsUFM m)+  JFunc args body   -> JS.JFunc args $ jStgStatToJS body -satJOp :: JOp -> Sat.Op-satJOp = go+jStgOpToJS :: Op -> JS.Op+jStgOpToJS = go   where-    go EqOp         = Sat.EqOp-    go StrictEqOp   = Sat.StrictEqOp-    go NeqOp        = Sat.NeqOp-    go StrictNeqOp  = Sat.StrictNeqOp-    go GtOp         = Sat.GtOp-    go GeOp         = Sat.GeOp-    go LtOp         = Sat.LtOp-    go LeOp         = Sat.LeOp-    go AddOp        = Sat.AddOp-    go SubOp        = Sat.SubOp-    go MulOp        = Sat.MulOp-    go DivOp        = Sat.DivOp-    go ModOp        = Sat.ModOp-    go LeftShiftOp  = Sat.LeftShiftOp-    go RightShiftOp = Sat.RightShiftOp-    go ZRightShiftOp = Sat.ZRightShiftOp-    go BAndOp       = Sat.BAndOp-    go BOrOp        = Sat.BOrOp-    go BXorOp       = Sat.BXorOp-    go LAndOp       = Sat.LAndOp-    go LOrOp        = Sat.LOrOp-    go InstanceofOp = Sat.InstanceofOp-    go InOp         = Sat.InOp+    go EqOp         = JS.EqOp+    go StrictEqOp   = JS.StrictEqOp+    go NeqOp        = JS.NeqOp+    go StrictNeqOp  = JS.StrictNeqOp+    go GtOp         = JS.GtOp+    go GeOp         = JS.GeOp+    go LtOp         = JS.LtOp+    go LeOp         = JS.LeOp+    go AddOp        = JS.AddOp+    go SubOp        = JS.SubOp+    go MulOp        = JS.MulOp+    go DivOp        = JS.DivOp+    go ModOp        = JS.ModOp+    go LeftShiftOp  = JS.LeftShiftOp+    go RightShiftOp = JS.RightShiftOp+    go ZRightShiftOp = JS.ZRightShiftOp+    go BAndOp       = JS.BAndOp+    go BOrOp        = JS.BOrOp+    go BXorOp       = JS.BXorOp+    go LAndOp       = JS.LAndOp+    go LOrOp        = JS.LOrOp+    go InstanceofOp = JS.InstanceofOp+    go InOp         = JS.InOp -satJUOp :: JUOp -> Sat.UOp-satJUOp = go+jStgUOpToJS :: UOp -> JS.UOp+jStgUOpToJS = go   where-    go NotOp     = Sat.NotOp-    go BNotOp    = Sat.BNotOp-    go NegOp     = Sat.NegOp-    go PlusOp    = Sat.PlusOp-    go NewOp     = Sat.NewOp-    go TypeofOp  = Sat.TypeofOp-    go DeleteOp  = Sat.DeleteOp-    go YieldOp   = Sat.YieldOp-    go VoidOp    = Sat.VoidOp-    go PreIncOp  = Sat.PreIncOp-    go PostIncOp = Sat.PostIncOp-    go PreDecOp  = Sat.PreDecOp-    go PostDecOp = Sat.PostDecOp+    go NotOp     = JS.NotOp+    go BNotOp    = JS.BNotOp+    go NegOp     = JS.NegOp+    go PlusOp    = JS.PlusOp+    go NewOp     = JS.NewOp+    go TypeofOp  = JS.TypeofOp+    go DeleteOp  = JS.DeleteOp+    go YieldOp   = JS.YieldOp+    go VoidOp    = JS.VoidOp+    go PreIncOp  = JS.PreIncOp+    go PostIncOp = JS.PostIncOp+    go PreDecOp  = JS.PreDecOp+    go PostDecOp = JS.PostDecOp +jStgAOpToJS :: AOp -> JS.AOp+jStgAOpToJS AssignOp    = JS.AssignOp+jStgAOpToJS AddAssignOp = JS.AddAssignOp+jStgAOpToJS SubAssignOp = JS.SubAssignOp
− compiler/GHC/JS/Unsat/Syntax.hs 
@@ -1,375 +0,0 @@-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DerivingVia #-}-{-# LANGUAGE BlockArguments #-}-{-# LANGUAGE PatternSynonyms #-}---------------------------------------------------------------------------------- |--- Module      :  GHC.JS.Unsat.Syntax--- Copyright   :  (c) The University of Glasgow 2001--- License     :  BSD-style (see the file LICENSE)------ Maintainer  :  Jeffrey Young  <jeffrey.young@iohk.io>---                Luite Stegeman <luite.stegeman@iohk.io>---                Sylvain Henry  <sylvain.henry@iohk.io>---                Josh Meredith  <josh.meredith@iohk.io>--- Stability   :  experimental--------- * Domain and Purpose------     GHC.JS.Unsat.Syntax defines the Syntax for the JS backend in GHC. It---     comports with the [ECMA-262](https://tc39.es/ecma262/) although not every---     production rule of the standard is represented. Code in this module is a---     fork of [JMacro](https://hackage.haskell.org/package/jmacro) (BSD 3---     Clause) by Gershom Bazerman, heavily modified to accomodate GHC's---     constraints.--------- * Strategy------     Nothing fancy in this module, this is a classic deeply embeded AST for---     JS. We define numerous ADTs and pattern synonyms to make pattern matching---     and constructing ASTs easier.--------- * Consumers------     The entire JS backend consumes this module, e.g., the modules in---     GHC.StgToJS.\*. Please see 'GHC.JS.Make' for a module which provides---     helper functions that use the deeply embedded DSL defined in this module---     to provide some of the benefits of a shallow embedding.-------------------------------------------------------------------------------module GHC.JS.Unsat.Syntax-  ( -- * Deeply embedded JS datatypes-    JStat(..)-  , JExpr(..)-  , JVal(..)-  , JOp(..)-  , JUOp(..)-  , Ident(..)-  , identFS-  , JsLabel-  -- * pattern synonyms over JS operators-  , pattern New-  , pattern Not-  , pattern Negate-  , pattern Add-  , pattern Sub-  , pattern Mul-  , pattern Div-  , pattern Mod-  , pattern BOr-  , pattern BAnd-  , pattern BXor-  , pattern BNot-  , pattern LOr-  , pattern LAnd-  , pattern Int-  , pattern String-  , pattern PreInc-  , pattern PostInc-  , pattern PreDec-  , pattern PostDec-  -- * Ident supply-  , IdentSupply(..)-  , newIdentSupply-  , pseudoSaturate-  -- * Utility-  , SaneDouble(..)-  ) where--import GHC.Prelude--import Control.DeepSeq--import Data.Function-import Data.Data-import Data.Word-import qualified Data.Semigroup as Semigroup--import GHC.Generics--import GHC.Data.FastString-import GHC.Utils.Monad.State.Strict-import GHC.Types.Unique-import GHC.Types.Unique.Map-import GHC.Types.SaneDouble---- | A supply of identifiers, possibly empty-newtype IdentSupply a-  = IS {runIdentSupply :: State [Ident] a}-  deriving Typeable--instance NFData (IdentSupply a) where rnf IS{} = ()--inIdentSupply :: (State [Ident] a -> State [Ident] b) -> IdentSupply a -> IdentSupply b-inIdentSupply f x = IS $ f (runIdentSupply x)--instance Functor IdentSupply where-    fmap f x = inIdentSupply (fmap f) x--newIdentSupply :: Maybe FastString -> [Ident]-newIdentSupply Nothing    = newIdentSupply (Just "jmId")-newIdentSupply (Just pfx) = [ TxtI (mconcat [pfx,"_",mkFastString (show x)])-                            | x <- [(0::Word64)..]-                            ]---- | Given a Pseudo-saturate a value with garbage @<<unsatId>>@ identifiers.-pseudoSaturate :: IdentSupply a -> a-pseudoSaturate x = evalState (runIdentSupply x) $ newIdentSupply (Just "<<unsatId>>")--instance Eq a => Eq (IdentSupply a) where-    (==) = (==) `on` pseudoSaturate-instance Ord a => Ord (IdentSupply a) where-    compare = compare `on` pseudoSaturate-instance Show a => Show (IdentSupply a) where-    show x = "(" ++ show (pseudoSaturate x) ++ ")"--------------------------------------------------------------------------------------                            Statements------------------------------------------------------------------------------------ | JavaScript statements, see the [ECMA262--- Reference](https://tc39.es/ecma262/#sec-ecmascript-language-statements-and-declarations)--- for details-data JStat-  = DeclStat   !Ident !(Maybe JExpr)         -- ^ Variable declarations: var foo [= e]-  | ReturnStat JExpr                         -- ^ Return-  | IfStat     JExpr JStat JStat             -- ^ If-  | WhileStat  Bool JExpr JStat              -- ^ While, bool is "do" when True-  | ForStat    JStat JExpr JStat JStat       -- ^ For-  | ForInStat  Bool Ident JExpr JStat        -- ^ For-in, bool is "each' when True-  | SwitchStat JExpr [(JExpr, JStat)] JStat  -- ^ Switch-  | TryStat    JStat Ident JStat JStat       -- ^ Try-  | BlockStat  [JStat]                       -- ^ Blocks-  | ApplStat   JExpr [JExpr]                 -- ^ Application-  | UOpStat JUOp JExpr                       -- ^ Unary operators-  | AssignStat JExpr JExpr                   -- ^ Binding form: @foo = bar@-  | UnsatBlock (IdentSupply JStat)           -- ^ /Unsaturated/ blocks see 'pseudoSaturate'-  | LabelStat JsLabel JStat                  -- ^ Statement Labels, makes me nostalgic for qbasic-  | BreakStat (Maybe JsLabel)                -- ^ Break-  | ContinueStat (Maybe JsLabel)             -- ^ Continue-  | FuncStat   !Ident [Ident] JStat          -- ^ an explicit function definition-  deriving (Eq, Typeable, Generic)---- | A Label used for 'JStat', specifically 'BreakStat', 'ContinueStat' and of--- course 'LabelStat'-type JsLabel = LexicalFastString--instance Semigroup JStat where-  (<>) = appendJStat--instance Monoid JStat where-  mempty = BlockStat []---- | Append a statement to another statement. 'appendJStat' only returns a--- 'JStat' that is /not/ a 'BlockStat' when either @mx@ or @my is an empty--- 'BlockStat'. That is:--- > (BlockStat [] , y           ) = y--- > (x            , BlockStat []) = x-appendJStat :: JStat -> JStat -> JStat-appendJStat mx my = case (mx,my) of-  (BlockStat [] , y           ) -> y-  (x            , BlockStat []) -> x-  (BlockStat xs , BlockStat ys) -> BlockStat $ xs ++ ys-  (BlockStat xs , ys          ) -> BlockStat $ xs ++ [ys]-  (xs           , BlockStat ys) -> BlockStat $ xs : ys-  (xs           , ys          ) -> BlockStat [xs,ys]--------------------------------------------------------------------------------------                            Expressions------------------------------------------------------------------------------------ | JavaScript Expressions-data JExpr-  = ValExpr    JVal                 -- ^ All values are trivially expressions-  | SelExpr    JExpr Ident          -- ^ Selection: Obj.foo, see 'GHC.JS.Make..^'-  | IdxExpr    JExpr JExpr          -- ^ Indexing:  Obj[foo], see 'GHC.JS.Make..!'-  | InfixExpr  JOp JExpr JExpr      -- ^ Infix Expressions, see 'JExpr'-                                    --   pattern synonyms-  | UOpExpr    JUOp JExpr           -- ^ Unary Expressions-  | IfExpr     JExpr JExpr JExpr    -- ^ If-expression-  | ApplExpr   JExpr [JExpr]        -- ^ Application-  | UnsatExpr  (IdentSupply JExpr)  -- ^ An /Saturated/ expression.-                                    --   See 'pseudoSaturate'-  deriving (Eq, Typeable, Generic)---- * Useful pattern synonyms to ease programming with the deeply embedded JS---   AST. Each pattern wraps @JUOp@ and @JOp@ into a @JExpr@s to save typing and---   for convienience. In addition we include a string wrapper for JS string---   and Integer literals.---- | pattern synonym for a unary operator new-pattern New :: JExpr -> JExpr-pattern New x = UOpExpr NewOp x---- | pattern synonym for prefix increment @++x@-pattern PreInc :: JExpr -> JExpr-pattern PreInc x = UOpExpr PreIncOp x---- | pattern synonym for postfix increment @x++@-pattern PostInc :: JExpr -> JExpr-pattern PostInc x = UOpExpr PostIncOp x---- | pattern synonym for prefix decrement @--x@-pattern PreDec :: JExpr -> JExpr-pattern PreDec x = UOpExpr PreDecOp x---- | pattern synonym for postfix decrement @--x@-pattern PostDec :: JExpr -> JExpr-pattern PostDec x = UOpExpr PostDecOp x---- | pattern synonym for logical not @!@-pattern Not :: JExpr -> JExpr-pattern Not x = UOpExpr NotOp x---- | pattern synonym for unary negation @-@-pattern Negate :: JExpr -> JExpr-pattern Negate x = UOpExpr NegOp x---- | pattern synonym for addition @+@-pattern Add :: JExpr -> JExpr -> JExpr-pattern Add x y = InfixExpr AddOp x y---- | pattern synonym for subtraction @-@-pattern Sub :: JExpr -> JExpr -> JExpr-pattern Sub x y = InfixExpr SubOp x y---- | pattern synonym for multiplication @*@-pattern Mul :: JExpr -> JExpr -> JExpr-pattern Mul x y = InfixExpr MulOp x y---- | pattern synonym for division @*@-pattern Div :: JExpr -> JExpr -> JExpr-pattern Div x y = InfixExpr DivOp x y---- | pattern synonym for remainder @%@-pattern Mod :: JExpr -> JExpr -> JExpr-pattern Mod x y = InfixExpr ModOp x y---- | pattern synonym for Bitwise Or @|@-pattern BOr :: JExpr -> JExpr -> JExpr-pattern BOr x y = InfixExpr BOrOp x y---- | pattern synonym for Bitwise And @&@-pattern BAnd :: JExpr -> JExpr -> JExpr-pattern BAnd x y = InfixExpr BAndOp x y---- | pattern synonym for Bitwise XOr @^@-pattern BXor :: JExpr -> JExpr -> JExpr-pattern BXor x y = InfixExpr BXorOp x y---- | pattern synonym for Bitwise Not @~@-pattern BNot :: JExpr -> JExpr-pattern BNot x = UOpExpr BNotOp x---- | pattern synonym for logical Or @||@-pattern LOr :: JExpr -> JExpr -> JExpr-pattern LOr x y = InfixExpr LOrOp x y---- | pattern synonym for logical And @&&@-pattern LAnd :: JExpr -> JExpr -> JExpr-pattern LAnd x y = InfixExpr LAndOp x y----- | pattern synonym to create integer values-pattern Int :: Integer -> JExpr-pattern Int x = ValExpr (JInt x)---- | pattern synonym to create string values-pattern String :: FastString -> JExpr-pattern String x = ValExpr (JStr x)--------------------------------------------------------------------------------------                            Values------------------------------------------------------------------------------------ | JavaScript values-data JVal-  = JVar     Ident                      -- ^ A variable reference-  | JList    [JExpr]                    -- ^ A JavaScript list, or what JS-                                        --   calls an Array-  | JDouble  SaneDouble                 -- ^ A Double-  | JInt     Integer                    -- ^ A BigInt-  | JStr     FastString                 -- ^ A String-  | JRegEx   FastString                 -- ^ A Regex-  | JHash    (UniqMap FastString JExpr) -- ^ A JS HashMap: @{"foo": 0}@-  | JFunc    [Ident] JStat              -- ^ A function-  | UnsatVal (IdentSupply JVal)         -- ^ An /Saturated/ value, see 'pseudoSaturate'-  deriving (Eq, Typeable, Generic)-------------------------------------------------------------------------------------                            Operators------------------------------------------------------------------------------------ | JS Binary Operators. We do not deeply embed the comma operator and the--- assignment operators-data JOp-  = EqOp            -- ^ Equality:              `==`-  | StrictEqOp      -- ^ Strict Equality:       `===`-  | NeqOp           -- ^ InEquality:            `!=`-  | StrictNeqOp     -- ^ Strict InEquality      `!==`-  | GtOp            -- ^ Greater Than:          `>`-  | GeOp            -- ^ Greater Than or Equal: `>=`-  | LtOp            -- ^ Less Than:             <-  | LeOp            -- ^ Less Than or Equal:     <=-  | AddOp           -- ^ Addition:               +-  | SubOp           -- ^ Subtraction:            --  | MulOp           -- ^ Multiplication          \*-  | DivOp           -- ^ Division:               \/-  | ModOp           -- ^ Remainder:              %-  | LeftShiftOp     -- ^ Left Shift:             \<\<-  | RightShiftOp    -- ^ Right Shift:            \>\>-  | ZRightShiftOp   -- ^ Unsigned RightShift:    \>\>\>-  | BAndOp          -- ^ Bitwise And:            &-  | BOrOp           -- ^ Bitwise Or:             |-  | BXorOp          -- ^ Bitwise XOr:            ^-  | LAndOp          -- ^ Logical And:            &&-  | LOrOp           -- ^ Logical Or:             ||-  | InstanceofOp    -- ^ @instanceof@-  | InOp            -- ^ @in@-  deriving (Show, Eq, Ord, Enum, Data, Typeable, Generic)--instance NFData JOp---- | JS Unary Operators-data JUOp-  = NotOp           -- ^ Logical Not: @!@-  | BNotOp          -- ^ Bitwise Not: @~@-  | NegOp           -- ^ Negation:    @-@-  | PlusOp          -- ^ Unary Plus:  @+x@-  | NewOp           -- ^ new    x-  | TypeofOp        -- ^ typeof x-  | DeleteOp        -- ^ delete x-  | YieldOp         -- ^ yield  x-  | VoidOp          -- ^ void   x-  | PreIncOp        -- ^ Prefix Increment:  @++x@-  | PostIncOp       -- ^ Postfix Increment: @x++@-  | PreDecOp        -- ^ Prefix Decrement:  @--x@-  | PostDecOp       -- ^ Postfix Decrement: @x--@-  deriving (Show, Eq, Ord, Enum, Data, Typeable, Generic)--instance NFData JUOp-------------------------------------------------------------------------------------                            Identifiers------------------------------------------------------------------------------------ We use FastString for identifiers in JS backend---- | A newtype wrapper around 'FastString' for JS identifiers.-newtype Ident = TxtI { itxt :: FastString }- deriving stock   (Show, Eq)- deriving newtype (Uniquable)--identFS :: Ident -> FastString-identFS = \case-  TxtI fs -> fs
+ compiler/GHC/Linker/Config.hs view
@@ -0,0 +1,27 @@+-- | Linker configuration++module GHC.Linker.Config+  ( FrameworkOpts(..)+  , LinkerConfig(..)+  )+where++import GHC.Prelude+import GHC.Utils.TmpFs+import GHC.Utils.CliOption++-- used on darwin only+data FrameworkOpts = FrameworkOpts+  { foFrameworkPaths    :: [String]+  , foCmdlineFrameworks :: [String]+  }++-- | External linker configuration+data LinkerConfig = LinkerConfig+  { linkerProgram     :: String           -- ^ Linker program+  , linkerOptionsPre  :: [Option]         -- ^ Linker options (before user options)+  , linkerOptionsPost :: [Option]         -- ^ Linker options (after user options)+  , linkerTempDir     :: TempDir          -- ^ Temporary directory to use+  , linkerFilter      :: String -> String -- ^ Output filter+  }+
compiler/GHC/Linker/Types.hs view
@@ -40,8 +40,7 @@ import GHC.Unit                ( UnitId, Module ) import GHC.ByteCode.Types      ( ItblEnv, AddrEnv, CompiledByteCode ) import GHC.Fingerprint.Type    ( Fingerprint )-import GHCi.RemoteTypes        ( ForeignHValue, RemotePtr )-import GHCi.Message            ( LoadedDLL )+import GHCi.RemoteTypes        ( ForeignHValue )  import GHC.Types.Var           ( Id ) import GHC.Types.Name.Env      ( NameEnv, emptyNameEnv, extendNameEnvList, filterNameEnv )@@ -76,53 +75,6 @@  The LinkerEnv maps Names to actual closures (for interpreted code only), for use during linking.--Note [Looking up symbols in the relevant objects]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In #23415, we determined that a lot of time (>10s, or even up to >35s!) was-being spent on dynamically loading symbols before actually interpreting code-when `:main` was run in GHCi. The root cause was that for each symbol we wanted-to lookup, we would traverse the list of loaded objects and try find the symbol-in each of them with dlsym (i.e. looking up a symbol was, worst case, linear in-the amount of loaded objects).--To drastically improve load time (from +-38 seconds down to +-2s), we now:--1. For every of the native objects loaded for a given unit, store the handles returned by `dlopen`.-  - In `pkgs_loaded` of the `LoaderState`, which maps `UnitId`s to-    `LoadedPkgInfo`s, where the handles live in its field `loaded_pkg_hs_dlls`.--2. When looking up a Name (e.g. `lookupHsSymbol`), find that name's `UnitId` in-    the `pkgs_loaded` mapping,--3. And only look for the symbol (with `dlsym`) on the /handles relevant to that-    unit/, rather than in every loaded object.--Note [Symbols may not be found in pkgs_loaded]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Currently the `pkgs_loaded` mapping only contains the dynamic objects-associated with loaded units. Symbols defined in a static object (e.g. from a-statically-linked Haskell library) are found via the generic `lookupSymbol`-function call by `lookupHsSymbol` when the symbol is not found in any of the-dynamic objects of `pkgs_loaded`.--The rationale here is two-fold:-- * we have only observed major link-time issues in dynamic linking; lookups in- the RTS linker's static symbol table seem to be fast enough-- * allowing symbol lookups restricted to a single ObjectCode would require the- maintenance of a symbol table per `ObjectCode`, which would introduce time and- space overhead--This fallback is further needed because we don't look in the haskell objects-loaded for the home units (see the call to `loadModuleLinkables` in-`loadDependencies`, as opposed to the call to `loadPackages'` in the same-function which updates `pkgs_loaded`). We should ultimately keep track of the-objects loaded (probably in `objs_loaded`, for which `LinkableSet` is a bit-unsatisfactory, see a suggestion in 51c5c4eb1f2a33e4dc88e6a37b7b7c135234ce9b)-and be able to lookup symbols specifically in them too (similarly to-`lookupSymbolInDLL`). -}  newtype Loader = Loader { loader_state :: MVar (Maybe LoaderState) }@@ -194,13 +146,11 @@   { loaded_pkg_uid         :: !UnitId   , loaded_pkg_hs_objs     :: ![LibrarySpec]   , loaded_pkg_non_hs_objs :: ![LibrarySpec]-  , loaded_pkg_hs_dlls     :: ![RemotePtr LoadedDLL]-    -- ^ See Note [Looking up symbols in the relevant objects]   , loaded_pkg_trans_deps  :: UniqDSet UnitId   }  instance Outputable LoadedPkgInfo where-  ppr (LoadedPkgInfo uid hs_objs non_hs_objs _ trans_deps) =+  ppr (LoadedPkgInfo uid hs_objs non_hs_objs trans_deps) =     vcat [ppr uid          , ppr hs_objs          , ppr non_hs_objs@@ -209,10 +159,10 @@  -- | Information we can use to dynamically link modules into the compiler data Linkable = LM {-  linkableTime     :: !UTCTime,         -- ^ Time at which this linkable was built+  linkableTime     :: !UTCTime,          -- ^ Time at which this linkable was built                                         -- (i.e. when the bytecodes were produced,                                         --       or the mod date on the files)-  linkableModule   :: !Module,          -- ^ The linkable module itself+  linkableModule   :: !Module,           -- ^ The linkable module itself   linkableUnlinked :: [Unlinked]     -- ^ Those files and chunks of code we have yet to link.     --
compiler/GHC/Parser.y view
@@ -249,4349 +249,4339 @@     We shift, so [0] is parsed as an activation rule. -} -{- Note [%shift: rule_foralls -> 'forall' rule_vars '.']-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Context:-    rule_foralls -> 'forall' rule_vars '.' . 'forall' rule_vars '.'-    rule_foralls -> 'forall' rule_vars '.' .--Example:-    {-# RULES "name" forall a1. forall a2. lhs = rhs #-}--Ambiguity:-    Same as in Note [%shift: rule_foralls -> {- empty -}]-    but for the second 'forall'.--}--{- Note [%shift: rule_foralls -> {- empty -}]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Context:-    rule -> STRING rule_activation . rule_foralls infixexp '=' exp--Example:-    {-# RULES "name" forall a1. lhs = rhs #-}--Ambiguity:-    If we reduced, then we would get an empty rule_foralls; the 'forall', being-    a valid term-level identifier, would be parsed as part of the left-hand-    side expression.--    We shift, so the 'forall' is parsed as part of rule_foralls.--}--{- Note [%shift: type -> btype]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Context:-    context -> btype .-    type -> btype .-    type -> btype . '->' ctype-    type -> btype . '->.' ctype--Example:-    a :: Maybe Integer -> Bool--Ambiguity:-    If we reduced, we would get:   (a :: Maybe Integer) -> Bool-    We shift to get this instead:  a :: (Maybe Integer -> Bool)--}--{- Note [%shift: infixtype -> ftype]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Context:-    infixtype -> ftype .-    infixtype -> ftype . tyop infixtype-    ftype -> ftype . tyarg-    ftype -> ftype . PREFIX_AT tyarg--Example:-    a :: Maybe Integer--Ambiguity:-    If we reduced, we would get:    (a :: Maybe) Integer-    We shift to get this instead:   a :: (Maybe Integer)--}--{- Note [%shift: atype -> tyvar]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Context:-    atype -> tyvar .-    tv_bndr_no_braces -> '(' tyvar . '::' kind ')'--Example:-    class C a where type D a = (a :: Type ...--Ambiguity:-    If we reduced, we could specify a default for an associated type like this:--      class C a where type D a-                      type D a = (a :: Type)--    But we shift in order to allow injectivity signatures like this:--      class C a where type D a = (r :: Type) | r -> a--}--{- Note [%shift: exp -> infixexp]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Context:-    exp -> infixexp . '::' sigtype-    exp -> infixexp . '-<' exp-    exp -> infixexp . '>-' exp-    exp -> infixexp . '-<<' exp-    exp -> infixexp . '>>-' exp-    exp -> infixexp .-    infixexp -> infixexp . qop exp10p--Examples:-    1) if x then y else z -< e-    2) if x then y else z :: T-    3) if x then y else z + 1   -- (NB: '+' is in VARSYM)--Ambiguity:-    If we reduced, we would get:--      1) (if x then y else z) -< e-      2) (if x then y else z) :: T-      3) (if x then y else z) + 1--    We shift to get this instead:--      1) if x then y else (z -< e)-      2) if x then y else (z :: T)-      3) if x then y else (z + 1)--}--{- Note [%shift: exp10 -> '-' fexp]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Context:-    exp10 -> '-' fexp .-    fexp -> fexp . aexp-    fexp -> fexp . PREFIX_AT atype--Examples & Ambiguity:-    Same as in Note [%shift: exp10 -> fexp],-    but with a '-' in front.--}--{- Note [%shift: exp10 -> fexp]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Context:-    exp10 -> fexp .-    fexp -> fexp . aexp-    fexp -> fexp . PREFIX_AT atype--Examples:-    1) if x then y else f z-    2) if x then y else f @z--Ambiguity:-    If we reduced, we would get:--      1) (if x then y else f) z-      2) (if x then y else f) @z--    We shift to get this instead:--      1) if x then y else (f z)-      2) if x then y else (f @z)--}--{- Note [%shift: aexp2 -> ipvar]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Context:-    aexp2 -> ipvar .-    dbind -> ipvar . '=' exp--Example:-    let ?x = ...--Ambiguity:-    If we reduced, ?x would be parsed as the LHS of a normal binding,-    eventually producing an error.--    We shift, so it is parsed as the LHS of an implicit binding.--}--{- Note [%shift: aexp2 -> TH_TY_QUOTE]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Context:-    aexp2 -> TH_TY_QUOTE . tyvar-    aexp2 -> TH_TY_QUOTE . gtycon-    aexp2 -> TH_TY_QUOTE .--Examples:-    1) x = ''-    2) x = ''a-    3) x = ''T--Ambiguity:-    If we reduced, the '' would result in reportEmptyDoubleQuotes even when-    followed by a type variable or a type constructor. But the only reason-    this reduction rule exists is to improve error messages.--    Naturally, we shift instead, so that ''a and ''T work as expected.--}--{- Note [%shift: tup_tail -> {- empty -}]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Context:-    tup_exprs -> commas . tup_tail-    sysdcon_nolist -> '(' commas . ')'-    sysdcon_nolist -> '(#' commas . '#)'-    commas -> commas . ','--Example:-    (,,)--Ambiguity:-    A tuple section with no components is indistinguishable from the Haskell98-    data constructor for a tuple.--    If we reduced, (,,) would be parsed as a tuple section.-    We shift, so (,,) is parsed as a data constructor.--    This is preferable because we want to accept (,,) without -XTupleSections.-    See also Note [ExplicitTuple] in GHC.Hs.Expr.--}--{- Note [%shift: qtyconop -> qtyconsym]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Context:-    oqtycon -> '(' qtyconsym . ')'-    qtyconop -> qtyconsym .--Example:-    foo :: (:%)--Ambiguity:-    If we reduced, (:%) would be parsed as a parenthesized infix type-    expression without arguments, resulting in the 'failOpFewArgs' error.--    We shift, so it is parsed as a type constructor.--}--{- Note [%shift: special_id -> 'group']-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Context:-    transformqual -> 'then' 'group' . 'using' exp-    transformqual -> 'then' 'group' . 'by' exp 'using' exp-    special_id -> 'group' .--Example:-    [ ... | then group by dept using groupWith-          , then take 5 ]--Ambiguity:-    If we reduced, 'group' would be parsed as a term-level identifier, just as-    'take' in the other clause.--    We shift, so it is parsed as part of the 'group by' clause introduced by-    the -XTransformListComp extension.--}--{- Note [%shift: activation -> {- empty -}]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Context:-    sigdecl -> '{-# INLINE' . activation qvarcon '#-}'-    activation -> {- empty -}-    activation -> explicit_activation--Example:--    {-# INLINE [0] Something #-}--Ambiguity:-    We don't know whether the '[' is the start of the activation or the beginning-    of the [] data constructor.-    We parse this as having '[0]' activation for inlining 'Something', rather than-    empty activation and inlining '[0] Something'.--}--{- Note [Parser API Annotations]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-A lot of the productions are now cluttered with calls to-aa,am,acs,acsA etc.--These are helper functions to make sure that the locations of the-various keywords such as do / let / in are captured for use by tools-that want to do source to source conversions, such as refactorers or-structured editors.--The helper functions are defined at the bottom of this file.--See-  https://gitlab.haskell.org/ghc/ghc/wikis/api-annotations and-  https://gitlab.haskell.org/ghc/ghc/wikis/ghc-ast-annotations-for some background.---}--{- Note [Parsing lists]-~~~~~~~~~~~~~~~~~~~~~~~-You might be wondering why we spend so much effort encoding our lists this-way:--importdecls-        : importdecls ';' importdecl-        | importdecls ';'-        | importdecl-        | {- empty -}--This might seem like an awfully roundabout way to declare a list; plus, to add-insult to injury you have to reverse the results at the end.  The answer is that-left recursion prevents us from running out of stack space when parsing long-sequences. See:-https://haskell-happy.readthedocs.io/en/latest/using.html#parsing-sequences-for more guidance.--By adding/removing branches, you can affect what lists are accepted.  Here-are the most common patterns, rewritten as regular expressions for clarity:--    -- Equivalent to: ';'* (x ';'+)* x?  (can be empty, permits leading/trailing semis)-    xs : xs ';' x-       | xs ';'-       | x-       | {- empty -}--    -- Equivalent to x (';' x)* ';'*  (non-empty, permits trailing semis)-    xs : xs ';' x-       | xs ';'-       | x--    -- Equivalent to ';'* alts (';' alts)* ';'* (non-empty, permits leading/trailing semis)-    alts : alts1-         | ';' alts-    alts1 : alts1 ';' alt-          | alts1 ';'-          | alt--    -- Equivalent to x (',' x)+ (non-empty, no trailing semis)-    xs : x-       | x ',' xs--}--%token- '_'            { L _ ITunderscore }            -- Haskell keywords- 'as'           { L _ ITas }- 'case'         { L _ ITcase }- 'class'        { L _ ITclass }- 'data'         { L _ ITdata }- 'default'      { L _ ITdefault }- 'deriving'     { L _ ITderiving }- 'else'         { L _ ITelse }- 'hiding'       { L _ IThiding }- 'if'           { L _ ITif }- 'import'       { L _ ITimport }- 'in'           { L _ ITin }- 'infix'        { L _ ITinfix }- 'infixl'       { L _ ITinfixl }- 'infixr'       { L _ ITinfixr }- 'instance'     { L _ ITinstance }- 'let'          { L _ ITlet }- 'module'       { L _ ITmodule }- 'newtype'      { L _ ITnewtype }- 'of'           { L _ ITof }- 'qualified'    { L _ ITqualified }- 'then'         { L _ ITthen }- 'type'         { L _ ITtype }- 'where'        { L _ ITwhere }-- 'forall'       { L _ (ITforall _) }                -- GHC extension keywords- 'foreign'      { L _ ITforeign }- 'export'       { L _ ITexport }- 'label'        { L _ ITlabel }- 'dynamic'      { L _ ITdynamic }- 'safe'         { L _ ITsafe }- 'interruptible' { L _ ITinterruptible }- 'unsafe'       { L _ ITunsafe }- 'family'       { L _ ITfamily }- 'role'         { L _ ITrole }- 'stdcall'      { L _ ITstdcallconv }- 'ccall'        { L _ ITccallconv }- 'capi'         { L _ ITcapiconv }- 'prim'         { L _ ITprimcallconv }- 'javascript'   { L _ ITjavascriptcallconv }- 'proc'         { L _ ITproc }          -- for arrow notation extension- 'rec'          { L _ ITrec }           -- for arrow notation extension- 'group'    { L _ ITgroup }     -- for list transform extension- 'by'       { L _ ITby }        -- for list transform extension- 'using'    { L _ ITusing }     -- for list transform extension- 'pattern'      { L _ ITpattern } -- for pattern synonyms- 'static'       { L _ ITstatic }  -- for static pointers extension- 'stock'        { L _ ITstock }    -- for DerivingStrategies extension- 'anyclass'     { L _ ITanyclass } -- for DerivingStrategies extension- 'via'          { L _ ITvia }      -- for DerivingStrategies extension-- 'unit'         { L _ ITunit }- 'signature'    { L _ ITsignature }- 'dependency'   { L _ ITdependency }-- '{-# INLINE'             { L _ (ITinline_prag _ _ _) } -- INLINE or INLINABLE- '{-# OPAQUE'             { L _ (ITopaque_prag _) }- '{-# SPECIALISE'         { L _ (ITspec_prag _) }- '{-# SPECIALISE_INLINE'  { L _ (ITspec_inline_prag _ _) }- '{-# SOURCE'             { L _ (ITsource_prag _) }- '{-# RULES'              { L _ (ITrules_prag _) }- '{-# SCC'                { L _ (ITscc_prag _)}- '{-# DEPRECATED'         { L _ (ITdeprecated_prag _) }- '{-# WARNING'            { L _ (ITwarning_prag _) }- '{-# UNPACK'             { L _ (ITunpack_prag _) }- '{-# NOUNPACK'           { L _ (ITnounpack_prag _) }- '{-# ANN'                { L _ (ITann_prag _) }- '{-# MINIMAL'            { L _ (ITminimal_prag _) }- '{-# CTYPE'              { L _ (ITctype _) }- '{-# OVERLAPPING'        { L _ (IToverlapping_prag _) }- '{-# OVERLAPPABLE'       { L _ (IToverlappable_prag _) }- '{-# OVERLAPS'           { L _ (IToverlaps_prag _) }- '{-# INCOHERENT'         { L _ (ITincoherent_prag _) }- '{-# COMPLETE'           { L _ (ITcomplete_prag _)   }- '#-}'                    { L _ ITclose_prag }-- '..'           { L _ ITdotdot }                        -- reserved symbols- ':'            { L _ ITcolon }- '::'           { L _ (ITdcolon _) }- '='            { L _ ITequal }- '\\'           { L _ ITlam }- 'lcase'        { L _ ITlcase }- 'lcases'       { L _ ITlcases }- '|'            { L _ ITvbar }- '<-'           { L _ (ITlarrow _) }- '->'           { L _ (ITrarrow _) }- '->.'          { L _ ITlolly }- TIGHT_INFIX_AT { L _ ITat }- '=>'           { L _ (ITdarrow _) }- '-'            { L _ ITminus }- PREFIX_TILDE   { L _ ITtilde }- PREFIX_BANG    { L _ ITbang }- PREFIX_MINUS   { L _ ITprefixminus }- '*'            { L _ (ITstar _) }- '-<'           { L _ (ITlarrowtail _) }            -- for arrow notation- '>-'           { L _ (ITrarrowtail _) }            -- for arrow notation- '-<<'          { L _ (ITLarrowtail _) }            -- for arrow notation- '>>-'          { L _ (ITRarrowtail _) }            -- for arrow notation- '.'            { L _ ITdot }- PREFIX_PROJ    { L _ (ITproj True) }               -- RecordDotSyntax- TIGHT_INFIX_PROJ { L _ (ITproj False) }            -- RecordDotSyntax- PREFIX_AT      { L _ ITtypeApp }- PREFIX_PERCENT { L _ ITpercent }                   -- for linear types-- '{'            { L _ ITocurly }                        -- special symbols- '}'            { L _ ITccurly }- vocurly        { L _ ITvocurly } -- virtual open curly (from layout)- vccurly        { L _ ITvccurly } -- virtual close curly (from layout)- '['            { L _ ITobrack }- ']'            { L _ ITcbrack }- '('            { L _ IToparen }- ')'            { L _ ITcparen }- '(#'           { L _ IToubxparen }- '#)'           { L _ ITcubxparen }- '(|'           { L _ (IToparenbar _) }- '|)'           { L _ (ITcparenbar _) }- ';'            { L _ ITsemi }- ','            { L _ ITcomma }- '`'            { L _ ITbackquote }- SIMPLEQUOTE    { L _ ITsimpleQuote      }     -- 'x-- VARID          { L _ (ITvarid    _) }          -- identifiers- CONID          { L _ (ITconid    _) }- VARSYM         { L _ (ITvarsym   _) }- CONSYM         { L _ (ITconsym   _) }- QVARID         { L _ (ITqvarid   _) }- QCONID         { L _ (ITqconid   _) }- QVARSYM        { L _ (ITqvarsym  _) }- QCONSYM        { L _ (ITqconsym  _) }--- -- QualifiedDo- DO             { L _ (ITdo  _) }- MDO            { L _ (ITmdo _) }-- IPDUPVARID     { L _ (ITdupipvarid   _) }              -- GHC extension- LABELVARID     { L _ (ITlabelvarid _ _) }-- CHAR           { L _ (ITchar   _ _) }- STRING         { L _ (ITstring _ _) }- INTEGER        { L _ (ITinteger _) }- RATIONAL       { L _ (ITrational _) }-- PRIMCHAR       { L _ (ITprimchar   _ _) }- PRIMSTRING     { L _ (ITprimstring _ _) }- PRIMINTEGER    { L _ (ITprimint    _ _) }- PRIMWORD       { L _ (ITprimword   _ _) }- PRIMINTEGER8   { L _ (ITprimint8   _ _) }- PRIMINTEGER16  { L _ (ITprimint16  _ _) }- PRIMINTEGER32  { L _ (ITprimint32  _ _) }- PRIMINTEGER64  { L _ (ITprimint64  _ _) }- PRIMWORD8      { L _ (ITprimword8  _ _) }- PRIMWORD16     { L _ (ITprimword16 _ _) }- PRIMWORD32     { L _ (ITprimword32 _ _) }- PRIMWORD64     { L _ (ITprimword64 _ _) }- PRIMFLOAT      { L _ (ITprimfloat  _) }- PRIMDOUBLE     { L _ (ITprimdouble _) }---- Template Haskell-'[|'            { L _ (ITopenExpQuote _ _) }-'[p|'           { L _ ITopenPatQuote  }-'[t|'           { L _ ITopenTypQuote  }-'[d|'           { L _ ITopenDecQuote  }-'|]'            { L _ (ITcloseQuote _) }-'[||'           { L _ (ITopenTExpQuote _) }-'||]'           { L _ ITcloseTExpQuote  }-PREFIX_DOLLAR   { L _ ITdollar }-PREFIX_DOLLAR_DOLLAR { L _ ITdollardollar }-TH_TY_QUOTE     { L _ ITtyQuote       }      -- ''T-TH_QUASIQUOTE   { L _ (ITquasiQuote _) }-TH_QQUASIQUOTE  { L _ (ITqQuasiQuote _) }--%monad { P } { >>= } { return }-%lexer { (lexer True) } { L _ ITeof }-  -- Replace 'lexer' above with 'lexerDbg'-  -- to dump the tokens fed to the parser.-%tokentype { (Located Token) }---- Exported parsers-%name parseModuleNoHaddock module-%name parseSignature signature-%name parseImport importdecl-%name parseStatement e_stmt-%name parseDeclaration topdecl-%name parseExpression exp-%name parsePattern pat-%name parseTypeSignature sigdecl-%name parseStmt   maybe_stmt-%name parseIdentifier  identifier-%name parseType ktype-%name parseBackpack backpack-%partial parseHeader header-%%---------------------------------------------------------------------------------- Identifiers; one of the entry points-identifier :: { LocatedN RdrName }-        : qvar                          { $1 }-        | qcon                          { $1 }-        | qvarop                        { $1 }-        | qconop                        { $1 }-    | '(' '->' ')'      {% amsrn (sLL $1 $> $ getRdrName unrestrictedFunTyCon)-                                 (NameAnnRArrow (isUnicode $2) (Just $ glAA $1) (glAA $2) (Just $ glAA $3) []) }-    | '->'              {% amsrn (sLL $1 $> $ getRdrName unrestrictedFunTyCon)-                                 (NameAnnRArrow (isUnicode $1) Nothing (glAA $1) Nothing []) }---------------------------------------------------------------------------------- Backpack stuff--backpack :: { [LHsUnit PackageName] }-         : implicit_top units close { fromOL $2 }-         | '{' units '}'            { fromOL $2 }--units :: { OrdList (LHsUnit PackageName) }-         : units ';' unit { $1 `appOL` unitOL $3 }-         | units ';'      { $1 }-         | unit           { unitOL $1 }--unit :: { LHsUnit PackageName }-        : 'unit' pkgname 'where' unitbody-            { sL1 $1 $ HsUnit { hsunitName = $2-                              , hsunitBody = fromOL $4 } }--unitid :: { LHsUnitId PackageName }-        : pkgname                  { sL1 $1 $ HsUnitId $1 [] }-        | pkgname '[' msubsts ']'  { sLL $1 $> $ HsUnitId $1 (fromOL $3) }--msubsts :: { OrdList (LHsModuleSubst PackageName) }-        : msubsts ',' msubst { $1 `appOL` unitOL $3 }-        | msubsts ','        { $1 }-        | msubst             { unitOL $1 }--msubst :: { LHsModuleSubst PackageName }-        : modid '=' moduleid { sLL (reLoc $1) $> $ (reLoc $1, $3) }-        | modid VARSYM modid VARSYM { sLL (reLoc $1) $> $ (reLoc $1, sLL $2 $> $ HsModuleVar (reLoc $3)) }--moduleid :: { LHsModuleId PackageName }-          : VARSYM modid VARSYM { sLL $1 $> $ HsModuleVar (reLoc $2) }-          | unitid ':' modid    { sLL $1 (reLoc $>) $ HsModuleId $1 (reLoc $3) }--pkgname :: { Located PackageName }-        : STRING     { sL1 $1 $ PackageName (getSTRING $1) }-        | litpkgname { sL1 $1 $ PackageName (unLoc $1) }--litpkgname_segment :: { Located FastString }-        : VARID  { sL1 $1 $ getVARID $1 }-        | CONID  { sL1 $1 $ getCONID $1 }-        | special_id { $1 }---- Parse a minus sign regardless of whether -XLexicalNegation is turned on or off.--- See Note [Minus tokens] in GHC.Parser.Lexer-HYPHEN :: { [AddEpAnn] }-      : '-'          { [mj AnnMinus $1 ] }-      | PREFIX_MINUS { [mj AnnMinus $1 ] }-      | VARSYM  {% if (getVARSYM $1 == fsLit "-")-                   then return [mj AnnMinus $1]-                   else do { addError $ mkPlainErrorMsgEnvelope (getLoc $1) $ PsErrExpectedHyphen-                           ; return [] } }---litpkgname :: { Located FastString }-        : litpkgname_segment { $1 }-        -- a bit of a hack, means p - b is parsed same as p-b, enough for now.-        | litpkgname_segment HYPHEN litpkgname  { sLL $1 $> $ concatFS [unLoc $1, fsLit "-", (unLoc $3)] }--mayberns :: { Maybe [LRenaming] }-        : {- empty -} { Nothing }-        | '(' rns ')' { Just (fromOL $2) }--rns :: { OrdList LRenaming }-        : rns ',' rn { $1 `appOL` unitOL $3 }-        | rns ','    { $1 }-        | rn         { unitOL $1 }--rn :: { LRenaming }-        : modid 'as' modid { sLL (reLoc $1) (reLoc $>) $ Renaming (reLoc $1) (Just (reLoc $3)) }-        | modid            { sL1 (reLoc $1)            $ Renaming (reLoc $1) Nothing }--unitbody :: { OrdList (LHsUnitDecl PackageName) }-        : '{'     unitdecls '}'   { $2 }-        | vocurly unitdecls close { $2 }--unitdecls :: { OrdList (LHsUnitDecl PackageName) }-        : unitdecls ';' unitdecl { $1 `appOL` unitOL $3 }-        | unitdecls ';'         { $1 }-        | unitdecl              { unitOL $1 }--unitdecl :: { LHsUnitDecl PackageName }-        : 'module' maybe_src modid maybemodwarning maybeexports 'where' body-             -- XXX not accurate-             { sL1 $1 $ DeclD-                 (case snd $2 of-                   NotBoot -> HsSrcFile-                   IsBoot  -> HsBootFile)-                 (reLoc $3)-                 (sL1 $1 (HsModule (XModulePs noAnn (thdOf3 $7) $4 Nothing) (Just $3) $5 (fst $ sndOf3 $7) (snd $ sndOf3 $7))) }-        | 'signature' modid maybemodwarning maybeexports 'where' body-             { sL1 $1 $ DeclD-                 HsigFile-                 (reLoc $2)-                 (sL1 $1 (HsModule (XModulePs noAnn (thdOf3 $6) $3 Nothing) (Just $2) $4 (fst $ sndOf3 $6) (snd $ sndOf3 $6))) }-        | 'dependency' unitid mayberns-             { sL1 $1 $ IncludeD (IncludeDecl { idUnitId = $2-                                              , idModRenaming = $3-                                              , idSignatureInclude = False }) }-        | 'dependency' 'signature' unitid-             { sL1 $1 $ IncludeD (IncludeDecl { idUnitId = $3-                                              , idModRenaming = Nothing-                                              , idSignatureInclude = True }) }---------------------------------------------------------------------------------- Module Header---- The place for module deprecation is really too restrictive, but if it--- was allowed at its natural place just before 'module', we get an ugly--- s/r conflict with the second alternative. Another solution would be the--- introduction of a new pragma DEPRECATED_MODULE, but this is not very nice,--- either, and DEPRECATED is only expected to be used by people who really--- know what they are doing. :-)--signature :: { Located (HsModule GhcPs) }-       : 'signature' modid maybemodwarning maybeexports 'where' body-             {% fileSrcSpan >>= \ loc ->-                acs (\cs-> (L loc (HsModule (XModulePs-                                               (EpAnn (spanAsAnchor loc) (AnnsModule [mj AnnSignature $1, mj AnnWhere $5] (fstOf3 $6) Nothing) cs)-                                               (thdOf3 $6) $3 Nothing)-                                            (Just $2) $4 (fst $ sndOf3 $6)-                                            (snd $ sndOf3 $6)))-                    ) }--module :: { Located (HsModule GhcPs) }-       : 'module' modid maybemodwarning maybeexports 'where' body-             {% fileSrcSpan >>= \ loc ->-                acsFinal (\cs eof -> (L loc (HsModule (XModulePs-                                                     (EpAnn (spanAsAnchor loc) (AnnsModule [mj AnnModule $1, mj AnnWhere $5] (fstOf3 $6) eof) cs)-                                                     (thdOf3 $6) $3 Nothing)-                                                  (Just $2) $4 (fst $ sndOf3 $6)-                                                  (snd $ sndOf3 $6))-                    )) }-        | body2-                {% fileSrcSpan >>= \ loc ->-                   acsFinal (\cs eof -> (L loc (HsModule (XModulePs-                                                        (EpAnn (spanAsAnchor loc) (AnnsModule [] (fstOf3 $1) eof) cs)-                                                        (thdOf3 $1) Nothing Nothing)-                                                     Nothing Nothing-                                                     (fst $ sndOf3 $1) (snd $ sndOf3 $1)))) }--missing_module_keyword :: { () }-        : {- empty -}                           {% pushModuleContext }--implicit_top :: { () }-        : {- empty -}                           {% pushModuleContext }--maybemodwarning :: { Maybe (LocatedP (WarningTxt GhcPs)) }-    : '{-# DEPRECATED' strings '#-}'-                      {% fmap Just $ amsrp (sLL $1 $> $ DeprecatedTxt (sL1 $1 $ getDEPRECATED_PRAGs $1) (map stringLiteralToHsDocWst $ snd $ unLoc $2))-                              (AnnPragma (mo $1) (mc $3) (fst $ unLoc $2)) }-    | '{-# WARNING' warning_category strings '#-}'-                         {% fmap Just $ amsrp (sLL $1 $> $ WarningTxt $2 (sL1 $1 $ getWARNING_PRAGs $1) (map stringLiteralToHsDocWst $ snd $ unLoc $3))-                                 (AnnPragma (mo $1) (mc $4) (fst $ unLoc $3))}-    |  {- empty -}                  { Nothing }--body    :: { ([TrailingAnn]-             ,([LImportDecl GhcPs], [LHsDecl GhcPs])-             ,LayoutInfo GhcPs) }-        :  '{'            top '}'      { (fst $2, snd $2, explicitBraces $1 $3) }-        |      vocurly    top close    { (fst $2, snd $2, VirtualBraces (getVOCURLY $1)) }--body2   :: { ([TrailingAnn]-             ,([LImportDecl GhcPs], [LHsDecl GhcPs])-             ,LayoutInfo GhcPs) }-        :  '{' top '}'                          { (fst $2, snd $2, explicitBraces $1 $3) }-        |  missing_module_keyword top close     { ([], snd $2, VirtualBraces leftmostColumn) }---top     :: { ([TrailingAnn]-             ,([LImportDecl GhcPs], [LHsDecl GhcPs])) }-        : semis top1                            { (reverse $1, $2) }--top1    :: { ([LImportDecl GhcPs], [LHsDecl GhcPs]) }-        : importdecls_semi topdecls_cs_semi        { (reverse $1, cvTopDecls $2) }-        | importdecls_semi topdecls_cs             { (reverse $1, cvTopDecls $2) }-        | importdecls                              { (reverse $1, []) }---------------------------------------------------------------------------------- Module declaration & imports only--header  :: { Located (HsModule GhcPs) }-        : 'module' modid maybemodwarning maybeexports 'where' header_body-                {% fileSrcSpan >>= \ loc ->-                   acs (\cs -> (L loc (HsModule (XModulePs-                                                   (EpAnn (spanAsAnchor loc) (AnnsModule [mj AnnModule $1,mj AnnWhere $5] [] Nothing) cs)-                                                   NoLayoutInfo $3 Nothing)-                                                (Just $2) $4 $6 []-                          ))) }-        | 'signature' modid maybemodwarning maybeexports 'where' header_body-                {% fileSrcSpan >>= \ loc ->-                   acs (\cs -> (L loc (HsModule (XModulePs-                                                   (EpAnn (spanAsAnchor loc) (AnnsModule [mj AnnModule $1,mj AnnWhere $5] [] Nothing) cs)-                                                   NoLayoutInfo $3 Nothing)-                                                (Just $2) $4 $6 []-                          ))) }-        | header_body2-                {% fileSrcSpan >>= \ loc ->-                   return (L loc (HsModule (XModulePs noAnn NoLayoutInfo Nothing Nothing) Nothing Nothing $1 [])) }--header_body :: { [LImportDecl GhcPs] }-        :  '{'            header_top            { $2 }-        |      vocurly    header_top            { $2 }--header_body2 :: { [LImportDecl GhcPs] }-        :  '{' header_top                       { $2 }-        |  missing_module_keyword header_top    { $2 }--header_top :: { [LImportDecl GhcPs] }-        :  semis header_top_importdecls         { $2 }--header_top_importdecls :: { [LImportDecl GhcPs] }-        :  importdecls_semi                     { $1 }-        |  importdecls                          { $1 }---------------------------------------------------------------------------------- The Export List--maybeexports :: { (Maybe (LocatedL [LIE GhcPs])) }-        :  '(' exportlist ')'       {% fmap Just $ amsrl (sLL $1 $> (fromOL $ snd $2))-                                        (AnnList Nothing (Just $ mop $1) (Just $ mcp $3) (fst $2) []) }-        |  {- empty -}              { Nothing }--exportlist :: { ([AddEpAnn], OrdList (LIE GhcPs)) }-        : exportlist1     { ([], $1) }-        | {- empty -}     { ([], nilOL) }--        -- trailing comma:-        | exportlist1 ',' {% case $1 of-                               SnocOL hs t -> do-                                 t' <- addTrailingCommaA t (gl $2)-                                 return ([], snocOL hs t')}-        | ','             { ([mj AnnComma $1], nilOL) }--exportlist1 :: { OrdList (LIE GhcPs) }-        : exportlist1 ',' export-                          {% let ls = $1-                             in if isNilOL ls-                                  then return (ls `appOL` $3)-                                  else case ls of-                                         SnocOL hs t -> do-                                           t' <- addTrailingCommaA t (gl $2)-                                           return (snocOL hs t' `appOL` $3)}-        | export          { $1 }---   -- No longer allow things like [] and (,,,) to be exported-   -- They are built in syntax, always available-export  :: { OrdList (LIE GhcPs) }-        : maybeexportwarning qcname_ext export_subspec {% do { let { span = (maybe comb2 (comb3 . reLoc) $1) (reLoc $2) $> }-                                                          ; impExp <- mkModuleImpExp $1 (fst $ unLoc $3) $2 (snd $ unLoc $3)-                                                          ; return $ unitOL $ reLocA $ sL span $ impExp } }-        | maybeexportwarning 'module' modid            {% do { let { span = (maybe comb2 (comb3 . reLoc) $1) $2 (reLoc $>)-                                                                   ; anchor = (maybe glR (\loc -> spanAsAnchor . comb2 (reLoc loc)) $1) $2 }-                                                          ; locImpExp <- acs (\cs -> sL span (IEModuleContents ($1, EpAnn anchor [mj AnnModule $2] cs) $3))-                                                          ; return $ unitOL $ reLocA $ locImpExp } }-        | maybeexportwarning 'pattern' qcon            { let span = (maybe comb2 (comb3 . reLoc) $1) $2 (reLoc $>)-                                                       in unitOL $ reLocA $ sL span $ IEVar $1 (sLLa $2 (reLocN $>) (IEPattern (glAA $2) $3)) }--maybeexportwarning :: { Maybe (LocatedP (WarningTxt GhcPs)) }-        : '{-# DEPRECATED' strings '#-}'-                            {% fmap Just $ amsrp (sLL $1 $> $ DeprecatedTxt (sL1 $1 $ getDEPRECATED_PRAGs $1) (map stringLiteralToHsDocWst $ snd $ unLoc $2))-                                (AnnPragma (mo $1) (mc $3) (fst $ unLoc $2)) }-        | '{-# WARNING' warning_category strings '#-}'-                            {% fmap Just $ amsrp (sLL $1 $> $ WarningTxt $2 (sL1 $1 $ getWARNING_PRAGs $1) (map stringLiteralToHsDocWst $ snd $ unLoc $3))-                                (AnnPragma (mo $1) (mc $4) (fst $ unLoc $3))}-        |  {- empty -}      { Nothing }--export_subspec :: { Located ([AddEpAnn],ImpExpSubSpec) }-        : {- empty -}             { sL0 ([],ImpExpAbs) }-        | '(' qcnames ')'         {% mkImpExpSubSpec (reverse (snd $2))-                                      >>= \(as,ie) -> return $ sLL $1 $>-                                            (as ++ [mop $1,mcp $3] ++ fst $2, ie) }--qcnames :: { ([AddEpAnn], [LocatedA ImpExpQcSpec]) }-  : {- empty -}                   { ([],[]) }-  | qcnames1                      { $1 }--qcnames1 :: { ([AddEpAnn], [LocatedA ImpExpQcSpec]) }     -- A reversed list-        :  qcnames1 ',' qcname_ext_w_wildcard  {% case (snd $1) of-                                                    (l@(L la ImpExpQcWildcard):t) ->-                                                       do { l' <- addTrailingCommaA l (gl $2)-                                                          ; return ([mj AnnDotdot (reLoc l),-                                                                     mj AnnComma $2]-                                                                   ,(snd (unLoc $3)  : l' : t)) }-                                                    (l:t) ->-                                                       do { l' <- addTrailingCommaA l (gl $2)-                                                          ; return (fst $1 ++ fst (unLoc $3)-                                                                   , snd (unLoc $3) : l' : t)} }--        -- Annotations re-added in mkImpExpSubSpec-        |  qcname_ext_w_wildcard                   { (fst (unLoc $1),[snd (unLoc $1)]) }---- Variable, data constructor or wildcard--- or tagged type constructor-qcname_ext_w_wildcard :: { Located ([AddEpAnn], LocatedA ImpExpQcSpec) }-        :  qcname_ext               { sL1A $1 ([],$1) }-        |  '..'                     { sL1  $1 ([mj AnnDotdot $1], sL1a $1 ImpExpQcWildcard)  }--qcname_ext :: { LocatedA ImpExpQcSpec }-        :  qcname                   { reLocA $ sL1N $1 (ImpExpQcName $1) }-        |  'type' oqtycon           {% do { n <- mkTypeImpExp $2-                                          ; return $ sLLa $1 (reLocN $>) (ImpExpQcType (glAA $1) n) }}--qcname  :: { LocatedN RdrName }  -- Variable or type constructor-        :  qvar                 { $1 } -- Things which look like functions-                                       -- Note: This includes record selectors but-                                       -- also (-.->), see #11432-        |  oqtycon_no_varcon    { $1 } -- see Note [Type constructors in export list]---------------------------------------------------------------------------------- Import Declarations---- importdecls and topdecls must contain at least one declaration;--- top handles the fact that these may be optional.---- One or more semicolons-semis1  :: { Located [TrailingAnn] }-semis1  : semis1 ';'  { if isZeroWidthSpan (gl $2) then (sL1 $1 $ unLoc $1) else (sLL $1 $> $ AddSemiAnn (glAA $2) : (unLoc $1)) }-        | ';'         { case msemi $1 of-                          [] -> noLoc []-                          ms -> sL1 $1 $ ms }---- Zero or more semicolons-semis   :: { [TrailingAnn] }-semis   : semis ';'   { if isZeroWidthSpan (gl $2) then $1 else (AddSemiAnn (glAA $2) : $1) }-        | {- empty -} { [] }---- No trailing semicolons, non-empty-importdecls :: { [LImportDecl GhcPs] }-importdecls-        : importdecls_semi importdecl-                                { $2 : $1 }---- May have trailing semicolons, can be empty-importdecls_semi :: { [LImportDecl GhcPs] }-importdecls_semi-        : importdecls_semi importdecl semis1-                                {% do { i <- amsAl $2 (comb2 (reLoc $2) $3) (reverse $ unLoc $3)-                                      ; return (i : $1)} }-        | {- empty -}           { [] }--importdecl :: { LImportDecl GhcPs }-        : 'import' maybe_src maybe_safe optqualified maybe_pkg modid optqualified maybeas maybeimpspec-                {% do {-                  ; let { ; mPreQual = unLoc $4-                          ; mPostQual = unLoc $7 }-                  ; checkImportDecl mPreQual mPostQual-                  ; let anns-                         = EpAnnImportDecl-                             { importDeclAnnImport    = glAA $1-                             , importDeclAnnPragma    = fst $ fst $2-                             , importDeclAnnSafe      = fst $3-                             , importDeclAnnQualified = fst $ importDeclQualifiedStyle mPreQual mPostQual-                             , importDeclAnnPackage   = fst $5-                             , importDeclAnnAs        = fst $8-                             }-                  ; fmap reLocA $ acs (\cs -> L (comb5 $1 (reLoc $6) $7 (snd $8) $9) $-                      ImportDecl { ideclExt = XImportDeclPass (EpAnn (glR $1) anns cs) (snd $ fst $2) False-                                  , ideclName = $6, ideclPkgQual = snd $5-                                  , ideclSource = snd $2, ideclSafe = snd $3-                                  , ideclQualified = snd $ importDeclQualifiedStyle mPreQual mPostQual-                                  , ideclAs = unLoc (snd $8)-                                  , ideclImportList = unLoc $9 })-                  }-                }---maybe_src :: { ((Maybe (EpaLocation,EpaLocation),SourceText),IsBootInterface) }-        : '{-# SOURCE' '#-}'        { ((Just (glAA $1,glAA $2),getSOURCE_PRAGs $1)-                                      , IsBoot) }-        | {- empty -}               { ((Nothing,NoSourceText),NotBoot) }--maybe_safe :: { (Maybe EpaLocation,Bool) }-        : 'safe'                                { (Just (glAA $1),True) }-        | {- empty -}                           { (Nothing,      False) }--maybe_pkg :: { (Maybe EpaLocation, RawPkgQual) }-        : STRING  {% do { let { pkgFS = getSTRING $1 }-                        ; unless (looksLikePackageName (unpackFS pkgFS)) $-                             addError $ mkPlainErrorMsgEnvelope (getLoc $1) $-                               (PsErrInvalidPackageName pkgFS)-                        ; return (Just (glAA $1), RawPkgQual (StringLiteral (getSTRINGs $1) pkgFS Nothing)) } }-        | {- empty -}                           { (Nothing,NoRawPkgQual) }--optqualified :: { Located (Maybe EpaLocation) }-        : 'qualified'                           { sL1 $1 (Just (glAA $1)) }-        | {- empty -}                           { noLoc Nothing }--maybeas :: { (Maybe EpaLocation,Located (Maybe (LocatedA ModuleName))) }-        : 'as' modid                           { (Just (glAA $1)-                                                 ,sLL $1 (reLoc $>) (Just $2)) }-        | {- empty -}                          { (Nothing,noLoc Nothing) }--maybeimpspec :: { Located (Maybe (ImportListInterpretation, LocatedL [LIE GhcPs])) }-        : impspec                  {% let (b, ie) = unLoc $1 in-                                       checkImportSpec ie-                                        >>= \checkedIe ->-                                          return (L (gl $1) (Just (b, checkedIe)))  }-        | {- empty -}              { noLoc Nothing }--impspec :: { Located (ImportListInterpretation, LocatedL [LIE GhcPs]) }-        :  '(' importlist ')'               {% do { es <- amsrl (sLL $1 $> $ fromOL $ snd $2)-                                                               (AnnList Nothing (Just $ mop $1) (Just $ mcp $3) (fst $2) [])-                                                  ; return $ sLL $1 $> (Exactly, es)} }-        |  'hiding' '(' importlist ')'      {% do { es <- amsrl (sLL $1 $> $ fromOL $ snd $3)-                                                               (AnnList Nothing (Just $ mop $2) (Just $ mcp $4) (mj AnnHiding $1:fst $3) [])-                                                  ; return $ sLL $1 $> (EverythingBut, es)} }--importlist :: { ([AddEpAnn], OrdList (LIE GhcPs)) }-        : importlist1     { ([], $1) }-        | {- empty -}     { ([], nilOL) }--        -- trailing comma:-        | importlist1 ',' {% case $1 of-                               SnocOL hs t -> do-                                 t' <- addTrailingCommaA t (gl $2)-                                 return ([], snocOL hs t')}-        | ','             { ([mj AnnComma $1], nilOL) }--importlist1 :: { OrdList (LIE GhcPs) }-        : importlist1 ',' import-                          {% let ls = $1-                             in if isNilOL ls-                                  then return (ls `appOL` $3)-                                  else case ls of-                                         SnocOL hs t -> do-                                           t' <- addTrailingCommaA t (gl $2)-                                           return (snocOL hs t' `appOL` $3)}-        | import          { $1 }--import  :: { OrdList (LIE GhcPs) }-        : qcname_ext export_subspec {% fmap (unitOL . reLocA . (sLL (reLoc $1) $>)) $ mkModuleImpExp Nothing (fst $ unLoc $2) $1 (snd $ unLoc $2) }-        | 'module' modid            {% fmap (unitOL . reLocA) $ acs (\cs -> sLL $1 (reLoc $>) (IEModuleContents (Nothing, EpAnn (glR $1) [mj AnnModule $1] cs) $2)) }-        | 'pattern' qcon            { unitOL $ reLocA $ sLL $1 (reLocN $>) $ IEVar Nothing (sLLa $1 (reLocN $>) (IEPattern (glAA $1) $2)) }---------------------------------------------------------------------------------- Fixity Declarations--prec    :: { Maybe (Located (SourceText,Int)) }-        : {- empty -}           { Nothing }-        | INTEGER-                 { Just (sL1 $1 (getINTEGERs $1,fromInteger (il_value (getINTEGER $1)))) }--infix   :: { Located FixityDirection }-        : 'infix'                               { sL1 $1 InfixN  }-        | 'infixl'                              { sL1 $1 InfixL  }-        | 'infixr'                              { sL1 $1 InfixR }--ops     :: { Located (OrdList (LocatedN RdrName)) }-        : ops ',' op       {% case (unLoc $1) of-                                SnocOL hs t -> do-                                  t' <- addTrailingCommaN t (gl $2)-                                  return (sLL $1 (reLocN $>) (snocOL hs t' `appOL` unitOL $3)) }-        | op               { sL1N $1 (unitOL $1) }---------------------------------------------------------------------------------- Top-Level Declarations---- No trailing semicolons, non-empty-topdecls :: { OrdList (LHsDecl GhcPs) }-        : topdecls_semi topdecl        { $1 `snocOL` $2 }---- May have trailing semicolons, can be empty-topdecls_semi :: { OrdList (LHsDecl GhcPs) }-        : topdecls_semi topdecl semis1 {% do { t <- amsAl $2 (comb2 (reLoc $2) $3) (reverse $ unLoc $3)-                                             ; return ($1 `snocOL` t) }}-        | {- empty -}                  { nilOL }----------------------------------------------------------------------------------- Each topdecl accumulates prior comments--- No trailing semicolons, non-empty-topdecls_cs :: { OrdList (LHsDecl GhcPs) }-        : topdecls_cs_semi topdecl_cs        { $1 `snocOL` $2 }---- May have trailing semicolons, can be empty-topdecls_cs_semi :: { OrdList (LHsDecl GhcPs) }-        : topdecls_cs_semi topdecl_cs semis1 {% do { t <- amsAl $2 (comb2 (reLoc $2) $3) (reverse $ unLoc $3)-                                                   ; return ($1 `snocOL` t) }}-        | {- empty -}                  { nilOL }---- Each topdecl accumulates prior comments-topdecl_cs :: { LHsDecl GhcPs }-topdecl_cs : topdecl {% commentsPA $1 }--------------------------------------------------------------------------------topdecl :: { LHsDecl GhcPs }-        : cl_decl                               { sL1 $1 (TyClD noExtField (unLoc $1)) }-        | ty_decl                               { sL1 $1 (TyClD noExtField (unLoc $1)) }-        | standalone_kind_sig                   { sL1 $1 (KindSigD noExtField (unLoc $1)) }-        | inst_decl                             { sL1 $1 (InstD noExtField (unLoc $1)) }-        | stand_alone_deriving                  { sL1 $1 (DerivD noExtField (unLoc $1)) }-        | role_annot                            { sL1 $1 (RoleAnnotD noExtField (unLoc $1)) }-        | 'default' '(' comma_types0 ')'        {% acsA (\cs -> sLL $1 $>-                                                    (DefD noExtField (DefaultDecl (EpAnn (glR $1) [mj AnnDefault $1,mop $2,mcp $4] cs) $3))) }-        | 'foreign' fdecl                       {% acsA (\cs -> sLL $1 $> ((snd $ unLoc $2) (EpAnn (glR $1) (mj AnnForeign $1:(fst $ unLoc $2)) cs))) }-        | '{-# DEPRECATED' deprecations '#-}'   {% acsA (\cs -> sLL $1 $> $ WarningD noExtField (Warnings ((EpAnn (glR $1) [mo $1,mc $3] cs), (getDEPRECATED_PRAGs $1)) (fromOL $2))) }-        | '{-# WARNING' warnings '#-}'          {% acsA (\cs -> sLL $1 $> $ WarningD noExtField (Warnings ((EpAnn (glR $1) [mo $1,mc $3] cs), (getWARNING_PRAGs $1)) (fromOL $2))) }-        | '{-# RULES' rules '#-}'               {% acsA (\cs -> sLL $1 $> $ RuleD noExtField (HsRules ((EpAnn (glR $1) [mo $1,mc $3] cs), (getRULES_PRAGs $1)) (reverse $2))) }-        | annotation { $1 }-        | decl_no_th                            { $1 }--        -- Template Haskell Extension-        -- The $(..) form is one possible form of infixexp-        -- but we treat an arbitrary expression just as if-        -- it had a $(..) wrapped around it-        | infixexp                              {% runPV (unECP $1) >>= \ $1 ->-                                                    do { d <- mkSpliceDecl $1-                                                       ; commentsPA d }}---- Type classes----cl_decl :: { LTyClDecl GhcPs }-        : 'class' tycl_hdr fds where_cls-                {% (mkClassDecl (comb4 $1 $2 $3 $4) $2 $3 (sndOf3 $ unLoc $4) (thdOf3 $ unLoc $4))-                        (mj AnnClass $1:(fst $ unLoc $3)++(fstOf3 $ unLoc $4)) }---- Type declarations (toplevel)----ty_decl :: { LTyClDecl GhcPs }-           -- ordinary type synonyms-        : 'type' type '=' ktype-                -- Note ktype, not sigtype, on the right of '='-                -- We allow an explicit for-all but we don't insert one-                -- in   type Foo a = (b,b)-                -- Instead we just say b is out of scope-                ---                -- Note the use of type for the head; this allows-                -- infix type constructors to be declared-                {% mkTySynonym (comb2A $1 $4) $2 $4 [mj AnnType $1,mj AnnEqual $3] }--           -- type family declarations-        | 'type' 'family' type opt_tyfam_kind_sig opt_injective_info-                          where_type_family-                -- Note the use of type for the head; this allows-                -- infix type constructors to be declared-                {% mkFamDecl (comb5 $1 (reLoc $3) $4 $5 $6) (snd $ unLoc $6) TopLevel $3-                                   (snd $ unLoc $4) (snd $ unLoc $5)-                           (mj AnnType $1:mj AnnFamily $2:(fst $ unLoc $4)-                           ++ (fst $ unLoc $5) ++ (fst $ unLoc $6))  }--          -- ordinary data type or newtype declaration-        | type_data_or_newtype capi_ctype tycl_hdr constrs maybe_derivings-                {% mkTyData (comb4 $1 $3 $4 $5) (sndOf3 $ unLoc $1) (thdOf3 $ unLoc $1) $2 $3-                           Nothing (reverse (snd $ unLoc $4))-                                   (fmap reverse $5)-                           ((fstOf3 $ unLoc $1)++(fst $ unLoc $4)) }-                                   -- We need the location on tycl_hdr in case-                                   -- constrs and deriving are both empty--          -- ordinary GADT declaration-        | type_data_or_newtype capi_ctype tycl_hdr opt_kind_sig-                 gadt_constrlist-                 maybe_derivings-            {% mkTyData (comb4 $1 $3 $5 $6) (sndOf3 $ unLoc $1) (thdOf3 $ unLoc $1) $2 $3-                            (snd $ unLoc $4) (snd $ unLoc $5)-                            (fmap reverse $6)-                            ((fstOf3 $ unLoc $1)++(fst $ unLoc $4)++(fst $ unLoc $5)) }-                                   -- We need the location on tycl_hdr in case-                                   -- constrs and deriving are both empty--          -- data/newtype family-        | 'data' 'family' type opt_datafam_kind_sig-                {% mkFamDecl (comb3 $1 $2 $4) DataFamily TopLevel $3-                                   (snd $ unLoc $4) Nothing-                          (mj AnnData $1:mj AnnFamily $2:(fst $ unLoc $4)) }---- standalone kind signature-standalone_kind_sig :: { LStandaloneKindSig GhcPs }-  : 'type' sks_vars '::' sigktype-      {% mkStandaloneKindSig (comb2A $1 $4) (L (gl $2) $ unLoc $2) $4-               [mj AnnType $1,mu AnnDcolon $3]}---- See also: sig_vars-sks_vars :: { Located [LocatedN RdrName] }  -- Returned in reverse order-  : sks_vars ',' oqtycon-      {% case unLoc $1 of-           (h:t) -> do-             h' <- addTrailingCommaN h (gl $2)-             return (sLL $1 (reLocN $>) ($3 : h' : t)) }-  | oqtycon { sL1N $1 [$1] }--inst_decl :: { LInstDecl GhcPs }-        : 'instance' overlap_pragma inst_type where_inst-       {% do { (binds, sigs, _, ats, adts, _) <- cvBindsAndSigs (snd $ unLoc $4)-             ; let anns = (mj AnnInstance $1 : (fst $ unLoc $4))-             ; let cid cs = ClsInstDecl-                                     { cid_ext = (EpAnn (glR $1) anns cs, NoAnnSortKey)-                                     , cid_poly_ty = $3, cid_binds = binds-                                     , cid_sigs = mkClassOpSigs sigs-                                     , cid_tyfam_insts = ats-                                     , cid_overlap_mode = $2-                                     , cid_datafam_insts = adts }-             ; acsA (\cs -> L (comb3 $1 (reLoc $3) $4)-                             (ClsInstD { cid_d_ext = noExtField, cid_inst = cid cs }))-                   } }--           -- type instance declarations-        | 'type' 'instance' ty_fam_inst_eqn-                {% mkTyFamInst (comb2A $1 $3) (unLoc $3)-                        (mj AnnType $1:mj AnnInstance $2:[]) }--          -- data/newtype instance declaration-        | data_or_newtype 'instance' capi_ctype datafam_inst_hdr constrs-                          maybe_derivings-            {% mkDataFamInst (comb4 $1 $4 $5 $6) (snd $ unLoc $1) $3 (unLoc $4)-                                      Nothing (reverse (snd  $ unLoc $5))-                                              (fmap reverse $6)-                      ((fst $ unLoc $1):mj AnnInstance $2:(fst $ unLoc $5)) }--          -- GADT instance declaration-        | data_or_newtype 'instance' capi_ctype datafam_inst_hdr opt_kind_sig-                 gadt_constrlist-                 maybe_derivings-            {% mkDataFamInst (comb4 $1 $4 $6 $7) (snd $ unLoc $1) $3 (unLoc $4)-                                   (snd $ unLoc $5) (snd $ unLoc $6)-                                   (fmap reverse $7)-                     ((fst $ unLoc $1):mj AnnInstance $2-                       :(fst $ unLoc $5)++(fst $ unLoc $6)) }--overlap_pragma :: { Maybe (LocatedP OverlapMode) }-  : '{-# OVERLAPPABLE'    '#-}' {% fmap Just $ amsrp (sLL $1 $> (Overlappable (getOVERLAPPABLE_PRAGs $1)))-                                       (AnnPragma (mo $1) (mc $2) []) }-  | '{-# OVERLAPPING'     '#-}' {% fmap Just $ amsrp (sLL $1 $> (Overlapping (getOVERLAPPING_PRAGs $1)))-                                       (AnnPragma (mo $1) (mc $2) []) }-  | '{-# OVERLAPS'        '#-}' {% fmap Just $ amsrp (sLL $1 $> (Overlaps (getOVERLAPS_PRAGs $1)))-                                       (AnnPragma (mo $1) (mc $2) []) }-  | '{-# INCOHERENT'      '#-}' {% fmap Just $ amsrp (sLL $1 $> (Incoherent (getINCOHERENT_PRAGs $1)))-                                       (AnnPragma (mo $1) (mc $2) []) }-  | {- empty -}                 { Nothing }--deriv_strategy_no_via :: { LDerivStrategy GhcPs }-  : 'stock'                     {% acsA (\cs -> sL1 $1 (StockStrategy (EpAnn (glR $1) [mj AnnStock $1] cs))) }-  | 'anyclass'                  {% acsA (\cs -> sL1 $1 (AnyclassStrategy (EpAnn (glR $1) [mj AnnAnyclass $1] cs))) }-  | 'newtype'                   {% acsA (\cs -> sL1 $1 (NewtypeStrategy (EpAnn (glR $1) [mj AnnNewtype $1] cs))) }--deriv_strategy_via :: { LDerivStrategy GhcPs }-  : 'via' sigktype          {% acsA (\cs -> sLLlA $1 $> (ViaStrategy (XViaStrategyPs (EpAnn (glR $1) [mj AnnVia $1] cs)-                                                                           $2))) }--deriv_standalone_strategy :: { Maybe (LDerivStrategy GhcPs) }-  : 'stock'                     {% fmap Just $ acsA (\cs -> sL1 $1 (StockStrategy (EpAnn (glR $1) [mj AnnStock $1] cs))) }-  | 'anyclass'                  {% fmap Just $ acsA (\cs -> sL1 $1 (AnyclassStrategy (EpAnn (glR $1) [mj AnnAnyclass $1] cs))) }-  | 'newtype'                   {% fmap Just $ acsA (\cs -> sL1 $1 (NewtypeStrategy (EpAnn (glR $1) [mj AnnNewtype $1] cs))) }-  | deriv_strategy_via          { Just $1 }-  | {- empty -}                 { Nothing }---- Injective type families--opt_injective_info :: { Located ([AddEpAnn], Maybe (LInjectivityAnn GhcPs)) }-        : {- empty -}               { noLoc ([], Nothing) }-        | '|' injectivity_cond      { sLL $1 (reLoc $>) ([mj AnnVbar $1]-                                                , Just ($2)) }--injectivity_cond :: { LInjectivityAnn GhcPs }-        : tyvarid '->' inj_varids-           {% acsA (\cs -> sLL (reLocN $1) $> (InjectivityAnn (EpAnn (glNR $1) [mu AnnRarrow $2] cs) $1 (reverse (unLoc $3)))) }--inj_varids :: { Located [LocatedN RdrName] }-        : inj_varids tyvarid  { sLL $1 (reLocN $>) ($2 : unLoc $1) }-        | tyvarid             { sL1N  $1 [$1]               }---- Closed type families--where_type_family :: { Located ([AddEpAnn],FamilyInfo GhcPs) }-        : {- empty -}                      { noLoc ([],OpenTypeFamily) }-        | 'where' ty_fam_inst_eqn_list-               { sLL $1 $> (mj AnnWhere $1:(fst $ unLoc $2)-                    ,ClosedTypeFamily (fmap reverse $ snd $ unLoc $2)) }--ty_fam_inst_eqn_list :: { Located ([AddEpAnn],Maybe [LTyFamInstEqn GhcPs]) }-        :     '{' ty_fam_inst_eqns '}'     { sLL $1 $> ([moc $1,mcc $3]-                                                ,Just (unLoc $2)) }-        | vocurly ty_fam_inst_eqns close   { let (L loc _) = $2 in-                                             L loc ([],Just (unLoc $2)) }-        |     '{' '..' '}'                 { sLL $1 $> ([moc $1,mj AnnDotdot $2-                                                 ,mcc $3],Nothing) }-        | vocurly '..' close               { let (L loc _) = $2 in-                                             L loc ([mj AnnDotdot $2],Nothing) }--ty_fam_inst_eqns :: { Located [LTyFamInstEqn GhcPs] }-        : ty_fam_inst_eqns ';' ty_fam_inst_eqn-                                      {% let (L loc eqn) = $3 in-                                         case unLoc $1 of-                                           [] -> return (sLLlA $1 $> (L loc eqn : unLoc $1))-                                           (h:t) -> do-                                             h' <- addTrailingSemiA h (gl $2)-                                             return (sLLlA $1 $> ($3 : h' : t)) }-        | ty_fam_inst_eqns ';'        {% case unLoc $1 of-                                           [] -> return (sLL $1 $> (unLoc $1))-                                           (h:t) -> do-                                             h' <- addTrailingSemiA h (gl $2)-                                             return (sLL $1 $>  (h':t)) }-        | ty_fam_inst_eqn             { sLLAA $1 $> [$1] }-        | {- empty -}                 { noLoc [] }--ty_fam_inst_eqn :: { LTyFamInstEqn GhcPs }-        : 'forall' tv_bndrs '.' type '=' ktype-              {% do { hintExplicitForall $1-                    ; tvbs <- fromSpecTyVarBndrs $2-                    ; let loc = comb2A $1 $>-                    ; cs <- getCommentsFor loc-                    ; mkTyFamInstEqn loc (mkHsOuterExplicit (EpAnn (glR $1) (mu AnnForall $1, mj AnnDot $3) cs) tvbs) $4 $6 [mj AnnEqual $5] }}-        | type '=' ktype-              {% mkTyFamInstEqn (comb2A (reLoc $1) $>) mkHsOuterImplicit $1 $3 (mj AnnEqual $2:[]) }-              -- Note the use of type for the head; this allows-              -- infix type constructors and type patterns---- Associated type family declarations------ * They have a different syntax than on the toplevel (no family special---   identifier).------ * They also need to be separate from instances; otherwise, data family---   declarations without a kind signature cause parsing conflicts with empty---   data declarations.----at_decl_cls :: { LHsDecl GhcPs }-        :  -- data family declarations, with optional 'family' keyword-          'data' opt_family type opt_datafam_kind_sig-                {% liftM mkTyClD (mkFamDecl (comb3 $1 (reLoc $3) $4) DataFamily NotTopLevel $3-                                                  (snd $ unLoc $4) Nothing-                        (mj AnnData $1:$2++(fst $ unLoc $4))) }--           -- type family declarations, with optional 'family' keyword-           -- (can't use opt_instance because you get shift/reduce errors-        | 'type' type opt_at_kind_inj_sig-               {% liftM mkTyClD-                        (mkFamDecl (comb3 $1 (reLoc $2) $3) OpenTypeFamily NotTopLevel $2-                                   (fst . snd $ unLoc $3)-                                   (snd . snd $ unLoc $3)-                         (mj AnnType $1:(fst $ unLoc $3)) )}-        | 'type' 'family' type opt_at_kind_inj_sig-               {% liftM mkTyClD-                        (mkFamDecl (comb3 $1 (reLoc $3) $4) OpenTypeFamily NotTopLevel $3-                                   (fst . snd $ unLoc $4)-                                   (snd . snd $ unLoc $4)-                         (mj AnnType $1:mj AnnFamily $2:(fst $ unLoc $4)))}--           -- default type instances, with optional 'instance' keyword-        | 'type' ty_fam_inst_eqn-                {% liftM mkInstD (mkTyFamInst (comb2A $1 $2) (unLoc $2)-                          [mj AnnType $1]) }-        | 'type' 'instance' ty_fam_inst_eqn-                {% liftM mkInstD (mkTyFamInst (comb2A $1 $3) (unLoc $3)-                              (mj AnnType $1:mj AnnInstance $2:[]) )}--opt_family   :: { [AddEpAnn] }-              : {- empty -}   { [] }-              | 'family'      { [mj AnnFamily $1] }--opt_instance :: { [AddEpAnn] }-              : {- empty -} { [] }-              | 'instance'  { [mj AnnInstance $1] }---- Associated type instances----at_decl_inst :: { LInstDecl GhcPs }-           -- type instance declarations, with optional 'instance' keyword-        : 'type' opt_instance ty_fam_inst_eqn-                -- Note the use of type for the head; this allows-                -- infix type constructors and type patterns-                {% mkTyFamInst (comb2A $1 $3) (unLoc $3)-                          (mj AnnType $1:$2) }--        -- data/newtype instance declaration, with optional 'instance' keyword-        | data_or_newtype opt_instance capi_ctype datafam_inst_hdr constrs maybe_derivings-               {% mkDataFamInst (comb4 $1 $4 $5 $6) (snd $ unLoc $1) $3 (unLoc $4)-                                    Nothing (reverse (snd $ unLoc $5))-                                            (fmap reverse $6)-                        ((fst $ unLoc $1):$2++(fst $ unLoc $5)) }--        -- GADT instance declaration, with optional 'instance' keyword-        | data_or_newtype opt_instance capi_ctype datafam_inst_hdr opt_kind_sig-                 gadt_constrlist-                 maybe_derivings-                {% mkDataFamInst (comb4 $1 $4 $6 $7) (snd $ unLoc $1) $3-                                (unLoc $4) (snd $ unLoc $5) (snd $ unLoc $6)-                                (fmap reverse $7)-                        ((fst $ unLoc $1):$2++(fst $ unLoc $5)++(fst $ unLoc $6)) }--type_data_or_newtype :: { Located ([AddEpAnn], Bool, NewOrData) }-        : 'data'        { sL1 $1 ([mj AnnData    $1],            False,DataType) }-        | 'newtype'     { sL1 $1 ([mj AnnNewtype $1],            False,NewType) }-        | 'type' 'data' { sL1 $1 ([mj AnnType $1, mj AnnData $2],True ,DataType) }--data_or_newtype :: { Located (AddEpAnn, NewOrData) }-        : 'data'        { sL1 $1 (mj AnnData    $1,DataType) }-        | 'newtype'     { sL1 $1 (mj AnnNewtype $1,NewType) }---- Family result/return kind signatures--opt_kind_sig :: { Located ([AddEpAnn], Maybe (LHsKind GhcPs)) }-        :               { noLoc     ([]               , Nothing) }-        | '::' kind     { sLL $1 (reLoc $>) ([mu AnnDcolon $1], Just $2) }--opt_datafam_kind_sig :: { Located ([AddEpAnn], LFamilyResultSig GhcPs) }-        :               { noLoc     ([]               , noLocA (NoSig noExtField)         )}-        | '::' kind     { sLL $1 (reLoc $>) ([mu AnnDcolon $1], sLLa $1 (reLoc $>) (KindSig noExtField $2))}--opt_tyfam_kind_sig :: { Located ([AddEpAnn], LFamilyResultSig GhcPs) }-        :              { noLoc     ([]               , noLocA     (NoSig    noExtField)   )}-        | '::' kind    { sLL $1 (reLoc $>) ([mu AnnDcolon $1], sLLa $1 (reLoc $>) (KindSig  noExtField $2))}-        | '='  tv_bndr {% do { tvb <- fromSpecTyVarBndr $2-                             ; return $ sLL $1 (reLoc $>) ([mj AnnEqual $1], sLLa $1 (reLoc $>) (TyVarSig noExtField tvb))} }--opt_at_kind_inj_sig :: { Located ([AddEpAnn], ( LFamilyResultSig GhcPs-                                            , Maybe (LInjectivityAnn GhcPs)))}-        :            { noLoc ([], (noLocA (NoSig noExtField), Nothing)) }-        | '::' kind  { sLL $1 (reLoc $>) ( [mu AnnDcolon $1]-                                 , (sL1a (reLoc $>) (KindSig noExtField $2), Nothing)) }-        | '='  tv_bndr_no_braces '|' injectivity_cond-                {% do { tvb <- fromSpecTyVarBndr $2-                      ; return $ sLL $1 (reLoc $>) ([mj AnnEqual $1, mj AnnVbar $3]-                                           , (sLLa $1 (reLoc $2) (TyVarSig noExtField tvb), Just $4))} }---- tycl_hdr parses the header of a class or data type decl,--- which takes the form---      T a b---      Eq a => T a---      (Eq a, Ord b) => T a b---      T Int [a]                       -- for associated types--- Rather a lot of inlining here, else we get reduce/reduce errors-tycl_hdr :: { Located (Maybe (LHsContext GhcPs), LHsType GhcPs) }-        : context '=>' type         {% acs (\cs -> (sLLAA $1 $> (Just (addTrailingDarrowC $1 $2 cs), $3))) }-        | type                      { sL1A $1 (Nothing, $1) }--datafam_inst_hdr :: { Located (Maybe (LHsContext GhcPs), HsOuterFamEqnTyVarBndrs GhcPs, LHsType GhcPs) }-        : 'forall' tv_bndrs '.' context '=>' type   {% hintExplicitForall $1-                                                       >> fromSpecTyVarBndrs $2-                                                         >>= \tvbs ->-                                                             (acs (\cs -> (sLL $1 (reLoc $>)-                                                                                  (Just ( addTrailingDarrowC $4 $5 cs)-                                                                                        , mkHsOuterExplicit (EpAnn (glR $1) (mu AnnForall $1, mj AnnDot $3) emptyComments) tvbs, $6))))-                                                    }-        | 'forall' tv_bndrs '.' type   {% do { hintExplicitForall $1-                                             ; tvbs <- fromSpecTyVarBndrs $2-                                             ; let loc = comb2 $1 (reLoc $>)-                                             ; cs <- getCommentsFor loc-                                             ; return (sL loc (Nothing, mkHsOuterExplicit (EpAnn (glR $1) (mu AnnForall $1, mj AnnDot $3) cs) tvbs, $4))-                                       } }-        | context '=>' type         {% acs (\cs -> (sLLAA $1 $>(Just (addTrailingDarrowC $1 $2 cs), mkHsOuterImplicit, $3))) }-        | type                      { sL1A $1 (Nothing, mkHsOuterImplicit, $1) }---capi_ctype :: { Maybe (LocatedP CType) }-capi_ctype : '{-# CTYPE' STRING STRING '#-}'-                       {% fmap Just $ amsrp (sLL $1 $> (CType (getCTYPEs $1) (Just (Header (getSTRINGs $2) (getSTRING $2)))-                                        (getSTRINGs $3,getSTRING $3)))-                              (AnnPragma (mo $1) (mc $4) [mj AnnHeader $2,mj AnnVal $3]) }--           | '{-# CTYPE'        STRING '#-}'-                       {% fmap Just $ amsrp (sLL $1 $> (CType (getCTYPEs $1) Nothing (getSTRINGs $2, getSTRING $2)))-                              (AnnPragma (mo $1) (mc $3) [mj AnnVal $2]) }--           |           { Nothing }---------------------------------------------------------------------------------- Stand-alone deriving---- Glasgow extension: stand-alone deriving declarations-stand_alone_deriving :: { LDerivDecl GhcPs }-  : 'deriving' deriv_standalone_strategy 'instance' overlap_pragma inst_type-                {% do { let { err = text "in the stand-alone deriving instance"-                                    <> colon <+> quotes (ppr $5) }-                      ; acsA (\cs -> sLL $1 (reLoc $>)-                                 (DerivDecl (EpAnn (glR $1) [mj AnnDeriving $1, mj AnnInstance $3] cs) (mkHsWildCardBndrs $5) $2 $4)) }}---------------------------------------------------------------------------------- Role annotations--role_annot :: { LRoleAnnotDecl GhcPs }-role_annot : 'type' 'role' oqtycon maybe_roles-          {% mkRoleAnnotDecl (comb3N $1 $4 $3) $3 (reverse (unLoc $4))-                   [mj AnnType $1,mj AnnRole $2] }---- Reversed!-maybe_roles :: { Located [Located (Maybe FastString)] }-maybe_roles : {- empty -}    { noLoc [] }-            | roles          { $1 }--roles :: { Located [Located (Maybe FastString)] }-roles : role             { sLL $1 $> [$1] }-      | roles role       { sLL $1 $> $ $2 : unLoc $1 }---- read it in as a varid for better error messages-role :: { Located (Maybe FastString) }-role : VARID             { sL1 $1 $ Just $ getVARID $1 }-     | '_'               { sL1 $1 Nothing }---- Pattern synonyms---- Glasgow extension: pattern synonyms-pattern_synonym_decl :: { LHsDecl GhcPs }-        : 'pattern' pattern_synonym_lhs '=' pat-         {%      let (name, args, as ) = $2 in-                 acsA (\cs -> sLL $1 (reLoc $>) . ValD noExtField $ mkPatSynBind name args $4-                                                    ImplicitBidirectional-                      (EpAnn (glR $1) (as ++ [mj AnnPattern $1, mj AnnEqual $3]) cs)) }--        | 'pattern' pattern_synonym_lhs '<-' pat-         {%    let (name, args, as) = $2 in-               acsA (\cs -> sLL $1 (reLoc $>) . ValD noExtField $ mkPatSynBind name args $4 Unidirectional-                       (EpAnn (glR $1) (as ++ [mj AnnPattern $1,mu AnnLarrow $3]) cs)) }--        | 'pattern' pattern_synonym_lhs '<-' pat where_decls-            {% do { let (name, args, as) = $2-                  ; mg <- mkPatSynMatchGroup name $5-                  ; acsA (\cs -> sLL $1 (reLoc $>) . ValD noExtField $-                           mkPatSynBind name args $4 (ExplicitBidirectional mg)-                            (EpAnn (glR $1) (as ++ [mj AnnPattern $1,mu AnnLarrow $3]) cs))-                   }}--pattern_synonym_lhs :: { (LocatedN RdrName, HsPatSynDetails GhcPs, [AddEpAnn]) }-        : con vars0 { ($1, PrefixCon noTypeArgs $2, []) }-        | varid conop varid { ($2, InfixCon $1 $3, []) }-        | con '{' cvars1 '}' { ($1, RecCon $3, [moc $2, mcc $4] ) }--vars0 :: { [LocatedN RdrName] }-        : {- empty -}                 { [] }-        | varid vars0                 { $1 : $2 }--cvars1 :: { [RecordPatSynField GhcPs] }-       : var                          { [RecordPatSynField (mkFieldOcc $1) $1] }-       | var ',' cvars1               {% do { h <- addTrailingCommaN $1 (gl $2)-                                            ; return ((RecordPatSynField (mkFieldOcc h) h) : $3 )}}--where_decls :: { LocatedL (OrdList (LHsDecl GhcPs)) }-        : 'where' '{' decls '}'       {% amsrl (sLL $1 $> (snd $ unLoc $3))-                                              (AnnList (Just $ glR $3) (Just $ moc $2) (Just $ mcc $4) [mj AnnWhere $1] (fst $ unLoc $3)) }-        | 'where' vocurly decls close {% amsrl (sLL $1 $3 (snd $ unLoc $3))-                                              (AnnList (Just $ glR $3) Nothing Nothing [mj AnnWhere $1] (fst $ unLoc $3))}--pattern_synonym_sig :: { LSig GhcPs }-        : 'pattern' con_list '::' sigtype-                   {% acsA (\cs -> sLL $1 (reLoc $>)-                                $ PatSynSig (EpAnn (glR $1) (AnnSig (mu AnnDcolon $3) [mj AnnPattern $1]) cs)-                                  (toList $ unLoc $2) $4) }--qvarcon :: { LocatedN RdrName }-        : qvar                          { $1 }-        | qcon                          { $1 }---------------------------------------------------------------------------------- Nested declarations---- Declaration in class bodies----decl_cls  :: { LHsDecl GhcPs }-decl_cls  : at_decl_cls                 { $1 }-          | decl                        { $1 }--          -- A 'default' signature used with the generic-programming extension-          | 'default' infixexp '::' sigtype-                    {% runPV (unECP $2) >>= \ $2 ->-                       do { v <- checkValSigLhs $2-                          ; let err = text "in default signature" <> colon <+>-                                      quotes (ppr $2)-                          ; acsA (\cs -> sLL $1 (reLoc $>) $ SigD noExtField $ ClassOpSig (EpAnn (glR $1) (AnnSig (mu AnnDcolon $3) [mj AnnDefault $1]) cs) True [v] $4) }}--decls_cls :: { Located ([AddEpAnn],OrdList (LHsDecl GhcPs)) }  -- Reversed-          : decls_cls ';' decl_cls      {% if isNilOL (snd $ unLoc $1)-                                             then return (sLLlA $1 $> ((fst $ unLoc $1) ++ (mz AnnSemi $2)-                                                                    , unitOL $3))-                                            else case (snd $ unLoc $1) of-                                              SnocOL hs t -> do-                                                 t' <- addTrailingSemiA t (gl $2)-                                                 return (sLLlA $1 $> (fst $ unLoc $1-                                                                , snocOL hs t' `appOL` unitOL $3)) }-          | decls_cls ';'               {% if isNilOL (snd $ unLoc $1)-                                             then return (sLL $1 $> ( (fst $ unLoc $1) ++ (mz AnnSemi $2)-                                                                                   ,snd $ unLoc $1))-                                             else case (snd $ unLoc $1) of-                                               SnocOL hs t -> do-                                                  t' <- addTrailingSemiA t (gl $2)-                                                  return (sLL $1 $> (fst $ unLoc $1-                                                                 , snocOL hs t')) }-          | decl_cls                    { sL1A $1 ([], unitOL $1) }-          | {- empty -}                 { noLoc ([],nilOL) }--decllist_cls-        :: { Located ([AddEpAnn]-                     , OrdList (LHsDecl GhcPs)-                     , LayoutInfo GhcPs) }      -- Reversed-        : '{'         decls_cls '}'     { sLL $1 $> (moc $1:mcc $3:(fst $ unLoc $2)-                                             ,snd $ unLoc $2, explicitBraces $1 $3) }-        |     vocurly decls_cls close   { let { L l (anns, decls) = $2 }-                                           in L l (anns, decls, VirtualBraces (getVOCURLY $1)) }---- Class body----where_cls :: { Located ([AddEpAnn]-                       ,(OrdList (LHsDecl GhcPs))    -- Reversed-                       ,LayoutInfo GhcPs) }-                                -- No implicit parameters-                                -- May have type declarations-        : 'where' decllist_cls          { sLL $1 $> (mj AnnWhere $1:(fstOf3 $ unLoc $2)-                                             ,sndOf3 $ unLoc $2,thdOf3 $ unLoc $2) }-        | {- empty -}                   { noLoc ([],nilOL,NoLayoutInfo) }---- Declarations in instance bodies----decl_inst  :: { Located (OrdList (LHsDecl GhcPs)) }-decl_inst  : at_decl_inst               { sL1A $1 (unitOL (sL1 $1 (InstD noExtField (unLoc $1)))) }-           | decl                       { sL1A $1 (unitOL $1) }--decls_inst :: { Located ([AddEpAnn],OrdList (LHsDecl GhcPs)) }   -- Reversed-           : decls_inst ';' decl_inst   {% if isNilOL (snd $ unLoc $1)-                                             then return (sLL $1 $> ((fst $ unLoc $1) ++ (mz AnnSemi $2)-                                                                    , unLoc $3))-                                             else case (snd $ unLoc $1) of-                                               SnocOL hs t -> do-                                                  t' <- addTrailingSemiA t (gl $2)-                                                  return (sLL $1 $> (fst $ unLoc $1-                                                                 , snocOL hs t' `appOL` unLoc $3)) }-           | decls_inst ';'             {% if isNilOL (snd $ unLoc $1)-                                             then return (sLL $1 $> ((fst $ unLoc $1) ++ (mz AnnSemi $2)-                                                                                   ,snd $ unLoc $1))-                                             else case (snd $ unLoc $1) of-                                               SnocOL hs t -> do-                                                  t' <- addTrailingSemiA t (gl $2)-                                                  return (sLL $1 $> (fst $ unLoc $1-                                                                 , snocOL hs t')) }-           | decl_inst                  { sL1 $1 ([],unLoc $1) }-           | {- empty -}                { noLoc ([],nilOL) }--decllist_inst-        :: { Located ([AddEpAnn]-                     , OrdList (LHsDecl GhcPs)) }      -- Reversed-        : '{'         decls_inst '}'    { sLL $1 $> (moc $1:mcc $3:(fst $ unLoc $2),snd $ unLoc $2) }-        |     vocurly decls_inst close  { L (gl $2) (unLoc $2) }---- Instance body----where_inst :: { Located ([AddEpAnn]-                        , OrdList (LHsDecl GhcPs)) }   -- Reversed-                                -- No implicit parameters-                                -- May have type declarations-        : 'where' decllist_inst         { sLL $1 $> (mj AnnWhere $1:(fst $ unLoc $2)-                                             ,(snd $ unLoc $2)) }-        | {- empty -}                   { noLoc ([],nilOL) }---- Declarations in binding groups other than classes and instances----decls   :: { Located ([TrailingAnn], OrdList (LHsDecl GhcPs)) }-        : decls ';' decl    {% if isNilOL (snd $ unLoc $1)-                                 then return (sLLlA $1 $> ((fst $ unLoc $1) ++ (msemi $2)-                                                        , unitOL $3))-                                 else case (snd $ unLoc $1) of-                                   SnocOL hs t -> do-                                      t' <- addTrailingSemiA t (gl $2)-                                      let { this = unitOL $3;-                                            rest = snocOL hs t';-                                            these = rest `appOL` this }-                                      return (rest `seq` this `seq` these `seq`-                                                 (sLLlA $1 $> (fst $ unLoc $1, these))) }-        | decls ';'          {% if isNilOL (snd $ unLoc $1)-                                  then return (sLL $1 $> (((fst $ unLoc $1) ++ (msemi $2)-                                                          ,snd $ unLoc $1)))-                                  else case (snd $ unLoc $1) of-                                    SnocOL hs t -> do-                                       t' <- addTrailingSemiA t (gl $2)-                                       return (sLL $1 $> (fst $ unLoc $1-                                                      , snocOL hs t')) }-        | decl                          { sL1A $1 ([], unitOL $1) }-        | {- empty -}                   { noLoc ([],nilOL) }--decllist :: { Located (AnnList,Located (OrdList (LHsDecl GhcPs))) }-        : '{'            decls '}'     { sLL $1 $> (AnnList (Just $ glR $2) (Just $ moc $1) (Just $ mcc $3) [] (fst $ unLoc $2)-                                                   ,sL1 $2 $ snd $ unLoc $2) }-        |     vocurly    decls close   { L (gl $2) (AnnList (Just $ glR $2) Nothing Nothing [] (fst $ unLoc $2)-                                                   ,sL1 $2 $ snd $ unLoc $2) }---- Binding groups other than those of class and instance declarations----binds   ::  { Located (HsLocalBinds GhcPs) }-                                         -- May have implicit parameters-                                                -- No type declarations-        : decllist          {% do { val_binds <- cvBindGroup (unLoc $ snd $ unLoc $1)-                                  ; cs <- getCommentsFor (gl $1)-                                  ; return (sL1 $1 $ HsValBinds (fixValbindsAnn $ EpAnn (glR $1) (fst $ unLoc $1) cs) val_binds)} }--        | '{'            dbinds '}'     {% acs (\cs -> (L (comb3 $1 $2 $3)-                                             $ HsIPBinds (EpAnn (glR $1) (AnnList (Just$ glR $2) (Just $ moc $1) (Just $ mcc $3) [] []) cs) (IPBinds noExtField (reverse $ unLoc $2)))) }--        |     vocurly    dbinds close   {% acs (\cs -> (L (gl $2)-                                             $ HsIPBinds (EpAnn (glR $1) (AnnList (Just $ glR $2) Nothing Nothing [] []) cs) (IPBinds noExtField (reverse $ unLoc $2)))) }---wherebinds :: { Maybe (Located (HsLocalBinds GhcPs, Maybe EpAnnComments )) }-                                                -- May have implicit parameters-                                                -- No type declarations-        : 'where' binds                 {% do { r <- acs (\cs ->-                                                (sLL $1 $> (annBinds (mj AnnWhere $1) cs (unLoc $2))))-                                              ; return $ Just r} }-        | {- empty -}                   { Nothing }---------------------------------------------------------------------------------- Transformation Rules--rules   :: { [LRuleDecl GhcPs] } -- Reversed-        :  rules ';' rule              {% case $1 of-                                            [] -> return ($3:$1)-                                            (h:t) -> do-                                              h' <- addTrailingSemiA h (gl $2)-                                              return ($3:h':t) }-        |  rules ';'                   {% case $1 of-                                            [] -> return $1-                                            (h:t) -> do-                                              h' <- addTrailingSemiA h (gl $2)-                                              return (h':t) }-        |  rule                        { [$1] }-        |  {- empty -}                 { [] }--rule    :: { LRuleDecl GhcPs }-        : STRING rule_activation rule_foralls infixexp '=' exp-         {%runPV (unECP $4) >>= \ $4 ->-           runPV (unECP $6) >>= \ $6 ->-           acsA (\cs -> (sLLlA $1 $> $ HsRule-                                   { rd_ext = (EpAnn (glR $1) ((fstOf3 $3) (mj AnnEqual $5 : (fst $2))) cs, getSTRINGs $1)-                                   , rd_name = L (noAnnSrcSpan $ gl $1) (getSTRING $1)-                                   , rd_act = (snd $2) `orElse` AlwaysActive-                                   , rd_tyvs = sndOf3 $3, rd_tmvs = thdOf3 $3-                                   , rd_lhs = $4, rd_rhs = $6 })) }---- Rules can be specified to be NeverActive, unlike inline/specialize pragmas-rule_activation :: { ([AddEpAnn],Maybe Activation) }-        -- See Note [%shift: rule_activation -> {- empty -}]-        : {- empty -} %shift                    { ([],Nothing) }-        | rule_explicit_activation              { (fst $1,Just (snd $1)) }---- This production is used to parse the tilde syntax in pragmas such as---   * {-# INLINE[~2] ... #-}---   * {-# SPECIALISE [~ 001] ... #-}---   * {-# RULES ... [~0] ... g #-}--- Note that it can be written either---   without a space [~1]  (the PREFIX_TILDE case), or---   with    a space [~ 1] (the VARSYM case).--- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer-rule_activation_marker :: { [AddEpAnn] }-      : PREFIX_TILDE { [mj AnnTilde $1] }-      | VARSYM  {% if (getVARSYM $1 == fsLit "~")-                   then return [mj AnnTilde $1]-                   else do { addError $ mkPlainErrorMsgEnvelope (getLoc $1) $-                               PsErrInvalidRuleActivationMarker-                           ; return [] } }--rule_explicit_activation :: { ([AddEpAnn]-                              ,Activation) }  -- In brackets-        : '[' INTEGER ']'       { ([mos $1,mj AnnVal $2,mcs $3]-                                  ,ActiveAfter  (getINTEGERs $2) (fromInteger (il_value (getINTEGER $2)))) }-        | '[' rule_activation_marker INTEGER ']'-                                { ($2++[mos $1,mj AnnVal $3,mcs $4]-                                  ,ActiveBefore (getINTEGERs $3) (fromInteger (il_value (getINTEGER $3)))) }-        | '[' rule_activation_marker ']'-                                { ($2++[mos $1,mcs $3]-                                  ,NeverActive) }--rule_foralls :: { ([AddEpAnn] -> HsRuleAnn, Maybe [LHsTyVarBndr () GhcPs], [LRuleBndr GhcPs]) }-        : 'forall' rule_vars '.' 'forall' rule_vars '.'    {% let tyvs = mkRuleTyVarBndrs $2-                                                              in hintExplicitForall $1-                                                              >> checkRuleTyVarBndrNames (mkRuleTyVarBndrs $2)-                                                              >> return (\anns -> HsRuleAnn-                                                                          (Just (mu AnnForall $1,mj AnnDot $3))-                                                                          (Just (mu AnnForall $4,mj AnnDot $6))-                                                                          anns,-                                                                         Just (mkRuleTyVarBndrs $2), mkRuleBndrs $5) }--        -- See Note [%shift: rule_foralls -> 'forall' rule_vars '.']-        | 'forall' rule_vars '.' %shift                    { (\anns -> HsRuleAnn Nothing (Just (mu AnnForall $1,mj AnnDot $3)) anns,-                                                              Nothing, mkRuleBndrs $2) }-        -- See Note [%shift: rule_foralls -> {- empty -}]-        | {- empty -}            %shift                    { (\anns -> HsRuleAnn Nothing Nothing anns, Nothing, []) }--rule_vars :: { [LRuleTyTmVar] }-        : rule_var rule_vars                    { $1 : $2 }-        | {- empty -}                           { [] }--rule_var :: { LRuleTyTmVar }-        : varid                         { sL1l $1 (RuleTyTmVar noAnn $1 Nothing) }-        | '(' varid '::' ctype ')'      {% acsA (\cs -> sLL $1 $> (RuleTyTmVar (EpAnn (glR $1) [mop $1,mu AnnDcolon $3,mcp $5] cs) $2 (Just $4))) }--{- Note [Parsing explicit foralls in Rules]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We really want the above definition of rule_foralls to be:--  rule_foralls : 'forall' tv_bndrs '.' 'forall' rule_vars '.'-               | 'forall' rule_vars '.'-               | {- empty -}--where rule_vars (term variables) can be named "forall", "family", or "role",-but tv_vars (type variables) cannot be. However, such a definition results-in a reduce/reduce conflict. For example, when parsing:-> {-# RULE "name" forall a ... #-}-before the '...' it is impossible to determine whether we should be in the-first or second case of the above.--This is resolved by using rule_vars (which is more general) for both, and-ensuring that type-level quantified variables do not have the names "forall",-"family", or "role" in the function 'checkRuleTyVarBndrNames' in-GHC.Parser.PostProcess.-Thus, whenever the definition of tyvarid (used for tv_bndrs) is changed relative-to varid (used for rule_vars), 'checkRuleTyVarBndrNames' must be updated.--}---------------------------------------------------------------------------------- Warnings and deprecations (c.f. rules)--warning_category :: { Maybe (Located InWarningCategory) }-        : 'in' STRING                  { Just (sLL $1 $> $ InWarningCategory (hsTok' $1) (getSTRINGs $2)-                                                                             (sL1 $2 $ mkWarningCategory (getSTRING $2))) }-        | {- empty -}                  { Nothing }--warnings :: { OrdList (LWarnDecl GhcPs) }-        : warnings ';' warning         {% if isNilOL $1-                                           then return ($1 `appOL` $3)-                                           else case $1 of-                                             SnocOL hs t -> do-                                              t' <- addTrailingSemiA t (gl $2)-                                              return (snocOL hs t' `appOL` $3) }-        | warnings ';'                 {% if isNilOL $1-                                           then return $1-                                           else case $1 of-                                             SnocOL hs t -> do-                                              t' <- addTrailingSemiA t (gl $2)-                                              return (snocOL hs t') }-        | warning                      { $1 }-        | {- empty -}                  { nilOL }---- SUP: TEMPORARY HACK, not checking for `module Foo'-warning :: { OrdList (LWarnDecl GhcPs) }-        : warning_category namelist strings-                {% fmap unitOL $ acsA (\cs -> L (comb3M $1 $2 $3)-                     (Warning (EpAnn (glMR $1 $2) (fst $ unLoc $3) cs) (unLoc $2)-                              (WarningTxt $1 (noLoc NoSourceText) $ map stringLiteralToHsDocWst $ snd $ unLoc $3))) }--deprecations :: { OrdList (LWarnDecl GhcPs) }-        : deprecations ';' deprecation-                                       {% if isNilOL $1-                                           then return ($1 `appOL` $3)-                                           else case $1 of-                                             SnocOL hs t -> do-                                              t' <- addTrailingSemiA t (gl $2)-                                              return (snocOL hs t' `appOL` $3) }-        | deprecations ';'             {% if isNilOL $1-                                           then return $1-                                           else case $1 of-                                             SnocOL hs t -> do-                                              t' <- addTrailingSemiA t (gl $2)-                                              return (snocOL hs t') }-        | deprecation                  { $1 }-        | {- empty -}                  { nilOL }---- SUP: TEMPORARY HACK, not checking for `module Foo'-deprecation :: { OrdList (LWarnDecl GhcPs) }-        : namelist strings-             {% fmap unitOL $ acsA (\cs -> sLL $1 $> $ (Warning (EpAnn (glR $1) (fst $ unLoc $2) cs) (unLoc $1)-                                          (DeprecatedTxt (noLoc NoSourceText) $ map stringLiteralToHsDocWst $ snd $ unLoc $2))) }--strings :: { Located ([AddEpAnn],[Located StringLiteral]) }-    : STRING { sL1 $1 ([],[L (gl $1) (getStringLiteral $1)]) }-    | '[' stringlist ']' { sLL $1 $> $ ([mos $1,mcs $3],fromOL (unLoc $2)) }--stringlist :: { Located (OrdList (Located StringLiteral)) }-    : stringlist ',' STRING {% if isNilOL (unLoc $1)-                                then return (sLL $1 $> (unLoc $1 `snocOL`-                                                  (L (gl $3) (getStringLiteral $3))))-                                else case (unLoc $1) of-                                   SnocOL hs t -> do-                                     let { t' = addTrailingCommaS t (glAA $2) }-                                     return (sLL $1 $> (snocOL hs t' `snocOL`-                                                  (L (gl $3) (getStringLiteral $3))))--}-    | STRING                { sLL $1 $> (unitOL (L (gl $1) (getStringLiteral $1))) }-    | {- empty -}           { noLoc nilOL }---------------------------------------------------------------------------------- Annotations-annotation :: { LHsDecl GhcPs }-    : '{-# ANN' name_var aexp '#-}'      {% runPV (unECP $3) >>= \ $3 ->-                                            acsA (\cs -> sLL $1 $> (AnnD noExtField $ HsAnnotation-                                            ((EpAnn (glR $1) (AnnPragma (mo $1) (mc $4) []) cs),-                                            (getANN_PRAGs $1))-                                            (ValueAnnProvenance $2) $3)) }--    | '{-# ANN' 'type' otycon aexp '#-}' {% runPV (unECP $4) >>= \ $4 ->-                                            acsA (\cs -> sLL $1 $> (AnnD noExtField $ HsAnnotation-                                            ((EpAnn (glR $1) (AnnPragma (mo $1) (mc $5) [mj AnnType $2]) cs),-                                            (getANN_PRAGs $1))-                                            (TypeAnnProvenance $3) $4)) }--    | '{-# ANN' 'module' aexp '#-}'      {% runPV (unECP $3) >>= \ $3 ->-                                            acsA (\cs -> sLL $1 $> (AnnD noExtField $ HsAnnotation-                                                ((EpAnn (glR $1) (AnnPragma (mo $1) (mc $4) [mj AnnModule $2]) cs),-                                                (getANN_PRAGs $1))-                                                 ModuleAnnProvenance $3)) }---------------------------------------------------------------------------------- Foreign import and export declarations--fdecl :: { Located ([AddEpAnn],EpAnn [AddEpAnn] -> HsDecl GhcPs) }-fdecl : 'import' callconv safety fspec-               {% mkImport $2 $3 (snd $ unLoc $4) >>= \i ->-                 return (sLL $1 $> (mj AnnImport $1 : (fst $ unLoc $4),i))  }-      | 'import' callconv        fspec-               {% do { d <- mkImport $2 (noLoc PlaySafe) (snd $ unLoc $3);-                    return (sLL $1 $> (mj AnnImport $1 : (fst $ unLoc $3),d)) }}-      | 'export' callconv fspec-               {% mkExport $2 (snd $ unLoc $3) >>= \i ->-                  return (sLL $1 $> (mj AnnExport $1 : (fst $ unLoc $3),i) ) }--callconv :: { Located CCallConv }-          : 'stdcall'                   { sLL $1 $> StdCallConv }-          | 'ccall'                     { sLL $1 $> CCallConv   }-          | 'capi'                      { sLL $1 $> CApiConv    }-          | 'prim'                      { sLL $1 $> PrimCallConv}-          | 'javascript'                { sLL $1 $> JavaScriptCallConv }--safety :: { Located Safety }-        : 'unsafe'                      { sLL $1 $> PlayRisky }-        | 'safe'                        { sLL $1 $> PlaySafe }-        | 'interruptible'               { sLL $1 $> PlayInterruptible }--fspec :: { Located ([AddEpAnn]-                    ,(Located StringLiteral, LocatedN RdrName, LHsSigType GhcPs)) }-       : STRING var '::' sigtype        { sLL $1 (reLoc $>) ([mu AnnDcolon $3]-                                             ,(L (getLoc $1)-                                                    (getStringLiteral $1), $2, $4)) }-       |        var '::' sigtype        { sLL (reLocN $1) (reLoc $>) ([mu AnnDcolon $2]-                                             ,(noLoc (StringLiteral NoSourceText nilFS Nothing), $1, $3)) }-         -- if the entity string is missing, it defaults to the empty string;-         -- the meaning of an empty entity string depends on the calling-         -- convention---------------------------------------------------------------------------------- Type signatures--opt_sig :: { Maybe (AddEpAnn, LHsType GhcPs) }-        : {- empty -}                   { Nothing }-        | '::' ctype                    { Just (mu AnnDcolon $1, $2) }--opt_tyconsig :: { ([AddEpAnn], Maybe (LocatedN RdrName)) }-             : {- empty -}              { ([], Nothing) }-             | '::' gtycon              { ([mu AnnDcolon $1], Just $2) }---- Like ktype, but for types that obey the forall-or-nothing rule.--- See Note [forall-or-nothing rule] in GHC.Hs.Type.-sigktype :: { LHsSigType GhcPs }-        : sigtype              { $1 }-        | ctype '::' kind      {% acsA (\cs -> sLLAA $1 $> $ mkHsImplicitSigType $-                                               sLLa  (reLoc $1) (reLoc $>) $ HsKindSig (EpAnn (glAR $1) [mu AnnDcolon $2] cs) $1 $3) }---- Like ctype, but for types that obey the forall-or-nothing rule.--- See Note [forall-or-nothing rule] in GHC.Hs.Type. To avoid duplicating the--- logic in ctype here, we simply reuse the ctype production and perform--- surgery on the LHsType it returns to turn it into an LHsSigType.-sigtype :: { LHsSigType GhcPs }-        : ctype                            { hsTypeToHsSigType $1 }--sig_vars :: { Located [LocatedN RdrName] }    -- Returned in reversed order-         : sig_vars ',' var           {% case unLoc $1 of-                                           [] -> return (sLL $1 (reLocN $>) ($3 : unLoc $1))-                                           (h:t) -> do-                                             h' <- addTrailingCommaN h (gl $2)-                                             return (sLL $1 (reLocN $>) ($3 : h' : t)) }-         | var                        { sL1N $1 [$1] }--sigtypes1 :: { OrdList (LHsSigType GhcPs) }-   : sigtype                 { unitOL $1 }-   | sigtype ',' sigtypes1   {% do { st <- addTrailingCommaA $1 (gl $2)-                                   ; return $ unitOL st `appOL` $3 } }--------------------------------------------------------------------------------- Types--unpackedness :: { Located UnpackednessPragma }-        : '{-# UNPACK' '#-}'   { sLL $1 $> (UnpackednessPragma [mo $1, mc $2] (getUNPACK_PRAGs $1) SrcUnpack) }-        | '{-# NOUNPACK' '#-}' { sLL $1 $> (UnpackednessPragma [mo $1, mc $2] (getNOUNPACK_PRAGs $1) SrcNoUnpack) }--forall_telescope :: { Located (HsForAllTelescope GhcPs) }-        : 'forall' tv_bndrs '.'  {% do { hintExplicitForall $1-                                       ; acs (\cs -> (sLL $1 $> $-                                           mkHsForAllInvisTele (EpAnn (glR $1) (mu AnnForall $1,mu AnnDot $3) cs) $2 )) }}-        | 'forall' tv_bndrs '->' {% do { hintExplicitForall $1-                                       ; req_tvbs <- fromSpecTyVarBndrs $2-                                       ; acs (\cs -> (sLL $1 $> $-                                           mkHsForAllVisTele (EpAnn (glR $1) (mu AnnForall $1,mu AnnRarrow $3) cs) req_tvbs )) }}---- A ktype is a ctype, possibly with a kind annotation-ktype :: { LHsType GhcPs }-        : ctype                { $1 }-        | ctype '::' kind      {% acsA (\cs -> sLLAA $1 $> $ HsKindSig (EpAnn (glAR $1) [mu AnnDcolon $2] cs) $1 $3) }---- A ctype is a for-all type-ctype   :: { LHsType GhcPs }-        : forall_telescope ctype      { reLocA $ sLL $1 (reLoc $>) $-                                              HsForAllTy { hst_tele = unLoc $1-                                                         , hst_xforall = noExtField-                                                         , hst_body = $2 } }-        | context '=>' ctype          {% acsA (\cs -> (sLL (reLoc $1) (reLoc $>) $-                                            HsQualTy { hst_ctxt = addTrailingDarrowC $1 $2 cs-                                                     , hst_xqual = NoExtField-                                                     , hst_body = $3 })) }--        | ipvar '::' ctype            {% acsA (\cs -> sLL $1 (reLoc $>) (HsIParamTy (EpAnn (glR $1) [mu AnnDcolon $2] cs) (reLocA $1) $3)) }-        | type                        { $1 }--------------------------- Notes for 'context'--- We parse a context as a btype so that we don't get reduce/reduce--- errors in ctype.  The basic problem is that---      (Eq a, Ord a)--- looks so much like a tuple type.  We can't tell until we find the =>--context :: { LHsContext GhcPs }-        :  btype                        {% checkContext $1 }--{- Note [GADT decl discards annotations]-~~~~~~~~~~~~~~~~~~~~~-The type production for--    btype `->` ctype--add the AnnRarrow annotation twice, in different places.--This is because if the type is processed as usual, it belongs on the annotations-for the type as a whole.--But if the type is passed to mkGadtDecl, it discards the top level SrcSpan, and-the top-level annotation will be disconnected. Hence for this specific case it-is connected to the first type too.--}--type :: { LHsType GhcPs }-        -- See Note [%shift: type -> btype]-        : btype %shift                 { $1 }-        | btype '->' ctype             {% acsA (\cs -> sLL (reLoc $1) (reLoc $>)-                                            $ HsFunTy (EpAnn (glAR $1) NoEpAnns cs) (HsUnrestrictedArrow (hsUniTok $2)) $1 $3) }--        | btype mult '->' ctype        {% hintLinear (getLoc $2)-                                       >> let arr = (unLoc $2) (hsUniTok $3)-                                          in acsA (\cs -> sLL (reLoc $1) (reLoc $>)-                                           $ HsFunTy (EpAnn (glAR $1) NoEpAnns cs) arr $1 $4) }--        | btype '->.' ctype            {% hintLinear (getLoc $2) >>-                                          acsA (\cs -> sLL (reLoc $1) (reLoc $>)-                                            $ HsFunTy (EpAnn (glAR $1) NoEpAnns cs) (HsLinearArrow (HsLolly (hsTok $2))) $1 $3) }-                                              -- [mu AnnLollyU $2] }--mult :: { Located (LHsUniToken "->" "\8594" GhcPs -> HsArrow GhcPs) }-        : PREFIX_PERCENT atype          { sLL $1 (reLoc $>) (mkMultTy (hsTok $1) $2) }--btype :: { LHsType GhcPs }-        : infixtype                     {% runPV $1 }--infixtype :: { forall b. DisambTD b => PV (LocatedA b) }-        -- See Note [%shift: infixtype -> ftype]-        : ftype %shift                  { $1 }-        | ftype tyop infixtype          { $1 >>= \ $1 ->-                                          $3 >>= \ $3 ->-                                          do { let (op, prom) = $2-                                             ; when (looksLikeMult $1 op $3) $ hintLinear (getLocA op)-                                             ; mkHsOpTyPV prom $1 op $3 } }-        | unpackedness infixtype        { $2 >>= \ $2 ->-                                          mkUnpackednessPV $1 $2 }--ftype :: { forall b. DisambTD b => PV (LocatedA b) }-        : atype                         { mkHsAppTyHeadPV $1 }-        | tyop                          { failOpFewArgs (fst $1) }-        | ftype tyarg                   { $1 >>= \ $1 ->-                                          mkHsAppTyPV $1 $2 }-        | ftype PREFIX_AT atype         { $1 >>= \ $1 ->-                                          mkHsAppKindTyPV $1 (hsTok $2) $3 }--tyarg :: { LHsType GhcPs }-        : atype                         { $1 }-        | unpackedness atype            {% addUnpackednessP $1 $2 }--tyop :: { (LocatedN RdrName, PromotionFlag) }-        : qtyconop                      { ($1, NotPromoted) }-        | tyvarop                       { ($1, NotPromoted) }-        | SIMPLEQUOTE qconop            {% do { op <- amsrn (sLL $1 (reLoc $>) (unLoc $2))-                                                            (NameAnnQuote (glAA $1) (gl $2) [])-                                              ; return (op, IsPromoted) } }-        | SIMPLEQUOTE varop             {% do { op <- amsrn (sLL $1 (reLoc $>) (unLoc $2))-                                                            (NameAnnQuote (glAA $1) (gl $2) [])-                                              ; return (op, IsPromoted) } }--atype :: { LHsType GhcPs }-        : ntgtycon                       {% acsa (\cs -> sL1a (reLocN $1) (HsTyVar (EpAnn (glNR $1) [] cs) NotPromoted $1)) }      -- Not including unit tuples-        -- See Note [%shift: atype -> tyvar]-        | tyvar %shift                   {% acsa (\cs -> sL1a (reLocN $1) (HsTyVar (EpAnn (glNR $1) [] cs) NotPromoted $1)) }      -- (See Note [Unit tuples])-        | '*'                            {% do { warnStarIsType (getLoc $1)-                                               ; return $ reLocA $ sL1 $1 (HsStarTy noExtField (isUnicode $1)) } }--        -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer-        | PREFIX_TILDE atype             {% acsA (\cs -> sLLlA $1 $> (mkBangTy (EpAnn (glR $1) [mj AnnTilde $1] cs) SrcLazy $2)) }-        | PREFIX_BANG  atype             {% acsA (\cs -> sLLlA $1 $> (mkBangTy (EpAnn (glR $1) [mj AnnBang $1] cs) SrcStrict $2)) }--        | '{' fielddecls '}'             {% do { decls <- acsA (\cs -> (sLL $1 $> $ HsRecTy (EpAnn (glR $1) (AnnList (Just $ listAsAnchor $2) (Just $ moc $1) (Just $ mcc $3) [] []) cs) $2))-                                               ; checkRecordSyntax decls }}-                                                        -- Constructor sigs only-        | '(' ')'                        {% acsA (\cs -> sLL $1 $> $ HsTupleTy (EpAnn (glR $1) (AnnParen AnnParens (glAA $1) (glAA $2)) cs)-                                                    HsBoxedOrConstraintTuple []) }-        | '(' ktype ',' comma_types1 ')' {% do { h <- addTrailingCommaA $2 (gl $3)-                                               ; acsA (\cs -> sLL $1 $> $ HsTupleTy (EpAnn (glR $1) (AnnParen AnnParens (glAA $1) (glAA $5)) cs)-                                                        HsBoxedOrConstraintTuple (h : $4)) }}-        | '(#' '#)'                   {% acsA (\cs -> sLL $1 $> $ HsTupleTy (EpAnn (glR $1) (AnnParen AnnParensHash (glAA $1) (glAA $2)) cs) HsUnboxedTuple []) }-        | '(#' comma_types1 '#)'      {% acsA (\cs -> sLL $1 $> $ HsTupleTy (EpAnn (glR $1) (AnnParen AnnParensHash (glAA $1) (glAA $3)) cs) HsUnboxedTuple $2) }-        | '(#' bar_types2 '#)'        {% acsA (\cs -> sLL $1 $> $ HsSumTy (EpAnn (glR $1) (AnnParen AnnParensHash (glAA $1) (glAA $3)) cs) $2) }-        | '[' ktype ']'               {% acsA (\cs -> sLL $1 $> $ HsListTy (EpAnn (glR $1) (AnnParen AnnParensSquare (glAA $1) (glAA $3)) cs) $2) }-        | '(' ktype ')'               {% acsA (\cs -> sLL $1 $> $ HsParTy  (EpAnn (glR $1) (AnnParen AnnParens       (glAA $1) (glAA $3)) cs) $2) }-        | quasiquote                  { mapLocA (HsSpliceTy noExtField) $1 }-        | splice_untyped              { mapLocA (HsSpliceTy noExtField) $1 }-                                      -- see Note [Promotion] for the followings-        | SIMPLEQUOTE qcon_nowiredlist {% acsA (\cs -> sLL $1 (reLocN $>) $ HsTyVar (EpAnn (glR $1) [mj AnnSimpleQuote $1,mjN AnnName $2] cs) IsPromoted $2) }-        | SIMPLEQUOTE  '(' ktype ',' comma_types1 ')'-                             {% do { h <- addTrailingCommaA $3 (gl $4)-                                   ; acsA (\cs -> sLL $1 $> $ HsExplicitTupleTy (EpAnn (glR $1) [mj AnnSimpleQuote $1,mop $2,mcp $6] cs) (h : $5)) }}-        | SIMPLEQUOTE  '[' comma_types0 ']'     {% acsA (\cs -> sLL $1 $> $ HsExplicitListTy (EpAnn (glR $1) [mj AnnSimpleQuote $1,mos $2,mcs $4] cs) IsPromoted $3) }-        | SIMPLEQUOTE var                       {% acsA (\cs -> sLL $1 (reLocN $>) $ HsTyVar (EpAnn (glR $1) [mj AnnSimpleQuote $1,mjN AnnName $2] cs) IsPromoted $2) }--        -- Two or more [ty, ty, ty] must be a promoted list type, just as-        -- if you had written '[ty, ty, ty]-        -- (One means a list type, zero means the list type constructor,-        -- so you have to quote those.)-        | '[' ktype ',' comma_types1 ']'  {% do { h <- addTrailingCommaA $2 (gl $3)-                                                ; acsA (\cs -> sLL $1 $> $ HsExplicitListTy (EpAnn (glR $1) [mos $1,mcs $5] cs) NotPromoted (h:$4)) }}-        | INTEGER              { reLocA $ sLL $1 $> $ HsTyLit noExtField $ HsNumTy (getINTEGERs $1)-                                                           (il_value (getINTEGER $1)) }-        | CHAR                 { reLocA $ sLL $1 $> $ HsTyLit noExtField $ HsCharTy (getCHARs $1)-                                                                        (getCHAR $1) }-        | STRING               { reLocA $ sLL $1 $> $ HsTyLit noExtField $ HsStrTy (getSTRINGs $1)-                                                                     (getSTRING  $1) }-        | '_'                  { reLocA $ sL1 $1 $ mkAnonWildCardTy }-        -- Type variables are never exported, so `M.tyvar` will be rejected by the renamer.-        -- We let it pass the parser because the renamer can generate a better error message.-        | QVARID                      {% let qname = mkQual tvName (getQVARID $1)-                                         in  acsa (\cs -> sL1a $1 (HsTyVar (EpAnn (glR $1) [] cs) NotPromoted (sL1n $1 $ qname)))}---- An inst_type is what occurs in the head of an instance decl---      e.g.  (Foo a, Gaz b) => Wibble a b--- It's kept as a single type for convenience.-inst_type :: { LHsSigType GhcPs }-        : sigtype                       { $1 }--deriv_types :: { [LHsSigType GhcPs] }-        : sigktype                      { [$1] }--        | sigktype ',' deriv_types      {% do { h <- addTrailingCommaA $1 (gl $2)-                                           ; return (h : $3) } }--comma_types0  :: { [LHsType GhcPs] }  -- Zero or more:  ty,ty,ty-        : comma_types1                  { $1 }-        | {- empty -}                   { [] }--comma_types1    :: { [LHsType GhcPs] }  -- One or more:  ty,ty,ty-        : ktype                        { [$1] }-        | ktype  ',' comma_types1      {% do { h <- addTrailingCommaA $1 (gl $2)-                                             ; return (h : $3) }}--bar_types2    :: { [LHsType GhcPs] }  -- Two or more:  ty|ty|ty-        : ktype  '|' ktype             {% do { h <- addTrailingVbarA $1 (gl $2)-                                             ; return [h,$3] }}-        | ktype  '|' bar_types2        {% do { h <- addTrailingVbarA $1 (gl $2)-                                             ; return (h : $3) }}--tv_bndrs :: { [LHsTyVarBndr Specificity GhcPs] }-         : tv_bndr tv_bndrs             { $1 : $2 }-         | {- empty -}                  { [] }--tv_bndr :: { LHsTyVarBndr Specificity GhcPs }-        : tv_bndr_no_braces             { $1 }-        | '{' tyvar '}'                 {% acsA (\cs -> sLL $1 $> (UserTyVar (EpAnn (glR $1) [moc $1, mcc $3] cs) InferredSpec $2)) }-        | '{' tyvar '::' kind '}'       {% acsA (\cs -> sLL $1 $> (KindedTyVar (EpAnn (glR $1) [moc $1,mu AnnDcolon $3 ,mcc $5] cs) InferredSpec $2 $4)) }--tv_bndr_no_braces :: { LHsTyVarBndr Specificity GhcPs }-        : tyvar                         {% acsA (\cs -> (sL1 (reLocN $1) (UserTyVar (EpAnn (glNR $1) [] cs) SpecifiedSpec $1))) }-        | '(' tyvar '::' kind ')'       {% acsA (\cs -> (sLL $1 $> (KindedTyVar (EpAnn (glR $1) [mop $1,mu AnnDcolon $3 ,mcp $5] cs) SpecifiedSpec $2 $4))) }--fds :: { Located ([AddEpAnn],[LHsFunDep GhcPs]) }-        : {- empty -}                   { noLoc ([],[]) }-        | '|' fds1                      { (sLL $1 $> ([mj AnnVbar $1]-                                                 ,reverse (unLoc $2))) }--fds1 :: { Located [LHsFunDep GhcPs] }-        : fds1 ',' fd   {%-                           do { let (h:t) = unLoc $1 -- Safe from fds1 rules-                              ; h' <- addTrailingCommaA h (gl $2)-                              ; return (sLLlA $1 $> ($3 : h' : t)) }}-        | fd            { sL1A $1 [$1] }--fd :: { LHsFunDep GhcPs }-        : varids0 '->' varids0  {% acsA (\cs -> L (comb3 $1 $2 $3)-                                       (FunDep (EpAnn (glR $1) [mu AnnRarrow $2] cs)-                                               (reverse (unLoc $1))-                                               (reverse (unLoc $3)))) }--varids0 :: { Located [LocatedN RdrName] }-        : {- empty -}                   { noLoc [] }-        | varids0 tyvar                 { sLL $1 (reLocN $>) ($2 : (unLoc $1)) }---------------------------------------------------------------------------------- Kinds--kind :: { LHsKind GhcPs }-        : ctype                  { $1 }--{- Note [Promotion]-   ~~~~~~~~~~~~~~~~--- Syntax of promoted qualified names-We write 'Nat.Zero instead of Nat.'Zero when dealing with qualified-names. Moreover ticks are only allowed in types, not in kinds, for a-few reasons:-  1. we don't need quotes since we cannot define names in kinds-  2. if one day we merge types and kinds, tick would mean look in DataName-  3. we don't have a kind namespace anyway--- Name resolution-When the user write Zero instead of 'Zero in types, we parse it a-HsTyVar ("Zero", TcClsName) instead of HsTyVar ("Zero", DataName). We-deal with this in the renamer. If a HsTyVar ("Zero", TcClsName) is not-bounded in the type level, then we look for it in the term level (we-change its namespace to DataName, see Note [Demotion] in GHC.Types.Names.OccName).-And both become a HsTyVar ("Zero", DataName) after the renamer.---}----------------------------------------------------------------------------------- Datatype declarations--gadt_constrlist :: { Located ([AddEpAnn]-                          ,[LConDecl GhcPs]) } -- Returned in order--        : 'where' '{'        gadt_constrs '}'    {% checkEmptyGADTs $-                                                      L (comb2 $1 $3)-                                                        ([mj AnnWhere $1-                                                         ,moc $2-                                                         ,mcc $4]-                                                        , unLoc $3) }-        | 'where' vocurly    gadt_constrs close  {% checkEmptyGADTs $-                                                      L (comb2 $1 $3)-                                                        ([mj AnnWhere $1]-                                                        , unLoc $3) }-        | {- empty -}                            { noLoc ([],[]) }--gadt_constrs :: { Located [LConDecl GhcPs] }-        : gadt_constr ';' gadt_constrs-                  {% do { h <- addTrailingSemiA $1 (gl $2)-                        ; return (L (comb2 (reLoc $1) $3) (h : unLoc $3)) }}-        | gadt_constr                   { L (glA $1) [$1] }-        | {- empty -}                   { noLoc [] }---- We allow the following forms:---      C :: Eq a => a -> T a---      C :: forall a. Eq a => !a -> T a---      D { x,y :: a } :: T a---      forall a. Eq a => D { x,y :: a } :: T a--gadt_constr :: { LConDecl GhcPs }-    -- see Note [Difference in parsing GADT and data constructors]-    -- Returns a list because of:   C,D :: ty-    -- TODO:AZ capture the optSemi. Why leading?-        : optSemi con_list '::' sigtype-                {% mkGadtDecl (comb2A $2 $>) (unLoc $2) (hsUniTok $3) $4 }--{- Note [Difference in parsing GADT and data constructors]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-GADT constructors have simpler syntax than usual data constructors:-in GADTs, types cannot occur to the left of '::', so they cannot be mixed-with constructor names (see Note [Parsing data constructors is hard]).--Due to simplified syntax, GADT constructor names (left-hand side of '::')-use simpler grammar production than usual data constructor names. As a-consequence, GADT constructor names are restricted (names like '(*)' are-allowed in usual data constructors, but not in GADTs).--}--constrs :: { Located ([AddEpAnn],[LConDecl GhcPs]) }-        : '=' constrs1    { sLL $1 $2 ([mj AnnEqual $1],unLoc $2)}--constrs1 :: { Located [LConDecl GhcPs] }-        : constrs1 '|' constr-            {% do { let (h:t) = unLoc $1-                  ; h' <- addTrailingVbarA h (gl $2)-                  ; return (sLLlA $1 $> ($3 : h' : t)) }}-        | constr                         { sL1A $1 [$1] }--constr :: { LConDecl GhcPs }-        : forall context '=>' constr_stuff-                {% acsA (\cs -> let (con,details) = unLoc $4 in-                  (L (comb4 $1 (reLoc $2) $3 $4) (mkConDeclH98-                                                       (EpAnn (spanAsAnchor (comb4 $1 (reLoc $2) $3 $4))-                                                                    (mu AnnDarrow $3:(fst $ unLoc $1)) cs)-                                                       con-                                                       (snd $ unLoc $1)-                                                       (Just $2)-                                                       details))) }-        | forall constr_stuff-                {% acsA (\cs -> let (con,details) = unLoc $2 in-                  (L (comb2 $1 $2) (mkConDeclH98 (EpAnn (spanAsAnchor (comb2 $1 $2)) (fst $ unLoc $1) cs)-                                                      con-                                                      (snd $ unLoc $1)-                                                      Nothing   -- No context-                                                      details))) }--forall :: { Located ([AddEpAnn], Maybe [LHsTyVarBndr Specificity GhcPs]) }-        : 'forall' tv_bndrs '.'       { sLL $1 $> ([mu AnnForall $1,mj AnnDot $3], Just $2) }-        | {- empty -}                 { noLoc ([], Nothing) }--constr_stuff :: { Located (LocatedN RdrName, HsConDeclH98Details GhcPs) }-        : infixtype       {% fmap (reLoc. (fmap (\b -> (dataConBuilderCon b,-                                                          dataConBuilderDetails b))))-                                     (runPV $1) }--fielddecls :: { [LConDeclField GhcPs] }-        : {- empty -}     { [] }-        | fielddecls1     { $1 }--fielddecls1 :: { [LConDeclField GhcPs] }-        : fielddecl ',' fielddecls1-            {% do { h <- addTrailingCommaA $1 (gl $2)-                  ; return (h : $3) }}-        | fielddecl   { [$1] }--fielddecl :: { LConDeclField GhcPs }-                                              -- A list because of   f,g :: Int-        : sig_vars '::' ctype-            {% acsA (\cs -> L (comb2 $1 (reLoc $3))-                      (ConDeclField (EpAnn (glR $1) [mu AnnDcolon $2] cs)-                                    (reverse (map (\ln@(L l n) -> L (l2l l) $ FieldOcc noExtField ln) (unLoc $1))) $3 Nothing))}---- Reversed!-maybe_derivings :: { Located (HsDeriving GhcPs) }-        : {- empty -}             { noLoc [] }-        | derivings               { $1 }---- A list of one or more deriving clauses at the end of a datatype-derivings :: { Located (HsDeriving GhcPs) }-        : derivings deriving      { sLL $1 (reLoc $>) ($2 : unLoc $1) } -- AZ: order?-        | deriving                { sL1 (reLoc $>) [$1] }---- The outer Located is just to allow the caller to--- know the rightmost extremity of the 'deriving' clause-deriving :: { LHsDerivingClause GhcPs }-        : 'deriving' deriv_clause_types-              {% let { full_loc = comb2A $1 $> }-                 in acsA (\cs -> L full_loc $ HsDerivingClause (EpAnn (glR $1) [mj AnnDeriving $1] cs) Nothing $2) }--        | 'deriving' deriv_strategy_no_via deriv_clause_types-              {% let { full_loc = comb2A $1 $> }-                 in acsA (\cs -> L full_loc $ HsDerivingClause (EpAnn (glR $1) [mj AnnDeriving $1] cs) (Just $2) $3) }--        | 'deriving' deriv_clause_types deriv_strategy_via-              {% let { full_loc = comb2 $1 (reLoc $>) }-                 in acsA (\cs -> L full_loc $ HsDerivingClause (EpAnn (glR $1) [mj AnnDeriving $1] cs) (Just $3) $2) }--deriv_clause_types :: { LDerivClauseTys GhcPs }-        : qtycon              { let { tc = sL1 (reLocL $1) $ mkHsImplicitSigType $-                                           sL1 (reLocL $1) $ HsTyVar noAnn NotPromoted $1 } in-                                sL1 (reLocC $1) (DctSingle noExtField tc) }-        | '(' ')'             {% amsrc (sLL $1 $> (DctMulti noExtField []))-                                       (AnnContext Nothing [glAA $1] [glAA $2]) }-        | '(' deriv_types ')' {% amsrc (sLL $1 $> (DctMulti noExtField $2))-                                       (AnnContext Nothing [glAA $1] [glAA $3])}---------------------------------------------------------------------------------- Value definitions--{- Note [Declaration/signature overlap]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-There's an awkward overlap with a type signature.  Consider-        f :: Int -> Int = ...rhs...-   Then we can't tell whether it's a type signature or a value-   definition with a result signature until we see the '='.-   So we have to inline enough to postpone reductions until we know.--}--{--  ATTENTION: Dirty Hackery Ahead! If the second alternative of vars is var-  instead of qvar, we get another shift/reduce-conflict. Consider the-  following programs:--     { (^^) :: Int->Int ; }          Type signature; only var allowed--     { (^^) :: Int->Int = ... ; }    Value defn with result signature;-                                     qvar allowed (because of instance decls)--  We can't tell whether to reduce var to qvar until after we've read the signatures.--}--decl_no_th :: { LHsDecl GhcPs }-        : sigdecl               { $1 }--        | infixexp     opt_sig rhs  {% runPV (unECP $1) >>= \ $1 ->-                                       do { let { l = comb2Al $1 $> }-                                          ; r <- checkValDef l $1 $2 $3;-                                        -- Depending upon what the pattern looks like we might get either-                                        -- a FunBind or PatBind back from checkValDef. See Note-                                        -- [FunBind vs PatBind]-                                          ; cs <- getCommentsFor l-                                          ; return $! (sL (commentsA l cs) $ ValD noExtField r) } }-        | pattern_synonym_decl  { $1 }--decl    :: { LHsDecl GhcPs }-        : decl_no_th            { $1 }--        -- Why do we only allow naked declaration splices in top-level-        -- declarations and not here? Short answer: because readFail009-        -- fails terribly with a panic in cvBindsAndSigs otherwise.-        | splice_exp            {% mkSpliceDecl $1 }--rhs     :: { Located (GRHSs GhcPs (LHsExpr GhcPs)) }-        : '=' exp wherebinds    {% runPV (unECP $2) >>= \ $2 ->-                                  do { let L l (bs, csw) = adaptWhereBinds $3-                                     ; let loc = (comb3 $1 (reLoc $2) (L l bs))-                                     ; acs (\cs ->-                                       sL loc (GRHSs csw (unguardedRHS (EpAnn (anc $ rs loc) (GrhsAnn Nothing (mj AnnEqual $1)) cs) loc $2)-                                                      bs)) } }-        | gdrhs wherebinds      {% do { let {L l (bs, csw) = adaptWhereBinds $2}-                                      ; acs (\cs -> sL (comb2 $1 (L l bs))-                                                (GRHSs (cs Semi.<> csw) (reverse (unLoc $1)) bs)) }}--gdrhs :: { Located [LGRHS GhcPs (LHsExpr GhcPs)] }-        : gdrhs gdrh            { sLL $1 (reLoc $>) ($2 : unLoc $1) }-        | gdrh                  { sL1 (reLoc $1) [$1] }--gdrh :: { LGRHS GhcPs (LHsExpr GhcPs) }-        : '|' guardquals '=' exp  {% runPV (unECP $4) >>= \ $4 ->-                                     acsA (\cs -> sL (comb2A $1 $>) $ GRHS (EpAnn (glR $1) (GrhsAnn (Just $ glAA $1) (mj AnnEqual $3)) cs) (unLoc $2) $4) }--sigdecl :: { LHsDecl GhcPs }-        :-        -- See Note [Declaration/signature overlap] for why we need infixexp here-          infixexp     '::' sigtype-                        {% do { $1 <- runPV (unECP $1)-                              ; v <- checkValSigLhs $1-                              ; acsA (\cs -> (sLLAl $1 (reLoc $>) $ SigD noExtField $-                                  TypeSig (EpAnn (glAR $1) (AnnSig (mu AnnDcolon $2) []) cs) [v] (mkHsWildCardBndrs $3)))} }--        | var ',' sig_vars '::' sigtype-           {% do { v <- addTrailingCommaN $1 (gl $2)-                 ; let sig cs = TypeSig (EpAnn (glNR $1) (AnnSig (mu AnnDcolon $4) []) cs) (v : reverse (unLoc $3))-                                      (mkHsWildCardBndrs $5)-                 ; acsA (\cs -> sLL (reLocN $1) (reLoc $>) $ SigD noExtField (sig cs) ) }}--        | infix prec ops-             {% do { mbPrecAnn <- traverse (\l2 -> do { checkPrecP l2 $3-                                                      ; pure (mj AnnVal l2) })-                                       $2-                   ; let (fixText, fixPrec) = case $2 of-                                                -- If an explicit precedence isn't supplied,-                                                -- it defaults to maxPrecedence-                                                Nothing -> (NoSourceText, maxPrecedence)-                                                Just l2 -> (fst $ unLoc l2, snd $ unLoc l2)-                   ; acsA (\cs -> sLL $1 $> $ SigD noExtField-                            (FixSig (EpAnn (glR $1) (mj AnnInfix $1 : maybeToList mbPrecAnn) cs) (FixitySig noExtField (fromOL $ unLoc $3)-                                    (Fixity fixText fixPrec (unLoc $1)))))-                   }}--        | pattern_synonym_sig   { sL1 $1 . SigD noExtField . unLoc $ $1 }--        | '{-# COMPLETE' qcon_list opt_tyconsig  '#-}'-                {% let (dcolon, tc) = $3-                   in acsA-                       (\cs -> sLL $1 $>-                         (SigD noExtField (CompleteMatchSig ((EpAnn (glR $1) ([ mo $1 ] ++ dcolon ++ [mc $4]) cs), (getCOMPLETE_PRAGs $1)) $2 tc))) }--        -- This rule is for both INLINE and INLINABLE pragmas-        | '{-# INLINE' activation qvarcon '#-}'-                {% acsA (\cs -> (sLL $1 $> $ SigD noExtField (InlineSig (EpAnn (glR $1) ((mo $1:fst $2) ++ [mc $4]) cs) $3-                            (mkInlinePragma (getINLINE_PRAGs $1) (getINLINE $1)-                                            (snd $2))))) }-        | '{-# OPAQUE' qvar '#-}'-                {% acsA (\cs -> (sLL $1 $> $ SigD noExtField (InlineSig (EpAnn (glR $1) [mo $1, mc $3] cs) $2-                            (mkOpaquePragma (getOPAQUE_PRAGs $1))))) }-        | '{-# SCC' qvar '#-}'-          {% acsA (\cs -> sLL $1 $> (SigD noExtField (SCCFunSig ((EpAnn (glR $1) [mo $1, mc $3] cs), (getSCC_PRAGs $1)) $2 Nothing))) }--        | '{-# SCC' qvar STRING '#-}'-          {% do { scc <- getSCC $3-                ; let str_lit = StringLiteral (getSTRINGs $3) scc Nothing-                ; acsA (\cs -> sLL $1 $> (SigD noExtField (SCCFunSig ((EpAnn (glR $1) [mo $1, mc $4] cs), (getSCC_PRAGs $1)) $2 (Just ( sL1a $3 str_lit))))) }}--        | '{-# SPECIALISE' activation qvar '::' sigtypes1 '#-}'-             {% acsA (\cs ->-                 let inl_prag = mkInlinePragma (getSPEC_PRAGs $1)-                                             (NoUserInlinePrag, FunLike) (snd $2)-                  in sLL $1 $> $ SigD noExtField (SpecSig (EpAnn (glR $1) (mo $1:mu AnnDcolon $4:mc $6:(fst $2)) cs) $3 (fromOL $5) inl_prag)) }--        | '{-# SPECIALISE_INLINE' activation qvar '::' sigtypes1 '#-}'-             {% acsA (\cs -> sLL $1 $> $ SigD noExtField (SpecSig (EpAnn (glR $1) (mo $1:mu AnnDcolon $4:mc $6:(fst $2)) cs) $3 (fromOL $5)-                               (mkInlinePragma (getSPEC_INLINE_PRAGs $1)-                                               (getSPEC_INLINE $1) (snd $2)))) }--        | '{-# SPECIALISE' 'instance' inst_type '#-}'-                {% acsA (\cs -> sLL $1 $>-                                  $ SigD noExtField (SpecInstSig ((EpAnn (glR $1) [mo $1,mj AnnInstance $2,mc $4] cs), (getSPEC_PRAGs $1)) $3)) }--        -- A minimal complete definition-        | '{-# MINIMAL' name_boolformula_opt '#-}'-            {% acsA (\cs -> sLL $1 $> $ SigD noExtField (MinimalSig ((EpAnn (glR $1) [mo $1,mc $3] cs), (getMINIMAL_PRAGs $1)) $2)) }--activation :: { ([AddEpAnn],Maybe Activation) }-        -- See Note [%shift: activation -> {- empty -}]-        : {- empty -} %shift                    { ([],Nothing) }-        | explicit_activation                   { (fst $1,Just (snd $1)) }--explicit_activation :: { ([AddEpAnn],Activation) }  -- In brackets-        : '[' INTEGER ']'       { ([mj AnnOpenS $1,mj AnnVal $2,mj AnnCloseS $3]-                                  ,ActiveAfter  (getINTEGERs $2) (fromInteger (il_value (getINTEGER $2)))) }-        | '[' rule_activation_marker INTEGER ']'-                                { ($2++[mj AnnOpenS $1,mj AnnVal $3,mj AnnCloseS $4]-                                  ,ActiveBefore (getINTEGERs $3) (fromInteger (il_value (getINTEGER $3)))) }---------------------------------------------------------------------------------- Expressions--quasiquote :: { Located (HsUntypedSplice GhcPs) }-        : TH_QUASIQUOTE   { let { loc = getLoc $1-                                ; ITquasiQuote (quoter, quote, quoteSpan) = unLoc $1-                                ; quoterId = mkUnqual varName quoter }-                            in sL1 $1 (HsQuasiQuote noExtField quoterId (L (noAnnSrcSpan (mkSrcSpanPs quoteSpan)) quote)) }-        | TH_QQUASIQUOTE  { let { loc = getLoc $1-                                ; ITqQuasiQuote (qual, quoter, quote, quoteSpan) = unLoc $1-                                ; quoterId = mkQual varName (qual, quoter) }-                            in sL1 $1 (HsQuasiQuote noExtField quoterId (L (noAnnSrcSpan (mkSrcSpanPs quoteSpan)) quote)) }--exp   :: { ECP }-        : infixexp '::' ctype-                                { ECP $-                                   unECP $1 >>= \ $1 ->-                                   rejectPragmaPV $1 >>-                                   mkHsTySigPV (noAnnSrcSpan $ comb2Al $1 (reLoc $>)) $1 $3-                                          [(mu AnnDcolon $2)] }-        | infixexp '-<' exp     {% runPV (unECP $1) >>= \ $1 ->-                                   runPV (unECP $3) >>= \ $3 ->-                                   fmap ecpFromCmd $-                                   acsA (\cs -> sLLAA $1 $> $ HsCmdArrApp (EpAnn (glAR $1) (mu Annlarrowtail $2) cs) $1 $3-                                                        HsFirstOrderApp True) }-        | infixexp '>-' exp     {% runPV (unECP $1) >>= \ $1 ->-                                   runPV (unECP $3) >>= \ $3 ->-                                   fmap ecpFromCmd $-                                   acsA (\cs -> sLLAA $1 $> $ HsCmdArrApp (EpAnn (glAR $1) (mu Annrarrowtail $2) cs) $3 $1-                                                      HsFirstOrderApp False) }-        | infixexp '-<<' exp    {% runPV (unECP $1) >>= \ $1 ->-                                   runPV (unECP $3) >>= \ $3 ->-                                   fmap ecpFromCmd $-                                   acsA (\cs -> sLLAA $1 $> $ HsCmdArrApp (EpAnn (glAR $1) (mu AnnLarrowtail $2) cs) $1 $3-                                                      HsHigherOrderApp True) }-        | infixexp '>>-' exp    {% runPV (unECP $1) >>= \ $1 ->-                                   runPV (unECP $3) >>= \ $3 ->-                                   fmap ecpFromCmd $-                                   acsA (\cs -> sLLAA $1 $> $ HsCmdArrApp (EpAnn (glAR $1) (mu AnnRarrowtail $2) cs) $3 $1-                                                      HsHigherOrderApp False) }-        -- See Note [%shift: exp -> infixexp]-        | infixexp %shift       { $1 }-        | exp_prag(exp)         { $1 } -- See Note [Pragmas and operator fixity]--infixexp :: { ECP }-        : exp10 { $1 }-        | infixexp qop exp10p    -- See Note [Pragmas and operator fixity]-                               { ECP $-                                 superInfixOp $-                                 $2 >>= \ $2 ->-                                 unECP $1 >>= \ $1 ->-                                 unECP $3 >>= \ $3 ->-                                 rejectPragmaPV $1 >>-                                 (mkHsOpAppPV (comb2A (reLoc $1) $3) $1 $2 $3) }-                 -- AnnVal annotation for NPlusKPat, which discards the operator--exp10p :: { ECP }-  : exp10            { $1 }-  | exp_prag(exp10p) { $1 } -- See Note [Pragmas and operator fixity]--exp_prag(e) :: { ECP }-  : prag_e e  -- See Note [Pragmas and operator fixity]-      {% runPV (unECP $2) >>= \ $2 ->-         fmap ecpFromExp $-         return $ (reLocA $ sLLlA $1 $> $ HsPragE noExtField (unLoc $1) $2) }--exp10 :: { ECP }-        -- See Note [%shift: exp10 -> '-' fexp]-        : '-' fexp %shift               { ECP $-                                           unECP $2 >>= \ $2 ->-                                           mkHsNegAppPV (comb2A $1 $>) $2-                                                 [mj AnnMinus $1] }-        -- See Note [%shift: exp10 -> fexp]-        | fexp %shift                  { $1 }--optSemi :: { (Maybe EpaLocation,Bool) }-        : ';'         { (msemim $1,True) }-        | {- empty -} { (Nothing,False) }--{- Note [Pragmas and operator fixity]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-'prag_e' is an expression pragma, such as {-# SCC ... #-}.--It must be used with care, or else #15730 happens. Consider this infix-expression:--         1 / 2 / 2--There are two ways to parse it:--    1.   (1 / 2) / 2   =  0.25-    2.   1 / (2 / 2)   =  1.0--Due to the fixity of the (/) operator (assuming it comes from Prelude),-option 1 is the correct parse. However, in the past GHC's parser used to get-confused by the SCC annotation when it occurred in the middle of an infix-expression:--         1 / {-# SCC ann #-} 2 / 2    -- used to get parsed as option 2--There are several ways to address this issue, see GHC Proposal #176 for a-detailed exposition:--  https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0176-scc-parsing.rst--The accepted fix is to disallow pragmas that occur within infix expressions.-Infix expressions are assembled out of 'exp10', so 'exp10' must not accept-pragmas. Instead, we accept them in exactly two places:--* at the start of an expression or a parenthesized subexpression:--    f = {-# SCC ann #-} 1 / 2 / 2          -- at the start of the expression-    g = 5 + ({-# SCC ann #-} 1 / 2 / 2)    -- at the start of a parenthesized subexpression--* immediately after the last operator:--    f = 1 / 2 / {-# SCC ann #-} 2--In both cases, the parse does not depend on operator fixity. The second case-may sound unnecessary, but it's actually needed to support a common idiom:--    f $ {-# SCC ann $-} ...---}-prag_e :: { Located (HsPragE GhcPs) }-      : '{-# SCC' STRING '#-}'      {% do { scc <- getSCC $2-                                          ; acs (\cs -> (sLL $1 $>-                                             (HsPragSCC-                                                ((EpAnn (glR $1) (AnnPragma (mo $1) (mc $3) [mj AnnValStr $2]) cs),-                                                (getSCC_PRAGs $1))-                                                (StringLiteral (getSTRINGs $2) scc Nothing))))} }-      | '{-# SCC' VARID  '#-}'      {% acs (\cs -> (sLL $1 $>-                                             (HsPragSCC-                                               ((EpAnn (glR $1) (AnnPragma (mo $1) (mc $3) [mj AnnVal $2]) cs),-                                               (getSCC_PRAGs $1))-                                               (StringLiteral NoSourceText (getVARID $2) Nothing)))) }--fexp    :: { ECP }-        : fexp aexp                  { ECP $-                                          superFunArg $-                                          unECP $1 >>= \ $1 ->-                                          unECP $2 >>= \ $2 ->-                                          mkHsAppPV (noAnnSrcSpan $ comb2A (reLoc $1) $>) $1 $2 }--        -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer-        | fexp PREFIX_AT atype       { ECP $-                                        unECP $1 >>= \ $1 ->-                                        mkHsAppTypePV (noAnnSrcSpan $ comb2 (reLoc $1) (reLoc $>)) $1 (hsTok $2) $3 }--        | 'static' aexp              {% runPV (unECP $2) >>= \ $2 ->-                                        fmap ecpFromExp $-                                        acsA (\cs -> sLL $1 (reLoc $>) $ HsStatic (EpAnn (glR $1) [mj AnnStatic $1] cs) $2) }--        | aexp                       { $1 }--aexp    :: { ECP }-        -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer-        : qvar TIGHT_INFIX_AT aexp-                                { ECP $-                                   unECP $3 >>= \ $3 ->-                                     mkHsAsPatPV (comb2 (reLocN $1) (reLoc $>)) $1 (hsTok $2) $3 }---        -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer-        | PREFIX_TILDE aexp     { ECP $-                                   unECP $2 >>= \ $2 ->-                                   mkHsLazyPatPV (comb2 $1 (reLoc $>)) $2 [mj AnnTilde $1] }-        | PREFIX_BANG aexp      { ECP $-                                   unECP $2 >>= \ $2 ->-                                   mkHsBangPatPV (comb2 $1 (reLoc $>)) $2 [mj AnnBang $1] }-        | PREFIX_MINUS aexp     { ECP $-                                   unECP $2 >>= \ $2 ->-                                   mkHsNegAppPV (comb2A $1 $>) $2 [mj AnnMinus $1] }--        | '\\' apats '->' exp-                   {  ECP $-                      unECP $4 >>= \ $4 ->-                      mkHsLamPV (comb2 $1 (reLoc $>)) (\cs -> mkMatchGroup FromSource-                            (reLocA $ sLLlA $1 $>-                            [reLocA $ sLLlA $1 $>-                                         $ Match { m_ext = EpAnn (glR $1) [mj AnnLam $1] cs-                                                 , m_ctxt = LambdaExpr-                                                 , m_pats = $2-                                                 , m_grhss = unguardedGRHSs (comb2 $3 (reLoc $4)) $4 (EpAnn (glR $3) (GrhsAnn Nothing (mu AnnRarrow $3)) emptyComments) }])) }-        | 'let' binds 'in' exp          {  ECP $-                                           unECP $4 >>= \ $4 ->-                                           mkHsLetPV (comb2A $1 $>) (hsTok $1) (unLoc $2) (hsTok $3) $4 }-        | '\\' 'lcase' altslist(pats1)-            {  ECP $ $3 >>= \ $3 ->-                 mkHsLamCasePV (comb2 $1 (reLoc $>)) LamCase $3 [mj AnnLam $1,mj AnnCase $2] }-        | '\\' 'lcases' altslist(apats)-            {  ECP $ $3 >>= \ $3 ->-                 mkHsLamCasePV (comb2 $1 (reLoc $>)) LamCases $3 [mj AnnLam $1,mj AnnCases $2] }-        | 'if' exp optSemi 'then' exp optSemi 'else' exp-                         {% runPV (unECP $2) >>= \ ($2 :: LHsExpr GhcPs) ->-                            return $ ECP $-                              unECP $5 >>= \ $5 ->-                              unECP $8 >>= \ $8 ->-                              mkHsIfPV (comb2A $1 $>) $2 (snd $3) $5 (snd $6) $8-                                    (AnnsIf-                                      { aiIf = glAA $1-                                      , aiThen = glAA $4-                                      , aiElse = glAA $7-                                      , aiThenSemi = fst $3-                                      , aiElseSemi = fst $6})}--        | 'if' ifgdpats                 {% hintMultiWayIf (getLoc $1) >>= \_ ->-                                           fmap ecpFromExp $-                                           acsA (\cs -> sLL $1 $> $ HsMultiIf (EpAnn (glR $1) (mj AnnIf $1:(fst $ unLoc $2)) cs)-                                                     (reverse $ snd $ unLoc $2)) }-        | 'case' exp 'of' altslist(pats1) {% runPV (unECP $2) >>= \ ($2 :: LHsExpr GhcPs) ->-                                             return $ ECP $-                                               $4 >>= \ $4 ->-                                               mkHsCasePV (comb3 $1 $3 (reLoc $4)) $2 $4-                                                    (EpAnnHsCase (glAA $1) (glAA $3) []) }-        -- QualifiedDo.-        | DO  stmtlist               {% do-                                      hintQualifiedDo $1-                                      return $ ECP $-                                        $2 >>= \ $2 ->-                                        mkHsDoPV (comb2A $1 $2)-                                                 (fmap mkModuleNameFS (getDO $1))-                                                 $2-                                                 (AnnList (Just $ glAR $2) Nothing Nothing [mj AnnDo $1] []) }-        | MDO stmtlist             {% hintQualifiedDo $1 >> runPV $2 >>= \ $2 ->-                                       fmap ecpFromExp $-                                       acsA (\cs -> L (comb2A $1 $2)-                                              (mkHsDoAnns (MDoExpr $-                                                          fmap mkModuleNameFS (getMDO $1))-                                                          $2-                                           (EpAnn (glR $1) (AnnList (Just $ glAR $2) Nothing Nothing [mj AnnMdo $1] []) cs) )) }-        | 'proc' aexp '->' exp-                       {% (checkPattern <=< runPV) (unECP $2) >>= \ p ->-                           runPV (unECP $4) >>= \ $4@cmd ->-                           fmap ecpFromExp $-                           acsA (\cs -> sLLlA $1 $> $ HsProc (EpAnn (glR $1) [mj AnnProc $1,mu AnnRarrow $3] cs) p (sLLa $1 (reLoc $>) $ HsCmdTop noExtField cmd)) }--        | aexp1                 { $1 }--aexp1   :: { ECP }-        : aexp1 '{' fbinds '}' { ECP $-                                   getBit OverloadedRecordUpdateBit >>= \ overloaded ->-                                   unECP $1 >>= \ $1 ->-                                   $3 >>= \ $3 ->-                                   mkHsRecordPV overloaded (comb2 (reLoc $1) $>) (comb2 $2 $4) $1 $3-                                        [moc $2,mcc $4]-                               }--        -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer-        | aexp1 TIGHT_INFIX_PROJ field-            {% runPV (unECP $1) >>= \ $1 ->-               fmap ecpFromExp $ acsa (\cs ->-                 let fl = sLLa $2 (reLoc $>) (DotFieldOcc ((EpAnn (glR $2) (AnnFieldLabel (Just $ glAA $2)) emptyComments)) $3) in-                 mkRdrGetField (noAnnSrcSpan $ comb2 (reLoc $1) (reLoc $>)) $1 fl (EpAnn (glAR $1) NoEpAnns cs))  }---        | aexp2                { $1 }--aexp2   :: { ECP }-        : qvar                          { ECP $ mkHsVarPV $! $1 }-        | qcon                          { ECP $ mkHsVarPV $! $1 }-        -- See Note [%shift: aexp2 -> ipvar]-        | ipvar %shift                  {% acsExpr (\cs -> sL1a $1 (HsIPVar (comment (glRR $1) cs) $! unLoc $1)) }-        | overloaded_label              {% acsExpr (\cs -> sL1a $1 (HsOverLabel (comment (glRR $1) cs) (fst $! unLoc $1) (snd $! unLoc $1))) }-        | literal                       { ECP $ pvA (mkHsLitPV $! $1) }--- This will enable overloaded strings permanently.  Normally the renamer turns HsString--- into HsOverLit when -XOverloadedStrings is on.---      | STRING    { sL (getLoc $1) (HsOverLit $! mkHsIsString (getSTRINGs $1)---                                       (getSTRING $1) noExtField) }-        | INTEGER   { ECP $ mkHsOverLitPV (sL1a $1 $ mkHsIntegral   (getINTEGER  $1)) }-        | RATIONAL  { ECP $ mkHsOverLitPV (sL1a $1 $ mkHsFractional (getRATIONAL $1)) }--        -- N.B.: sections get parsed by these next two productions.-        -- This allows you to write, e.g., '(+ 3, 4 -)', which isn't-        -- correct Haskell (you'd have to write '((+ 3), (4 -))')-        -- but the less cluttered version fell out of having texps.-        | '(' texp ')'                  { ECP $-                                           unECP $2 >>= \ $2 ->-                                           mkHsParPV (comb2 $1 $>) (hsTok $1) $2 (hsTok $3) }-        | '(' tup_exprs ')'             { ECP $-                                           $2 >>= \ $2 ->-                                           mkSumOrTuplePV (noAnnSrcSpan $ comb2 $1 $>) Boxed $2-                                                [mop $1,mcp $3]}--        -- This case is only possible when 'OverloadedRecordDotBit' is enabled.-        | '(' projection ')'            { ECP $-                                            acsA (\cs -> sLL $1 $> $ mkRdrProjection (NE.reverse (unLoc $2)) (EpAnn (glR $1) (AnnProjection (glAA $1) (glAA $3)) cs))-                                            >>= ecpFromExp'-                                        }--        | '(#' texp '#)'                { ECP $-                                           unECP $2 >>= \ $2 ->-                                           mkSumOrTuplePV (noAnnSrcSpan $ comb2 $1 $>) Unboxed (Tuple [Right $2])-                                                 [moh $1,mch $3] }-        | '(#' tup_exprs '#)'           { ECP $-                                           $2 >>= \ $2 ->-                                           mkSumOrTuplePV (noAnnSrcSpan $ comb2 $1 $>) Unboxed $2-                                                [moh $1,mch $3] }--        | '[' list ']'      { ECP $ $2 (comb2 $1 $>) (mos $1,mcs $3) }-        | '_'               { ECP $ pvA $ mkHsWildCardPV (getLoc $1) }--        -- Template Haskell Extension-        | splice_untyped { ECP $ pvA $ mkHsSplicePV $1 }-        | splice_typed   { ecpFromExp $ fmap (uncurry HsTypedSplice) (reLocA $1) }--        | SIMPLEQUOTE  qvar     {% fmap ecpFromExp $ acsA (\cs -> sLL $1 (reLocN $>) $ HsUntypedBracket (EpAnn (glR $1) [mj AnnSimpleQuote $1] cs) (VarBr noExtField True  $2)) }-        | SIMPLEQUOTE  qcon     {% fmap ecpFromExp $ acsA (\cs -> sLL $1 (reLocN $>) $ HsUntypedBracket (EpAnn (glR $1) [mj AnnSimpleQuote $1] cs) (VarBr noExtField True  $2)) }-        | TH_TY_QUOTE tyvar     {% fmap ecpFromExp $ acsA (\cs -> sLL $1 (reLocN $>) $ HsUntypedBracket (EpAnn (glR $1) [mj AnnThTyQuote $1  ] cs) (VarBr noExtField False $2)) }-        | TH_TY_QUOTE gtycon    {% fmap ecpFromExp $ acsA (\cs -> sLL $1 (reLocN $>) $ HsUntypedBracket (EpAnn (glR $1) [mj AnnThTyQuote $1  ] cs) (VarBr noExtField False $2)) }-        -- See Note [%shift: aexp2 -> TH_TY_QUOTE]-        | TH_TY_QUOTE %shift    {% reportEmptyDoubleQuotes (getLoc $1) }-        | '[|' exp '|]'       {% runPV (unECP $2) >>= \ $2 ->-                                 fmap ecpFromExp $-                                 acsA (\cs -> sLL $1 $> $ HsUntypedBracket (EpAnn (glR $1) (if (hasE $1) then [mj AnnOpenE $1, mu AnnCloseQ $3]-                                                                                         else [mu AnnOpenEQ $1,mu AnnCloseQ $3]) cs) (ExpBr noExtField $2)) }-        | '[||' exp '||]'     {% runPV (unECP $2) >>= \ $2 ->-                                 fmap ecpFromExp $-                                 acsA (\cs -> sLL $1 $> $ HsTypedBracket (EpAnn (glR $1) (if (hasE $1) then [mj AnnOpenE $1,mc $3] else [mo $1,mc $3]) cs) $2) }-        | '[t|' ktype '|]'    {% fmap ecpFromExp $-                                 acsA (\cs -> sLL $1 $> $ HsUntypedBracket (EpAnn (glR $1) [mo $1,mu AnnCloseQ $3] cs) (TypBr noExtField $2)) }-        | '[p|' infixexp '|]' {% (checkPattern <=< runPV) (unECP $2) >>= \p ->-                                      fmap ecpFromExp $-                                      acsA (\cs -> sLL $1 $> $ HsUntypedBracket (EpAnn (glR $1) [mo $1,mu AnnCloseQ $3] cs) (PatBr noExtField p)) }-        | '[d|' cvtopbody '|]' {% fmap ecpFromExp $-                                  acsA (\cs -> sLL $1 $> $ HsUntypedBracket (EpAnn (glR $1) (mo $1:mu AnnCloseQ $3:fst $2) cs) (DecBrL noExtField (snd $2))) }-        | quasiquote          { ECP $ pvA $ mkHsSplicePV $1 }--        -- arrow notation extension-        | '(|' aexp cmdargs '|)'  {% runPV (unECP $2) >>= \ $2 ->-                                      fmap ecpFromCmd $-                                      acsA (\cs -> sLL $1 $> $ HsCmdArrForm (EpAnn (glR $1) (AnnList (Just $ glR $1) (Just $ mu AnnOpenB $1) (Just $ mu AnnCloseB $4) [] []) cs) $2 Prefix-                                                           Nothing (reverse $3)) }--projection :: { Located (NonEmpty (LocatedAn NoEpAnns (DotFieldOcc GhcPs))) }-projection-        -- See Note [Whitespace-sensitive operator parsing] in GHC.Parsing.Lexer-        : projection TIGHT_INFIX_PROJ field-                             {% acs (\cs -> sLL $1 (reLoc $>) ((sLLa $2 (reLoc $>) $ DotFieldOcc (EpAnn (glR $1) (AnnFieldLabel (Just $ glAA $2)) cs) $3) `NE.cons` unLoc $1)) }-        | PREFIX_PROJ field  {% acs (\cs -> sLL $1 (reLoc $>) ((sLLa $1 (reLoc $>) $ DotFieldOcc (EpAnn (glR $1) (AnnFieldLabel (Just $ glAA $1)) cs) $2) :| [])) }--splice_exp :: { LHsExpr GhcPs }-        : splice_untyped { fmap (HsUntypedSplice noAnn) (reLocA $1) }-        | splice_typed   { fmap (uncurry HsTypedSplice) (reLocA $1) }--splice_untyped :: { Located (HsUntypedSplice GhcPs) }-        -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer-        : PREFIX_DOLLAR aexp2   {% runPV (unECP $2) >>= \ $2 ->-                                   acs (\cs -> sLLlA $1 $> $ HsUntypedSpliceExpr (EpAnn (glR $1) [mj AnnDollar $1] cs) $2) }--splice_typed :: { Located ((EpAnnCO, EpAnn [AddEpAnn]), LHsExpr GhcPs) }-        -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer-        : PREFIX_DOLLAR_DOLLAR aexp2-                                {% runPV (unECP $2) >>= \ $2 ->-                                   acs (\cs -> sLLlA $1 $> $ ((noAnn, EpAnn (glR $1) [mj AnnDollarDollar $1] cs), $2)) }--cmdargs :: { [LHsCmdTop GhcPs] }-        : cmdargs acmd                  { $2 : $1 }-        | {- empty -}                   { [] }--acmd    :: { LHsCmdTop GhcPs }-        : aexp                  {% runPV (unECP $1) >>= \ (cmd :: LHsCmd GhcPs) ->-                                   runPV (checkCmdBlockArguments cmd) >>= \ _ ->-                                   return (sL1a (reLoc cmd) $ HsCmdTop noExtField cmd) }--cvtopbody :: { ([AddEpAnn],[LHsDecl GhcPs]) }-        :  '{'            cvtopdecls0 '}'      { ([mj AnnOpenC $1-                                                  ,mj AnnCloseC $3],$2) }-        |      vocurly    cvtopdecls0 close    { ([],$2) }--cvtopdecls0 :: { [LHsDecl GhcPs] }-        : topdecls_semi         { cvTopDecls $1 }-        | topdecls              { cvTopDecls $1 }---------------------------------------------------------------------------------- Tuple expressions---- "texp" is short for tuple expressions:--- things that can appear unparenthesized as long as they're--- inside parens or delimited by commas-texp :: { ECP }-        : exp                           { $1 }--        -- Note [Parsing sections]-        -- ~~~~~~~~~~~~~~~~~~~~~~~-        -- We include left and right sections here, which isn't-        -- technically right according to the Haskell standard.-        -- For example (3 +, True) isn't legal.-        -- However, we want to parse bang patterns like-        --      (!x, !y)-        -- and it's convenient to do so here as a section-        -- Then when converting expr to pattern we unravel it again-        -- Meanwhile, the renamer checks that real sections appear-        -- inside parens.-        | infixexp qop-                             {% runPV (unECP $1) >>= \ $1 ->-                                runPV (rejectPragmaPV $1) >>-                                runPV $2 >>= \ $2 ->-                                return $ ecpFromExp $-                                reLocA $ sLL (reLoc $1) (reLocN $>) $ SectionL noAnn $1 (n2l $2) }-        | qopm infixexp      { ECP $-                                superInfixOp $-                                unECP $2 >>= \ $2 ->-                                $1 >>= \ $1 ->-                                pvA $ mkHsSectionR_PV (comb2 (reLocN $1) (reLoc $>)) (n2l $1) $2 }--       -- View patterns get parenthesized above-        | exp '->' texp   { ECP $-                             unECP $1 >>= \ $1 ->-                             unECP $3 >>= \ $3 ->-                             mkHsViewPatPV (comb2 (reLoc $1) (reLoc $>)) $1 $3 [mu AnnRarrow $2] }---- Always at least one comma or bar.--- Though this can parse just commas (without any expressions), it won't--- in practice, because (,,,) is parsed as a name. See Note [ExplicitTuple]--- in GHC.Hs.Expr.-tup_exprs :: { forall b. DisambECP b => PV (SumOrTuple b) }-           : texp commas_tup_tail-                           { unECP $1 >>= \ $1 ->-                             $2 >>= \ $2 ->-                             do { t <- amsA $1 [AddCommaAnn (srcSpan2e $ fst $2)]-                                ; return (Tuple (Right t : snd $2)) } }-           | commas tup_tail-                 { $2 >>= \ $2 ->-                   do { let {cos = map (\ll -> (Left (EpAnn (anc $ rs ll) (srcSpan2e ll) emptyComments))) (fst $1) }-                      ; return (Tuple (cos ++ $2)) } }--           | texp bars   { unECP $1 >>= \ $1 -> return $-                            (Sum 1  (snd $2 + 1) $1 [] (map srcSpan2e $ fst $2)) }--           | bars texp bars0-                { unECP $2 >>= \ $2 -> return $-                  (Sum (snd $1 + 1) (snd $1 + snd $3 + 1) $2-                    (map srcSpan2e $ fst $1)-                    (map srcSpan2e $ fst $3)) }---- Always starts with commas; always follows an expr-commas_tup_tail :: { forall b. DisambECP b => PV (SrcSpan,[Either (EpAnn EpaLocation) (LocatedA b)]) }-commas_tup_tail : commas tup_tail-        { $2 >>= \ $2 ->-          do { let {cos = map (\l -> (Left (EpAnn (anc $ rs l) (srcSpan2e l) emptyComments))) (tail $ fst $1) }-             ; return ((head $ fst $1, cos ++ $2)) } }---- Always follows a comma-tup_tail :: { forall b. DisambECP b => PV [Either (EpAnn EpaLocation) (LocatedA b)] }-          : texp commas_tup_tail { unECP $1 >>= \ $1 ->-                                   $2 >>= \ $2 ->-                                   do { t <- amsA $1 [AddCommaAnn (srcSpan2e $ fst $2)]-                                      ; return (Right t : snd $2) } }-          | texp                 { unECP $1 >>= \ $1 ->-                                   return [Right $1] }-          -- See Note [%shift: tup_tail -> {- empty -}]-          | {- empty -} %shift   { return [Left noAnn] }---------------------------------------------------------------------------------- List expressions---- The rules below are little bit contorted to keep lexps left-recursive while--- avoiding another shift/reduce-conflict.--- Never empty.-list :: { forall b. DisambECP b => SrcSpan -> (AddEpAnn, AddEpAnn) -> PV (LocatedA b) }-        : texp    { \loc (ao,ac) -> unECP $1 >>= \ $1 ->-                            mkHsExplicitListPV loc [$1] (AnnList Nothing (Just ao) (Just ac) [] []) }-        | lexps   { \loc (ao,ac) -> $1 >>= \ $1 ->-                            mkHsExplicitListPV loc (reverse $1) (AnnList Nothing (Just ao) (Just ac) [] []) }-        | texp '..'  { \loc (ao,ac) -> unECP $1 >>= \ $1 ->-                                  acsA (\cs -> L loc $ ArithSeq (EpAnn (spanAsAnchor loc) [ao,mj AnnDotdot $2,ac] cs) Nothing (From $1))-                                      >>= ecpFromExp' }-        | texp ',' exp '..' { \loc (ao,ac) ->-                                   unECP $1 >>= \ $1 ->-                                   unECP $3 >>= \ $3 ->-                                   acsA (\cs -> L loc $ ArithSeq (EpAnn (spanAsAnchor loc) [ao,mj AnnComma $2,mj AnnDotdot $4,ac] cs) Nothing (FromThen $1 $3))-                                       >>= ecpFromExp' }-        | texp '..' exp  { \loc (ao,ac) ->-                                   unECP $1 >>= \ $1 ->-                                   unECP $3 >>= \ $3 ->-                                   acsA (\cs -> L loc $ ArithSeq (EpAnn (spanAsAnchor loc) [ao,mj AnnDotdot $2,ac] cs) Nothing (FromTo $1 $3))-                                       >>= ecpFromExp' }-        | texp ',' exp '..' exp { \loc (ao,ac) ->-                                   unECP $1 >>= \ $1 ->-                                   unECP $3 >>= \ $3 ->-                                   unECP $5 >>= \ $5 ->-                                   acsA (\cs -> L loc $ ArithSeq (EpAnn (spanAsAnchor loc) [ao,mj AnnComma $2,mj AnnDotdot $4,ac] cs) Nothing (FromThenTo $1 $3 $5))-                                       >>= ecpFromExp' }-        | texp '|' flattenedpquals-             { \loc (ao,ac) ->-                checkMonadComp >>= \ ctxt ->-                unECP $1 >>= \ $1 -> do { t <- addTrailingVbarA $1 (gl $2)-                ; acsA (\cs -> L loc $ mkHsCompAnns ctxt (unLoc $3) t (EpAnn (spanAsAnchor loc) (AnnList Nothing (Just ao) (Just ac) [] []) cs))-                    >>= ecpFromExp' } }--lexps :: { forall b. DisambECP b => PV [LocatedA b] }-        : lexps ',' texp           { $1 >>= \ $1 ->-                                     unECP $3 >>= \ $3 ->-                                     case $1 of-                                       (h:t) -> do-                                         h' <- addTrailingCommaA h (gl $2)-                                         return (((:) $! $3) $! (h':t)) }-        | texp ',' texp             { unECP $1 >>= \ $1 ->-                                      unECP $3 >>= \ $3 ->-                                      do { h <- addTrailingCommaA $1 (gl $2)-                                         ; return [$3,h] }}---------------------------------------------------------------------------------- List Comprehensions--flattenedpquals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] }-    : pquals   { case (unLoc $1) of-                    [qs] -> sL1 $1 qs-                    -- We just had one thing in our "parallel" list so-                    -- we simply return that thing directly--                    qss -> sL1 $1 [sL1a $1 $ ParStmt noExtField [ParStmtBlock noExtField qs [] noSyntaxExpr |-                                            qs <- qss]-                                            noExpr noSyntaxExpr]-                    -- We actually found some actual parallel lists so-                    -- we wrap them into as a ParStmt-                }--pquals :: { Located [[LStmt GhcPs (LHsExpr GhcPs)]] }-    : squals '|' pquals-                     {% case unLoc $1 of-                          (h:t) -> do-                            h' <- addTrailingVbarA h (gl $2)-                            return (sLL $1 $> (reverse (h':t) : unLoc $3)) }-    | squals         { L (getLoc $1) [reverse (unLoc $1)] }--squals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] }   -- In reverse order, because the last-                                        -- one can "grab" the earlier ones-    : squals ',' transformqual-             {% case unLoc $1 of-                  (h:t) -> do-                    h' <- addTrailingCommaA h (gl $2)-                    return (sLL $1 $> [sLLa $1 $> ((unLoc $3) (glRR $1) (reverse (h':t)))]) }-    | squals ',' qual-             {% runPV $3 >>= \ $3 ->-                case unLoc $1 of-                  (h:t) -> do-                    h' <- addTrailingCommaA h (gl $2)-                    return (sLL $1 (reLoc $>) ($3 : (h':t))) }-    | transformqual        {% return (sLL $1 $> [L (getLocAnn $1) ((unLoc $1) (glRR $1) [])]) }-    | qual                               {% runPV $1 >>= \ $1 ->-                                            return $ sL1A $1 [$1] }---  | transformquals1 ',' '{|' pquals '|}'   { sLL $1 $> ($4 : unLoc $1) }---  | '{|' pquals '|}'                       { sL1 $1 [$2] }---- It is possible to enable bracketing (associating) qualifier lists--- by uncommenting the lines with {| |} above. Due to a lack of--- consensus on the syntax, this feature is not being used until we--- get user demand.--transformqual :: { Located (RealSrcSpan -> [LStmt GhcPs (LHsExpr GhcPs)] -> Stmt GhcPs (LHsExpr GhcPs)) }-                        -- Function is applied to a list of stmts *in order*-    : 'then' exp              {% runPV (unECP $2) >>= \ $2 ->-                                 acs (\cs->-                                 sLLlA $1 $> (\r ss -> (mkTransformStmt (EpAnn (anc r) [mj AnnThen $1] cs) ss $2))) }-    | 'then' exp 'by' exp     {% runPV (unECP $2) >>= \ $2 ->-                                 runPV (unECP $4) >>= \ $4 ->-                                 acs (\cs -> sLLlA $1 $> (-                                                     \r ss -> (mkTransformByStmt (EpAnn (anc r) [mj AnnThen $1,mj AnnBy $3] cs) ss $2 $4))) }-    | 'then' 'group' 'using' exp-            {% runPV (unECP $4) >>= \ $4 ->-               acs (\cs -> sLLlA $1 $> (-                                   \r ss -> (mkGroupUsingStmt (EpAnn (anc r) [mj AnnThen $1,mj AnnGroup $2,mj AnnUsing $3] cs) ss $4))) }--    | 'then' 'group' 'by' exp 'using' exp-            {% runPV (unECP $4) >>= \ $4 ->-               runPV (unECP $6) >>= \ $6 ->-               acs (\cs -> sLLlA $1 $> (-                                   \r ss -> (mkGroupByUsingStmt (EpAnn (anc r) [mj AnnThen $1,mj AnnGroup $2,mj AnnBy $3,mj AnnUsing $5] cs) ss $4 $6))) }---- Note that 'group' is a special_id, which means that you can enable--- TransformListComp while still using Data.List.group. However, this--- introduces a shift/reduce conflict. Happy chooses to resolve the conflict--- in by choosing the "group by" variant, which is what we want.---------------------------------------------------------------------------------- Guards--guardquals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] }-    : guardquals1           { L (getLoc $1) (reverse (unLoc $1)) }--guardquals1 :: { Located [LStmt GhcPs (LHsExpr GhcPs)] }-    : guardquals1 ',' qual  {% runPV $3 >>= \ $3 ->-                               case unLoc $1 of-                                 (h:t) -> do-                                   h' <- addTrailingCommaA h (gl $2)-                                   return (sLL $1 (reLoc $>) ($3 : (h':t))) }-    | qual                  {% runPV $1 >>= \ $1 ->-                               return $ sL1A $1 [$1] }---------------------------------------------------------------------------------- Case alternatives--altslist(PATS) :: { forall b. DisambECP b => PV (LocatedL [LMatch GhcPs (LocatedA b)]) }-        : '{'        alts(PATS) '}'    { $2 >>= \ $2 -> amsrl-                                           (sLL $1 $> (reverse (snd $ unLoc $2)))-                                           (AnnList (Just $ glR $2) (Just $ moc $1) (Just $ mcc $3) (fst $ unLoc $2) []) }-        | vocurly    alts(PATS)  close { $2 >>= \ $2 -> amsrl-                                           (L (getLoc $2) (reverse (snd $ unLoc $2)))-                                           (AnnList (Just $ glR $2) Nothing Nothing (fst $ unLoc $2) []) }-        | '{'              '}'   { amsrl (sLL $1 $> []) (AnnList Nothing (Just $ moc $1) (Just $ mcc $2) [] []) }-        | vocurly          close { return $ noLocA [] }--alts(PATS) :: { forall b. DisambECP b => PV (Located ([AddEpAnn],[LMatch GhcPs (LocatedA b)])) }-        : alts1(PATS)              { $1 >>= \ $1 -> return $-                                     sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }-        | ';' alts(PATS)           { $2 >>= \ $2 -> return $-                                     sLL $1 $> (((mz AnnSemi $1) ++ (fst $ unLoc $2) )-                                               ,snd $ unLoc $2) }--alts1(PATS) :: { forall b. DisambECP b => PV (Located ([AddEpAnn],[LMatch GhcPs (LocatedA b)])) }-        : alts1(PATS) ';' alt(PATS) { $1 >>= \ $1 ->-                                        $3 >>= \ $3 ->-                                          case snd $ unLoc $1 of-                                            [] -> return (sLL $1 (reLoc $>) ((fst $ unLoc $1) ++ (mz AnnSemi $2)-                                                                            ,[$3]))-                                            (h:t) -> do-                                              h' <- addTrailingSemiA h (gl $2)-                                              return (sLL $1 (reLoc $>) (fst $ unLoc $1,$3 : h' : t)) }-        | alts1(PATS) ';'           {  $1 >>= \ $1 ->-                                         case snd $ unLoc $1 of-                                           [] -> return (sLL $1 $> ((fst $ unLoc $1) ++ (mz AnnSemi $2)-                                                                           ,[]))-                                           (h:t) -> do-                                             h' <- addTrailingSemiA h (gl $2)-                                             return (sLL $1 $> (fst $ unLoc $1, h' : t)) }-        | alt(PATS)                 { $1 >>= \ $1 -> return $ sL1 (reLoc $1) ([],[$1]) }--alt(PATS) :: { forall b. DisambECP b => PV (LMatch GhcPs (LocatedA b)) }-        : PATS alt_rhs { $2 >>= \ $2 ->-                         acsA (\cs -> sLLAsl $1 $>-                                         (Match { m_ext = EpAnn (listAsAnchor $1) [] cs-                                                , m_ctxt = CaseAlt -- for \case and \cases, this will be changed during post-processing-                                                , m_pats = $1-                                                , m_grhss = unLoc $2 }))}--alt_rhs :: { forall b. DisambECP b => PV (Located (GRHSs GhcPs (LocatedA b))) }-        : ralt wherebinds           { $1 >>= \alt ->-                                      do { let {L l (bs, csw) = adaptWhereBinds $2}-                                         ; acs (\cs -> sLL alt (L l bs) (GRHSs (cs Semi.<> csw) (unLoc alt) bs)) }}--ralt :: { forall b. DisambECP b => PV (Located [LGRHS GhcPs (LocatedA b)]) }-        : '->' exp            { unECP $2 >>= \ $2 ->-                                acs (\cs -> sLLlA $1 $> (unguardedRHS (EpAnn (glR $1) (GrhsAnn Nothing (mu AnnRarrow $1)) cs) (comb2 $1 (reLoc $2)) $2)) }-        | gdpats              { $1 >>= \gdpats ->-                                return $ sL1 gdpats (reverse (unLoc gdpats)) }--gdpats :: { forall b. DisambECP b => PV (Located [LGRHS GhcPs (LocatedA b)]) }-        : gdpats gdpat { $1 >>= \gdpats ->-                         $2 >>= \gdpat ->-                         return $ sLL gdpats (reLoc gdpat) (gdpat : unLoc gdpats) }-        | gdpat        { $1 >>= \gdpat -> return $ sL1A gdpat [gdpat] }---- layout for MultiWayIf doesn't begin with an open brace, because it's hard to--- generate the open brace in addition to the vertical bar in the lexer, and--- we don't need it.-ifgdpats :: { Located ([AddEpAnn],[LGRHS GhcPs (LHsExpr GhcPs)]) }-         : '{' gdpats '}'                 {% runPV $2 >>= \ $2 ->-                                             return $ sLL $1 $> ([moc $1,mcc $3],unLoc $2)  }-         |     gdpats close               {% runPV $1 >>= \ $1 ->-                                             return $ sL1 $1 ([],unLoc $1) }--gdpat   :: { forall b. DisambECP b => PV (LGRHS GhcPs (LocatedA b)) }-        : '|' guardquals '->' exp-                                   { unECP $4 >>= \ $4 ->-                                     acsA (\cs -> sL (comb2A $1 $>) $ GRHS (EpAnn (glR $1) (GrhsAnn (Just $ glAA $1) (mu AnnRarrow $3)) cs) (unLoc $2) $4) }---- 'pat' recognises a pattern, including one with a bang at the top---      e.g.  "!x" or "!(x,y)" or "C a b" etc--- Bangs inside are parsed as infix operator applications, so that--- we parse them right when bang-patterns are off-pat     :: { LPat GhcPs }-pat     :  exp          {% (checkPattern <=< runPV) (unECP $1) }---- 'pats1' does the same thing as 'pat', but returns it as a singleton--- list so that it can be used with a parameterized production rule-pats1   :: { [LPat GhcPs] }-pats1   : pat { [ $1 ] }--bindpat :: { LPat GhcPs }-bindpat :  exp            {% -- See Note [Parser-Validator Details] in GHC.Parser.PostProcess-                             checkPattern_details incompleteDoBlock-                                              (unECP $1) }--apat   :: { LPat GhcPs }-apat    : aexp                  {% (checkPattern <=< runPV) (unECP $1) }--apats  :: { [LPat GhcPs] }-        : apat apats            { $1 : $2 }-        | {- empty -}           { [] }---------------------------------------------------------------------------------- Statement sequences--stmtlist :: { forall b. DisambECP b => PV (LocatedL [LocatedA (Stmt GhcPs (LocatedA b))]) }-        : '{'           stmts '}'       { $2 >>= \ $2 ->-                                          amsrl (sLL $1 $> (reverse $ snd $ unLoc $2)) (AnnList (Just $ stmtsAnchor $2) (Just $ moc $1) (Just $ mcc $3) (fromOL $ fst $ unLoc $2) []) }-        |     vocurly   stmts close     { $2 >>= \ $2 -> amsrl-                                          (L (stmtsLoc $2) (reverse $ snd $ unLoc $2)) (AnnList (Just $ stmtsAnchor $2) Nothing Nothing (fromOL $ fst $ unLoc $2) []) }----      do { ;; s ; s ; ; s ;; }--- The last Stmt should be an expression, but that's hard to enforce--- here, because we need too much lookahead if we see do { e ; }--- So we use BodyStmts throughout, and switch the last one over--- in ParseUtils.checkDo instead--stmts :: { forall b. DisambECP b => PV (Located (OrdList AddEpAnn,[LStmt GhcPs (LocatedA b)])) }-        : stmts ';' stmt  { $1 >>= \ $1 ->-                            $3 >>= \ ($3 :: LStmt GhcPs (LocatedA b)) ->-                            case (snd $ unLoc $1) of-                              [] -> return (sLL $1 (reLoc $>) ((fst $ unLoc $1) `snocOL` (mj AnnSemi $2)-                                                     ,$3   : (snd $ unLoc $1)))-                              (h:t) -> do-                               { h' <- addTrailingSemiA h (gl $2)-                               ; return $ sLL $1 (reLoc $>) (fst $ unLoc $1,$3 :(h':t)) }}--        | stmts ';'     {  $1 >>= \ $1 ->-                           case (snd $ unLoc $1) of-                             [] -> return (sLL $1 $> ((fst $ unLoc $1) `snocOL` (mj AnnSemi $2),snd $ unLoc $1))-                             (h:t) -> do-                               { h' <- addTrailingSemiA h (gl $2)-                               ; return $ sL1 $1 (fst $ unLoc $1,h':t) }}-        | stmt                   { $1 >>= \ $1 ->-                                   return $ sL1A $1 (nilOL,[$1]) }-        | {- empty -}            { return $ noLoc (nilOL,[]) }----- For typing stmts at the GHCi prompt, where--- the input may consist of just comments.-maybe_stmt :: { Maybe (LStmt GhcPs (LHsExpr GhcPs)) }-        : stmt                          {% fmap Just (runPV $1) }-        | {- nothing -}                 { Nothing }---- For GHC API.-e_stmt :: { LStmt GhcPs (LHsExpr GhcPs) }-        : stmt                          {% runPV $1 }--stmt  :: { forall b. DisambECP b => PV (LStmt GhcPs (LocatedA b)) }-        : qual                          { $1 }-        | 'rec' stmtlist                {  $2 >>= \ $2 ->-                                           acsA (\cs -> (sLL $1 (reLoc $>) $ mkRecStmt-                                                 (EpAnn (glR $1) (hsDoAnn $1 $2 AnnRec) cs)-                                                  $2)) }--qual  :: { forall b. DisambECP b => PV (LStmt GhcPs (LocatedA b)) }-    : bindpat '<-' exp                   { unECP $3 >>= \ $3 ->-                                           acsA (\cs -> sLLlA (reLoc $1) $>-                                            $ mkPsBindStmt (EpAnn (glAR $1) [mu AnnLarrow $2] cs) $1 $3) }-    | exp                                { unECP $1 >>= \ $1 ->-                                           return $ sL1 $1 $ mkBodyStmt $1 }-    | 'let' binds                        { acsA (\cs -> (sLL $1 $>-                                                $ mkLetStmt (EpAnn (glR $1) [mj AnnLet $1] cs) (unLoc $2))) }---------------------------------------------------------------------------------- Record Field Update/Construction--fbinds  :: { forall b. DisambECP b => PV ([Fbind b], Maybe SrcSpan) }-        : fbinds1                       { $1 }-        | {- empty -}                   { return ([], Nothing) }--fbinds1 :: { forall b. DisambECP b => PV ([Fbind b], Maybe SrcSpan) }-        : fbind ',' fbinds1-                 { $1 >>= \ $1 ->-                   $3 >>= \ $3 -> do-                   h <- addTrailingCommaFBind $1 (gl $2)-                   return (case $3 of (flds, dd) -> (h : flds, dd)) }-        | fbind                         { $1 >>= \ $1 ->-                                          return ([$1], Nothing) }-        | '..'                          { return ([],   Just (getLoc $1)) }--fbind   :: { forall b. DisambECP b => PV (Fbind b) }-        : qvar '=' texp  { unECP $3 >>= \ $3 ->-                           fmap Left $ acsA (\cs -> sLL (reLocN $1) (reLoc $>) $ HsFieldBind (EpAnn (glNR $1) [mj AnnEqual $2] cs) (sL1l $1 $ mkFieldOcc $1) $3 False) }-                        -- RHS is a 'texp', allowing view patterns (#6038)-                        -- and, incidentally, sections.  Eg-                        -- f (R { x = show -> s }) = ...--        | qvar          { placeHolderPunRhs >>= \rhs ->-                          fmap Left $ acsa (\cs -> sL1a (reLocN $1) $ HsFieldBind (EpAnn (glNR $1) [] cs) (sL1l $1 $ mkFieldOcc $1) rhs True) }-                        -- In the punning case, use a place-holder-                        -- The renamer fills in the final value--        -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer-        -- AZ: need to pull out the let block into a helper-        | field TIGHT_INFIX_PROJ fieldToUpdate '=' texp-                        { do-                            let top = sL1 (la2la $1) $ DotFieldOcc noAnn $1-                                ((L lf (DotFieldOcc _ f)):t) = reverse (unLoc $3)-                                lf' = comb2 $2 (reLoc $ L lf ())-                                fields = top : L (noAnnSrcSpan lf') (DotFieldOcc (EpAnn (spanAsAnchor lf') (AnnFieldLabel (Just $ glAA $2)) emptyComments) f) : t-                                final = last fields-                                l = comb2 (reLoc $1) $3-                                isPun = False-                            $5 <- unECP $5-                            fmap Right $ mkHsProjUpdatePV (comb2 (reLoc $1) (reLoc $5)) (L l fields) $5 isPun-                                            [mj AnnEqual $4]-                        }--        -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer-        -- AZ: need to pull out the let block into a helper-        | field TIGHT_INFIX_PROJ fieldToUpdate-                        { do-                            let top =  sL1 (la2la $1) $ DotFieldOcc noAnn $1-                                ((L lf (DotFieldOcc _ f)):t) = reverse (unLoc $3)-                                lf' = comb2 $2 (reLoc $ L lf ())-                                fields = top : L (noAnnSrcSpan lf') (DotFieldOcc (EpAnn (spanAsAnchor lf') (AnnFieldLabel (Just $ glAA $2)) emptyComments) f) : t-                                final = last fields-                                l = comb2 (reLoc $1) $3-                                isPun = True-                            var <- mkHsVarPV (L (noAnnSrcSpan $ getLocA final) (mkRdrUnqual . mkVarOccFS . field_label . unLoc . dfoLabel . unLoc $ final))-                            fmap Right $ mkHsProjUpdatePV l (L l fields) var isPun []-                        }--fieldToUpdate :: { Located [LocatedAn NoEpAnns (DotFieldOcc GhcPs)] }-fieldToUpdate-        -- See Note [Whitespace-sensitive operator parsing] in Lexer.x-        : fieldToUpdate TIGHT_INFIX_PROJ field   {% getCommentsFor (getLocA $3) >>= \cs ->-                                                     return (sLL $1 (reLoc $>) ((sLLa $2 (reLoc $>) (DotFieldOcc (EpAnn (glR $2) (AnnFieldLabel $ Just $ glAA $2) cs) $3)) : unLoc $1)) }-        | field       {% getCommentsFor (getLocA $1) >>= \cs ->-                        return (sL1 (reLoc $1) [sL1a (reLoc $1) (DotFieldOcc (EpAnn (glNR $1) (AnnFieldLabel Nothing) cs) $1)]) }---------------------------------------------------------------------------------- Implicit Parameter Bindings--dbinds  :: { Located [LIPBind GhcPs] } -- reversed-        : dbinds ';' dbind-                      {% case unLoc $1 of-                           (h:t) -> do-                             h' <- addTrailingSemiA h (gl $2)-                             return (let { this = $3; rest = h':t }-                                in rest `seq` this `seq` sLL $1 (reLoc $>) (this : rest)) }-        | dbinds ';'  {% case unLoc $1 of-                           (h:t) -> do-                             h' <- addTrailingSemiA h (gl $2)-                             return (sLL $1 $> (h':t)) }-        | dbind                        { let this = $1 in this `seq` (sL1 (reLoc $1) [this]) }---      | {- empty -}                  { [] }--dbind   :: { LIPBind GhcPs }-dbind   : ipvar '=' exp                {% runPV (unECP $3) >>= \ $3 ->-                                          acsA (\cs -> sLLlA $1 $> (IPBind (EpAnn (glR $1) [mj AnnEqual $2] cs) (reLocA $1) $3)) }--ipvar   :: { Located HsIPName }-        : IPDUPVARID            { sL1 $1 (HsIPName (getIPDUPVARID $1)) }---------------------------------------------------------------------------------- Overloaded labels--overloaded_label :: { Located (SourceText, FastString) }-        : LABELVARID          { sL1 $1 (getLABELVARIDs $1, getLABELVARID $1) }---------------------------------------------------------------------------------- Warnings and deprecations--name_boolformula_opt :: { LBooleanFormula (LocatedN RdrName) }-        : name_boolformula          { $1 }-        | {- empty -}               { noLocA mkTrue }--name_boolformula :: { LBooleanFormula (LocatedN RdrName) }-        : name_boolformula_and                      { $1 }-        | name_boolformula_and '|' name_boolformula-                           {% do { h <- addTrailingVbarL $1 (gl $2)-                                 ; return (reLocA $ sLLAA $1 $> (Or [h,$3])) } }--name_boolformula_and :: { LBooleanFormula (LocatedN RdrName) }-        : name_boolformula_and_list-                  { reLocA $ sLLAA (head $1) (last $1) (And ($1)) }--name_boolformula_and_list :: { [LBooleanFormula (LocatedN RdrName)] }-        : name_boolformula_atom                               { [$1] }-        | name_boolformula_atom ',' name_boolformula_and_list-            {% do { h <- addTrailingCommaL $1 (gl $2)-                  ; return (h : $3) } }--name_boolformula_atom :: { LBooleanFormula (LocatedN RdrName) }-        : '(' name_boolformula ')'  {% amsrl (sLL $1 $> (Parens $2))-                                      (AnnList Nothing (Just (mop $1)) (Just (mcp $3)) [] []) }-        | name_var                  { reLocA $ sL1N $1 (Var $1) }--namelist :: { Located [LocatedN RdrName] }-namelist : name_var              { sL1N $1 [$1] }-         | name_var ',' namelist {% do { h <- addTrailingCommaN $1 (gl $2)-                                       ; return (sLL (reLocN $1) $> (h : unLoc $3)) }}--name_var :: { LocatedN RdrName }-name_var : var { $1 }-         | con { $1 }---------------------------------------------- Data constructors--- There are two different productions here as lifted list constructors--- are parsed differently.--qcon_nowiredlist :: { LocatedN RdrName }-        : gen_qcon                     { $1 }-        | sysdcon_nolist               { L (getLoc $1) $ nameRdrName (dataConName (unLoc $1)) }--qcon :: { LocatedN RdrName }-  : gen_qcon              { $1}-  | sysdcon               { L (getLoc $1) $ nameRdrName (dataConName (unLoc $1)) }--gen_qcon :: { LocatedN RdrName }-  : qconid                { $1 }-  | '(' qconsym ')'       {% amsrn (sLL $1 $> (unLoc $2))-                                   (NameAnn NameParens (glAA $1) (glNRR $2) (glAA $3) []) }--con     :: { LocatedN RdrName }-        : conid                 { $1 }-        | '(' consym ')'        {% amsrn (sLL $1 $> (unLoc $2))-                                         (NameAnn NameParens (glAA $1) (glNRR $2) (glAA $3) []) }-        | sysdcon               { L (getLoc $1) $ nameRdrName (dataConName (unLoc $1)) }--con_list :: { Located (NonEmpty (LocatedN RdrName)) }-con_list : con                  { sL1N $1 (pure $1) }-         | con ',' con_list     {% sLL (reLocN $1) $> . (:| toList (unLoc $3)) <\$> addTrailingCommaN $1 (gl $2) }--qcon_list :: { Located [LocatedN RdrName] }-qcon_list : qcon                  { sL1N $1 [$1] }-          | qcon ',' qcon_list    {% do { h <- addTrailingCommaN $1 (gl $2)-                                        ; return (sLL (reLocN $1) $> (h : unLoc $3)) }}---- See Note [ExplicitTuple] in GHC.Hs.Expr-sysdcon_nolist :: { LocatedN DataCon }  -- Wired in data constructors-        : '(' ')'               {% amsrn (sLL $1 $> unitDataCon) (NameAnnOnly NameParens (glAA $1) (glAA $2) []) }-        | '(' commas ')'        {% amsrn (sLL $1 $> $ tupleDataCon Boxed (snd $2 + 1))-                                       (NameAnnCommas NameParens (glAA $1) (map srcSpan2e (fst $2)) (glAA $3) []) }-        | '(#' '#)'             {% amsrn (sLL $1 $> $ unboxedUnitDataCon) (NameAnnOnly NameParensHash (glAA $1) (glAA $2) []) }-        | '(#' commas '#)'      {% amsrn (sLL $1 $> $ tupleDataCon Unboxed (snd $2 + 1))-                                       (NameAnnCommas NameParensHash (glAA $1) (map srcSpan2e (fst $2)) (glAA $3) []) }---- See Note [Empty lists] in GHC.Hs.Expr-sysdcon :: { LocatedN DataCon }-        : sysdcon_nolist                 { $1 }-        | '[' ']'               {% amsrn (sLL $1 $> nilDataCon) (NameAnnOnly NameSquare (glAA $1) (glAA $2) []) }--conop :: { LocatedN RdrName }-        : consym                { $1 }-        | '`' conid '`'         {% amsrn (sLL $1 $> (unLoc $2))-                                           (NameAnn NameBackquotes (glAA $1) (glNRR $2) (glAA $3) []) }--qconop :: { LocatedN RdrName }-        : qconsym               { $1 }-        | '`' qconid '`'        {% amsrn (sLL $1 $> (unLoc $2))-                                           (NameAnn NameBackquotes (glAA $1) (glNRR $2) (glAA $3) []) }--------------------------------------------------------------------------------- Type constructors----- See Note [Unit tuples] in GHC.Hs.Type for the distinction--- between gtycon and ntgtycon-gtycon :: { LocatedN RdrName }  -- A "general" qualified tycon, including unit tuples-        : ntgtycon                     { $1 }-        | '(' ')'                      {% amsrn (sLL $1 $> $ getRdrName unitTyCon)-                                                 (NameAnnOnly NameParens (glAA $1) (glAA $2) []) }-        | '(#' '#)'                    {% amsrn (sLL $1 $> $ getRdrName unboxedUnitTyCon)-                                                 (NameAnnOnly NameParensHash (glAA $1) (glAA $2) []) }--ntgtycon :: { LocatedN RdrName }  -- A "general" qualified tycon, excluding unit tuples-        : oqtycon               { $1 }-        | '(' commas ')'        {% amsrn (sLL $1 $> $ getRdrName (tupleTyCon Boxed-                                                        (snd $2 + 1)))-                                       (NameAnnCommas NameParens (glAA $1) (map srcSpan2e (fst $2)) (glAA $3) []) }-        | '(#' commas '#)'      {% amsrn (sLL $1 $> $ getRdrName (tupleTyCon Unboxed-                                                        (snd $2 + 1)))-                                       (NameAnnCommas NameParensHash (glAA $1) (map srcSpan2e (fst $2)) (glAA $3) []) }-        | '(#' bars '#)'        {% amsrn (sLL $1 $> $ getRdrName (sumTyCon (snd $2 + 1)))-                                       (NameAnnBars NameParensHash (glAA $1) (map srcSpan2e (fst $2)) (glAA $3) []) }-        | '(' '->' ')'          {% amsrn (sLL $1 $> $ getRdrName unrestrictedFunTyCon)-                                       (NameAnnRArrow (isUnicode $2) (Just $ glAA $1) (glAA $2) (Just $ glAA $3) []) }-        | '[' ']'               {% amsrn (sLL $1 $> $ listTyCon_RDR)-                                       (NameAnnOnly NameSquare (glAA $1) (glAA $2) []) }--oqtycon :: { LocatedN RdrName }  -- An "ordinary" qualified tycon;-                                -- These can appear in export lists-        : qtycon                        { $1 }-        | '(' qtyconsym ')'             {% amsrn (sLL $1 $> (unLoc $2))-                                                  (NameAnn NameParens (glAA $1) (glNRR $2) (glAA $3) []) }--oqtycon_no_varcon :: { LocatedN RdrName }  -- Type constructor which cannot be mistaken-                                          -- for variable constructor in export lists-                                          -- see Note [Type constructors in export list]-        :  qtycon            { $1 }-        | '(' QCONSYM ')'    {% let { name :: Located RdrName-                                    ; name = sL1 $2 $! mkQual tcClsName (getQCONSYM $2) }-                                in amsrn (sLL $1 $> (unLoc name)) (NameAnn NameParens (glAA $1) (glAA $2) (glAA $3) []) }-        | '(' CONSYM ')'     {% let { name :: Located RdrName-                                    ; name = sL1 $2 $! mkUnqual tcClsName (getCONSYM $2) }-                                in amsrn (sLL $1 $> (unLoc name)) (NameAnn NameParens (glAA $1) (glAA $2) (glAA $3) []) }-        | '(' ':' ')'        {% let { name :: Located RdrName-                                    ; name = sL1 $2 $! consDataCon_RDR }-                                in amsrn (sLL $1 $> (unLoc name)) (NameAnn NameParens (glAA $1) (glAA $2) (glAA $3) []) }--{- Note [Type constructors in export list]-~~~~~~~~~~~~~~~~~~~~~-Mixing type constructors and data constructors in export lists introduces-ambiguity in grammar: e.g. (*) may be both a type constructor and a function.---XExplicitNamespaces allows to disambiguate by explicitly prefixing type-constructors with 'type' keyword.--This ambiguity causes reduce/reduce conflicts in parser, which are always-resolved in favour of data constructors. To get rid of conflicts we demand-that ambiguous type constructors (those, which are formed by the same-productions as variable constructors) are always prefixed with 'type' keyword.-Unambiguous type constructors may occur both with or without 'type' keyword.--Note that in the parser we still parse data constructors as type-constructors. As such, they still end up in the type constructor namespace-until after renaming when we resolve the proper namespace for each exported-child.--}--qtyconop :: { LocatedN RdrName } -- Qualified or unqualified-        -- See Note [%shift: qtyconop -> qtyconsym]-        : qtyconsym %shift              { $1 }-        | '`' qtycon '`'                {% amsrn (sLL $1 $> (unLoc $2))-                                                 (NameAnn NameBackquotes (glAA $1) (glNRR $2) (glAA $3) []) }--qtycon :: { LocatedN RdrName }   -- Qualified or unqualified-        : QCONID            { sL1n $1 $! mkQual tcClsName (getQCONID $1) }-        | tycon             { $1 }--tycon   :: { LocatedN RdrName }  -- Unqualified-        : CONID                   { sL1n $1 $! mkUnqual tcClsName (getCONID $1) }--qtyconsym :: { LocatedN RdrName }-        : QCONSYM            { sL1n $1 $! mkQual tcClsName (getQCONSYM $1) }-        | QVARSYM            { sL1n $1 $! mkQual tcClsName (getQVARSYM $1) }-        | tyconsym           { $1 }--tyconsym :: { LocatedN RdrName }-        : CONSYM                { sL1n $1 $! mkUnqual tcClsName (getCONSYM $1) }-        | VARSYM                { sL1n $1 $! mkUnqual tcClsName (getVARSYM $1) }-        | ':'                   { sL1n $1 $! consDataCon_RDR }-        | '-'                   { sL1n $1 $! mkUnqual tcClsName (fsLit "-") }-        | '.'                   { sL1n $1 $! mkUnqual tcClsName (fsLit ".") }---- An "ordinary" unqualified tycon. See `oqtycon` for the qualified version.--- These can appear in `ANN type` declarations (#19374).-otycon :: { LocatedN RdrName }-        : tycon                 { $1 }-        | '(' tyconsym ')'      {% amsrn (sLL $1 $> (unLoc $2))-                                         (NameAnn NameParens (glAA $1) (glNRR $2) (glAA $3) []) }---------------------------------------------------------------------------------- Operators--op      :: { LocatedN RdrName }   -- used in infix decls-        : varop                 { $1 }-        | conop                 { $1 }-        | '->'                  {% amsrn (sLL $1 $> $ getRdrName unrestrictedFunTyCon)-                                     (NameAnnRArrow (isUnicode $1) Nothing (glAA $1) Nothing []) }--varop   :: { LocatedN RdrName }-        : varsym                { $1 }-        | '`' varid '`'         {% amsrn (sLL $1 $> (unLoc $2))-                                           (NameAnn NameBackquotes (glAA $1) (glNRR $2) (glAA $3) []) }--qop     :: { forall b. DisambInfixOp b => PV (LocatedN b) }   -- used in sections-        : qvarop                { mkHsVarOpPV $1 }-        | qconop                { mkHsConOpPV $1 }-        | hole_op               { pvN $1 }--qopm    :: { forall b. DisambInfixOp b => PV (LocatedN b) }   -- used in sections-        : qvaropm               { mkHsVarOpPV $1 }-        | qconop                { mkHsConOpPV $1 }-        | hole_op               { pvN $1 }--hole_op :: { forall b. DisambInfixOp b => PV (Located b) }   -- used in sections-hole_op : '`' '_' '`'           { mkHsInfixHolePV (comb2 $1 $>)-                                         (\cs -> EpAnn (glR $1) (EpAnnUnboundVar (glAA $1, glAA $3) (glAA $2)) cs) }--qvarop :: { LocatedN RdrName }-        : qvarsym               { $1 }-        | '`' qvarid '`'        {% amsrn (sLL $1 $> (unLoc $2))-                                           (NameAnn NameBackquotes (glAA $1) (glNRR $2) (glAA $3) []) }--qvaropm :: { LocatedN RdrName }-        : qvarsym_no_minus      { $1 }-        | '`' qvarid '`'        {% amsrn (sLL $1 $> (unLoc $2))-                                           (NameAnn NameBackquotes (glAA $1) (glNRR $2) (glAA $3) []) }---------------------------------------------------------------------------------- Type variables--tyvar   :: { LocatedN RdrName }-tyvar   : tyvarid               { $1 }--tyvarop :: { LocatedN RdrName }-tyvarop : '`' tyvarid '`'       {% amsrn (sLL $1 $> (unLoc $2))-                                           (NameAnn NameBackquotes (glAA $1) (glNRR $2) (glAA $3) []) }--tyvarid :: { LocatedN RdrName }-        : VARID            { sL1n $1 $! mkUnqual tvName (getVARID $1) }-        | special_id       { sL1n $1 $! mkUnqual tvName (unLoc $1) }-        | 'unsafe'         { sL1n $1 $! mkUnqual tvName (fsLit "unsafe") }-        | 'safe'           { sL1n $1 $! mkUnqual tvName (fsLit "safe") }-        | 'interruptible'  { sL1n $1 $! mkUnqual tvName (fsLit "interruptible") }-        -- If this changes relative to varid, update 'checkRuleTyVarBndrNames'-        -- in GHC.Parser.PostProcess-        -- See Note [Parsing explicit foralls in Rules]---------------------------------------------------------------------------------- Variables--var     :: { LocatedN RdrName }-        : varid                 { $1 }-        | '(' varsym ')'        {% amsrn (sLL $1 $> (unLoc $2))-                                   (NameAnn NameParens (glAA $1) (glNRR $2) (glAA $3) []) }--qvar    :: { LocatedN RdrName }-        : qvarid                { $1 }-        | '(' varsym ')'        {% amsrn (sLL $1 $> (unLoc $2))-                                   (NameAnn NameParens (glAA $1) (glNRR $2) (glAA $3) []) }-        | '(' qvarsym1 ')'      {% amsrn (sLL $1 $> (unLoc $2))-                                   (NameAnn NameParens (glAA $1) (glNRR $2) (glAA $3) []) }--- We've inlined qvarsym here so that the decision about--- whether it's a qvar or a var can be postponed until--- *after* we see the close paren.--field :: { LocatedN FieldLabelString  }-      : varid { fmap (FieldLabelString . occNameFS . rdrNameOcc) $1 }--qvarid :: { LocatedN RdrName }-        : varid               { $1 }-        | QVARID              { sL1n $1 $! mkQual varName (getQVARID $1) }---- Note that 'role' and 'family' get lexed separately regardless of--- the use of extensions. However, because they are listed here,--- this is OK and they can be used as normal varids.--- See Note [Lexing type pseudo-keywords] in GHC.Parser.Lexer-varid :: { LocatedN RdrName }-        : VARID            { sL1n $1 $! mkUnqual varName (getVARID $1) }-        | special_id       { sL1n $1 $! mkUnqual varName (unLoc $1) }-        | 'unsafe'         { sL1n $1 $! mkUnqual varName (fsLit "unsafe") }-        | 'safe'           { sL1n $1 $! mkUnqual varName (fsLit "safe") }-        | 'interruptible'  { sL1n $1 $! mkUnqual varName (fsLit "interruptible")}-        | 'forall'         { sL1n $1 $! mkUnqual varName (fsLit "forall") }-        | 'family'         { sL1n $1 $! mkUnqual varName (fsLit "family") }-        | 'role'           { sL1n $1 $! mkUnqual varName (fsLit "role") }-        -- If this changes relative to tyvarid, update 'checkRuleTyVarBndrNames'-        -- in GHC.Parser.PostProcess-        -- See Note [Parsing explicit foralls in Rules]--qvarsym :: { LocatedN RdrName }-        : varsym                { $1 }-        | qvarsym1              { $1 }--qvarsym_no_minus :: { LocatedN RdrName }-        : varsym_no_minus       { $1 }-        | qvarsym1              { $1 }--qvarsym1 :: { LocatedN RdrName }-qvarsym1 : QVARSYM              { sL1n $1 $ mkQual varName (getQVARSYM $1) }--varsym :: { LocatedN RdrName }-        : varsym_no_minus       { $1 }-        | '-'                   { sL1n $1 $ mkUnqual varName (fsLit "-") }--varsym_no_minus :: { LocatedN RdrName } -- varsym not including '-'-        : VARSYM               { sL1n $1 $ mkUnqual varName (getVARSYM $1) }-        | special_sym          { sL1n $1 $ mkUnqual varName (unLoc $1) }----- These special_ids are treated as keywords in various places,--- but as ordinary ids elsewhere.   'special_id' collects all these--- except 'unsafe', 'interruptible', 'forall', 'family', 'role', 'stock', and--- 'anyclass', whose treatment differs depending on context-special_id :: { Located FastString }-special_id-        : 'as'                  { sL1 $1 (fsLit "as") }-        | 'qualified'           { sL1 $1 (fsLit "qualified") }-        | 'hiding'              { sL1 $1 (fsLit "hiding") }-        | 'export'              { sL1 $1 (fsLit "export") }-        | 'label'               { sL1 $1 (fsLit "label")  }-        | 'dynamic'             { sL1 $1 (fsLit "dynamic") }-        | 'stdcall'             { sL1 $1 (fsLit "stdcall") }-        | 'ccall'               { sL1 $1 (fsLit "ccall") }-        | 'capi'                { sL1 $1 (fsLit "capi") }-        | 'prim'                { sL1 $1 (fsLit "prim") }-        | 'javascript'          { sL1 $1 (fsLit "javascript") }-        -- See Note [%shift: special_id -> 'group']-        | 'group' %shift        { sL1 $1 (fsLit "group") }-        | 'stock'               { sL1 $1 (fsLit "stock") }-        | 'anyclass'            { sL1 $1 (fsLit "anyclass") }-        | 'via'                 { sL1 $1 (fsLit "via") }-        | 'unit'                { sL1 $1 (fsLit "unit") }-        | 'dependency'          { sL1 $1 (fsLit "dependency") }-        | 'signature'           { sL1 $1 (fsLit "signature") }--special_sym :: { Located FastString }-special_sym : '.'       { sL1 $1 (fsLit ".") }-            | '*'       { sL1 $1 (starSym (isUnicode $1)) }---------------------------------------------------------------------------------- Data constructors--qconid :: { LocatedN RdrName }   -- Qualified or unqualified-        : conid              { $1 }-        | QCONID             { sL1n $1 $! mkQual dataName (getQCONID $1) }--conid   :: { LocatedN RdrName }-        : CONID                { sL1n $1 $ mkUnqual dataName (getCONID $1) }--qconsym :: { LocatedN RdrName }  -- Qualified or unqualified-        : consym               { $1 }-        | QCONSYM              { sL1n $1 $ mkQual dataName (getQCONSYM $1) }--consym :: { LocatedN RdrName }-        : CONSYM              { sL1n $1 $ mkUnqual dataName (getCONSYM $1) }--        -- ':' means only list cons-        | ':'                { sL1n $1 $ consDataCon_RDR }----------------------------------------------------------------------------------- Literals--literal :: { Located (HsLit GhcPs) }-        : CHAR              { sL1 $1 $ HsChar       (getCHARs $1) $ getCHAR $1 }-        | STRING            { sL1 $1 $ HsString     (getSTRINGs $1)-                                                    $ getSTRING $1 }-        | PRIMINTEGER       { sL1 $1 $ HsIntPrim    (getPRIMINTEGERs $1)-                                                    $ getPRIMINTEGER $1 }-        | PRIMWORD          { sL1 $1 $ HsWordPrim   (getPRIMWORDs $1)-                                                    $ getPRIMWORD $1 }-        | PRIMINTEGER8      { sL1 $1 $ HsInt8Prim   (getPRIMINTEGER8s $1)-                                                    $ getPRIMINTEGER8 $1 }-        | PRIMINTEGER16     { sL1 $1 $ HsInt16Prim  (getPRIMINTEGER16s $1)-                                                    $ getPRIMINTEGER16 $1 }-        | PRIMINTEGER32     { sL1 $1 $ HsInt32Prim  (getPRIMINTEGER32s $1)-                                                    $ getPRIMINTEGER32 $1 }-        | PRIMINTEGER64     { sL1 $1 $ HsInt64Prim  (getPRIMINTEGER64s $1)-                                                    $ getPRIMINTEGER64 $1 }-        | PRIMWORD8         { sL1 $1 $ HsWord8Prim  (getPRIMWORD8s $1)-                                                    $ getPRIMWORD8 $1 }-        | PRIMWORD16        { sL1 $1 $ HsWord16Prim (getPRIMWORD16s $1)-                                                    $ getPRIMWORD16 $1 }-        | PRIMWORD32        { sL1 $1 $ HsWord32Prim (getPRIMWORD32s $1)-                                                    $ getPRIMWORD32 $1 }-        | PRIMWORD64        { sL1 $1 $ HsWord64Prim (getPRIMWORD64s $1)-                                                    $ getPRIMWORD64 $1 }-        | PRIMCHAR          { sL1 $1 $ HsCharPrim   (getPRIMCHARs $1)-                                                    $ getPRIMCHAR $1 }-        | PRIMSTRING        { sL1 $1 $ HsStringPrim (getPRIMSTRINGs $1)-                                                    $ getPRIMSTRING $1 }-        | PRIMFLOAT         { sL1 $1 $ HsFloatPrim  noExtField $ getPRIMFLOAT $1 }-        | PRIMDOUBLE        { sL1 $1 $ HsDoublePrim noExtField $ getPRIMDOUBLE $1 }---------------------------------------------------------------------------------- Layout--close :: { () }-        : vccurly               { () } -- context popped in lexer.-        | error                 {% popContext }---------------------------------------------------------------------------------- Miscellaneous (mostly renamings)--modid   :: { LocatedA ModuleName }-        : CONID                 { sL1a $1 $ mkModuleNameFS (getCONID $1) }-        | QCONID                { sL1a $1 $ let (mod,c) = getQCONID $1 in-                                  mkModuleNameFS-                                   (concatFS [mod, fsLit ".", c])-                                }--commas :: { ([SrcSpan],Int) }   -- One or more commas-        : commas ','             { ((fst $1)++[gl $2],snd $1 + 1) }-        | ','                    { ([gl $1],1) }--bars0 :: { ([SrcSpan],Int) }     -- Zero or more bars-        : bars                   { $1 }-        |                        { ([], 0) }--bars :: { ([SrcSpan],Int) }     -- One or more bars-        : bars '|'               { ((fst $1)++[gl $2],snd $1 + 1) }-        | '|'                    { ([gl $1],1) }--{-happyError :: P a-happyError = srcParseFail--getVARID          (L _ (ITvarid    x)) = x-getCONID          (L _ (ITconid    x)) = x-getVARSYM         (L _ (ITvarsym   x)) = x-getCONSYM         (L _ (ITconsym   x)) = x-getDO             (L _ (ITdo      x)) = x-getMDO            (L _ (ITmdo     x)) = x-getQVARID         (L _ (ITqvarid   x)) = x-getQCONID         (L _ (ITqconid   x)) = x-getQVARSYM        (L _ (ITqvarsym  x)) = x-getQCONSYM        (L _ (ITqconsym  x)) = x-getIPDUPVARID     (L _ (ITdupipvarid   x)) = x-getLABELVARID     (L _ (ITlabelvarid _ x)) = x-getCHAR           (L _ (ITchar   _ x)) = x-getSTRING         (L _ (ITstring _ x)) = x-getINTEGER        (L _ (ITinteger x))  = x-getRATIONAL       (L _ (ITrational x)) = x-getPRIMCHAR       (L _ (ITprimchar _ x)) = x-getPRIMSTRING     (L _ (ITprimstring _ x)) = x-getPRIMINTEGER    (L _ (ITprimint  _ x)) = x-getPRIMWORD       (L _ (ITprimword _ x)) = x-getPRIMINTEGER8   (L _ (ITprimint8 _ x)) = x-getPRIMINTEGER16  (L _ (ITprimint16 _ x)) = x-getPRIMINTEGER32  (L _ (ITprimint32 _ x)) = x-getPRIMINTEGER64  (L _ (ITprimint64 _ x)) = x-getPRIMWORD8      (L _ (ITprimword8 _ x)) = x-getPRIMWORD16     (L _ (ITprimword16 _ x)) = x-getPRIMWORD32     (L _ (ITprimword32 _ x)) = x-getPRIMWORD64     (L _ (ITprimword64 _ x)) = x-getPRIMFLOAT      (L _ (ITprimfloat x)) = x-getPRIMDOUBLE     (L _ (ITprimdouble x)) = x-getINLINE         (L _ (ITinline_prag _ inl conl)) = (inl,conl)-getSPEC_INLINE    (L _ (ITspec_inline_prag src True))  = (Inline src,FunLike)-getSPEC_INLINE    (L _ (ITspec_inline_prag src False)) = (NoInline src,FunLike)-getCOMPLETE_PRAGs (L _ (ITcomplete_prag x)) = x-getVOCURLY        (L (RealSrcSpan l _) ITvocurly) = srcSpanStartCol l--getINTEGERs       (L _ (ITinteger (IL src _ _))) = src-getCHARs          (L _ (ITchar       src _)) = src-getSTRINGs        (L _ (ITstring     src _)) = src-getPRIMCHARs      (L _ (ITprimchar   src _)) = src-getPRIMSTRINGs    (L _ (ITprimstring src _)) = src-getPRIMINTEGERs   (L _ (ITprimint    src _)) = src-getPRIMWORDs      (L _ (ITprimword   src _)) = src-getPRIMINTEGER8s  (L _ (ITprimint8   src _)) = src-getPRIMINTEGER16s (L _ (ITprimint16  src _)) = src-getPRIMINTEGER32s (L _ (ITprimint32  src _)) = src-getPRIMINTEGER64s (L _ (ITprimint64  src _)) = src-getPRIMWORD8s     (L _ (ITprimword8  src _)) = src-getPRIMWORD16s    (L _ (ITprimword16 src _)) = src-getPRIMWORD32s    (L _ (ITprimword32 src _)) = src-getPRIMWORD64s    (L _ (ITprimword64 src _)) = src--getLABELVARIDs    (L _ (ITlabelvarid src _)) = src---- See Note [Pragma source text] in "GHC.Types.SourceText" for the following-getINLINE_PRAGs       (L _ (ITinline_prag       _ inl _)) = inlineSpecSource inl-getOPAQUE_PRAGs       (L _ (ITopaque_prag       src))     = src-getSPEC_PRAGs         (L _ (ITspec_prag         src))     = src-getSPEC_INLINE_PRAGs  (L _ (ITspec_inline_prag  src _))   = src-getSOURCE_PRAGs       (L _ (ITsource_prag       src)) = src-getRULES_PRAGs        (L _ (ITrules_prag        src)) = src-getWARNING_PRAGs      (L _ (ITwarning_prag      src)) = src-getDEPRECATED_PRAGs   (L _ (ITdeprecated_prag   src)) = src-getSCC_PRAGs          (L _ (ITscc_prag          src)) = src-getUNPACK_PRAGs       (L _ (ITunpack_prag       src)) = src-getNOUNPACK_PRAGs     (L _ (ITnounpack_prag     src)) = src-getANN_PRAGs          (L _ (ITann_prag          src)) = src-getMINIMAL_PRAGs      (L _ (ITminimal_prag      src)) = src-getOVERLAPPABLE_PRAGs (L _ (IToverlappable_prag src)) = src-getOVERLAPPING_PRAGs  (L _ (IToverlapping_prag  src)) = src-getOVERLAPS_PRAGs     (L _ (IToverlaps_prag     src)) = src-getINCOHERENT_PRAGs   (L _ (ITincoherent_prag   src)) = src-getCTYPEs             (L _ (ITctype             src)) = src--getStringLiteral l = StringLiteral (getSTRINGs l) (getSTRING l) Nothing--isUnicode :: Located Token -> Bool-isUnicode (L _ (ITforall         iu)) = iu == UnicodeSyntax-isUnicode (L _ (ITdarrow         iu)) = iu == UnicodeSyntax-isUnicode (L _ (ITdcolon         iu)) = iu == UnicodeSyntax-isUnicode (L _ (ITlarrow         iu)) = iu == UnicodeSyntax-isUnicode (L _ (ITrarrow         iu)) = iu == UnicodeSyntax-isUnicode (L _ (ITlarrowtail     iu)) = iu == UnicodeSyntax-isUnicode (L _ (ITrarrowtail     iu)) = iu == UnicodeSyntax-isUnicode (L _ (ITLarrowtail     iu)) = iu == UnicodeSyntax-isUnicode (L _ (ITRarrowtail     iu)) = iu == UnicodeSyntax-isUnicode (L _ (IToparenbar      iu)) = iu == UnicodeSyntax-isUnicode (L _ (ITcparenbar      iu)) = iu == UnicodeSyntax-isUnicode (L _ (ITopenExpQuote _ iu)) = iu == UnicodeSyntax-isUnicode (L _ (ITcloseQuote     iu)) = iu == UnicodeSyntax-isUnicode (L _ (ITstar           iu)) = iu == UnicodeSyntax-isUnicode (L _ ITlolly)               = True-isUnicode _                           = False--hasE :: Located Token -> Bool-hasE (L _ (ITopenExpQuote HasE _)) = True-hasE (L _ (ITopenTExpQuote HasE))  = True-hasE _                             = False--getSCC :: Located Token -> P FastString-getSCC lt = do let s = getSTRING lt-               -- We probably actually want to be more restrictive than this-               if ' ' `elem` unpackFS s-                   then addFatalError $ mkPlainErrorMsgEnvelope (getLoc lt) $ PsErrSpaceInSCC-                   else return s--stringLiteralToHsDocWst :: Located StringLiteral -> Located (WithHsDocIdentifiers StringLiteral GhcPs)-stringLiteralToHsDocWst  = lexStringLiteral parseIdentifier---- Utilities for combining source spans-comb2 :: Located a -> Located b -> SrcSpan-comb2 a b = a `seq` b `seq` combineLocs a b---- Utilities for combining source spans-comb2A :: Located a -> LocatedAn t b -> SrcSpan-comb2A a b = a `seq` b `seq` combineLocs a (reLoc b)--comb2N :: Located a -> LocatedN b -> SrcSpan-comb2N a b = a `seq` b `seq` combineLocs a (reLocN b)--comb2Al :: LocatedAn t a -> Located b -> SrcSpan-comb2Al a b = a `seq` b `seq` combineLocs (reLoc a) b--comb3 :: Located a -> Located b -> Located c -> SrcSpan-comb3 a b c = a `seq` b `seq` c `seq`-    combineSrcSpans (getLoc a) (combineSrcSpans (getLoc b) (getLoc c))--comb3A :: Located a -> Located b -> LocatedAn t c -> SrcSpan-comb3A a b c = a `seq` b `seq` c `seq`-    combineSrcSpans (getLoc a) (combineSrcSpans (getLoc b) (getLocA c))--comb3N :: Located a -> Located b -> LocatedN c -> SrcSpan-comb3N a b c = a `seq` b `seq` c `seq`-    combineSrcSpans (getLoc a) (combineSrcSpans (getLoc b) (getLocA c))--comb3M :: Maybe (Located a) -> Located b -> Located c -> SrcSpan-comb3M (Just a) b c = a `seq` b `seq` c `seq`-    combineSrcSpans (getLoc a) (combineSrcSpans (getLoc b) (getLoc c))-comb3M Nothing b c =  b `seq` c `seq`-    (combineSrcSpans (getLoc b) (getLoc c))--comb4 :: Located a -> Located b -> Located c -> Located d -> SrcSpan-comb4 a b c d = a `seq` b `seq` c `seq` d `seq`-    (combineSrcSpans (getLoc a) $ combineSrcSpans (getLoc b) $-                combineSrcSpans (getLoc c) (getLoc d))--comb5 :: Located a -> Located b -> Located c -> Located d -> Located e -> SrcSpan-comb5 a b c d e = a `seq` b `seq` c `seq` d `seq` e `seq`-    (combineSrcSpans (getLoc a) $ combineSrcSpans (getLoc b) $-       combineSrcSpans (getLoc c) $ combineSrcSpans (getLoc d) (getLoc e))---- strict constructor version:-{-# INLINE sL #-}-sL :: l -> a -> GenLocated l a-sL loc a = loc `seq` a `seq` L loc a---- See Note [Adding location info] for how these utility functions are used---- replaced last 3 CPP macros in this file-{-# INLINE sL0 #-}-sL0 :: a -> Located a-sL0 = L noSrcSpan       -- #define L0   L noSrcSpan--{-# INLINE sL1 #-}-sL1 :: GenLocated l a -> b -> GenLocated l b-sL1 x = sL (getLoc x)   -- #define sL1   sL (getLoc $1)--{-# INLINE sL1A #-}-sL1A :: LocatedAn t a -> b -> Located b-sL1A x = sL (getLocA x)   -- #define sL1   sL (getLoc $1)--{-# INLINE sL1N #-}-sL1N :: LocatedN a -> b -> Located b-sL1N x = sL (getLocA x)   -- #define sL1   sL (getLoc $1)--{-# INLINE sL1a #-}-sL1a :: Located a -> b -> LocatedAn t b-sL1a x = sL (noAnnSrcSpan $ getLoc x)   -- #define sL1   sL (getLoc $1)--{-# INLINE sL1l #-}-sL1l :: LocatedAn t a -> b -> LocatedAn u b-sL1l x = sL (l2l $ getLoc x)   -- #define sL1   sL (getLoc $1)--{-# INLINE sL1n #-}-sL1n :: Located a -> b -> LocatedN b-sL1n x = L (noAnnSrcSpan $ getLoc x)   -- #define sL1   sL (getLoc $1)--{-# INLINE sLL #-}-sLL :: Located a -> Located b -> c -> Located c-sLL x y = sL (comb2 x y) -- #define LL   sL (comb2 $1 $>)--{-# INLINE sLLa #-}-sLLa :: Located a -> Located b -> c -> LocatedAn t c-sLLa x y = sL (noAnnSrcSpan $ comb2 x y) -- #define LL   sL (comb2 $1 $>)--{-# INLINE sLLlA #-}-sLLlA :: Located a -> LocatedAn t b -> c -> Located c-sLLlA x y = sL (comb2A x y) -- #define LL   sL (comb2 $1 $>)--{-# INLINE sLLAl #-}-sLLAl :: LocatedAn t a -> Located b -> c -> Located c-sLLAl x y = sL (comb2A y x) -- #define LL   sL (comb2 $1 $>)--{-# INLINE sLLAsl #-}-sLLAsl :: [LocatedAn t a] -> Located b -> c -> Located c-sLLAsl [] = sL1-sLLAsl (x:_) = sLLAl x--{-# INLINE sLLAA #-}-sLLAA :: LocatedAn t a -> LocatedAn u b -> c -> Located c-sLLAA x y = sL (comb2 (reLoc y) (reLoc x)) -- #define LL   sL (comb2 $1 $>)---{- Note [Adding location info]-   ~~~~~~~~~~~~~~~~~~~~~~~~~~~--This is done using the three functions below, sL0, sL1-and sLL.  Note that these functions were mechanically-converted from the three macros that used to exist before,-namely L0, L1 and LL.--They each add a SrcSpan to their argument.--   sL0  adds 'noSrcSpan', used for empty productions-     -- This doesn't seem to work anymore -=chak--   sL1  for a production with a single token on the lhs.  Grabs the SrcSpan-        from that token.--   sLL  for a production with >1 token on the lhs.  Makes up a SrcSpan from-        the first and last tokens.--These suffice for the majority of cases.  However, we must be-especially careful with empty productions: sLL won't work if the first-or last token on the lhs can represent an empty span.  In these cases,-we have to calculate the span using more of the tokens from the lhs, eg.--        | 'newtype' tycl_hdr '=' newconstr deriving-                { L (comb3 $1 $4 $5)-                    (mkTyData NewType (unLoc $2) $4 (unLoc $5)) }--We provide comb3 and comb4 functions which are useful in such cases.--Be careful: there's no checking that you actually got this right, the-only symptom will be that the SrcSpans of your syntax will be-incorrect.---}---- Make a source location for the file.  We're a bit lazy here and just--- make a point SrcSpan at line 1, column 0.  Strictly speaking we should--- try to find the span of the whole file (ToDo).-fileSrcSpan :: P SrcSpan-fileSrcSpan = do-  l <- getRealSrcLoc;-  let loc = mkSrcLoc (srcLocFile l) 1 1;-  return (mkSrcSpan loc loc)---- Hint about linear types-hintLinear :: MonadP m => SrcSpan -> m ()-hintLinear span = do-  linearEnabled <- getBit LinearTypesBit-  unless linearEnabled $ addError $ mkPlainErrorMsgEnvelope span $ PsErrLinearFunction---- Does this look like (a %m)?-looksLikeMult :: LHsType GhcPs -> LocatedN RdrName -> LHsType GhcPs -> Bool-looksLikeMult ty1 l_op ty2-  | Unqual op_name <- unLoc l_op-  , occNameFS op_name == fsLit "%"-  , Strict.Just ty1_pos <- getBufSpan (getLocA ty1)-  , Strict.Just pct_pos <- getBufSpan (getLocA l_op)-  , Strict.Just ty2_pos <- getBufSpan (getLocA ty2)-  , bufSpanEnd ty1_pos /= bufSpanStart pct_pos-  , bufSpanEnd pct_pos == bufSpanStart ty2_pos-  = True-  | otherwise = False---- Hint about the MultiWayIf extension-hintMultiWayIf :: SrcSpan -> P ()-hintMultiWayIf span = do-  mwiEnabled <- getBit MultiWayIfBit-  unless mwiEnabled $ addError $ mkPlainErrorMsgEnvelope span PsErrMultiWayIf---- Hint about explicit-forall-hintExplicitForall :: Located Token -> P ()-hintExplicitForall tok = do-    forall   <- getBit ExplicitForallBit-    rulePrag <- getBit InRulePragBit-    unless (forall || rulePrag) $ addError $ mkPlainErrorMsgEnvelope (getLoc tok) $-      (PsErrExplicitForall (isUnicode tok))---- Hint about qualified-do-hintQualifiedDo :: Located Token -> P ()-hintQualifiedDo tok = do-    qualifiedDo   <- getBit QualifiedDoBit-    case maybeQDoDoc of-      Just qdoDoc | not qualifiedDo ->-        addError $ mkPlainErrorMsgEnvelope (getLoc tok) $-          (PsErrIllegalQualifiedDo qdoDoc)-      _ -> return ()-  where-    maybeQDoDoc = case unLoc tok of-      ITdo (Just m) -> Just $ ftext m <> text ".do"-      ITmdo (Just m) -> Just $ ftext m <> text ".mdo"-      t -> Nothing---- When two single quotes don't followed by tyvar or gtycon, we report the--- error as empty character literal, or TH quote that missing proper type--- variable or constructor. See #13450.-reportEmptyDoubleQuotes :: SrcSpan -> P a-reportEmptyDoubleQuotes span = do-    thQuotes <- getBit ThQuotesBit-    addFatalError $ mkPlainErrorMsgEnvelope span $ PsErrEmptyDoubleQuotes thQuotes--{--%************************************************************************-%*                                                                      *-        Helper functions for generating annotations in the parser-%*                                                                      *-%************************************************************************--For the general principles of the following routines, see Note [exact print annotations]-in GHC.Parser.Annotation---}---- |Construct an AddEpAnn from the annotation keyword and the location--- of the keyword itself-mj :: AnnKeywordId -> Located e -> AddEpAnn-mj a l = AddEpAnn a (srcSpan2e $ gl l)--mjN :: AnnKeywordId -> LocatedN e -> AddEpAnn-mjN a l = AddEpAnn a (srcSpan2e $ glN l)---- |Construct an AddEpAnn from the annotation keyword and the location--- of the keyword itself, provided the span is not zero width-mz :: AnnKeywordId -> Located e -> [AddEpAnn]-mz a l = if isZeroWidthSpan (gl l) then [] else [AddEpAnn a (srcSpan2e $ gl l)]--msemi :: Located e -> [TrailingAnn]-msemi l = if isZeroWidthSpan (gl l) then [] else [AddSemiAnn (srcSpan2e $ gl l)]--msemim :: Located e -> Maybe EpaLocation-msemim l = if isZeroWidthSpan (gl l) then Nothing else Just (srcSpan2e $ gl l)---- |Construct an AddEpAnn from the annotation keyword and the Located Token. If--- the token has a unicode equivalent and this has been used, provide the--- unicode variant of the annotation.-mu :: AnnKeywordId -> Located Token -> AddEpAnn-mu a lt@(L l t) = AddEpAnn (toUnicodeAnn a lt) (srcSpan2e l)---- | If the 'Token' is using its unicode variant return the unicode variant of---   the annotation-toUnicodeAnn :: AnnKeywordId -> Located Token -> AnnKeywordId-toUnicodeAnn a t = if isUnicode t then unicodeAnn a else a--toUnicode :: Located Token -> IsUnicodeSyntax-toUnicode t = if isUnicode t then UnicodeSyntax else NormalSyntax--gl :: GenLocated l a -> l-gl = getLoc--glA :: LocatedAn t a -> SrcSpan-glA = getLocA--glN :: LocatedN a -> SrcSpan-glN = getLocA--glR :: Located a -> Anchor-glR la = Anchor (realSrcSpan $ getLoc la) UnchangedAnchor--glMR :: Maybe (Located a) -> Located b -> Anchor-glMR (Just la) _ = glR la-glMR _ la = glR la--glAA :: Located a -> EpaLocation-glAA = srcSpan2e . getLoc--glRR :: Located a -> RealSrcSpan-glRR = realSrcSpan . getLoc--glAR :: LocatedAn t a -> Anchor-glAR la = Anchor (realSrcSpan $ getLocA la) UnchangedAnchor--glNR :: LocatedN a -> Anchor-glNR ln = Anchor (realSrcSpan $ getLocA ln) UnchangedAnchor--glNRR :: LocatedN a -> EpaLocation-glNRR = srcSpan2e . getLocA--anc :: RealSrcSpan -> Anchor-anc r = Anchor r UnchangedAnchor--acs :: MonadP m => (EpAnnComments -> Located a) -> m (Located a)-acs a = do-  let (L l _) = a emptyComments-  cs <- getCommentsFor l-  return (a cs)---- Called at the very end to pick up the EOF position, as well as any comments not allocated yet.-acsFinal :: (EpAnnComments -> Maybe (RealSrcSpan, RealSrcSpan) -> Located a) -> P (Located a)-acsFinal a = do-  let (L l _) = a emptyComments Nothing-  cs <- getCommentsFor l-  csf <- getFinalCommentsFor l-  meof <- getEofPos-  let ce = case meof of-             Strict.Nothing  -> Nothing-             Strict.Just (pos `Strict.And` gap) -> Just (pos,gap)-  return (a (cs Semi.<> csf) ce)---acsa :: MonadP m => (EpAnnComments -> LocatedAn t a) -> m (LocatedAn t a)-acsa a = do-  let (L l _) = a emptyComments-  cs <- getCommentsFor (locA l)-  return (a cs)--acsA :: MonadP m => (EpAnnComments -> Located a) -> m (LocatedAn t a)-acsA a = reLocA <$> acs a--acsExpr :: (EpAnnComments -> LHsExpr GhcPs) -> P ECP-acsExpr a = do { expr :: (LHsExpr GhcPs) <- runPV $ acsa a-               ; return (ecpFromExp $ expr) }--amsA :: MonadP m => LocatedA a -> [TrailingAnn] -> m (LocatedA a)-amsA (L l a) bs = do-  cs <- getCommentsFor (locA l)-  return (L (addAnnsA l bs cs) a)--amsAl :: MonadP m => LocatedA a -> SrcSpan -> [TrailingAnn] -> m (LocatedA a)-amsAl (L l a) loc bs = do-  cs <- getCommentsFor loc-  return (L (addAnnsA l bs cs) a)--amsrc :: MonadP m => Located a -> AnnContext -> m (LocatedC a)-amsrc a@(L l _) bs = do-  cs <- getCommentsFor l-  return (reAnnC bs cs a)--amsrl :: MonadP m => Located a -> AnnList -> m (LocatedL a)-amsrl a@(L l _) bs = do-  cs <- getCommentsFor l-  return (reAnnL bs cs a)--amsrp :: MonadP m => Located a -> AnnPragma -> m (LocatedP a)-amsrp a@(L l _) bs = do-  cs <- getCommentsFor l-  return (reAnnL bs cs a)--amsrn :: MonadP m => Located a -> NameAnn -> m (LocatedN a)-amsrn (L l a) an = do-  cs <- getCommentsFor l-  let ann = (EpAnn (spanAsAnchor l) an cs)-  return (L (SrcSpanAnn ann l) a)---- |Synonyms for AddEpAnn versions of AnnOpen and AnnClose-mo,mc :: Located Token -> AddEpAnn-mo ll = mj AnnOpen ll-mc ll = mj AnnClose ll--moc,mcc :: Located Token -> AddEpAnn-moc ll = mj AnnOpenC ll-mcc ll = mj AnnCloseC ll--mop,mcp :: Located Token -> AddEpAnn-mop ll = mj AnnOpenP ll-mcp ll = mj AnnCloseP ll--moh,mch :: Located Token -> AddEpAnn-moh ll = mj AnnOpenPH ll-mch ll = mj AnnClosePH ll--mos,mcs :: Located Token -> AddEpAnn-mos ll = mj AnnOpenS ll-mcs ll = mj AnnCloseS ll--pvA :: MonadP m => m (Located a) -> m (LocatedAn t a)-pvA a = do { av <- a-           ; return (reLocA av) }--pvN :: MonadP m => m (Located a) -> m (LocatedN a)-pvN a = do { (L l av) <- a-           ; return (L (noAnnSrcSpan l) av) }--pvL :: MonadP m => m (LocatedAn t a) -> m (Located a)-pvL a = do { av <- a-           ; return (reLoc av) }---- | Parse a Haskell module with Haddock comments.--- This is done in two steps:------ * 'parseModuleNoHaddock' to build the AST--- * 'addHaddockToModule' to insert Haddock comments into it------ This is the only parser entry point that deals with Haddock comments.--- The other entry points ('parseDeclaration', 'parseExpression', etc) do--- not insert them into the AST.-parseModule :: P (Located (HsModule GhcPs))-parseModule = parseModuleNoHaddock >>= addHaddockToModule--commentsA :: (Monoid ann) => SrcSpan -> EpAnnComments -> SrcSpanAnn' (EpAnn ann)-commentsA loc cs = SrcSpanAnn (EpAnn (Anchor (rs loc) UnchangedAnchor) mempty cs) loc---- | Instead of getting the *enclosed* comments, this includes the--- *preceding* ones.  It is used at the top level to get comments--- between top level declarations.-commentsPA :: (Monoid ann) => LocatedAn ann a -> P (LocatedAn ann a)-commentsPA la@(L l a) = do-  cs <- getPriorCommentsFor (getLocA la)-  return (L (addCommentsToSrcAnn l cs) a)--rs :: SrcSpan -> RealSrcSpan-rs (RealSrcSpan l _) = l-rs _ = panic "Parser should only have RealSrcSpan"--hsDoAnn :: Located a -> LocatedAn t b -> AnnKeywordId -> AnnList-hsDoAnn (L l _) (L ll _) kw-  = AnnList (Just $ spanAsAnchor (locA ll)) Nothing Nothing [AddEpAnn kw (srcSpan2e l)] []--listAsAnchor :: [LocatedAn t a] -> Anchor-listAsAnchor [] = spanAsAnchor noSrcSpan-listAsAnchor (L l _:_) = spanAsAnchor (locA l)--hsTok :: Located Token -> LHsToken tok GhcPs-hsTok (L l _) = L (mkTokenLocation l) HsTok--hsTok' :: Located Token -> Located (HsToken tok)-hsTok' (L l _) = L l HsTok--hsUniTok :: Located Token -> LHsUniToken tok utok GhcPs-hsUniTok t@(L l _) =-  L (mkTokenLocation l)-    (if isUnicode t then HsUnicodeTok else HsNormalTok)--explicitBraces :: Located Token -> Located Token -> LayoutInfo GhcPs-explicitBraces t1 t2 = ExplicitBraces (hsTok t1) (hsTok t2)---- ---------------------------------------addTrailingCommaFBind :: MonadP m => Fbind b -> SrcSpan -> m (Fbind b)-addTrailingCommaFBind (Left b)  l = fmap Left  (addTrailingCommaA b l)-addTrailingCommaFBind (Right b) l = fmap Right (addTrailingCommaA b l)--addTrailingVbarA :: MonadP m => LocatedA a -> SrcSpan -> m (LocatedA a)-addTrailingVbarA  la span = addTrailingAnnA la span AddVbarAnn--addTrailingSemiA :: MonadP m => LocatedA a -> SrcSpan -> m (LocatedA a)-addTrailingSemiA  la span = addTrailingAnnA la span AddSemiAnn--addTrailingCommaA :: MonadP m => LocatedA a -> SrcSpan -> m (LocatedA a)-addTrailingCommaA  la span = addTrailingAnnA la span AddCommaAnn--addTrailingAnnA :: MonadP m => LocatedA a -> SrcSpan -> (EpaLocation -> TrailingAnn) -> m (LocatedA a)-addTrailingAnnA (L (SrcSpanAnn anns l) a) ss ta = do-  -- cs <- getCommentsFor l-  let cs = emptyComments-  -- AZ:TODO: generalise updating comments into an annotation-  let-    anns' = if isZeroWidthSpan ss-              then anns-              else addTrailingAnnToA l (ta (srcSpan2e ss)) cs anns-  return (L (SrcSpanAnn anns' l) a)---- ---------------------------------------addTrailingVbarL :: MonadP m => LocatedL a -> SrcSpan -> m (LocatedL a)-addTrailingVbarL  la span = addTrailingAnnL la (AddVbarAnn (srcSpan2e span))--addTrailingCommaL :: MonadP m => LocatedL a -> SrcSpan -> m (LocatedL a)-addTrailingCommaL  la span = addTrailingAnnL la (AddCommaAnn (srcSpan2e span))--addTrailingAnnL :: MonadP m => LocatedL a -> TrailingAnn -> m (LocatedL a)-addTrailingAnnL (L (SrcSpanAnn anns l) a) ta = do-  cs <- getCommentsFor l-  let anns' = addTrailingAnnToL l ta cs anns-  return (L (SrcSpanAnn anns' l) a)---- ----------------------------------------- Mostly use to add AnnComma, special case it to NOP if adding a zero-width annotation-addTrailingCommaN :: MonadP m => LocatedN a -> SrcSpan -> m (LocatedN a)-addTrailingCommaN (L (SrcSpanAnn anns l) a) span = do-  -- cs <- getCommentsFor l-  let cs = emptyComments-  -- AZ:TODO: generalise updating comments into an annotation-  let anns' = if isZeroWidthSpan span-                then anns-                else addTrailingCommaToN l anns (srcSpan2e span)-  return (L (SrcSpanAnn anns' l) a)--addTrailingCommaS :: Located StringLiteral -> EpaLocation -> Located StringLiteral-addTrailingCommaS (L l sl) span = L l (sl { sl_tc = Just (epaLocationRealSrcSpan span) })---- ---------------------------------------addTrailingDarrowC :: LocatedC a -> Located Token -> EpAnnComments -> LocatedC a-addTrailingDarrowC (L (SrcSpanAnn EpAnnNotUsed l) a) lt cs =-  let-    u = if (isUnicode lt) then UnicodeSyntax else NormalSyntax-  in L (SrcSpanAnn (EpAnn (spanAsAnchor l) (AnnContext (Just (u,glAA lt)) [] []) cs) l) a-addTrailingDarrowC (L (SrcSpanAnn (EpAnn lr (AnnContext _ o c) csc) l) a) lt cs =-  let-    u = if (isUnicode lt) then UnicodeSyntax else NormalSyntax-  in L (SrcSpanAnn (EpAnn lr (AnnContext (Just (u,glAA lt)) o c) (cs Semi.<> csc)) l) a---- ----------------------------------------- We need a location for the where binds, when computing the SrcSpan--- for the AST element using them.  Where there is a span, we return--- it, else noLoc, which is ignored in the comb2 call.-adaptWhereBinds :: Maybe (Located (HsLocalBinds GhcPs, Maybe EpAnnComments))-                ->        Located (HsLocalBinds GhcPs,       EpAnnComments)-adaptWhereBinds Nothing = noLoc (EmptyLocalBinds noExtField, emptyComments)-adaptWhereBinds (Just (L l (b, mc))) = L l (b, maybe emptyComments id mc)+{- Note [%shift: rule_foralls -> {- empty -}]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Context:+    rule -> STRING rule_activation . rule_foralls infixexp '=' exp++Example:+    {-# RULES "name" forall a1. lhs = rhs #-}++Ambiguity:+    If we reduced, then we would get an empty rule_foralls; the 'forall', being+    a valid term-level identifier, would be parsed as part of the left-hand+    side expression.++    We shift, so the 'forall' is parsed as part of rule_foralls.+-}++{- Note [%shift: type -> btype]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Context:+    context -> btype .+    type -> btype .+    type -> btype . '->' ctype+    type -> btype . '->.' ctype++Example:+    a :: Maybe Integer -> Bool++Ambiguity:+    If we reduced, we would get:   (a :: Maybe Integer) -> Bool+    We shift to get this instead:  a :: (Maybe Integer -> Bool)+-}++{- Note [%shift: infixtype -> ftype]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Context:+    infixtype -> ftype .+    infixtype -> ftype . tyop infixtype+    ftype -> ftype . tyarg+    ftype -> ftype . PREFIX_AT tyarg++Example:+    a :: Maybe Integer++Ambiguity:+    If we reduced, we would get:    (a :: Maybe) Integer+    We shift to get this instead:   a :: (Maybe Integer)+-}++{- Note [%shift: atype -> tyvar]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Context:+    atype -> tyvar .+    tv_bndr_no_braces -> '(' tyvar . '::' kind ')'++Example:+    class C a where type D a = (a :: Type ...++Ambiguity:+    If we reduced, we could specify a default for an associated type like this:++      class C a where type D a+                      type D a = (a :: Type)++    But we shift in order to allow injectivity signatures like this:++      class C a where type D a = (r :: Type) | r -> a+-}++{- Note [%shift: exp -> infixexp]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Context:+    exp -> infixexp . '::' sigtype+    exp -> infixexp . '-<' exp+    exp -> infixexp . '>-' exp+    exp -> infixexp . '-<<' exp+    exp -> infixexp . '>>-' exp+    exp -> infixexp .+    infixexp -> infixexp . qop exp10p++Examples:+    1) if x then y else z -< e+    2) if x then y else z :: T+    3) if x then y else z + 1   -- (NB: '+' is in VARSYM)++Ambiguity:+    If we reduced, we would get:++      1) (if x then y else z) -< e+      2) (if x then y else z) :: T+      3) (if x then y else z) + 1++    We shift to get this instead:++      1) if x then y else (z -< e)+      2) if x then y else (z :: T)+      3) if x then y else (z + 1)+-}++{- Note [%shift: exp10 -> '-' fexp]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Context:+    exp10 -> '-' fexp .+    fexp -> fexp . aexp+    fexp -> fexp . PREFIX_AT atype++Examples & Ambiguity:+    Same as in Note [%shift: exp10 -> fexp],+    but with a '-' in front.+-}++{- Note [%shift: exp10 -> fexp]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Context:+    exp10 -> fexp .+    fexp -> fexp . aexp+    fexp -> fexp . PREFIX_AT atype++Examples:+    1) if x then y else f z+    2) if x then y else f @z++Ambiguity:+    If we reduced, we would get:++      1) (if x then y else f) z+      2) (if x then y else f) @z++    We shift to get this instead:++      1) if x then y else (f z)+      2) if x then y else (f @z)+-}++{- Note [%shift: aexp2 -> ipvar]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Context:+    aexp2 -> ipvar .+    dbind -> ipvar . '=' exp++Example:+    let ?x = ...++Ambiguity:+    If we reduced, ?x would be parsed as the LHS of a normal binding,+    eventually producing an error.++    We shift, so it is parsed as the LHS of an implicit binding.+-}++{- Note [%shift: aexp2 -> TH_TY_QUOTE]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Context:+    aexp2 -> TH_TY_QUOTE . tyvar+    aexp2 -> TH_TY_QUOTE . gtycon+    aexp2 -> TH_TY_QUOTE .++Examples:+    1) x = ''+    2) x = ''a+    3) x = ''T++Ambiguity:+    If we reduced, the '' would result in reportEmptyDoubleQuotes even when+    followed by a type variable or a type constructor. But the only reason+    this reduction rule exists is to improve error messages.++    Naturally, we shift instead, so that ''a and ''T work as expected.+-}++{- Note [%shift: tup_tail -> {- empty -}]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Context:+    tup_exprs -> commas . tup_tail+    sysdcon_nolist -> '(' commas . ')'+    sysdcon_nolist -> '(#' commas . '#)'+    commas -> commas . ','++Example:+    (,,)++Ambiguity:+    A tuple section with no components is indistinguishable from the Haskell98+    data constructor for a tuple.++    If we reduced, (,,) would be parsed as a tuple section.+    We shift, so (,,) is parsed as a data constructor.++    This is preferable because we want to accept (,,) without -XTupleSections.+    See also Note [ExplicitTuple] in GHC.Hs.Expr.+-}++{- Note [%shift: qtyconop -> qtyconsym]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Context:+    oqtycon -> '(' qtyconsym . ')'+    qtyconop -> qtyconsym .++Example:+    foo :: (:%)++Ambiguity:+    If we reduced, (:%) would be parsed as a parenthesized infix type+    expression without arguments, resulting in the 'failOpFewArgs' error.++    We shift, so it is parsed as a type constructor.+-}++{- Note [%shift: special_id -> 'group']+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Context:+    transformqual -> 'then' 'group' . 'using' exp+    transformqual -> 'then' 'group' . 'by' exp 'using' exp+    special_id -> 'group' .++Example:+    [ ... | then group by dept using groupWith+          , then take 5 ]++Ambiguity:+    If we reduced, 'group' would be parsed as a term-level identifier, just as+    'take' in the other clause.++    We shift, so it is parsed as part of the 'group by' clause introduced by+    the -XTransformListComp extension.+-}++{- Note [%shift: activation -> {- empty -}]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Context:+    sigdecl -> '{-# INLINE' . activation qvarcon '#-}'+    activation -> {- empty -}+    activation -> explicit_activation++Example:++    {-# INLINE [0] Something #-}++Ambiguity:+    We don't know whether the '[' is the start of the activation or the beginning+    of the [] data constructor.+    We parse this as having '[0]' activation for inlining 'Something', rather than+    empty activation and inlining '[0] Something'.+-}++{- Note [Parser API Annotations]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A lot of the productions are now cluttered with calls to+aa,am,acs,acsA etc.++These are helper functions to make sure that the locations of the+various keywords such as do / let / in are captured for use by tools+that want to do source to source conversions, such as refactorers or+structured editors.++The helper functions are defined at the bottom of this file.++See+  https://gitlab.haskell.org/ghc/ghc/wikis/api-annotations and+  https://gitlab.haskell.org/ghc/ghc/wikis/ghc-ast-annotations+for some background.++-}++{- Note [Parsing lists]+~~~~~~~~~~~~~~~~~~~~~~~+You might be wondering why we spend so much effort encoding our lists this+way:++importdecls+        : importdecls ';' importdecl+        | importdecls ';'+        | importdecl+        | {- empty -}++This might seem like an awfully roundabout way to declare a list; plus, to add+insult to injury you have to reverse the results at the end.  The answer is that+left recursion prevents us from running out of stack space when parsing long+sequences. See:+https://haskell-happy.readthedocs.io/en/latest/using.html#parsing-sequences+for more guidance.++By adding/removing branches, you can affect what lists are accepted.  Here+are the most common patterns, rewritten as regular expressions for clarity:++    -- Equivalent to: ';'* (x ';'+)* x?  (can be empty, permits leading/trailing semis)+    xs : xs ';' x+       | xs ';'+       | x+       | {- empty -}++    -- Equivalent to x (';' x)* ';'*  (non-empty, permits trailing semis)+    xs : xs ';' x+       | xs ';'+       | x++    -- Equivalent to ';'* alts (';' alts)* ';'* (non-empty, permits leading/trailing semis)+    alts : alts1+         | ';' alts+    alts1 : alts1 ';' alt+          | alts1 ';'+          | alt++    -- Equivalent to x (',' x)+ (non-empty, no trailing semis)+    xs : x+       | x ',' xs+-}++%token+ '_'            { L _ ITunderscore }            -- Haskell keywords+ 'as'           { L _ ITas }+ 'case'         { L _ ITcase }+ 'class'        { L _ ITclass }+ 'data'         { L _ ITdata }+ 'default'      { L _ ITdefault }+ 'deriving'     { L _ ITderiving }+ 'else'         { L _ ITelse }+ 'hiding'       { L _ IThiding }+ 'if'           { L _ ITif }+ 'import'       { L _ ITimport }+ 'in'           { L _ ITin }+ 'infix'        { L _ ITinfix }+ 'infixl'       { L _ ITinfixl }+ 'infixr'       { L _ ITinfixr }+ 'instance'     { L _ ITinstance }+ 'let'          { L _ ITlet }+ 'module'       { L _ ITmodule }+ 'newtype'      { L _ ITnewtype }+ 'of'           { L _ ITof }+ 'qualified'    { L _ ITqualified }+ 'then'         { L _ ITthen }+ 'type'         { L _ ITtype }+ 'where'        { L _ ITwhere }++ 'forall'       { L _ (ITforall _) }                -- GHC extension keywords+ 'foreign'      { L _ ITforeign }+ 'export'       { L _ ITexport }+ 'label'        { L _ ITlabel }+ 'dynamic'      { L _ ITdynamic }+ 'safe'         { L _ ITsafe }+ 'interruptible' { L _ ITinterruptible }+ 'unsafe'       { L _ ITunsafe }+ 'family'       { L _ ITfamily }+ 'role'         { L _ ITrole }+ 'stdcall'      { L _ ITstdcallconv }+ 'ccall'        { L _ ITccallconv }+ 'capi'         { L _ ITcapiconv }+ 'prim'         { L _ ITprimcallconv }+ 'javascript'   { L _ ITjavascriptcallconv }+ 'proc'         { L _ ITproc }          -- for arrow notation extension+ 'rec'          { L _ ITrec }           -- for arrow notation extension+ 'group'    { L _ ITgroup }     -- for list transform extension+ 'by'       { L _ ITby }        -- for list transform extension+ 'using'    { L _ ITusing }     -- for list transform extension+ 'pattern'      { L _ ITpattern } -- for pattern synonyms+ 'static'       { L _ ITstatic }  -- for static pointers extension+ 'stock'        { L _ ITstock }    -- for DerivingStrategies extension+ 'anyclass'     { L _ ITanyclass } -- for DerivingStrategies extension+ 'via'          { L _ ITvia }      -- for DerivingStrategies extension++ 'unit'         { L _ ITunit }+ 'signature'    { L _ ITsignature }+ 'dependency'   { L _ ITdependency }++ '{-# INLINE'             { L _ (ITinline_prag _ _ _) } -- INLINE or INLINABLE+ '{-# OPAQUE'             { L _ (ITopaque_prag _) }+ '{-# SPECIALISE'         { L _ (ITspec_prag _) }+ '{-# SPECIALISE_INLINE'  { L _ (ITspec_inline_prag _ _) }+ '{-# SOURCE'             { L _ (ITsource_prag _) }+ '{-# RULES'              { L _ (ITrules_prag _) }+ '{-# SCC'                { L _ (ITscc_prag _)}+ '{-# DEPRECATED'         { L _ (ITdeprecated_prag _) }+ '{-# WARNING'            { L _ (ITwarning_prag _) }+ '{-# UNPACK'             { L _ (ITunpack_prag _) }+ '{-# NOUNPACK'           { L _ (ITnounpack_prag _) }+ '{-# ANN'                { L _ (ITann_prag _) }+ '{-# MINIMAL'            { L _ (ITminimal_prag _) }+ '{-# CTYPE'              { L _ (ITctype _) }+ '{-# OVERLAPPING'        { L _ (IToverlapping_prag _) }+ '{-# OVERLAPPABLE'       { L _ (IToverlappable_prag _) }+ '{-# OVERLAPS'           { L _ (IToverlaps_prag _) }+ '{-# INCOHERENT'         { L _ (ITincoherent_prag _) }+ '{-# COMPLETE'           { L _ (ITcomplete_prag _)   }+ '#-}'                    { L _ ITclose_prag }++ '..'           { L _ ITdotdot }                        -- reserved symbols+ ':'            { L _ ITcolon }+ '::'           { L _ (ITdcolon _) }+ '='            { L _ ITequal }+ '\\'           { L _ ITlam }+ 'lcase'        { L _ ITlcase }+ 'lcases'       { L _ ITlcases }+ '|'            { L _ ITvbar }+ '<-'           { L _ (ITlarrow _) }+ '->'           { L _ (ITrarrow _) }+ '->.'          { L _ ITlolly }+ TIGHT_INFIX_AT { L _ ITat }+ '=>'           { L _ (ITdarrow _) }+ '-'            { L _ ITminus }+ PREFIX_TILDE   { L _ ITtilde }+ PREFIX_BANG    { L _ ITbang }+ PREFIX_MINUS   { L _ ITprefixminus }+ '*'            { L _ (ITstar _) }+ '-<'           { L _ (ITlarrowtail _) }            -- for arrow notation+ '>-'           { L _ (ITrarrowtail _) }            -- for arrow notation+ '-<<'          { L _ (ITLarrowtail _) }            -- for arrow notation+ '>>-'          { L _ (ITRarrowtail _) }            -- for arrow notation+ '.'            { L _ ITdot }+ PREFIX_PROJ    { L _ (ITproj True) }               -- RecordDotSyntax+ TIGHT_INFIX_PROJ { L _ (ITproj False) }            -- RecordDotSyntax+ PREFIX_AT      { L _ ITtypeApp }+ PREFIX_PERCENT { L _ ITpercent }                   -- for linear types++ '{'            { L _ ITocurly }                        -- special symbols+ '}'            { L _ ITccurly }+ vocurly        { L _ ITvocurly } -- virtual open curly (from layout)+ vccurly        { L _ ITvccurly } -- virtual close curly (from layout)+ '['            { L _ ITobrack }+ ']'            { L _ ITcbrack }+ '('            { L _ IToparen }+ ')'            { L _ ITcparen }+ '(#'           { L _ IToubxparen }+ '#)'           { L _ ITcubxparen }+ '(|'           { L _ (IToparenbar _) }+ '|)'           { L _ (ITcparenbar _) }+ ';'            { L _ ITsemi }+ ','            { L _ ITcomma }+ '`'            { L _ ITbackquote }+ SIMPLEQUOTE    { L _ ITsimpleQuote      }     -- 'x++ VARID          { L _ (ITvarid    _) }          -- identifiers+ CONID          { L _ (ITconid    _) }+ VARSYM         { L _ (ITvarsym   _) }+ CONSYM         { L _ (ITconsym   _) }+ QVARID         { L _ (ITqvarid   _) }+ QCONID         { L _ (ITqconid   _) }+ QVARSYM        { L _ (ITqvarsym  _) }+ QCONSYM        { L _ (ITqconsym  _) }+++ -- QualifiedDo+ DO             { L _ (ITdo  _) }+ MDO            { L _ (ITmdo _) }++ IPDUPVARID     { L _ (ITdupipvarid   _) }              -- GHC extension+ LABELVARID     { L _ (ITlabelvarid _ _) }++ CHAR           { L _ (ITchar   _ _) }+ STRING         { L _ (ITstring _ _) }+ INTEGER        { L _ (ITinteger _) }+ RATIONAL       { L _ (ITrational _) }++ PRIMCHAR       { L _ (ITprimchar   _ _) }+ PRIMSTRING     { L _ (ITprimstring _ _) }+ PRIMINTEGER    { L _ (ITprimint    _ _) }+ PRIMWORD       { L _ (ITprimword   _ _) }+ PRIMINTEGER8   { L _ (ITprimint8   _ _) }+ PRIMINTEGER16  { L _ (ITprimint16  _ _) }+ PRIMINTEGER32  { L _ (ITprimint32  _ _) }+ PRIMINTEGER64  { L _ (ITprimint64  _ _) }+ PRIMWORD8      { L _ (ITprimword8  _ _) }+ PRIMWORD16     { L _ (ITprimword16 _ _) }+ PRIMWORD32     { L _ (ITprimword32 _ _) }+ PRIMWORD64     { L _ (ITprimword64 _ _) }+ PRIMFLOAT      { L _ (ITprimfloat  _) }+ PRIMDOUBLE     { L _ (ITprimdouble _) }++-- Template Haskell+'[|'            { L _ (ITopenExpQuote _ _) }+'[p|'           { L _ ITopenPatQuote  }+'[t|'           { L _ ITopenTypQuote  }+'[d|'           { L _ ITopenDecQuote  }+'|]'            { L _ (ITcloseQuote _) }+'[||'           { L _ (ITopenTExpQuote _) }+'||]'           { L _ ITcloseTExpQuote  }+PREFIX_DOLLAR   { L _ ITdollar }+PREFIX_DOLLAR_DOLLAR { L _ ITdollardollar }+TH_TY_QUOTE     { L _ ITtyQuote       }      -- ''T+TH_QUASIQUOTE   { L _ (ITquasiQuote _) }+TH_QQUASIQUOTE  { L _ (ITqQuasiQuote _) }++%monad { P } { >>= } { return }+%lexer { (lexer True) } { L _ ITeof }+  -- Replace 'lexer' above with 'lexerDbg'+  -- to dump the tokens fed to the parser.+%tokentype { (Located Token) }++-- Exported parsers+%name parseModuleNoHaddock module+%name parseSignatureNoHaddock signature+%name parseImport importdecl+%name parseStatement e_stmt+%name parseDeclaration topdecl+%name parseExpression exp+%name parsePattern pat+%name parseTypeSignature sigdecl+%name parseStmt   maybe_stmt+%name parseIdentifier  identifier+%name parseType ktype+%name parseBackpack backpack+%partial parseHeader header+%%++-----------------------------------------------------------------------------+-- Identifiers; one of the entry points+identifier :: { LocatedN RdrName }+        : qvar                          { $1 }+        | qcon                          { $1 }+        | qvarop                        { $1 }+        | qconop                        { $1 }+    | '(' '->' ')'      {% amsr (sLL $1 $> $ getRdrName unrestrictedFunTyCon)+                                (NameAnnRArrow (isUnicode $2) (Just $ glAA $1) (glAA $2) (Just $ glAA $3) []) }+    | '->'              {% amsr (sLL $1 $> $ getRdrName unrestrictedFunTyCon)+                                (NameAnnRArrow (isUnicode $1) Nothing (glAA $1) Nothing []) }++-----------------------------------------------------------------------------+-- Backpack stuff++backpack :: { [LHsUnit PackageName] }+         : implicit_top units close { fromOL $2 }+         | '{' units '}'            { fromOL $2 }++units :: { OrdList (LHsUnit PackageName) }+         : units ';' unit { $1 `appOL` unitOL $3 }+         | units ';'      { $1 }+         | unit           { unitOL $1 }++unit :: { LHsUnit PackageName }+        : 'unit' pkgname 'where' unitbody+            { sL1 $1 $ HsUnit { hsunitName = $2+                              , hsunitBody = fromOL $4 } }++unitid :: { LHsUnitId PackageName }+        : pkgname                  { sL1 $1 $ HsUnitId $1 [] }+        | pkgname '[' msubsts ']'  { sLL $1 $> $ HsUnitId $1 (fromOL $3) }++msubsts :: { OrdList (LHsModuleSubst PackageName) }+        : msubsts ',' msubst { $1 `appOL` unitOL $3 }+        | msubsts ','        { $1 }+        | msubst             { unitOL $1 }++msubst :: { LHsModuleSubst PackageName }+        : modid '=' moduleid { sLL $1 $> $ (reLoc $1, $3) }+        | modid VARSYM modid VARSYM { sLL $1 $> $ (reLoc $1, sLL $2 $> $ HsModuleVar (reLoc $3)) }++moduleid :: { LHsModuleId PackageName }+          : VARSYM modid VARSYM { sLL $1 $> $ HsModuleVar (reLoc $2) }+          | unitid ':' modid    { sLL $1 $> $ HsModuleId $1 (reLoc $3) }++pkgname :: { Located PackageName }+        : STRING     { sL1 $1 $ PackageName (getSTRING $1) }+        | litpkgname { sL1 $1 $ PackageName (unLoc $1) }++litpkgname_segment :: { Located FastString }+        : VARID  { sL1 $1 $ getVARID $1 }+        | CONID  { sL1 $1 $ getCONID $1 }+        | special_id { $1 }++-- Parse a minus sign regardless of whether -XLexicalNegation is turned on or off.+-- See Note [Minus tokens] in GHC.Parser.Lexer+HYPHEN :: { [AddEpAnn] }+      : '-'          { [mj AnnMinus $1 ] }+      | PREFIX_MINUS { [mj AnnMinus $1 ] }+      | VARSYM  {% if (getVARSYM $1 == fsLit "-")+                   then return [mj AnnMinus $1]+                   else do { addError $ mkPlainErrorMsgEnvelope (getLoc $1) $ PsErrExpectedHyphen+                           ; return [] } }+++litpkgname :: { Located FastString }+        : litpkgname_segment { $1 }+        -- a bit of a hack, means p - b is parsed same as p-b, enough for now.+        | litpkgname_segment HYPHEN litpkgname  { sLL $1 $> $ concatFS [unLoc $1, fsLit "-", (unLoc $3)] }++mayberns :: { Maybe [LRenaming] }+        : {- empty -} { Nothing }+        | '(' rns ')' { Just (fromOL $2) }++rns :: { OrdList LRenaming }+        : rns ',' rn { $1 `appOL` unitOL $3 }+        | rns ','    { $1 }+        | rn         { unitOL $1 }++rn :: { LRenaming }+        : modid 'as' modid { sLL $1 $> $ Renaming (reLoc $1) (Just (reLoc $3)) }+        | modid            { sL1 $1    $ Renaming (reLoc $1) Nothing }++unitbody :: { OrdList (LHsUnitDecl PackageName) }+        : '{'     unitdecls '}'   { $2 }+        | vocurly unitdecls close { $2 }++unitdecls :: { OrdList (LHsUnitDecl PackageName) }+        : unitdecls ';' unitdecl { $1 `appOL` unitOL $3 }+        | unitdecls ';'         { $1 }+        | unitdecl              { unitOL $1 }++unitdecl :: { LHsUnitDecl PackageName }+        : 'module' maybe_src modid maybe_warning_pragma maybeexports 'where' body+             -- XXX not accurate+             { sL1 $1 $ DeclD+                 (case snd $2 of+                   NotBoot -> HsSrcFile+                   IsBoot  -> HsBootFile)+                 (reLoc $3)+                 (sL1 $1 (HsModule (XModulePs noAnn (thdOf3 $7) $4 Nothing) (Just $3) $5 (fst $ sndOf3 $7) (snd $ sndOf3 $7))) }+        | 'signature' modid maybe_warning_pragma maybeexports 'where' body+             { sL1 $1 $ DeclD+                 HsigFile+                 (reLoc $2)+                 (sL1 $1 (HsModule (XModulePs noAnn (thdOf3 $6) $3 Nothing) (Just $2) $4 (fst $ sndOf3 $6) (snd $ sndOf3 $6))) }+        | 'dependency' unitid mayberns+             { sL1 $1 $ IncludeD (IncludeDecl { idUnitId = $2+                                              , idModRenaming = $3+                                              , idSignatureInclude = False }) }+        | 'dependency' 'signature' unitid+             { sL1 $1 $ IncludeD (IncludeDecl { idUnitId = $3+                                              , idModRenaming = Nothing+                                              , idSignatureInclude = True }) }++-----------------------------------------------------------------------------+-- Module Header++-- The place for module deprecation is really too restrictive, but if it+-- was allowed at its natural place just before 'module', we get an ugly+-- s/r conflict with the second alternative. Another solution would be the+-- introduction of a new pragma DEPRECATED_MODULE, but this is not very nice,+-- either, and DEPRECATED is only expected to be used by people who really+-- know what they are doing. :-)++signature :: { Located (HsModule GhcPs) }+       : 'signature' modid maybe_warning_pragma maybeexports 'where' body+             {% fileSrcSpan >>= \ loc ->+                acs loc (\loc cs-> (L loc (HsModule (XModulePs+                                               (EpAnn (spanAsAnchor loc) (AnnsModule [mj AnnSignature $1, mj AnnWhere $5] (fstOf3 $6) [] Nothing) cs)+                                               (thdOf3 $6) $3 Nothing)+                                            (Just $2) $4 (fst $ sndOf3 $6)+                                            (snd $ sndOf3 $6)))+                    ) }++module :: { Located (HsModule GhcPs) }+       : 'module' modid maybe_warning_pragma maybeexports 'where' body+             {% fileSrcSpan >>= \ loc ->+                acsFinal (\cs eof -> (L loc (HsModule (XModulePs+                                                     (EpAnn (spanAsAnchor loc) (AnnsModule [mj AnnModule $1, mj AnnWhere $5] (fstOf3 $6) [] eof) cs)+                                                     (thdOf3 $6) $3 Nothing)+                                                  (Just $2) $4 (fst $ sndOf3 $6)+                                                  (snd $ sndOf3 $6))+                    )) }+        | body2+                {% fileSrcSpan >>= \ loc ->+                   acsFinal (\cs eof -> (L loc (HsModule (XModulePs+                                                        (EpAnn (spanAsAnchor loc) (AnnsModule [] (fstOf3 $1) [] eof) cs)+                                                        (thdOf3 $1) Nothing Nothing)+                                                     Nothing Nothing+                                                     (fst $ sndOf3 $1) (snd $ sndOf3 $1)))) }++missing_module_keyword :: { () }+        : {- empty -}                           {% pushModuleContext }++implicit_top :: { () }+        : {- empty -}                           {% pushModuleContext }++body    :: { ([TrailingAnn]+             ,([LImportDecl GhcPs], [LHsDecl GhcPs])+             ,EpLayout) }+        :  '{'            top '}'      { (fst $2, snd $2, epExplicitBraces $1 $3) }+        |      vocurly    top close    { (fst $2, snd $2, EpVirtualBraces (getVOCURLY $1)) }++body2   :: { ([TrailingAnn]+             ,([LImportDecl GhcPs], [LHsDecl GhcPs])+             ,EpLayout) }+        :  '{' top '}'                          { (fst $2, snd $2, epExplicitBraces $1 $3) }+        |  missing_module_keyword top close     { ([], snd $2, EpVirtualBraces leftmostColumn) }+++top     :: { ([TrailingAnn]+             ,([LImportDecl GhcPs], [LHsDecl GhcPs])) }+        : semis top1                            { (reverse $1, $2) }++top1    :: { ([LImportDecl GhcPs], [LHsDecl GhcPs]) }+        : importdecls_semi topdecls_cs_semi        { (reverse $1, cvTopDecls $2) }+        | importdecls_semi topdecls_cs             { (reverse $1, cvTopDecls $2) }+        | importdecls                              { (reverse $1, []) }++-----------------------------------------------------------------------------+-- Module declaration & imports only++header  :: { Located (HsModule GhcPs) }+        : 'module' modid maybe_warning_pragma maybeexports 'where' header_body+                {% fileSrcSpan >>= \ loc ->+                   acs loc (\loc cs -> (L loc (HsModule (XModulePs+                                                   (EpAnn (spanAsAnchor loc) (AnnsModule [mj AnnModule $1,mj AnnWhere $5] [] [] Nothing) cs)+                                                   EpNoLayout $3 Nothing)+                                                (Just $2) $4 $6 []+                          ))) }+        | 'signature' modid maybe_warning_pragma maybeexports 'where' header_body+                {% fileSrcSpan >>= \ loc ->+                   acs loc (\loc cs -> (L loc (HsModule (XModulePs+                                                   (EpAnn (spanAsAnchor loc) (AnnsModule [mj AnnModule $1,mj AnnWhere $5] [] [] Nothing) cs)+                                                   EpNoLayout $3 Nothing)+                                                (Just $2) $4 $6 []+                          ))) }+        | header_body2+                {% fileSrcSpan >>= \ loc ->+                   return (L loc (HsModule (XModulePs noAnn EpNoLayout Nothing Nothing) Nothing Nothing $1 [])) }++header_body :: { [LImportDecl GhcPs] }+        :  '{'            header_top            { $2 }+        |      vocurly    header_top            { $2 }++header_body2 :: { [LImportDecl GhcPs] }+        :  '{' header_top                       { $2 }+        |  missing_module_keyword header_top    { $2 }++header_top :: { [LImportDecl GhcPs] }+        :  semis header_top_importdecls         { $2 }++header_top_importdecls :: { [LImportDecl GhcPs] }+        :  importdecls_semi                     { $1 }+        |  importdecls                          { $1 }++-----------------------------------------------------------------------------+-- The Export List++maybeexports :: { (Maybe (LocatedL [LIE GhcPs])) }+        :  '(' exportlist ')'       {% fmap Just $ amsr (sLL $1 $> (fromOL $ snd $2))+                                        (AnnList Nothing (Just $ mop $1) (Just $ mcp $3) (fst $2) []) }+        |  {- empty -}              { Nothing }++exportlist :: { ([AddEpAnn], OrdList (LIE GhcPs)) }+        : exportlist1     { ([], $1) }+        | {- empty -}     { ([], nilOL) }++        -- trailing comma:+        | exportlist1 ',' {% case $1 of+                               SnocOL hs t -> do+                                 t' <- addTrailingCommaA t (gl $2)+                                 return ([], snocOL hs t')}+        | ','             { ([mj AnnComma $1], nilOL) }++exportlist1 :: { OrdList (LIE GhcPs) }+        : exportlist1 ',' export_cs+                          {% let ls = $1+                             in if isNilOL ls+                                  then return (ls `appOL` $3)+                                  else case ls of+                                         SnocOL hs t -> do+                                           t' <- addTrailingCommaA t (gl $2)+                                           return (snocOL hs t' `appOL` $3)}+        | export_cs       { $1 }+++export_cs :: { OrdList (LIE GhcPs) }+export_cs : export {% return (unitOL $1) }++   -- No longer allow things like [] and (,,,) to be exported+   -- They are built in syntax, always available+export  :: { LIE GhcPs }+        : maybe_warning_pragma qcname_ext export_subspec {% do { let { span = (maybe comb2 comb3 $1) $2 $> }+                                                          ; impExp <- mkModuleImpExp $1 (fst $ unLoc $3) $2 (snd $ unLoc $3)+                                                          ; return $ reLoc $ sL span $ impExp } }+        | maybe_warning_pragma 'module' modid            {% do { let { span = (maybe comb2 comb3 $1) $2 $>+                                                                     ; anchor = (maybe glR (\loc -> spanAsAnchor . comb2 loc) $1) $2 }+                                                          ; locImpExp <- return (sL span (IEModuleContents ($1, [mj AnnModule $2]) $3))+                                                          ; return $ reLoc $ locImpExp } }+        | maybe_warning_pragma 'pattern' qcon            { let span = (maybe comb2 comb3 $1) $2 $>+                                                           in reLoc $ sL span $ IEVar $1 (sLLa $2 $> (IEPattern (glAA $2) $3)) Nothing }++export_subspec :: { Located ([AddEpAnn],ImpExpSubSpec) }+        : {- empty -}             { sL0 ([],ImpExpAbs) }+        | '(' qcnames ')'         {% mkImpExpSubSpec (reverse (snd $2))+                                      >>= \(as,ie) -> return $ sLL $1 $>+                                            (as ++ [mop $1,mcp $3] ++ fst $2, ie) }++qcnames :: { ([AddEpAnn], [LocatedA ImpExpQcSpec]) }+  : {- empty -}                   { ([],[]) }+  | qcnames1                      { $1 }++qcnames1 :: { ([AddEpAnn], [LocatedA ImpExpQcSpec]) }     -- A reversed list+        :  qcnames1 ',' qcname_ext_w_wildcard  {% case (snd $1) of+                                                    (l@(L la ImpExpQcWildcard):t) ->+                                                       do { l' <- addTrailingCommaA l (gl $2)+                                                          ; return ([mj AnnDotdot (reLoc l),+                                                                     mj AnnComma $2]+                                                                   ,(snd (unLoc $3)  : l' : t)) }+                                                    (l:t) ->+                                                       do { l' <- addTrailingCommaA l (gl $2)+                                                          ; return (fst $1 ++ fst (unLoc $3)+                                                                   , snd (unLoc $3) : l' : t)} }++        -- Annotations re-added in mkImpExpSubSpec+        |  qcname_ext_w_wildcard                   { (fst (unLoc $1),[snd (unLoc $1)]) }++-- Variable, data constructor or wildcard+-- or tagged type constructor+qcname_ext_w_wildcard :: { Located ([AddEpAnn], LocatedA ImpExpQcSpec) }+        :  qcname_ext               { sL1 $1 ([],$1) }+        |  '..'                     { sL1 $1 ([mj AnnDotdot $1], sL1a $1 ImpExpQcWildcard)  }++qcname_ext :: { LocatedA ImpExpQcSpec }+        :  qcname                   { sL1a $1 (ImpExpQcName $1) }+        |  'type' oqtycon           {% do { n <- mkTypeImpExp $2+                                          ; return $ sLLa $1 $> (ImpExpQcType (glAA $1) n) }}++qcname  :: { LocatedN RdrName }  -- Variable or type constructor+        :  qvar                 { $1 } -- Things which look like functions+                                       -- Note: This includes record selectors but+                                       -- also (-.->), see #11432+        |  oqtycon_no_varcon    { $1 } -- see Note [Type constructors in export list]++-----------------------------------------------------------------------------+-- Import Declarations++-- importdecls and topdecls must contain at least one declaration;+-- top handles the fact that these may be optional.++-- One or more semicolons+semis1  :: { Located [TrailingAnn] }+semis1  : semis1 ';'  { if isZeroWidthSpan (gl $2) then (sL1 $1 $ unLoc $1) else (sLL $1 $> $ AddSemiAnn (glAA $2) : (unLoc $1)) }+        | ';'         { case msemi $1 of+                          [] -> noLoc []+                          ms -> sL1 $1 $ ms }++-- Zero or more semicolons+semis   :: { [TrailingAnn] }+semis   : semis ';'   { if isZeroWidthSpan (gl $2) then $1 else (AddSemiAnn (glAA $2) : $1) }+        | {- empty -} { [] }++-- No trailing semicolons, non-empty+importdecls :: { [LImportDecl GhcPs] }+importdecls+        : importdecls_semi importdecl+                                { $2 : $1 }++-- May have trailing semicolons, can be empty+importdecls_semi :: { [LImportDecl GhcPs] }+importdecls_semi+        : importdecls_semi importdecl semis1+                                {% do { i <- amsAl $2 (comb2 $2 $3) (reverse $ unLoc $3)+                                      ; return (i : $1)} }+        | {- empty -}           { [] }++importdecl :: { LImportDecl GhcPs }+        : 'import' maybe_src maybe_safe optqualified maybe_pkg modid optqualified maybeas maybeimpspec+                {% do {+                  ; let { ; mPreQual = unLoc $4+                          ; mPostQual = unLoc $7 }+                  ; checkImportDecl mPreQual mPostQual+                  ; let anns+                         = EpAnnImportDecl+                             { importDeclAnnImport    = glAA $1+                             , importDeclAnnPragma    = fst $ fst $2+                             , importDeclAnnSafe      = fst $3+                             , importDeclAnnQualified = fst $ importDeclQualifiedStyle mPreQual mPostQual+                             , importDeclAnnPackage   = fst $5+                             , importDeclAnnAs        = fst $8+                             }+                  ; let loc = (comb5 $1 $6 $7 (snd $8) $9);+                  ; fmap reLoc $ acs loc (\loc cs -> L loc $+                      ImportDecl { ideclExt = XImportDeclPass (EpAnn (spanAsAnchor loc) anns cs) (snd $ fst $2) False+                                  , ideclName = $6, ideclPkgQual = snd $5+                                  , ideclSource = snd $2, ideclSafe = snd $3+                                  , ideclQualified = snd $ importDeclQualifiedStyle mPreQual mPostQual+                                  , ideclAs = unLoc (snd $8)+                                  , ideclImportList = unLoc $9 })+                  }+                }+++maybe_src :: { ((Maybe (EpaLocation,EpaLocation),SourceText),IsBootInterface) }+        : '{-# SOURCE' '#-}'        { ((Just (glAA $1,glAA $2),getSOURCE_PRAGs $1)+                                      , IsBoot) }+        | {- empty -}               { ((Nothing,NoSourceText),NotBoot) }++maybe_safe :: { (Maybe EpaLocation,Bool) }+        : 'safe'                                { (Just (glAA $1),True) }+        | {- empty -}                           { (Nothing,      False) }++maybe_pkg :: { (Maybe EpaLocation, RawPkgQual) }+        : STRING  {% do { let { pkgFS = getSTRING $1 }+                        ; unless (looksLikePackageName (unpackFS pkgFS)) $+                             addError $ mkPlainErrorMsgEnvelope (getLoc $1) $+                               (PsErrInvalidPackageName pkgFS)+                        ; return (Just (glAA $1), RawPkgQual (StringLiteral (getSTRINGs $1) pkgFS Nothing)) } }+        | {- empty -}                           { (Nothing,NoRawPkgQual) }++optqualified :: { Located (Maybe EpaLocation) }+        : 'qualified'                           { sL1 $1 (Just (glAA $1)) }+        | {- empty -}                           { noLoc Nothing }++maybeas :: { (Maybe EpaLocation,Located (Maybe (LocatedA ModuleName))) }+        : 'as' modid                           { (Just (glAA $1)+                                                 ,sLL $1 $> (Just $2)) }+        | {- empty -}                          { (Nothing,noLoc Nothing) }++maybeimpspec :: { Located (Maybe (ImportListInterpretation, LocatedL [LIE GhcPs])) }+        : impspec                  {% let (b, ie) = unLoc $1 in+                                       checkImportSpec ie+                                        >>= \checkedIe ->+                                          return (L (gl $1) (Just (b, checkedIe)))  }+        | {- empty -}              { noLoc Nothing }++impspec :: { Located (ImportListInterpretation, LocatedL [LIE GhcPs]) }+        :  '(' importlist ')'               {% do { es <- amsr (sLL $1 $> $ fromOL $ snd $2)+                                                               (AnnList Nothing (Just $ mop $1) (Just $ mcp $3) (fst $2) [])+                                                  ; return $ sLL $1 $> (Exactly, es)} }+        |  'hiding' '(' importlist ')'      {% do { es <- amsr (sLL $1 $> $ fromOL $ snd $3)+                                                               (AnnList Nothing (Just $ mop $2) (Just $ mcp $4) (mj AnnHiding $1:fst $3) [])+                                                  ; return $ sLL $1 $> (EverythingBut, es)} }++importlist :: { ([AddEpAnn], OrdList (LIE GhcPs)) }+        : importlist1     { ([], $1) }+        | {- empty -}     { ([], nilOL) }++        -- trailing comma:+        | importlist1 ',' {% case $1 of+                               SnocOL hs t -> do+                                 t' <- addTrailingCommaA t (gl $2)+                                 return ([], snocOL hs t')}+        | ','             { ([mj AnnComma $1], nilOL) }++importlist1 :: { OrdList (LIE GhcPs) }+        : importlist1 ',' import+                          {% let ls = $1+                             in if isNilOL ls+                                  then return (ls `appOL` $3)+                                  else case ls of+                                         SnocOL hs t -> do+                                           t' <- addTrailingCommaA t (gl $2)+                                           return (snocOL hs t' `appOL` $3)}+        | import          { $1 }++import  :: { OrdList (LIE GhcPs) }+        : qcname_ext export_subspec {% fmap (unitOL . reLoc . (sLL $1 $>)) $ mkModuleImpExp Nothing (fst $ unLoc $2) $1 (snd $ unLoc $2) }+        | 'module' modid            {% fmap (unitOL . reLoc) $ return (sLL $1 $> (IEModuleContents (Nothing, [mj AnnModule $1]) $2)) }+        | 'pattern' qcon            { unitOL $ reLoc $ sLL $1 $> $ IEVar Nothing (sLLa $1 $> (IEPattern (glAA $1) $2)) Nothing }++-----------------------------------------------------------------------------+-- Fixity Declarations++prec    :: { Maybe (Located (SourceText,Int)) }+        : {- empty -}           { Nothing }+        | INTEGER+                 { Just (sL1 $1 (getINTEGERs $1,fromInteger (il_value (getINTEGER $1)))) }++infix   :: { Located FixityDirection }+        : 'infix'                               { sL1 $1 InfixN  }+        | 'infixl'                              { sL1 $1 InfixL  }+        | 'infixr'                              { sL1 $1 InfixR }++ops     :: { Located (OrdList (LocatedN RdrName)) }+        : ops ',' op       {% case (unLoc $1) of+                                SnocOL hs t -> do+                                  t' <- addTrailingCommaN t (gl $2)+                                  return (sLL $1 $> (snocOL hs t' `appOL` unitOL $3)) }+        | op               { sL1 $1 (unitOL $1) }++-----------------------------------------------------------------------------+-- Top-Level Declarations++-- No trailing semicolons, non-empty+topdecls :: { OrdList (LHsDecl GhcPs) }+        : topdecls_semi topdecl        { $1 `snocOL` $2 }++-- May have trailing semicolons, can be empty+topdecls_semi :: { OrdList (LHsDecl GhcPs) }+        : topdecls_semi topdecl semis1 {% do { t <- amsAl $2 (comb2 $2 $3) (reverse $ unLoc $3)+                                             ; return ($1 `snocOL` t) }}+        | {- empty -}                  { nilOL }+++-----------------------------------------------------------------------------+-- Each topdecl accumulates prior comments+-- No trailing semicolons, non-empty+topdecls_cs :: { OrdList (LHsDecl GhcPs) }+        : topdecls_cs_semi topdecl_cs        { $1 `snocOL` $2 }++-- May have trailing semicolons, can be empty+topdecls_cs_semi :: { OrdList (LHsDecl GhcPs) }+        : topdecls_cs_semi topdecl_cs semis1 {% do { t <- amsAl $2 (comb2 $2 $3) (reverse $ unLoc $3)+                                                   ; return ($1 `snocOL` t) }}+        | {- empty -}                  { nilOL }++-- Each topdecl accumulates prior comments+topdecl_cs :: { LHsDecl GhcPs }+topdecl_cs : topdecl {% commentsPA $1 }++-----------------------------------------------------------------------------+topdecl :: { LHsDecl GhcPs }+        : cl_decl                               { L (getLoc $1) (TyClD noExtField (unLoc $1)) }+        | ty_decl                               { L (getLoc $1) (TyClD noExtField (unLoc $1)) }+        | standalone_kind_sig                   { L (getLoc $1) (KindSigD noExtField (unLoc $1)) }+        | inst_decl                             { L (getLoc $1) (InstD noExtField (unLoc $1)) }+        | stand_alone_deriving                  { L (getLoc $1) (DerivD noExtField (unLoc $1)) }+        | role_annot                            { L (getLoc $1) (RoleAnnotD noExtField (unLoc $1)) }+        | 'default' '(' comma_types0 ')'        {% amsA' (sLL $1 $>+                                                    (DefD noExtField (DefaultDecl [mj AnnDefault $1,mop $2,mcp $4] $3))) }+        | 'foreign' fdecl                       {% amsA' (sLL $1 $> ((snd $ unLoc $2) (mj AnnForeign $1:(fst $ unLoc $2)))) }+        | '{-# DEPRECATED' deprecations '#-}'   {% amsA' (sLL $1 $> $ WarningD noExtField (Warnings ([mo $1,mc $3], (getDEPRECATED_PRAGs $1)) (fromOL $2))) }+        | '{-# WARNING' warnings '#-}'          {% amsA' (sLL $1 $> $ WarningD noExtField (Warnings ([mo $1,mc $3], (getWARNING_PRAGs $1)) (fromOL $2))) }+        | '{-# RULES' rules '#-}'               {% amsA' (sLL $1 $> $ RuleD noExtField (HsRules ([mo $1,mc $3], (getRULES_PRAGs $1)) (reverse $2))) }+        | annotation { $1 }+        | decl_no_th                            { $1 }++        -- Template Haskell Extension+        -- The $(..) form is one possible form of infixexp+        -- but we treat an arbitrary expression just as if+        -- it had a $(..) wrapped around it+        | infixexp                              {% runPV (unECP $1) >>= \ $1 ->+                                                       commentsPA $ mkSpliceDecl $1 }++-- Type classes+--+cl_decl :: { LTyClDecl GhcPs }+        : 'class' tycl_hdr fds where_cls+                {% (mkClassDecl (comb4 $1 $2 $3 $4) $2 $3 (sndOf3 $ unLoc $4) (thdOf3 $ unLoc $4))+                        (mj AnnClass $1:(fst $ unLoc $3)++(fstOf3 $ unLoc $4)) }++-- Type declarations (toplevel)+--+ty_decl :: { LTyClDecl GhcPs }+           -- ordinary type synonyms+        : 'type' type '=' ktype+                -- Note ktype, not sigtype, on the right of '='+                -- We allow an explicit for-all but we don't insert one+                -- in   type Foo a = (b,b)+                -- Instead we just say b is out of scope+                --+                -- Note the use of type for the head; this allows+                -- infix type constructors to be declared+                {% mkTySynonym (comb2 $1 $4) $2 $4 [mj AnnType $1,mj AnnEqual $3] }++           -- type family declarations+        | 'type' 'family' type opt_tyfam_kind_sig opt_injective_info+                          where_type_family+                -- Note the use of type for the head; this allows+                -- infix type constructors to be declared+                {% mkFamDecl (comb5 $1 $3 $4 $5 $6) (snd $ unLoc $6) TopLevel $3+                                   (snd $ unLoc $4) (snd $ unLoc $5)+                           (mj AnnType $1:mj AnnFamily $2:(fst $ unLoc $4)+                           ++ (fst $ unLoc $5) ++ (fst $ unLoc $6))  }++          -- ordinary data type or newtype declaration+        | type_data_or_newtype capi_ctype tycl_hdr constrs maybe_derivings+                {% mkTyData (comb4 $1 $3 $4 $5) (sndOf3 $ unLoc $1) (thdOf3 $ unLoc $1) $2 $3+                           Nothing (reverse (snd $ unLoc $4))+                                   (fmap reverse $5)+                           ((fstOf3 $ unLoc $1)++(fst $ unLoc $4)) }+                                   -- We need the location on tycl_hdr in case+                                   -- constrs and deriving are both empty++          -- ordinary GADT declaration+        | type_data_or_newtype capi_ctype tycl_hdr opt_kind_sig+                 gadt_constrlist+                 maybe_derivings+            {% mkTyData (comb5 $1 $3 $4 $5 $6) (sndOf3 $ unLoc $1) (thdOf3 $ unLoc $1) $2 $3+                            (snd $ unLoc $4) (snd $ unLoc $5)+                            (fmap reverse $6)+                            ((fstOf3 $ unLoc $1)++(fst $ unLoc $4)++(fst $ unLoc $5)) }+                                   -- We need the location on tycl_hdr in case+                                   -- constrs and deriving are both empty++          -- data/newtype family+        | 'data' 'family' type opt_datafam_kind_sig+                {% mkFamDecl (comb4 $1 $2 $3 $4) DataFamily TopLevel $3+                                   (snd $ unLoc $4) Nothing+                          (mj AnnData $1:mj AnnFamily $2:(fst $ unLoc $4)) }++-- standalone kind signature+standalone_kind_sig :: { LStandaloneKindSig GhcPs }+  : 'type' sks_vars '::' sigktype+      {% mkStandaloneKindSig (comb2 $1 $4) (L (gl $2) $ unLoc $2) $4+               [mj AnnType $1,mu AnnDcolon $3]}++-- See also: sig_vars+sks_vars :: { Located [LocatedN RdrName] }  -- Returned in reverse order+  : sks_vars ',' oqtycon+      {% case unLoc $1 of+           (h:t) -> do+             h' <- addTrailingCommaN h (gl $2)+             return (sLL $1 $> ($3 : h' : t)) }+  | oqtycon { sL1 $1 [$1] }++inst_decl :: { LInstDecl GhcPs }+        : 'instance' maybe_warning_pragma overlap_pragma inst_type where_inst+       {% do { (binds, sigs, _, ats, adts, _) <- cvBindsAndSigs (snd $ unLoc $5)+             ; let anns = (mj AnnInstance $1 : (fst $ unLoc $5))+             ; let cid = ClsInstDecl+                                  { cid_ext = ($2, anns, NoAnnSortKey)+                                  , cid_poly_ty = $4, cid_binds = binds+                                  , cid_sigs = mkClassOpSigs sigs+                                  , cid_tyfam_insts = ats+                                  , cid_overlap_mode = $3+                                  , cid_datafam_insts = adts }+             ; amsA' (L (comb3 $1 $4 $5)+                             (ClsInstD { cid_d_ext = noExtField, cid_inst = cid }))+                   } }++           -- type instance declarations+        | 'type' 'instance' ty_fam_inst_eqn+                {% mkTyFamInst (comb2 $1 $3) (unLoc $3)+                        (mj AnnType $1:mj AnnInstance $2:[]) }++          -- data/newtype instance declaration+        | data_or_newtype 'instance' capi_ctype datafam_inst_hdr constrs+                          maybe_derivings+            {% mkDataFamInst (comb4 $1 $4 $5 $6) (snd $ unLoc $1) $3 (unLoc $4)+                                      Nothing (reverse (snd  $ unLoc $5))+                                              (fmap reverse $6)+                      ((fst $ unLoc $1):mj AnnInstance $2:(fst $ unLoc $5)) }++          -- GADT instance declaration+        | data_or_newtype 'instance' capi_ctype datafam_inst_hdr opt_kind_sig+                 gadt_constrlist+                 maybe_derivings+            {% mkDataFamInst (comb4 $1 $4 $6 $7) (snd $ unLoc $1) $3 (unLoc $4)+                                   (snd $ unLoc $5) (snd $ unLoc $6)+                                   (fmap reverse $7)+                     ((fst $ unLoc $1):mj AnnInstance $2+                       :(fst $ unLoc $5)++(fst $ unLoc $6)) }++overlap_pragma :: { Maybe (LocatedP OverlapMode) }+  : '{-# OVERLAPPABLE'    '#-}' {% fmap Just $ amsr (sLL $1 $> (Overlappable (getOVERLAPPABLE_PRAGs $1)))+                                       (AnnPragma (mo $1) (mc $2) []) }+  | '{-# OVERLAPPING'     '#-}' {% fmap Just $ amsr (sLL $1 $> (Overlapping (getOVERLAPPING_PRAGs $1)))+                                       (AnnPragma (mo $1) (mc $2) []) }+  | '{-# OVERLAPS'        '#-}' {% fmap Just $ amsr (sLL $1 $> (Overlaps (getOVERLAPS_PRAGs $1)))+                                       (AnnPragma (mo $1) (mc $2) []) }+  | '{-# INCOHERENT'      '#-}' {% fmap Just $ amsr (sLL $1 $> (Incoherent (getINCOHERENT_PRAGs $1)))+                                       (AnnPragma (mo $1) (mc $2) []) }+  | {- empty -}                 { Nothing }++deriv_strategy_no_via :: { LDerivStrategy GhcPs }+  : 'stock'                     {% amsA' (sL1 $1 (StockStrategy [mj AnnStock $1])) }+  | 'anyclass'                  {% amsA' (sL1 $1 (AnyclassStrategy [mj AnnAnyclass $1])) }+  | 'newtype'                   {% amsA' (sL1 $1 (NewtypeStrategy [mj AnnNewtype $1])) }++deriv_strategy_via :: { LDerivStrategy GhcPs }+  : 'via' sigktype          {% amsA' (sLL $1 $> (ViaStrategy (XViaStrategyPs [mj AnnVia $1] $2))) }++deriv_standalone_strategy :: { Maybe (LDerivStrategy GhcPs) }+  : 'stock'                     {% fmap Just $ amsA' (sL1 $1 (StockStrategy [mj AnnStock $1])) }+  | 'anyclass'                  {% fmap Just $ amsA' (sL1 $1 (AnyclassStrategy [mj AnnAnyclass $1])) }+  | 'newtype'                   {% fmap Just $ amsA' (sL1 $1 (NewtypeStrategy [mj AnnNewtype $1])) }+  | deriv_strategy_via          { Just $1 }+  | {- empty -}                 { Nothing }++-- Injective type families++opt_injective_info :: { Located ([AddEpAnn], Maybe (LInjectivityAnn GhcPs)) }+        : {- empty -}               { noLoc ([], Nothing) }+        | '|' injectivity_cond      { sLL $1 $> ([mj AnnVbar $1]+                                                , Just ($2)) }++injectivity_cond :: { LInjectivityAnn GhcPs }+        : tyvarid '->' inj_varids+           {% amsA' (sLL $1 $> (InjectivityAnn [mu AnnRarrow $2] $1 (reverse (unLoc $3)))) }++inj_varids :: { Located [LocatedN RdrName] }+        : inj_varids tyvarid  { sLL $1 $> ($2 : unLoc $1) }+        | tyvarid             { sL1  $1 [$1]               }++-- Closed type families++where_type_family :: { Located ([AddEpAnn],FamilyInfo GhcPs) }+        : {- empty -}                      { noLoc ([],OpenTypeFamily) }+        | 'where' ty_fam_inst_eqn_list+               { sLL $1 $> (mj AnnWhere $1:(fst $ unLoc $2)+                    ,ClosedTypeFamily (fmap reverse $ snd $ unLoc $2)) }++ty_fam_inst_eqn_list :: { Located ([AddEpAnn],Maybe [LTyFamInstEqn GhcPs]) }+        :     '{' ty_fam_inst_eqns '}'     { sLL $1 $> ([moc $1,mcc $3]+                                                ,Just (unLoc $2)) }+        | vocurly ty_fam_inst_eqns close   { let (L loc _) = $2 in+                                             L loc ([],Just (unLoc $2)) }+        |     '{' '..' '}'                 { sLL $1 $> ([moc $1,mj AnnDotdot $2+                                                 ,mcc $3],Nothing) }+        | vocurly '..' close               { let (L loc _) = $2 in+                                             L loc ([mj AnnDotdot $2],Nothing) }++ty_fam_inst_eqns :: { Located [LTyFamInstEqn GhcPs] }+        : ty_fam_inst_eqns ';' ty_fam_inst_eqn+                                      {% let (L loc eqn) = $3 in+                                         case unLoc $1 of+                                           [] -> return (sLL $1 $> (L loc eqn : unLoc $1))+                                           (h:t) -> do+                                             h' <- addTrailingSemiA h (gl $2)+                                             return (sLL $1 $> ($3 : h' : t)) }+        | ty_fam_inst_eqns ';'        {% case unLoc $1 of+                                           [] -> return (sLZ $1 $> (unLoc $1))+                                           (h:t) -> do+                                             h' <- addTrailingSemiA h (gl $2)+                                             return (sLZ $1 $>  (h':t)) }+        | ty_fam_inst_eqn             { sLL $1 $> [$1] }+        | {- empty -}                 { noLoc [] }++ty_fam_inst_eqn :: { LTyFamInstEqn GhcPs }+        : 'forall' tv_bndrs '.' type '=' ktype+              {% do { hintExplicitForall $1+                    ; tvbs <- fromSpecTyVarBndrs $2+                    ; let loc = comb2 $1 $>+                    ; !cs <- getCommentsFor loc+                    ; mkTyFamInstEqn loc (mkHsOuterExplicit (EpAnn (glEE $1 $3) (mu AnnForall $1, mj AnnDot $3) cs) tvbs) $4 $6 [mj AnnEqual $5] }}+        | type '=' ktype+              {% mkTyFamInstEqn (comb2 $1 $>) mkHsOuterImplicit $1 $3 (mj AnnEqual $2:[]) }+              -- Note the use of type for the head; this allows+              -- infix type constructors and type patterns++-- Associated type family declarations+--+-- * They have a different syntax than on the toplevel (no family special+--   identifier).+--+-- * They also need to be separate from instances; otherwise, data family+--   declarations without a kind signature cause parsing conflicts with empty+--   data declarations.+--+at_decl_cls :: { LHsDecl GhcPs }+        :  -- data family declarations, with optional 'family' keyword+          'data' opt_family type opt_datafam_kind_sig+                {% liftM mkTyClD (mkFamDecl (comb3 $1 $3 $4) DataFamily NotTopLevel $3+                                                  (snd $ unLoc $4) Nothing+                        (mj AnnData $1:$2++(fst $ unLoc $4))) }++           -- type family declarations, with optional 'family' keyword+           -- (can't use opt_instance because you get shift/reduce errors+        | 'type' type opt_at_kind_inj_sig+               {% liftM mkTyClD+                        (mkFamDecl (comb3 $1 $2 $3) OpenTypeFamily NotTopLevel $2+                                   (fst . snd $ unLoc $3)+                                   (snd . snd $ unLoc $3)+                         (mj AnnType $1:(fst $ unLoc $3)) )}+        | 'type' 'family' type opt_at_kind_inj_sig+               {% liftM mkTyClD+                        (mkFamDecl (comb3 $1 $3 $4) OpenTypeFamily NotTopLevel $3+                                   (fst . snd $ unLoc $4)+                                   (snd . snd $ unLoc $4)+                         (mj AnnType $1:mj AnnFamily $2:(fst $ unLoc $4)))}++           -- default type instances, with optional 'instance' keyword+        | 'type' ty_fam_inst_eqn+                {% liftM mkInstD (mkTyFamInst (comb2 $1 $2) (unLoc $2)+                          [mj AnnType $1]) }+        | 'type' 'instance' ty_fam_inst_eqn+                {% liftM mkInstD (mkTyFamInst (comb2 $1 $3) (unLoc $3)+                              (mj AnnType $1:mj AnnInstance $2:[]) )}++opt_family   :: { [AddEpAnn] }+              : {- empty -}   { [] }+              | 'family'      { [mj AnnFamily $1] }++opt_instance :: { [AddEpAnn] }+              : {- empty -} { [] }+              | 'instance'  { [mj AnnInstance $1] }++-- Associated type instances+--+at_decl_inst :: { LInstDecl GhcPs }+           -- type instance declarations, with optional 'instance' keyword+        : 'type' opt_instance ty_fam_inst_eqn+                -- Note the use of type for the head; this allows+                -- infix type constructors and type patterns+                {% mkTyFamInst (comb2 $1 $3) (unLoc $3)+                          (mj AnnType $1:$2) }++        -- data/newtype instance declaration, with optional 'instance' keyword+        | data_or_newtype opt_instance capi_ctype datafam_inst_hdr constrs maybe_derivings+               {% mkDataFamInst (comb4 $1 $4 $5 $6) (snd $ unLoc $1) $3 (unLoc $4)+                                    Nothing (reverse (snd $ unLoc $5))+                                            (fmap reverse $6)+                        ((fst $ unLoc $1):$2++(fst $ unLoc $5)) }++        -- GADT instance declaration, with optional 'instance' keyword+        | data_or_newtype opt_instance capi_ctype datafam_inst_hdr opt_kind_sig+                 gadt_constrlist+                 maybe_derivings+                {% mkDataFamInst (comb4 $1 $4 $6 $7) (snd $ unLoc $1) $3+                                (unLoc $4) (snd $ unLoc $5) (snd $ unLoc $6)+                                (fmap reverse $7)+                        ((fst $ unLoc $1):$2++(fst $ unLoc $5)++(fst $ unLoc $6)) }++type_data_or_newtype :: { Located ([AddEpAnn], Bool, NewOrData) }+        : 'data'        { sL1 $1 ([mj AnnData    $1],            False,DataType) }+        | 'newtype'     { sL1 $1 ([mj AnnNewtype $1],            False,NewType) }+        | 'type' 'data' { sL1 $1 ([mj AnnType $1, mj AnnData $2],True ,DataType) }++data_or_newtype :: { Located (AddEpAnn, NewOrData) }+        : 'data'        { sL1 $1 (mj AnnData    $1,DataType) }+        | 'newtype'     { sL1 $1 (mj AnnNewtype $1,NewType) }++-- Family result/return kind signatures++opt_kind_sig :: { Located ([AddEpAnn], Maybe (LHsKind GhcPs)) }+        :               { noLoc     ([]               , Nothing) }+        | '::' kind     { sLL $1 $> ([mu AnnDcolon $1], Just $2) }++opt_datafam_kind_sig :: { Located ([AddEpAnn], LFamilyResultSig GhcPs) }+        :               { noLoc     ([]               , noLocA (NoSig noExtField)         )}+        | '::' kind     { sLL $1 $> ([mu AnnDcolon $1], sLLa $1 $> (KindSig noExtField $2))}++opt_tyfam_kind_sig :: { Located ([AddEpAnn], LFamilyResultSig GhcPs) }+        :              { noLoc     ([]               , noLocA     (NoSig    noExtField)   )}+        | '::' kind    { sLL $1 $> ([mu AnnDcolon $1], sLLa $1 $> (KindSig  noExtField $2))}+        | '='  tv_bndr {% do { tvb <- fromSpecTyVarBndr $2+                             ; return $ sLL $1 $> ([mj AnnEqual $1], sLLa $1 $> (TyVarSig noExtField tvb))} }++opt_at_kind_inj_sig :: { Located ([AddEpAnn], ( LFamilyResultSig GhcPs+                                            , Maybe (LInjectivityAnn GhcPs)))}+        :            { noLoc ([], (noLocA (NoSig noExtField), Nothing)) }+        | '::' kind  { sLL $1 $> ( [mu AnnDcolon $1]+                                 , (sL1a $> (KindSig noExtField $2), Nothing)) }+        | '='  tv_bndr_no_braces '|' injectivity_cond+                {% do { tvb <- fromSpecTyVarBndr $2+                      ; return $ sLL $1 $> ([mj AnnEqual $1, mj AnnVbar $3]+                                           , (sLLa $1 $2 (TyVarSig noExtField tvb), Just $4))} }++-- tycl_hdr parses the header of a class or data type decl,+-- which takes the form+--      T a b+--      Eq a => T a+--      (Eq a, Ord b) => T a b+--      T Int [a]                       -- for associated types+-- Rather a lot of inlining here, else we get reduce/reduce errors+tycl_hdr :: { Located (Maybe (LHsContext GhcPs), LHsType GhcPs) }+        : context '=>' type         {% acs (comb2 $1 $>) (\loc cs -> (L loc (Just (addTrailingDarrowC $1 $2 cs), $3))) }+        | type                      { sL1 $1 (Nothing, $1) }++datafam_inst_hdr :: { Located (Maybe (LHsContext GhcPs), HsOuterFamEqnTyVarBndrs GhcPs, LHsType GhcPs) }+        : 'forall' tv_bndrs '.' context '=>' type   {% hintExplicitForall $1+                                                       >> fromSpecTyVarBndrs $2+                                                         >>= \tvbs ->+                                                             (acs (comb2 $1 $>) (\loc cs -> (L loc+                                                                                  (Just ( addTrailingDarrowC $4 $5 cs)+                                                                                        , mkHsOuterExplicit (EpAnn (glEE $1 $3) (mu AnnForall $1, mj AnnDot $3) emptyComments) tvbs, $6))))+                                                    }+        | 'forall' tv_bndrs '.' type   {% do { hintExplicitForall $1+                                             ; tvbs <- fromSpecTyVarBndrs $2+                                             ; let loc = comb2 $1 $>+                                             ; !cs <- getCommentsFor loc+                                             ; return (sL loc (Nothing, mkHsOuterExplicit (EpAnn (glEE $1 $3) (mu AnnForall $1, mj AnnDot $3) cs) tvbs, $4))+                                       } }+        | context '=>' type         {% acs (comb2 $1 $>) (\loc cs -> (L loc (Just (addTrailingDarrowC $1 $2 cs), mkHsOuterImplicit, $3))) }+        | type                      { sL1 $1 (Nothing, mkHsOuterImplicit, $1) }+++capi_ctype :: { Maybe (LocatedP CType) }+capi_ctype : '{-# CTYPE' STRING STRING '#-}'+                       {% fmap Just $ amsr (sLL $1 $> (CType (getCTYPEs $1) (Just (Header (getSTRINGs $2) (getSTRING $2)))+                                        (getSTRINGs $3,getSTRING $3)))+                              (AnnPragma (mo $1) (mc $4) [mj AnnHeader $2,mj AnnVal $3]) }++           | '{-# CTYPE'        STRING '#-}'+                       {% fmap Just $ amsr (sLL $1 $> (CType (getCTYPEs $1) Nothing (getSTRINGs $2, getSTRING $2)))+                              (AnnPragma (mo $1) (mc $3) [mj AnnVal $2]) }++           |           { Nothing }++-----------------------------------------------------------------------------+-- Stand-alone deriving++-- Glasgow extension: stand-alone deriving declarations+stand_alone_deriving :: { LDerivDecl GhcPs }+  : 'deriving' deriv_standalone_strategy 'instance' maybe_warning_pragma overlap_pragma inst_type+                {% do { let { err = text "in the stand-alone deriving instance"+                                    <> colon <+> quotes (ppr $6) }+                      ; amsA' (sLL $1 $>+                                 (DerivDecl ($4, [mj AnnDeriving $1, mj AnnInstance $3]) (mkHsWildCardBndrs $6) $2 $5)) }}++-----------------------------------------------------------------------------+-- Role annotations++role_annot :: { LRoleAnnotDecl GhcPs }+role_annot : 'type' 'role' oqtycon maybe_roles+          {% mkRoleAnnotDecl (comb3 $1 $4 $3) $3 (reverse (unLoc $4))+                   [mj AnnType $1,mj AnnRole $2] }++-- Reversed!+maybe_roles :: { Located [Located (Maybe FastString)] }+maybe_roles : {- empty -}    { noLoc [] }+            | roles          { $1 }++roles :: { Located [Located (Maybe FastString)] }+roles : role             { sLL $1 $> [$1] }+      | roles role       { sLL $1 $> $ $2 : unLoc $1 }++-- read it in as a varid for better error messages+role :: { Located (Maybe FastString) }+role : VARID             { sL1 $1 $ Just $ getVARID $1 }+     | '_'               { sL1 $1 Nothing }++-- Pattern synonyms++-- Glasgow extension: pattern synonyms+pattern_synonym_decl :: { LHsDecl GhcPs }+        : 'pattern' pattern_synonym_lhs '=' pat+         {%      let (name, args, as ) = $2 in+                 amsA' (sLL $1 $> . ValD noExtField $ mkPatSynBind name args $4+                                                    ImplicitBidirectional+                      (as ++ [mj AnnPattern $1, mj AnnEqual $3])) }++        | 'pattern' pattern_synonym_lhs '<-' pat+         {%    let (name, args, as) = $2 in+               amsA' (sLL $1 $> . ValD noExtField $ mkPatSynBind name args $4 Unidirectional+                       (as ++ [mj AnnPattern $1,mu AnnLarrow $3])) }++        | 'pattern' pattern_synonym_lhs '<-' pat where_decls+            {% do { let (name, args, as) = $2+                  ; mg <- mkPatSynMatchGroup name $5+                  ; amsA' (sLL $1 $> . ValD noExtField $+                           mkPatSynBind name args $4 (ExplicitBidirectional mg)+                            (as ++ [mj AnnPattern $1,mu AnnLarrow $3]))+                   }}++pattern_synonym_lhs :: { (LocatedN RdrName, HsPatSynDetails GhcPs, [AddEpAnn]) }+        : con vars0 { ($1, PrefixCon noTypeArgs $2, []) }+        | varid conop varid { ($2, InfixCon $1 $3, []) }+        | con '{' cvars1 '}' { ($1, RecCon $3, [moc $2, mcc $4] ) }++vars0 :: { [LocatedN RdrName] }+        : {- empty -}                 { [] }+        | varid vars0                 { $1 : $2 }++cvars1 :: { [RecordPatSynField GhcPs] }+       : var                          { [RecordPatSynField (mkFieldOcc $1) $1] }+       | var ',' cvars1               {% do { h <- addTrailingCommaN $1 (gl $2)+                                            ; return ((RecordPatSynField (mkFieldOcc h) h) : $3 )}}++where_decls :: { LocatedL (OrdList (LHsDecl GhcPs)) }+        : 'where' '{' decls '}'       {% amsr (sLL $1 $> (snd $ unLoc $3))+                                              (AnnList (Just $ glR $3) (Just $ moc $2) (Just $ mcc $4) (mj AnnWhere $1: (fst $ unLoc $3)) []) }+        | 'where' vocurly decls close {% amsr (sLL $1 $3 (snd $ unLoc $3))+                                              (AnnList (Just $ glR $3) Nothing Nothing (mj AnnWhere $1: (fst $ unLoc $3)) []) }++pattern_synonym_sig :: { LSig GhcPs }+        : 'pattern' con_list '::' sigtype+                   {% amsA' (sLL $1 $>+                                $ PatSynSig (AnnSig (mu AnnDcolon $3) [mj AnnPattern $1])+                                  (toList $ unLoc $2) $4) }++qvarcon :: { LocatedN RdrName }+        : qvar                          { $1 }+        | qcon                          { $1 }++-----------------------------------------------------------------------------+-- Nested declarations++-- Declaration in class bodies+--+decl_cls  :: { LHsDecl GhcPs }+decl_cls  : at_decl_cls                 { $1 }+          | decl                        { $1 }++          -- A 'default' signature used with the generic-programming extension+          | 'default' infixexp '::' sigtype+                    {% runPV (unECP $2) >>= \ $2 ->+                       do { v <- checkValSigLhs $2+                          ; let err = text "in default signature" <> colon <+>+                                      quotes (ppr $2)+                          ; amsA' (sLL $1 $> $ SigD noExtField $ ClassOpSig (AnnSig (mu AnnDcolon $3) [mj AnnDefault $1]) True [v] $4) }}++decls_cls :: { Located ([AddEpAnn],OrdList (LHsDecl GhcPs)) }  -- Reversed+          : decls_cls ';' decl_cls      {% if isNilOL (snd $ unLoc $1)+                                             then return (sLL $1 $> ((fst $ unLoc $1) ++ (mz AnnSemi $2)+                                                                    , unitOL $3))+                                            else case (snd $ unLoc $1) of+                                              SnocOL hs t -> do+                                                 t' <- addTrailingSemiA t (gl $2)+                                                 return (sLL $1 $> (fst $ unLoc $1+                                                                , snocOL hs t' `appOL` unitOL $3)) }+          | decls_cls ';'               {% if isNilOL (snd $ unLoc $1)+                                             then return (sLZ $1 $> ( (fst $ unLoc $1) ++ (mz AnnSemi $2)+                                                                                   ,snd $ unLoc $1))+                                             else case (snd $ unLoc $1) of+                                               SnocOL hs t -> do+                                                  t' <- addTrailingSemiA t (gl $2)+                                                  return (sLZ $1 $> (fst $ unLoc $1+                                                                 , snocOL hs t')) }+          | decl_cls                    { sL1 $1 ([], unitOL $1) }+          | {- empty -}                 { noLoc ([],nilOL) }++decllist_cls+        :: { Located ([AddEpAnn]+                     , OrdList (LHsDecl GhcPs)+                     , EpLayout) }      -- Reversed+        : '{'         decls_cls '}'     { sLL $1 $> (moc $1:mcc $3:(fst $ unLoc $2)+                                             ,snd $ unLoc $2, epExplicitBraces $1 $3) }+        |     vocurly decls_cls close   { let { L l (anns, decls) = $2 }+                                           in L l (anns, decls, EpVirtualBraces (getVOCURLY $1)) }++-- Class body+--+where_cls :: { Located ([AddEpAnn]+                       ,(OrdList (LHsDecl GhcPs))    -- Reversed+                       ,EpLayout) }+                                -- No implicit parameters+                                -- May have type declarations+        : 'where' decllist_cls          { sLL $1 $> (mj AnnWhere $1:(fstOf3 $ unLoc $2)+                                             ,sndOf3 $ unLoc $2,thdOf3 $ unLoc $2) }+        | {- empty -}                   { noLoc ([],nilOL,EpNoLayout) }++-- Declarations in instance bodies+--+decl_inst  :: { Located (OrdList (LHsDecl GhcPs)) }+decl_inst  : at_decl_inst               { sL1 $1 (unitOL (sL1a $1 (InstD noExtField (unLoc $1)))) }+           | decl                       { sL1 $1 (unitOL $1) }++decls_inst :: { Located ([AddEpAnn],OrdList (LHsDecl GhcPs)) }   -- Reversed+           : decls_inst ';' decl_inst   {% if isNilOL (snd $ unLoc $1)+                                             then return (sLL $1 $> ((fst $ unLoc $1) ++ (mz AnnSemi $2)+                                                                    , unLoc $3))+                                             else case (snd $ unLoc $1) of+                                               SnocOL hs t -> do+                                                  t' <- addTrailingSemiA t (gl $2)+                                                  return (sLL $1 $> (fst $ unLoc $1+                                                                 , snocOL hs t' `appOL` unLoc $3)) }+           | decls_inst ';'             {% if isNilOL (snd $ unLoc $1)+                                             then return (sLZ $1 $> ((fst $ unLoc $1) ++ (mz AnnSemi $2)+                                                                                   ,snd $ unLoc $1))+                                             else case (snd $ unLoc $1) of+                                               SnocOL hs t -> do+                                                  t' <- addTrailingSemiA t (gl $2)+                                                  return (sLZ $1 $> (fst $ unLoc $1+                                                                 , snocOL hs t')) }+           | decl_inst                  { sL1 $1 ([],unLoc $1) }+           | {- empty -}                { noLoc ([],nilOL) }++decllist_inst+        :: { Located ([AddEpAnn]+                     , OrdList (LHsDecl GhcPs)) }      -- Reversed+        : '{'         decls_inst '}'    { sLL $1 $> (moc $1:mcc $3:(fst $ unLoc $2),snd $ unLoc $2) }+        |     vocurly decls_inst close  { L (gl $2) (unLoc $2) }++-- Instance body+--+where_inst :: { Located ([AddEpAnn]+                        , OrdList (LHsDecl GhcPs)) }   -- Reversed+                                -- No implicit parameters+                                -- May have type declarations+        : 'where' decllist_inst         { sLL $1 $> (mj AnnWhere $1:(fst $ unLoc $2)+                                             ,(snd $ unLoc $2)) }+        | {- empty -}                   { noLoc ([],nilOL) }++-- Declarations in binding groups other than classes and instances+--+decls   :: { Located ([AddEpAnn], OrdList (LHsDecl GhcPs)) }+        : decls ';' decl    {% if isNilOL (snd $ unLoc $1)+                                 then return (sLL $1 $> ((fst $ unLoc $1) ++ (msemiA $2)+                                                        , unitOL $3))+                                 else case (snd $ unLoc $1) of+                                   SnocOL hs t -> do+                                      t' <- addTrailingSemiA t (gl $2)+                                      let { this = unitOL $3;+                                            rest = snocOL hs t';+                                            these = rest `appOL` this }+                                      return (rest `seq` this `seq` these `seq`+                                                 (sLL $1 $> (fst $ unLoc $1, these))) }+        | decls ';'          {% if isNilOL (snd $ unLoc $1)+                                  then return (sLZ $1 $> (((fst $ unLoc $1) ++ (msemiA $2)+                                                          ,snd $ unLoc $1)))+                                  else case (snd $ unLoc $1) of+                                    SnocOL hs t -> do+                                       t' <- addTrailingSemiA t (gl $2)+                                       return (sLZ $1 $> (fst $ unLoc $1+                                                      , snocOL hs t')) }+        | decl                          { sL1 $1 ([], unitOL $1) }+        | {- empty -}                   { noLoc ([],nilOL) }++decllist :: { Located (AnnList,Located (OrdList (LHsDecl GhcPs))) }+        : '{'            decls '}'     { sLL $1 $> (AnnList (Just $ glR $2) (Just $ moc $1) (Just $ mcc $3)  (fst $ unLoc $2) []+                                                   ,sL1 $2 $ snd $ unLoc $2) }+        |     vocurly    decls close   { L (gl $2) (AnnList (Just $ glR $2) Nothing Nothing (fst $ unLoc $2) []+                                                   ,sL1 $2 $ snd $ unLoc $2) }++-- Binding groups other than those of class and instance declarations+--+binds   ::  { Located (HsLocalBinds GhcPs) }+                                         -- May have implicit parameters+                                                -- No type declarations+        : decllist          {% do { val_binds <- cvBindGroup (unLoc $ snd $ unLoc $1)+                                  ; !cs <- getCommentsFor (gl $1)+                                  ; return (sL1 $1 $ HsValBinds (fixValbindsAnn $ EpAnn (glR $1) (fst $ unLoc $1) cs) val_binds)} }++        | '{'            dbinds '}'     {% acs (comb3 $1 $2 $3) (\loc cs -> (L loc+                                             $ HsIPBinds (EpAnn (spanAsAnchor (comb3 $1 $2 $3)) (AnnList (Just$ glR $2) (Just $ moc $1) (Just $ mcc $3) [] []) cs) (IPBinds noExtField (reverse $ unLoc $2)))) }++        |     vocurly    dbinds close   {% acs (gl $2) (\loc cs -> (L loc+                                             $ HsIPBinds (EpAnn (glR $1) (AnnList (Just $ glR $2) Nothing Nothing [] []) cs) (IPBinds noExtField (reverse $ unLoc $2)))) }+++wherebinds :: { Maybe (Located (HsLocalBinds GhcPs, Maybe EpAnnComments )) }+                                                -- May have implicit parameters+                                                -- No type declarations+        : 'where' binds                 {% do { r <- acs (comb2 $1 $>) (\loc cs ->+                                                (L loc (annBinds (mj AnnWhere $1) cs (unLoc $2))))+                                              ; return $ Just r} }+        | {- empty -}                   { Nothing }++-----------------------------------------------------------------------------+-- Transformation Rules++rules   :: { [LRuleDecl GhcPs] } -- Reversed+        :  rules ';' rule              {% case $1 of+                                            [] -> return ($3:$1)+                                            (h:t) -> do+                                              h' <- addTrailingSemiA h (gl $2)+                                              return ($3:h':t) }+        |  rules ';'                   {% case $1 of+                                            [] -> return $1+                                            (h:t) -> do+                                              h' <- addTrailingSemiA h (gl $2)+                                              return (h':t) }+        |  rule                        { [$1] }+        |  {- empty -}                 { [] }++rule    :: { LRuleDecl GhcPs }+        : STRING rule_activation rule_foralls infixexp '=' exp+         {%runPV (unECP $4) >>= \ $4 ->+           runPV (unECP $6) >>= \ $6 ->+           amsA' (sLL $1 $> $ HsRule+                                   { rd_ext = (((fstOf3 $3) (mj AnnEqual $5 : (fst $2))), getSTRINGs $1)+                                   , rd_name = L (noAnnSrcSpan $ gl $1) (getSTRING $1)+                                   , rd_act = (snd $2) `orElse` AlwaysActive+                                   , rd_tyvs = sndOf3 $3, rd_tmvs = thdOf3 $3+                                   , rd_lhs = $4, rd_rhs = $6 }) }++-- Rules can be specified to be NeverActive, unlike inline/specialize pragmas+rule_activation :: { ([AddEpAnn],Maybe Activation) }+        -- See Note [%shift: rule_activation -> {- empty -}]+        : {- empty -} %shift                    { ([],Nothing) }+        | rule_explicit_activation              { (fst $1,Just (snd $1)) }++-- This production is used to parse the tilde syntax in pragmas such as+--   * {-# INLINE[~2] ... #-}+--   * {-# SPECIALISE [~ 001] ... #-}+--   * {-# RULES ... [~0] ... g #-}+-- Note that it can be written either+--   without a space [~1]  (the PREFIX_TILDE case), or+--   with    a space [~ 1] (the VARSYM case).+-- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer+rule_activation_marker :: { [AddEpAnn] }+      : PREFIX_TILDE { [mj AnnTilde $1] }+      | VARSYM  {% if (getVARSYM $1 == fsLit "~")+                   then return [mj AnnTilde $1]+                   else do { addError $ mkPlainErrorMsgEnvelope (getLoc $1) $+                               PsErrInvalidRuleActivationMarker+                           ; return [] } }++rule_explicit_activation :: { ([AddEpAnn]+                              ,Activation) }  -- In brackets+        : '[' INTEGER ']'       { ([mos $1,mj AnnVal $2,mcs $3]+                                  ,ActiveAfter  (getINTEGERs $2) (fromInteger (il_value (getINTEGER $2)))) }+        | '[' rule_activation_marker INTEGER ']'+                                { ($2++[mos $1,mj AnnVal $3,mcs $4]+                                  ,ActiveBefore (getINTEGERs $3) (fromInteger (il_value (getINTEGER $3)))) }+        | '[' rule_activation_marker ']'+                                { ($2++[mos $1,mcs $3]+                                  ,NeverActive) }++rule_foralls :: { ([AddEpAnn] -> HsRuleAnn, Maybe [LHsTyVarBndr () GhcPs], [LRuleBndr GhcPs]) }+        : 'forall' rule_vars '.' 'forall' rule_vars '.'    {% let tyvs = mkRuleTyVarBndrs $2+                                                              in hintExplicitForall $1+                                                              >> checkRuleTyVarBndrNames (mkRuleTyVarBndrs $2)+                                                              >> return (\anns -> HsRuleAnn+                                                                          (Just (mu AnnForall $1,mj AnnDot $3))+                                                                          (Just (mu AnnForall $4,mj AnnDot $6))+                                                                          anns,+                                                                         Just (mkRuleTyVarBndrs $2), mkRuleBndrs $5) }+        | 'forall' rule_vars '.'                           { (\anns -> HsRuleAnn Nothing (Just (mu AnnForall $1,mj AnnDot $3)) anns,+                                                              Nothing, mkRuleBndrs $2) }+        -- See Note [%shift: rule_foralls -> {- empty -}]+        | {- empty -}            %shift                    { (\anns -> HsRuleAnn Nothing Nothing anns, Nothing, []) }++rule_vars :: { [LRuleTyTmVar] }+        : rule_var rule_vars                    { $1 : $2 }+        | {- empty -}                           { [] }++rule_var :: { LRuleTyTmVar }+        : varid                         { sL1a $1 (RuleTyTmVar noAnn $1 Nothing) }+        | '(' varid '::' ctype ')'      {% amsA' (sLL $1 $> (RuleTyTmVar [mop $1,mu AnnDcolon $3,mcp $5] $2 (Just $4))) }++{- Note [Parsing explicit foralls in Rules]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+We really want the above definition of rule_foralls to be:++  rule_foralls : 'forall' tv_bndrs '.' 'forall' rule_vars '.'+               | 'forall' rule_vars '.'+               | {- empty -}++where rule_vars (term variables) can be named "family" or "role",+but tv_vars (type variables) cannot be. However, such a definition results+in a reduce/reduce conflict. For example, when parsing:+> {-# RULE "name" forall a ... #-}+before the '...' it is impossible to determine whether we should be in the+first or second case of the above.++This is resolved by using rule_vars (which is more general) for both, and+ensuring that type-level quantified variables do not have the names "forall",+"family", or "role" in the function 'checkRuleTyVarBndrNames' in+GHC.Parser.PostProcess.+Thus, whenever the definition of tyvarid (used for tv_bndrs) is changed relative+to varid (used for rule_vars), 'checkRuleTyVarBndrNames' must be updated.+-}++-----------------------------------------------------------------------------+-- Warnings and deprecations (c.f. rules)++maybe_warning_pragma :: { Maybe (LWarningTxt GhcPs) }+        : '{-# DEPRECATED' strings '#-}'+                            {% fmap Just $ amsr (sLL $1 $> $ DeprecatedTxt (getDEPRECATED_PRAGs $1) (map stringLiteralToHsDocWst $ snd $ unLoc $2))+                                (AnnPragma (mo $1) (mc $3) (fst $ unLoc $2)) }+        | '{-# WARNING' warning_category strings '#-}'+                            {% fmap Just $ amsr (sLL $1 $> $ WarningTxt $2 (getWARNING_PRAGs $1) (map stringLiteralToHsDocWst $ snd $ unLoc $3))+                                (AnnPragma (mo $1) (mc $4) (fst $ unLoc $3))}+        |  {- empty -}      { Nothing }++warning_category :: { Maybe (LocatedE InWarningCategory) }+        : 'in' STRING                  { Just (reLoc $ sLL $1 $> $ InWarningCategory (epTok $1) (getSTRINGs $2)+                                                                    (reLoc $ sL1 $2 $ mkWarningCategory (getSTRING $2))) }+        | {- empty -}                  { Nothing }++warnings :: { OrdList (LWarnDecl GhcPs) }+        : warnings ';' warning         {% if isNilOL $1+                                           then return ($1 `appOL` $3)+                                           else case $1 of+                                             SnocOL hs t -> do+                                              t' <- addTrailingSemiA t (gl $2)+                                              return (snocOL hs t' `appOL` $3) }+        | warnings ';'                 {% if isNilOL $1+                                           then return $1+                                           else case $1 of+                                             SnocOL hs t -> do+                                              t' <- addTrailingSemiA t (gl $2)+                                              return (snocOL hs t') }+        | warning                      { $1 }+        | {- empty -}                  { nilOL }++-- SUP: TEMPORARY HACK, not checking for `module Foo'+warning :: { OrdList (LWarnDecl GhcPs) }+        : warning_category namespace_spec namelist strings+                {% fmap unitOL $ amsA' (L (comb4 $1 $2 $3 $4)+                     (Warning (unLoc $2, fst $ unLoc $4) (unLoc $3)+                              (WarningTxt $1 NoSourceText $ map stringLiteralToHsDocWst $ snd $ unLoc $4))) }++namespace_spec :: { Located NamespaceSpecifier }+  : 'type'      { sL1 $1 $ TypeNamespaceSpecifier (epTok $1) }+  | 'data'      { sL1 $1 $ DataNamespaceSpecifier (epTok $1) }+  | {- empty -} { sL0    $ NoNamespaceSpecifier }++deprecations :: { OrdList (LWarnDecl GhcPs) }+        : deprecations ';' deprecation+                                       {% if isNilOL $1+                                           then return ($1 `appOL` $3)+                                           else case $1 of+                                             SnocOL hs t -> do+                                              t' <- addTrailingSemiA t (gl $2)+                                              return (snocOL hs t' `appOL` $3) }+        | deprecations ';'             {% if isNilOL $1+                                           then return $1+                                           else case $1 of+                                             SnocOL hs t -> do+                                              t' <- addTrailingSemiA t (gl $2)+                                              return (snocOL hs t') }+        | deprecation                  { $1 }+        | {- empty -}                  { nilOL }++-- SUP: TEMPORARY HACK, not checking for `module Foo'+deprecation :: { OrdList (LWarnDecl GhcPs) }+        : namespace_spec namelist strings+             {% fmap unitOL $ amsA' (sL (comb3 $1 $2 $>) $ (Warning (unLoc $1, fst $ unLoc $3) (unLoc $2)+                                          (DeprecatedTxt NoSourceText $ map stringLiteralToHsDocWst $ snd $ unLoc $3))) }++strings :: { Located ([AddEpAnn],[Located StringLiteral]) }+    : STRING { sL1 $1 ([],[L (gl $1) (getStringLiteral $1)]) }+    | '[' stringlist ']' { sLL $1 $> $ ([mos $1,mcs $3],fromOL (unLoc $2)) }++stringlist :: { Located (OrdList (Located StringLiteral)) }+    : stringlist ',' STRING {% if isNilOL (unLoc $1)+                                then return (sLL $1 $> (unLoc $1 `snocOL`+                                                  (L (gl $3) (getStringLiteral $3))))+                                else case (unLoc $1) of+                                   SnocOL hs t -> do+                                     let { t' = addTrailingCommaS t (glAA $2) }+                                     return (sLL $1 $> (snocOL hs t' `snocOL`+                                                  (L (gl $3) (getStringLiteral $3))))++}+    | STRING                { sLL $1 $> (unitOL (L (gl $1) (getStringLiteral $1))) }+    | {- empty -}           { noLoc nilOL }++-----------------------------------------------------------------------------+-- Annotations+annotation :: { LHsDecl GhcPs }+    : '{-# ANN' name_var aexp '#-}'      {% runPV (unECP $3) >>= \ $3 ->+                                            amsA' (sLL $1 $> (AnnD noExtField $ HsAnnotation+                                            (AnnPragma (mo $1) (mc $4) [],+                                            (getANN_PRAGs $1))+                                            (ValueAnnProvenance $2) $3)) }++    | '{-# ANN' 'type' otycon aexp '#-}' {% runPV (unECP $4) >>= \ $4 ->+                                            amsA' (sLL $1 $> (AnnD noExtField $ HsAnnotation+                                            (AnnPragma (mo $1) (mc $5) [mj AnnType $2],+                                            (getANN_PRAGs $1))+                                            (TypeAnnProvenance $3) $4)) }++    | '{-# ANN' 'module' aexp '#-}'      {% runPV (unECP $3) >>= \ $3 ->+                                            amsA' (sLL $1 $> (AnnD noExtField $ HsAnnotation+                                                (AnnPragma (mo $1) (mc $4) [mj AnnModule $2],+                                                (getANN_PRAGs $1))+                                                 ModuleAnnProvenance $3)) }++-----------------------------------------------------------------------------+-- Foreign import and export declarations++fdecl :: { Located ([AddEpAnn], [AddEpAnn] -> HsDecl GhcPs) }+fdecl : 'import' callconv safety fspec+               {% mkImport $2 $3 (snd $ unLoc $4) >>= \i ->+                 return (sLL $1 $> (mj AnnImport $1 : (fst $ unLoc $4),i))  }+      | 'import' callconv        fspec+               {% do { d <- mkImport $2 (noLoc PlaySafe) (snd $ unLoc $3);+                    return (sLL $1 $> (mj AnnImport $1 : (fst $ unLoc $3),d)) }}+      | 'export' callconv fspec+               {% mkExport $2 (snd $ unLoc $3) >>= \i ->+                  return (sLL $1 $> (mj AnnExport $1 : (fst $ unLoc $3),i) ) }++callconv :: { Located CCallConv }+          : 'stdcall'                   { sLL $1 $> StdCallConv }+          | 'ccall'                     { sLL $1 $> CCallConv   }+          | 'capi'                      { sLL $1 $> CApiConv    }+          | 'prim'                      { sLL $1 $> PrimCallConv}+          | 'javascript'                { sLL $1 $> JavaScriptCallConv }++safety :: { Located Safety }+        : 'unsafe'                      { sLL $1 $> PlayRisky }+        | 'safe'                        { sLL $1 $> PlaySafe }+        | 'interruptible'               { sLL $1 $> PlayInterruptible }++fspec :: { Located ([AddEpAnn]+                    ,(Located StringLiteral, LocatedN RdrName, LHsSigType GhcPs)) }+       : STRING var '::' sigtype        { sLL $1 $> ([mu AnnDcolon $3]+                                             ,(L (getLoc $1)+                                                    (getStringLiteral $1), $2, $4)) }+       |        var '::' sigtype        { sLL $1 $> ([mu AnnDcolon $2]+                                             ,(noLoc (StringLiteral NoSourceText nilFS Nothing), $1, $3)) }+         -- if the entity string is missing, it defaults to the empty string;+         -- the meaning of an empty entity string depends on the calling+         -- convention++-----------------------------------------------------------------------------+-- Type signatures++opt_sig :: { Maybe (AddEpAnn, LHsType GhcPs) }+        : {- empty -}                   { Nothing }+        | '::' ctype                    { Just (mu AnnDcolon $1, $2) }++opt_tyconsig :: { ([AddEpAnn], Maybe (LocatedN RdrName)) }+             : {- empty -}              { ([], Nothing) }+             | '::' gtycon              { ([mu AnnDcolon $1], Just $2) }++-- Like ktype, but for types that obey the forall-or-nothing rule.+-- See Note [forall-or-nothing rule] in GHC.Hs.Type.+sigktype :: { LHsSigType GhcPs }+        : sigtype              { $1 }+        | ctype '::' kind      {% amsA' (sLL $1 $> $ mkHsImplicitSigType $+                                         sLLa $1 $> $ HsKindSig [mu AnnDcolon $2] $1 $3) }++-- Like ctype, but for types that obey the forall-or-nothing rule.+-- See Note [forall-or-nothing rule] in GHC.Hs.Type. To avoid duplicating the+-- logic in ctype here, we simply reuse the ctype production and perform+-- surgery on the LHsType it returns to turn it into an LHsSigType.+sigtype :: { LHsSigType GhcPs }+        : ctype                            { hsTypeToHsSigType $1 }++sig_vars :: { Located [LocatedN RdrName] }    -- Returned in reversed order+         : sig_vars ',' var           {% case unLoc $1 of+                                           [] -> return (sLL $1 $> ($3 : unLoc $1))+                                           (h:t) -> do+                                             h' <- addTrailingCommaN h (gl $2)+                                             return (sLL $1 $> ($3 : h' : t)) }+         | var                        { sL1 $1 [$1] }++sigtypes1 :: { OrdList (LHsSigType GhcPs) }+   : sigtype                 { unitOL $1 }+   | sigtype ',' sigtypes1   {% do { st <- addTrailingCommaA $1 (gl $2)+                                   ; return $ unitOL st `appOL` $3 } }+-----------------------------------------------------------------------------+-- Types++unpackedness :: { Located UnpackednessPragma }+        : '{-# UNPACK' '#-}'   { sLL $1 $> (UnpackednessPragma [mo $1, mc $2] (getUNPACK_PRAGs $1) SrcUnpack) }+        | '{-# NOUNPACK' '#-}' { sLL $1 $> (UnpackednessPragma [mo $1, mc $2] (getNOUNPACK_PRAGs $1) SrcNoUnpack) }++forall_telescope :: { Located (HsForAllTelescope GhcPs) }+        : 'forall' tv_bndrs '.'  {% do { hintExplicitForall $1+                                       ; acs (comb2 $1 $>) (\loc cs -> (L loc $+                                           mkHsForAllInvisTele (EpAnn (glEE $1 $>) (mu AnnForall $1,mu AnnDot $3) cs) $2 )) }}+        | 'forall' tv_bndrs '->' {% do { hintExplicitForall $1+                                       ; req_tvbs <- fromSpecTyVarBndrs $2+                                       ; acs (comb2 $1 $>) (\loc cs -> (L loc $+                                           mkHsForAllVisTele (EpAnn (glEE $1 $>) (mu AnnForall $1,mu AnnRarrow $3) cs) req_tvbs )) }}++-- A ktype is a ctype, possibly with a kind annotation+ktype :: { LHsType GhcPs }+        : ctype                { $1 }+        | ctype '::' kind      {% amsA' (sLL $1 $> $ HsKindSig [mu AnnDcolon $2] $1 $3) }++-- A ctype is a for-all type+ctype   :: { LHsType GhcPs }+        : forall_telescope ctype      { sLLa $1 $> $+                                              HsForAllTy { hst_tele = unLoc $1+                                                         , hst_xforall = noExtField+                                                         , hst_body = $2 } }+        | context '=>' ctype          {% acsA (comb2 $1 $>) (\loc cs -> (L loc $+                                            HsQualTy { hst_ctxt = addTrailingDarrowC $1 $2 cs+                                                     , hst_xqual = NoExtField+                                                     , hst_body = $3 })) }++        | ipvar '::' ctype            {% amsA' (sLL $1 $> (HsIParamTy [mu AnnDcolon $2] (reLoc $1) $3)) }+        | type                        { $1 }++----------------------+-- Notes for 'context'+-- We parse a context as a btype so that we don't get reduce/reduce+-- errors in ctype.  The basic problem is that+--      (Eq a, Ord a)+-- looks so much like a tuple type.  We can't tell until we find the =>++context :: { LHsContext GhcPs }+        :  btype                        {% checkContext $1 }++{- Note [GADT decl discards annotations]+~~~~~~~~~~~~~~~~~~~~~+The type production for++    btype `->` ctype++add the AnnRarrow annotation twice, in different places.++This is because if the type is processed as usual, it belongs on the annotations+for the type as a whole.++But if the type is passed to mkGadtDecl, it discards the top level SrcSpan, and+the top-level annotation will be disconnected. Hence for this specific case it+is connected to the first type too.+-}++type :: { LHsType GhcPs }+        -- See Note [%shift: type -> btype]+        : btype %shift                 { $1 }+        | btype '->' ctype             {% amsA' (sLL $1 $>+                                            $ HsFunTy noExtField (HsUnrestrictedArrow (epUniTok $2)) $1 $3) }++        | btype mult '->' ctype        {% hintLinear (getLoc $2)+                                       >> let arr = (unLoc $2) (epUniTok $3)+                                          in amsA' (sLL $1 $> $ HsFunTy noExtField arr $1 $4) }++        | btype '->.' ctype            {% hintLinear (getLoc $2) >>+                                          amsA' (sLL $1 $> $ HsFunTy noExtField (HsLinearArrow (EpLolly (epTok $2))) $1 $3) }+                                              -- [mu AnnLollyU $2] }++mult :: { Located (EpUniToken "->" "\8594" -> HsArrow GhcPs) }+        : PREFIX_PERCENT atype          { sLL $1 $> (mkMultTy (epTok $1) $2) }++btype :: { LHsType GhcPs }+        : infixtype                     {% runPV $1 }++infixtype :: { forall b. DisambTD b => PV (LocatedA b) }+        -- See Note [%shift: infixtype -> ftype]+        : ftype %shift                  { $1 }+        | ftype tyop infixtype          { $1 >>= \ $1 ->+                                          $3 >>= \ $3 ->+                                          do { let (op, prom) = $2+                                             ; when (looksLikeMult $1 op $3) $ hintLinear (getLocA op)+                                             ; mkHsOpTyPV prom $1 op $3 } }+        | unpackedness infixtype        { $2 >>= \ $2 ->+                                          mkUnpackednessPV $1 $2 }++ftype :: { forall b. DisambTD b => PV (LocatedA b) }+        : atype                         { mkHsAppTyHeadPV $1 }+        | tyop                          { failOpFewArgs (fst $1) }+        | ftype tyarg                   { $1 >>= \ $1 ->+                                          mkHsAppTyPV $1 $2 }+        | ftype PREFIX_AT atype         { $1 >>= \ $1 ->+                                          mkHsAppKindTyPV $1 (epTok $2) $3 }++tyarg :: { LHsType GhcPs }+        : atype                         { $1 }+        | unpackedness atype            {% addUnpackednessP $1 $2 }++tyop :: { (LocatedN RdrName, PromotionFlag) }+        : qtyconop                      { ($1, NotPromoted) }+        | tyvarop                       { ($1, NotPromoted) }+        | SIMPLEQUOTE qconop            {% do { op <- amsr (sLL $1 $> (unLoc $2))+                                                           (NameAnnQuote (glAA $1) (gl $2) [])+                                              ; return (op, IsPromoted) } }+        | SIMPLEQUOTE varop             {% do { op <- amsr (sLL $1 $> (unLoc $2))+                                                           (NameAnnQuote (glAA $1) (gl $2) [])+                                              ; return (op, IsPromoted) } }++atype :: { LHsType GhcPs }+        : ntgtycon                       {% amsA' (sL1 $1 (HsTyVar [] NotPromoted $1)) }      -- Not including unit tuples+        -- See Note [%shift: atype -> tyvar]+        | tyvar %shift                   {% amsA' (sL1 $1 (HsTyVar [] NotPromoted $1)) }      -- (See Note [Unit tuples])+        | '*'                            {% do { warnStarIsType (getLoc $1)+                                               ; return $ sL1a $1 (HsStarTy noExtField (isUnicode $1)) } }++        -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer+        | PREFIX_TILDE atype             {% amsA' (sLL $1 $> (mkBangTy [mj AnnTilde $1] SrcLazy $2)) }+        | PREFIX_BANG  atype             {% amsA' (sLL $1 $> (mkBangTy [mj AnnBang $1] SrcStrict $2)) }++        | '{' fielddecls '}'             {% do { decls <- amsA' (sLL $1 $> $ HsRecTy (AnnList (listAsAnchorM $2) (Just $ moc $1) (Just $ mcc $3) [] []) $2)+                                               ; checkRecordSyntax decls }}+                                                        -- Constructor sigs only++        -- List and tuple syntax whose interpretation depends on the extension ListTuplePuns.+        | '(' ')'                        {% amsA' . sLL $1 $> =<< (mkTupleSyntaxTy (glR $1) [] (glR $>)) }+        | '(' ktype ',' comma_types1 ')' {% do { h <- addTrailingCommaA $2 (gl $3)+                                               ; amsA' . sLL $1 $> =<< (mkTupleSyntaxTy (glR $1) (h : $4) (glR $>)) }}+        | '(#' '#)'                   {% do { requireLTPuns PEP_TupleSyntaxType $1 $>+                                            ; amsA' (sLL $1 $> $ HsTupleTy (AnnParen AnnParensHash (glAA $1) (glAA $2)) HsUnboxedTuple []) } }+        | '(#' comma_types1 '#)'      {% do { requireLTPuns PEP_TupleSyntaxType $1 $>+                                            ; amsA' (sLL $1 $> $ HsTupleTy (AnnParen AnnParensHash (glAA $1) (glAA $3)) HsUnboxedTuple $2) } }+        | '(#' bar_types2 '#)'        {% do { requireLTPuns PEP_SumSyntaxType $1 $>+                                      ; amsA' (sLL $1 $> $ HsSumTy (AnnParen AnnParensHash (glAA $1) (glAA $3)) $2) } }+        | '[' ktype ']'               {% amsA' . sLL $1 $> =<< (mkListSyntaxTy1 (glR $1) $2 (glR $3)) }+        | '(' ktype ')'               {% amsA' (sLL $1 $> $ HsParTy  (AnnParen AnnParens       (glAA $1) (glAA $3)) $2) }+                                      -- see Note [Promotion] for the followings+        | SIMPLEQUOTE '(' ')'         {% do { requireLTPuns PEP_QuoteDisambiguation $1 $>+                                            ; amsA' (sLL $1 $> $ HsExplicitTupleTy [mj AnnSimpleQuote $1,mop $2,mcp $3] []) }}+        | SIMPLEQUOTE gen_qcon {% amsA' (sLL $1 $> $ HsTyVar [mj AnnSimpleQuote $1,mjN AnnName $2] IsPromoted $2) }+        | SIMPLEQUOTE sysdcon_nolist {% do { requireLTPuns PEP_QuoteDisambiguation $1 (reLoc $>)+                                           ; amsA' (sLL $1 $> $ HsTyVar [mj AnnSimpleQuote $1,mjN AnnName $2] IsPromoted (L (getLoc $2) $ nameRdrName (dataConName (unLoc $2)))) }}+        | SIMPLEQUOTE  '(' ktype ',' comma_types1 ')'+                             {% do { requireLTPuns PEP_QuoteDisambiguation $1 $>+                                   ; h <- addTrailingCommaA $3 (gl $4)+                                   ; amsA' (sLL $1 $> $ HsExplicitTupleTy [mj AnnSimpleQuote $1,mop $2,mcp $6] (h : $5)) }}+        | '[' ']'               {% withCombinedComments $1 $> (mkListSyntaxTy0 (glR $1) (glR $2)) }+        | SIMPLEQUOTE  '[' comma_types0 ']'     {% do { requireLTPuns PEP_QuoteDisambiguation $1 $>+                                                      ; amsA' (sLL $1 $> $ HsExplicitListTy [mj AnnSimpleQuote $1,mos $2,mcs $4] IsPromoted $3) }}+        | SIMPLEQUOTE var                       {% amsA' (sLL $1 $> $ HsTyVar [mj AnnSimpleQuote $1,mjN AnnName $2] IsPromoted $2) }++        | quasiquote                  { mapLocA (HsSpliceTy noExtField) $1 }+        | splice_untyped              { mapLocA (HsSpliceTy noExtField) $1 }++        -- Two or more [ty, ty, ty] must be a promoted list type, just as+        -- if you had written '[ty, ty, ty]+        -- (One means a list type, zero means the list type constructor,+        -- so you have to quote those.)+        | '[' ktype ',' comma_types1 ']'  {% do { h <- addTrailingCommaA $2 (gl $3)+                                                ; amsA' (sLL $1 $> $ HsExplicitListTy [mos $1,mcs $5] NotPromoted (h:$4)) }}+        | INTEGER              { sLLa $1 $> $ HsTyLit noExtField $ HsNumTy (getINTEGERs $1)+                                                           (il_value (getINTEGER $1)) }+        | CHAR                 { sLLa $1 $> $ HsTyLit noExtField $ HsCharTy (getCHARs $1)+                                                                        (getCHAR $1) }+        | STRING               { sLLa $1 $> $ HsTyLit noExtField $ HsStrTy (getSTRINGs $1)+                                                                     (getSTRING  $1) }+        | '_'                  { sL1a $1 $ mkAnonWildCardTy }+        -- Type variables are never exported, so `M.tyvar` will be rejected by the renamer.+        -- We let it pass the parser because the renamer can generate a better error message.+        | QVARID                      {% let qname = mkQual tvName (getQVARID $1)+                                         in  amsA' (sL1 $1 (HsTyVar [] NotPromoted (sL1n $1 $ qname)))}++-- An inst_type is what occurs in the head of an instance decl+--      e.g.  (Foo a, Gaz b) => Wibble a b+-- It's kept as a single type for convenience.+inst_type :: { LHsSigType GhcPs }+        : sigtype                       { $1 }++deriv_types :: { [LHsSigType GhcPs] }+        : sigktype                      { [$1] }++        | sigktype ',' deriv_types      {% do { h <- addTrailingCommaA $1 (gl $2)+                                           ; return (h : $3) } }++comma_types0  :: { [LHsType GhcPs] }  -- Zero or more:  ty,ty,ty+        : comma_types1                  { $1 }+        | {- empty -}                   { [] }++comma_types1    :: { [LHsType GhcPs] }  -- One or more:  ty,ty,ty+        : ktype                        { [$1] }+        | ktype  ',' comma_types1      {% do { h <- addTrailingCommaA $1 (gl $2)+                                             ; return (h : $3) }}++bar_types2    :: { [LHsType GhcPs] }  -- Two or more:  ty|ty|ty+        : ktype  '|' ktype             {% do { h <- addTrailingVbarA $1 (gl $2)+                                             ; return [h,$3] }}+        | ktype  '|' bar_types2        {% do { h <- addTrailingVbarA $1 (gl $2)+                                             ; return (h : $3) }}++tv_bndrs :: { [LHsTyVarBndr Specificity GhcPs] }+         : tv_bndr tv_bndrs             { $1 : $2 }+         | {- empty -}                  { [] }++tv_bndr :: { LHsTyVarBndr Specificity GhcPs }+        : tv_bndr_no_braces             { $1 }+        | '{' tyvar '}'                 {% amsA' (sLL $1 $> (UserTyVar   [moc $1, mcc $3] InferredSpec $2)) }+        | '{' tyvar '::' kind '}'       {% amsA' (sLL $1 $> (KindedTyVar [moc $1,mu AnnDcolon $3 ,mcc $5] InferredSpec $2 $4)) }++tv_bndr_no_braces :: { LHsTyVarBndr Specificity GhcPs }+        : tyvar                         {% amsA' (sL1 $1    (UserTyVar   [] SpecifiedSpec $1)) }+        | '(' tyvar '::' kind ')'       {% amsA' (sLL $1 $> (KindedTyVar [mop $1,mu AnnDcolon $3 ,mcp $5] SpecifiedSpec $2 $4)) }++fds :: { Located ([AddEpAnn],[LHsFunDep GhcPs]) }+        : {- empty -}                   { noLoc ([],[]) }+        | '|' fds1                      { (sLL $1 $> ([mj AnnVbar $1]+                                                 ,reverse (unLoc $2))) }++fds1 :: { Located [LHsFunDep GhcPs] }+        : fds1 ',' fd   {%+                           do { let (h:t) = unLoc $1 -- Safe from fds1 rules+                              ; h' <- addTrailingCommaA h (gl $2)+                              ; return (sLL $1 $> ($3 : h' : t)) }}+        | fd            { sL1 $1 [$1] }++fd :: { LHsFunDep GhcPs }+        : varids0 '->' varids0  {% amsA' (L (comb3 $1 $2 $3)+                                       (FunDep [mu AnnRarrow $2]+                                               (reverse (unLoc $1))+                                               (reverse (unLoc $3)))) }++varids0 :: { Located [LocatedN RdrName] }+        : {- empty -}                   { noLoc [] }+        | varids0 tyvar                 { sLL $1 $> ($2 : (unLoc $1)) }++-----------------------------------------------------------------------------+-- Kinds++kind :: { LHsKind GhcPs }+        : ctype                  { $1 }++{- Note [Promotion]+   ~~~~~~~~~~~~~~~~++- Syntax of promoted qualified names+We write 'Nat.Zero instead of Nat.'Zero when dealing with qualified+names. Moreover ticks are only allowed in types, not in kinds, for a+few reasons:+  1. we don't need quotes since we cannot define names in kinds+  2. if one day we merge types and kinds, tick would mean look in DataName+  3. we don't have a kind namespace anyway++- Name resolution+When the user write Zero instead of 'Zero in types, we parse it a+HsTyVar ("Zero", TcClsName) instead of HsTyVar ("Zero", DataName). We+deal with this in the renamer. If a HsTyVar ("Zero", TcClsName) is not+bounded in the type level, then we look for it in the term level (we+change its namespace to DataName, see Note [Demotion] in GHC.Types.Names.OccName).+And both become a HsTyVar ("Zero", DataName) after the renamer.++- ListTuplePuns+When this extension is disabled, ticked constructors for lists and tuples are+not accepted, while the unticked variants are unconditionally parsed as data+constructors.++-}+++-----------------------------------------------------------------------------+-- Datatype declarations++gadt_constrlist :: { Located ([AddEpAnn]+                          ,[LConDecl GhcPs]) } -- Returned in order++        : 'where' '{'        gadt_constrs '}'    {% checkEmptyGADTs $+                                                      L (comb2 $1 $4)+                                                        ([mj AnnWhere $1+                                                         ,moc $2+                                                         ,mcc $4]+                                                        , unLoc $3) }+        | 'where' vocurly    gadt_constrs close  {% checkEmptyGADTs $+                                                      L (comb2 $1 $3)+                                                        ([mj AnnWhere $1]+                                                        , unLoc $3) }+        | {- empty -}                            { noLoc ([],[]) }++gadt_constrs :: { Located [LConDecl GhcPs] }+        : gadt_constr ';' gadt_constrs+                  {% do { h <- addTrailingSemiA $1 (gl $2)+                        ; return (L (comb2 $1 $3) (h : unLoc $3)) }}+        | gadt_constr                   { L (glA $1) [$1] }+        | {- empty -}                   { noLoc [] }++-- We allow the following forms:+--      C :: Eq a => a -> T a+--      C :: forall a. Eq a => !a -> T a+--      D { x,y :: a } :: T a+--      forall a. Eq a => D { x,y :: a } :: T a++gadt_constr :: { LConDecl GhcPs }+    -- see Note [Difference in parsing GADT and data constructors]+    -- Returns a list because of:   C,D :: ty+    -- TODO:AZ capture the optSemi. Why leading?+        : optSemi con_list '::' sigtype+                {% mkGadtDecl (comb2 $2 $>) (unLoc $2) (epUniTok $3) $4 }++{- Note [Difference in parsing GADT and data constructors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+GADT constructors have simpler syntax than usual data constructors:+in GADTs, types cannot occur to the left of '::', so they cannot be mixed+with constructor names (see Note [Parsing data constructors is hard]).++Due to simplified syntax, GADT constructor names (left-hand side of '::')+use simpler grammar production than usual data constructor names. As a+consequence, GADT constructor names are restricted (names like '(*)' are+allowed in usual data constructors, but not in GADTs).+-}++constrs :: { Located ([AddEpAnn],[LConDecl GhcPs]) }+        : '=' constrs1    { sLL $1 $2 ([mj AnnEqual $1],unLoc $2)}++constrs1 :: { Located [LConDecl GhcPs] }+        : constrs1 '|' constr+            {% do { let (h:t) = unLoc $1+                  ; h' <- addTrailingVbarA h (gl $2)+                  ; return (sLL $1 $> ($3 : h' : t)) }}+        | constr                         { sL1 $1 [$1] }++constr :: { LConDecl GhcPs }+        : forall context '=>' constr_stuff+                {% amsA' (let (con,details) = unLoc $4 in+                  (L (comb4 $1 $2 $3 $4) (mkConDeclH98+                                                       (mu AnnDarrow $3:(fst $ unLoc $1))+                                                       con+                                                       (snd $ unLoc $1)+                                                       (Just $2)+                                                       details))) }+        | forall constr_stuff+                {% amsA' (let (con,details) = unLoc $2 in+                  (L (comb2 $1 $2) (mkConDeclH98 (fst $ unLoc $1)+                                                      con+                                                      (snd $ unLoc $1)+                                                      Nothing   -- No context+                                                      details))) }++forall :: { Located ([AddEpAnn], Maybe [LHsTyVarBndr Specificity GhcPs]) }+        : 'forall' tv_bndrs '.'       { sLL $1 $> ([mu AnnForall $1,mj AnnDot $3], Just $2) }+        | {- empty -}                 { noLoc ([], Nothing) }++constr_stuff :: { Located (LocatedN RdrName, HsConDeclH98Details GhcPs) }+        : infixtype       {% do { b <- runPV $1+                                ; return (sL1 b (dataConBuilderCon b, dataConBuilderDetails b)) }}+        | '(#' usum_constr '#)' {% let (t, tag, arity) = $2 in pure (sLL $1 $3 $ mkUnboxedSumCon t tag arity)}++usum_constr :: { (LHsType GhcPs, Int, Int) } -- constructor for the data decls SumN#+         : ktype bars { ($1, 1, (snd $2 + 1)) }+         | bars ktype bars0 { ($2, snd $1 + 1, snd $1 + snd $3 + 1) }++fielddecls :: { [LConDeclField GhcPs] }+        : {- empty -}     { [] }+        | fielddecls1     { $1 }++fielddecls1 :: { [LConDeclField GhcPs] }+        : fielddecl ',' fielddecls1+            {% do { h <- addTrailingCommaA $1 (gl $2)+                  ; return (h : $3) }}+        | fielddecl   { [$1] }++fielddecl :: { LConDeclField GhcPs }+                                              -- A list because of   f,g :: Int+        : sig_vars '::' ctype+            {% amsA' (L (comb2 $1 $3)+                      (ConDeclField [mu AnnDcolon $2]+                                    (reverse (map (\ln@(L l n)+                                               -> L (fromTrailingN l) $ FieldOcc noExtField (L (noTrailingN l) n)) (unLoc $1))) $3 Nothing))}++-- Reversed!+maybe_derivings :: { Located (HsDeriving GhcPs) }+        : {- empty -}             { noLoc [] }+        | derivings               { $1 }++-- A list of one or more deriving clauses at the end of a datatype+derivings :: { Located (HsDeriving GhcPs) }+        : derivings deriving      { sLL $1 $> ($2 : unLoc $1) } -- AZ: order?+        | deriving                { sL1 $> [$1] }++-- The outer Located is just to allow the caller to+-- know the rightmost extremity of the 'deriving' clause+deriving :: { LHsDerivingClause GhcPs }+        : 'deriving' deriv_clause_types+              {% let { full_loc = comb2 $1 $> }+                 in amsA' (L full_loc $ HsDerivingClause [mj AnnDeriving $1] Nothing $2) }++        | 'deriving' deriv_strategy_no_via deriv_clause_types+              {% let { full_loc = comb2 $1 $> }+                 in amsA' (L full_loc $ HsDerivingClause [mj AnnDeriving $1] (Just $2) $3) }++        | 'deriving' deriv_clause_types deriv_strategy_via+              {% let { full_loc = comb2 $1 $> }+                 in amsA' (L full_loc $ HsDerivingClause [mj AnnDeriving $1] (Just $3) $2) }++deriv_clause_types :: { LDerivClauseTys GhcPs }+        : qtycon              { let { tc = sL1a $1 $ mkHsImplicitSigType $+                                           sL1a $1 $ HsTyVar noAnn NotPromoted $1 } in+                                sL1a $1 (DctSingle noExtField tc) }+        | '(' ')'             {% amsr (sLL $1 $> (DctMulti noExtField []))+                                      (AnnContext Nothing [glAA $1] [glAA $2]) }+        | '(' deriv_types ')' {% amsr (sLL $1 $> (DctMulti noExtField $2))+                                      (AnnContext Nothing [glAA $1] [glAA $3])}++-----------------------------------------------------------------------------+-- Value definitions++{- Note [Declaration/signature overlap]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There's an awkward overlap with a type signature.  Consider+        f :: Int -> Int = ...rhs...+   Then we can't tell whether it's a type signature or a value+   definition with a result signature until we see the '='.+   So we have to inline enough to postpone reductions until we know.+-}++{-+  ATTENTION: Dirty Hackery Ahead! If the second alternative of vars is var+  instead of qvar, we get another shift/reduce-conflict. Consider the+  following programs:++     { (^^) :: Int->Int ; }          Type signature; only var allowed++     { (^^) :: Int->Int = ... ; }    Value defn with result signature;+                                     qvar allowed (because of instance decls)++  We can't tell whether to reduce var to qvar until after we've read the signatures.+-}++decl_no_th :: { LHsDecl GhcPs }+        : sigdecl               { $1 }++        | infixexp     opt_sig rhs  {% runPV (unECP $1) >>= \ $1 ->+                                       do { let { l = comb2 $1 $> }+                                          ; r <- checkValDef l $1 (HsNoMultAnn noExtField, $2) $3;+                                        -- Depending upon what the pattern looks like we might get either+                                        -- a FunBind or PatBind back from checkValDef. See Note+                                        -- [FunBind vs PatBind]+                                          ; !cs <- getCommentsFor l+                                          ; return $! (sL (commentsA l cs) $ ValD noExtField r) } }+        | PREFIX_PERCENT atype infixexp     opt_sig rhs  {% runPV (unECP $3) >>= \ $3 ->+                                       do { let { l = comb2 $1 $> }+                                          ; r <- checkValDef l $3 (mkMultAnn (epTok $1) $2, $4) $5;+                                        -- parses bindings of the form %p x or+                                        -- %p x :: sig+                                        --+                                        -- Depending upon what the pattern looks like we might get either+                                        -- a FunBind or PatBind back from checkValDef. See Note+                                        -- [FunBind vs PatBind]+                                          ; !cs <- getCommentsFor l+                                          ; return $! (sL (commentsA l cs) $ ValD noExtField r) } }+        | pattern_synonym_decl  { $1 }++decl    :: { LHsDecl GhcPs }+        : decl_no_th            { $1 }++        -- Why do we only allow naked declaration splices in top-level+        -- declarations and not here? Short answer: because readFail009+        -- fails terribly with a panic in cvBindsAndSigs otherwise.+        | splice_exp            { mkSpliceDecl $1 }++rhs     :: { Located (GRHSs GhcPs (LHsExpr GhcPs)) }+        : '=' exp wherebinds    {% runPV (unECP $2) >>= \ $2 ->+                                  do { let L l (bs, csw) = adaptWhereBinds $3+                                     ; let loc = (comb3 $1 $2 (L l bs))+                                     ; let locg = (comb2 $1 $2)+                                     ; acs loc (\loc cs ->+                                       sL loc (GRHSs csw (unguardedRHS (EpAnn (spanAsAnchor locg) (GrhsAnn Nothing (mj AnnEqual $1)) cs) locg $2)+                                                      bs)) } }+        | gdrhs wherebinds      {% do { let {L l (bs, csw) = adaptWhereBinds $2}+                                      ; acs (comb2 $1 (L l bs)) (\loc cs -> L loc+                                                (GRHSs (cs Semi.<> csw) (reverse (unLoc $1)) bs)) }}++gdrhs :: { Located [LGRHS GhcPs (LHsExpr GhcPs)] }+        : gdrhs gdrh            { sLL $1 $> ($2 : unLoc $1) }+        | gdrh                  { sL1 $1 [$1] }++gdrh :: { LGRHS GhcPs (LHsExpr GhcPs) }+        : '|' guardquals '=' exp  {% runPV (unECP $4) >>= \ $4 ->+                                     acsA (comb2 $1 $>) (\loc cs -> L loc $ GRHS (EpAnn (glEE $1 $>) (GrhsAnn (Just $ glAA $1) (mj AnnEqual $3)) cs) (unLoc $2) $4) }++sigdecl :: { LHsDecl GhcPs }+        :+        -- See Note [Declaration/signature overlap] for why we need infixexp here+          infixexp     '::' sigtype+                        {% do { $1 <- runPV (unECP $1)+                              ; v <- checkValSigLhs $1+                              ; amsA' (sLL $1 $> $ SigD noExtField $+                                  TypeSig (AnnSig (mu AnnDcolon $2) []) [v] (mkHsWildCardBndrs $3))} }++        | var ',' sig_vars '::' sigtype+           {% do { v <- addTrailingCommaN $1 (gl $2)+                 ; let sig = TypeSig (AnnSig (mu AnnDcolon $4) []) (v : reverse (unLoc $3))+                                      (mkHsWildCardBndrs $5)+                 ; amsA' (sLL $1 $> $ SigD noExtField sig ) }}++        | infix prec namespace_spec ops+             {% do { mbPrecAnn <- traverse (\l2 -> do { checkPrecP l2 $4+                                                      ; pure (mj AnnVal l2) })+                                       $2+                   ; let (fixText, fixPrec) = case $2 of+                                                -- If an explicit precedence isn't supplied,+                                                -- it defaults to maxPrecedence+                                                Nothing -> (NoSourceText, maxPrecedence)+                                                Just l2 -> (fst $ unLoc l2, snd $ unLoc l2)+                   ; amsA' (sLL $1 $> $ SigD noExtField+                            (FixSig (mj AnnInfix $1 : maybeToList mbPrecAnn) (FixitySig (unLoc $3) (fromOL $ unLoc $4)+                                    (Fixity fixText fixPrec (unLoc $1)))))+                   }}++        | pattern_synonym_sig   { L (getLoc $1) . SigD noExtField . unLoc $ $1 }++        | '{-# COMPLETE' qcon_list opt_tyconsig  '#-}'+                {% let (dcolon, tc) = $3+                   in amsA' (sLL $1 $>+                         (SigD noExtField (CompleteMatchSig ([ mo $1 ] ++ dcolon ++ [mc $4], (getCOMPLETE_PRAGs $1)) $2 tc))) }++        -- This rule is for both INLINE and INLINABLE pragmas+        | '{-# INLINE' activation qvarcon '#-}'+                {% amsA' (sLL $1 $> $ SigD noExtField (InlineSig ((mo $1:fst $2) ++ [mc $4]) $3+                            (mkInlinePragma (getINLINE_PRAGs $1) (getINLINE $1)+                                            (snd $2)))) }+        | '{-# OPAQUE' qvar '#-}'+                {% amsA' (sLL $1 $> $ SigD noExtField (InlineSig [mo $1, mc $3] $2+                            (mkOpaquePragma (getOPAQUE_PRAGs $1)))) }+        | '{-# SCC' qvar '#-}'+          {% amsA' (sLL $1 $> (SigD noExtField (SCCFunSig ([mo $1, mc $3], (getSCC_PRAGs $1)) $2 Nothing))) }++        | '{-# SCC' qvar STRING '#-}'+          {% do { scc <- getSCC $3+                ; let str_lit = StringLiteral (getSTRINGs $3) scc Nothing+                ; amsA' (sLL $1 $> (SigD noExtField (SCCFunSig ([mo $1, mc $4], (getSCC_PRAGs $1)) $2 (Just ( sL1a $3 str_lit))))) }}++        | '{-# SPECIALISE' activation qvar '::' sigtypes1 '#-}'+             {% amsA' (+                 let inl_prag = mkInlinePragma (getSPEC_PRAGs $1)+                                             (NoUserInlinePrag, FunLike) (snd $2)+                  in sLL $1 $> $ SigD noExtField (SpecSig (mo $1:mu AnnDcolon $4:mc $6:(fst $2)) $3 (fromOL $5) inl_prag)) }++        | '{-# SPECIALISE_INLINE' activation qvar '::' sigtypes1 '#-}'+             {% amsA' (sLL $1 $> $ SigD noExtField (SpecSig (mo $1:mu AnnDcolon $4:mc $6:(fst $2)) $3 (fromOL $5)+                               (mkInlinePragma (getSPEC_INLINE_PRAGs $1)+                                               (getSPEC_INLINE $1) (snd $2)))) }++        | '{-# SPECIALISE' 'instance' inst_type '#-}'+                {% amsA' (sLL $1 $> $ SigD noExtField (SpecInstSig ([mo $1,mj AnnInstance $2,mc $4], (getSPEC_PRAGs $1)) $3)) }++        -- A minimal complete definition+        | '{-# MINIMAL' name_boolformula_opt '#-}'+            {% amsA' (sLL $1 $> $ SigD noExtField (MinimalSig ([mo $1,mc $3], (getMINIMAL_PRAGs $1)) $2)) }++activation :: { ([AddEpAnn],Maybe Activation) }+        -- See Note [%shift: activation -> {- empty -}]+        : {- empty -} %shift                    { ([],Nothing) }+        | explicit_activation                   { (fst $1,Just (snd $1)) }++explicit_activation :: { ([AddEpAnn],Activation) }  -- In brackets+        : '[' INTEGER ']'       { ([mj AnnOpenS $1,mj AnnVal $2,mj AnnCloseS $3]+                                  ,ActiveAfter  (getINTEGERs $2) (fromInteger (il_value (getINTEGER $2)))) }+        | '[' rule_activation_marker INTEGER ']'+                                { ($2++[mj AnnOpenS $1,mj AnnVal $3,mj AnnCloseS $4]+                                  ,ActiveBefore (getINTEGERs $3) (fromInteger (il_value (getINTEGER $3)))) }++-----------------------------------------------------------------------------+-- Expressions++quasiquote :: { Located (HsUntypedSplice GhcPs) }+        : TH_QUASIQUOTE   { let { loc = getLoc $1+                                ; ITquasiQuote (quoter, quote, quoteSpan) = unLoc $1+                                ; quoterId = mkUnqual varName quoter }+                            in sL1 $1 (HsQuasiQuote noExtField quoterId (L (noAnnSrcSpan (mkSrcSpanPs quoteSpan)) quote)) }+        | TH_QQUASIQUOTE  { let { loc = getLoc $1+                                ; ITqQuasiQuote (qual, quoter, quote, quoteSpan) = unLoc $1+                                ; quoterId = mkQual varName (qual, quoter) }+                            in sL1 $1 (HsQuasiQuote noExtField quoterId (L (noAnnSrcSpan (mkSrcSpanPs quoteSpan)) quote)) }++exp   :: { ECP }+        : infixexp '::' ctype+                                { ECP $+                                   unECP $1 >>= \ $1 ->+                                   rejectPragmaPV $1 >>+                                   mkHsTySigPV (noAnnSrcSpan $ comb2 $1 $>) $1 $3+                                          [(mu AnnDcolon $2)] }+        | infixexp '-<' exp     {% runPV (unECP $1) >>= \ $1 ->+                                   runPV (unECP $3) >>= \ $3 ->+                                   fmap ecpFromCmd $+                                   amsA' (sLL $1 $> $ HsCmdArrApp (mu Annlarrowtail $2) $1 $3+                                                        HsFirstOrderApp True) }+        | infixexp '>-' exp     {% runPV (unECP $1) >>= \ $1 ->+                                   runPV (unECP $3) >>= \ $3 ->+                                   fmap ecpFromCmd $+                                   amsA' (sLL $1 $> $ HsCmdArrApp (mu Annrarrowtail $2) $3 $1+                                                      HsFirstOrderApp False) }+        | infixexp '-<<' exp    {% runPV (unECP $1) >>= \ $1 ->+                                   runPV (unECP $3) >>= \ $3 ->+                                   fmap ecpFromCmd $+                                   amsA' (sLL $1 $> $ HsCmdArrApp (mu AnnLarrowtail $2) $1 $3+                                                      HsHigherOrderApp True) }+        | infixexp '>>-' exp    {% runPV (unECP $1) >>= \ $1 ->+                                   runPV (unECP $3) >>= \ $3 ->+                                   fmap ecpFromCmd $+                                   amsA' (sLL $1 $> $ HsCmdArrApp (mu AnnRarrowtail $2) $3 $1+                                                      HsHigherOrderApp False) }+        -- See Note [%shift: exp -> infixexp]+        | infixexp %shift       { $1 }+        | exp_prag(exp)         { $1 } -- See Note [Pragmas and operator fixity]++        -- Embed types into expressions and patterns for required type arguments+        | 'type' atype+                {% do { requireExplicitNamespaces (getLoc $1)+                      ; return $ ECP $ mkHsEmbTyPV (comb2 $1 $>) (epTok $1) $2 } }++infixexp :: { ECP }+        : exp10 { $1 }+        | infixexp qop exp10p    -- See Note [Pragmas and operator fixity]+                               { ECP $+                                 superInfixOp $+                                 $2 >>= \ $2 ->+                                 unECP $1 >>= \ $1 ->+                                 unECP $3 >>= \ $3 ->+                                 rejectPragmaPV $1 >>+                                 (mkHsOpAppPV (comb2 $1 $3) $1 $2 $3) }+                 -- AnnVal annotation for NPlusKPat, which discards the operator++exp10p :: { ECP }+  : exp10            { $1 }+  | exp_prag(exp10p) { $1 } -- See Note [Pragmas and operator fixity]++exp_prag(e) :: { ECP }+  : prag_e e  -- See Note [Pragmas and operator fixity]+      {% runPV (unECP $2) >>= \ $2 ->+         fmap ecpFromExp $+         amsA' $ (sLL $1 $> $ HsPragE noExtField (unLoc $1) $2) }++exp10 :: { ECP }+        -- See Note [%shift: exp10 -> '-' fexp]+        : '-' fexp %shift               { ECP $+                                           unECP $2 >>= \ $2 ->+                                           mkHsNegAppPV (comb2 $1 $>) $2+                                                 [mj AnnMinus $1] }+        -- See Note [%shift: exp10 -> fexp]+        | fexp %shift                  { $1 }++optSemi :: { (Maybe EpaLocation,Bool) }+        : ';'         { (msemim $1,True) }+        | {- empty -} { (Nothing,False) }++{- Note [Pragmas and operator fixity]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+'prag_e' is an expression pragma, such as {-# SCC ... #-}.++It must be used with care, or else #15730 happens. Consider this infix+expression:++         1 / 2 / 2++There are two ways to parse it:++    1.   (1 / 2) / 2   =  0.25+    2.   1 / (2 / 2)   =  1.0++Due to the fixity of the (/) operator (assuming it comes from Prelude),+option 1 is the correct parse. However, in the past GHC's parser used to get+confused by the SCC annotation when it occurred in the middle of an infix+expression:++         1 / {-# SCC ann #-} 2 / 2    -- used to get parsed as option 2++There are several ways to address this issue, see GHC Proposal #176 for a+detailed exposition:++  https://github.com/ghc-proposals/ghc-proposals/blob/master/proposals/0176-scc-parsing.rst++The accepted fix is to disallow pragmas that occur within infix expressions.+Infix expressions are assembled out of 'exp10', so 'exp10' must not accept+pragmas. Instead, we accept them in exactly two places:++* at the start of an expression or a parenthesized subexpression:++    f = {-# SCC ann #-} 1 / 2 / 2          -- at the start of the expression+    g = 5 + ({-# SCC ann #-} 1 / 2 / 2)    -- at the start of a parenthesized subexpression++* immediately after the last operator:++    f = 1 / 2 / {-# SCC ann #-} 2++In both cases, the parse does not depend on operator fixity. The second case+may sound unnecessary, but it's actually needed to support a common idiom:++    f $ {-# SCC ann $-} ...++-}+prag_e :: { Located (HsPragE GhcPs) }+      : '{-# SCC' STRING '#-}'      {% do { scc <- getSCC $2+                                          ; return (sLL $1 $>+                                             (HsPragSCC+                                                (AnnPragma (mo $1) (mc $3) [mj AnnValStr $2],+                                                (getSCC_PRAGs $1))+                                                (StringLiteral (getSTRINGs $2) scc Nothing)))} }+      | '{-# SCC' VARID  '#-}'      { sLL $1 $>+                                             (HsPragSCC+                                               (AnnPragma (mo $1) (mc $3) [mj AnnVal $2],+                                               (getSCC_PRAGs $1))+                                               (StringLiteral NoSourceText (getVARID $2) Nothing)) }++fexp    :: { ECP }+        : fexp aexp                  { ECP $+                                          superFunArg $+                                          unECP $1 >>= \ $1 ->+                                          unECP $2 >>= \ $2 ->+                                          spanWithComments (comb2 $1 $>) >>= \l ->+                                          mkHsAppPV l $1 $2 }++        -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer+        | fexp PREFIX_AT atype       { ECP $+                                        unECP $1 >>= \ $1 ->+                                        mkHsAppTypePV (noAnnSrcSpan $ comb2 $1 $>) $1 (epTok $2) $3 }++        | 'static' aexp              {% runPV (unECP $2) >>= \ $2 ->+                                        fmap ecpFromExp $+                                        amsA' (sLL $1 $> $ HsStatic [mj AnnStatic $1] $2) }++        | aexp                       { $1 }++aexp    :: { ECP }+        -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer+        : qvar TIGHT_INFIX_AT aexp+                                { ECP $+                                   unECP $3 >>= \ $3 ->+                                     mkHsAsPatPV (comb2 $1 $>) $1 (epTok $2) $3 }+++        -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer+        | PREFIX_TILDE aexp     { ECP $+                                   unECP $2 >>= \ $2 ->+                                   mkHsLazyPatPV (comb2 $1 $>) $2 [mj AnnTilde $1] }+        | PREFIX_BANG aexp      { ECP $+                                   unECP $2 >>= \ $2 ->+                                   mkHsBangPatPV (comb2 $1 $>) $2 [mj AnnBang $1] }+        | PREFIX_MINUS aexp     { ECP $+                                   unECP $2 >>= \ $2 ->+                                   mkHsNegAppPV (comb2 $1 $>) $2 [mj AnnMinus $1] }+        | 'let' binds 'in' exp          {  ECP $+                                           unECP $4 >>= \ $4 ->+                                           mkHsLetPV (comb2 $1 $>) (epTok $1) (unLoc $2) (epTok $3) $4 }+        | '\\' argpats '->' exp { ECP $+                      unECP $4 >>= \ $4 ->+                      mkHsLamPV (comb2 $1 $>) LamSingle+                            (sLLl $1 $>+                            [sLLa $1 $>+                                         $ Match { m_ext = []+                                                 , m_ctxt = LamAlt LamSingle+                                                 , m_pats = $2+                                                 , m_grhss = unguardedGRHSs (comb2 $3 $4) $4 (EpAnn (glR $3) (GrhsAnn Nothing (mu AnnRarrow $3)) emptyComments) }])+                            [mj AnnLam $1] }+        | '\\' 'lcase' altslist(pats1)+            {  ECP $ $3 >>= \ $3 ->+                 mkHsLamPV (comb3 $1 $2 $>) LamCase $3 [mj AnnLam $1,mj AnnCase $2] }+        | '\\' 'lcases' altslist(argpats)+            {  ECP $ $3 >>= \ $3 ->+                 mkHsLamPV (comb3 $1 $2 $>) LamCases $3 [mj AnnLam $1,mj AnnCases $2] }+        | 'if' exp optSemi 'then' exp optSemi 'else' exp+                         {% runPV (unECP $2) >>= \ ($2 :: LHsExpr GhcPs) ->+                            return $ ECP $+                              unECP $5 >>= \ $5 ->+                              unECP $8 >>= \ $8 ->+                              mkHsIfPV (comb2 $1 $>) $2 (snd $3) $5 (snd $6) $8+                                    (AnnsIf+                                      { aiIf = glAA $1+                                      , aiThen = glAA $4+                                      , aiElse = glAA $7+                                      , aiThenSemi = fst $3+                                      , aiElseSemi = fst $6})}++        | 'if' ifgdpats                 {% hintMultiWayIf (getLoc $1) >>= \_ ->+                                           fmap ecpFromExp $+                                           amsA' (sLL $1 $> $ HsMultiIf (mj AnnIf $1:(fst $ unLoc $2))+                                                     (reverse $ snd $ unLoc $2)) }+        | 'case' exp 'of' altslist(pats1) {% runPV (unECP $2) >>= \ ($2 :: LHsExpr GhcPs) ->+                                             return $ ECP $+                                               $4 >>= \ $4 ->+                                               mkHsCasePV (comb3 $1 $3 $4) $2 $4+                                                    (EpAnnHsCase (glAA $1) (glAA $3) []) }+        -- QualifiedDo.+        | DO  stmtlist               {% do+                                      hintQualifiedDo $1+                                      return $ ECP $+                                        $2 >>= \ $2 ->+                                        mkHsDoPV (comb2 $1 $2)+                                                 (fmap mkModuleNameFS (getDO $1))+                                                 $2+                                                 (AnnList (Just $ glR $2) Nothing Nothing [mj AnnDo $1] []) }+        | MDO stmtlist             {% hintQualifiedDo $1 >> runPV $2 >>= \ $2 ->+                                       fmap ecpFromExp $+                                       amsA' (L (comb2 $1 $2)+                                              (mkHsDoAnns (MDoExpr $+                                                          fmap mkModuleNameFS (getMDO $1))+                                                          $2+                                              (AnnList (Just $ glR $2) Nothing Nothing [mj AnnMdo $1] []) )) }+        | 'proc' aexp '->' exp+                       {% (checkPattern <=< runPV) (unECP $2) >>= \ p ->+                           runPV (unECP $4) >>= \ $4@cmd ->+                           fmap ecpFromExp $+                           amsA' (sLL $1 $> $ HsProc [mj AnnProc $1,mu AnnRarrow $3] p (sLLa $1 $> $ HsCmdTop noExtField cmd)) }++        | aexp1                 { $1 }++aexp1   :: { ECP }+        : aexp1 '{' fbinds '}' { ECP $+                                   getBit OverloadedRecordUpdateBit >>= \ overloaded ->+                                   unECP $1 >>= \ $1 ->+                                   $3 >>= \ $3 ->+                                   mkHsRecordPV overloaded (comb2 $1 $>) (comb2 $2 $4) $1 $3+                                        [moc $2,mcc $4]+                               }++        -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer+        | aexp1 TIGHT_INFIX_PROJ field+            {% runPV (unECP $1) >>= \ $1 ->+               fmap ecpFromExp $ amsA' (+                 let fl = sLLa $2 $> (DotFieldOcc (AnnFieldLabel (Just $ glAA $2)) $3) in+               sLL $1 $> $ mkRdrGetField $1 fl)  }++++        | aexp2                { $1 }++aexp2   :: { ECP }+        : qvar                          { ECP $ mkHsVarPV $! $1 }+        | qcon                          { ECP $ mkHsVarPV $! $1 }+        -- See Note [%shift: aexp2 -> ipvar]+        | ipvar %shift                  {% fmap ecpFromExp+                                           (ams1 $1 (HsIPVar NoExtField $! unLoc $1)) }+        | overloaded_label              {% fmap ecpFromExp+                                           (ams1 $1 (HsOverLabel NoExtField (fst $! unLoc $1) (snd $! unLoc $1))) }+        | literal                       { ECP $ mkHsLitPV $! $1 }+-- This will enable overloaded strings permanently.  Normally the renamer turns HsString+-- into HsOverLit when -XOverloadedStrings is on.+--      | STRING    { sL (getLoc $1) (HsOverLit $! mkHsIsString (getSTRINGs $1)+--                                       (getSTRING $1) noExtField) }+        | INTEGER   { ECP $ mkHsOverLitPV (sL1a $1 $ mkHsIntegral   (getINTEGER  $1)) }+        | RATIONAL  { ECP $ mkHsOverLitPV (sL1a $1 $ mkHsFractional (getRATIONAL $1)) }++        -- N.B.: sections get parsed by these next two productions.+        -- This allows you to write, e.g., '(+ 3, 4 -)', which isn't+        -- correct Haskell (you'd have to write '((+ 3), (4 -))')+        -- but the less cluttered version fell out of having texps.+        | '(' texp ')'                  { ECP $+                                           unECP $2 >>= \ $2 ->+                                           mkHsParPV (comb2 $1 $>) (epTok $1) $2 (epTok $3) }+        | '(' tup_exprs ')'             { ECP $+                                           $2 >>= \ $2 ->+                                           mkSumOrTuplePV (noAnnSrcSpan $ comb2 $1 $>) Boxed $2+                                                [mop $1,mcp $3]}++        -- This case is only possible when 'OverloadedRecordDotBit' is enabled.+        | '(' projection ')'            { ECP $+                                            amsA' (sLL $1 $> $ mkRdrProjection (NE.reverse (unLoc $2)) (AnnProjection (glAA $1) (glAA $3)) )+                                            >>= ecpFromExp'+                                        }++        | '(#' texp '#)'                { ECP $+                                           unECP $2 >>= \ $2 ->+                                           mkSumOrTuplePV (noAnnSrcSpan $ comb2 $1 $>) Unboxed (Tuple [Right $2])+                                                 [moh $1,mch $3] }+        | '(#' tup_exprs '#)'           { ECP $+                                           $2 >>= \ $2 ->+                                           mkSumOrTuplePV (noAnnSrcSpan $ comb2 $1 $>) Unboxed $2+                                                [moh $1,mch $3] }++        | '[' list ']'      { ECP $ $2 (comb2 $1 $>) (mos $1,mcs $3) }+        | '_'               { ECP $ mkHsWildCardPV (getLoc $1) }++        -- Template Haskell Extension+        | splice_untyped { ECP $ mkHsSplicePV $1 }+        | splice_typed   { ecpFromExp $ fmap (uncurry HsTypedSplice) (reLoc $1) }++        | SIMPLEQUOTE  qvar     {% fmap ecpFromExp $ amsA' (sLL $1 $> $ HsUntypedBracket [mj AnnSimpleQuote $1] (VarBr noExtField True  $2)) }+        | SIMPLEQUOTE  qcon     {% fmap ecpFromExp $ amsA' (sLL $1 $> $ HsUntypedBracket [mj AnnSimpleQuote $1] (VarBr noExtField True  $2)) }+        | TH_TY_QUOTE tyvar     {% fmap ecpFromExp $ amsA' (sLL $1 $> $ HsUntypedBracket [mj AnnThTyQuote $1  ] (VarBr noExtField False $2)) }+        | TH_TY_QUOTE gtycon    {% fmap ecpFromExp $ amsA' (sLL $1 $> $ HsUntypedBracket [mj AnnThTyQuote $1  ] (VarBr noExtField False $2)) }+        -- See Note [%shift: aexp2 -> TH_TY_QUOTE]+        | TH_TY_QUOTE %shift    {% reportEmptyDoubleQuotes (getLoc $1) }+        | '[|' exp '|]'       {% runPV (unECP $2) >>= \ $2 ->+                                 fmap ecpFromExp $+                                 amsA' (sLL $1 $> $ HsUntypedBracket (if (hasE $1) then [mj AnnOpenE $1, mu AnnCloseQ $3]+                                                                                         else [mu AnnOpenEQ $1,mu AnnCloseQ $3]) (ExpBr noExtField $2)) }+        | '[||' exp '||]'     {% runPV (unECP $2) >>= \ $2 ->+                                 fmap ecpFromExp $+                                 amsA' (sLL $1 $> $ HsTypedBracket (if (hasE $1) then [mj AnnOpenE $1,mc $3] else [mo $1,mc $3]) $2) }+        | '[t|' ktype '|]'    {% fmap ecpFromExp $+                                 amsA' (sLL $1 $> $ HsUntypedBracket [mo $1,mu AnnCloseQ $3] (TypBr noExtField $2)) }+        | '[p|' infixexp '|]' {% (checkPattern <=< runPV) (unECP $2) >>= \p ->+                                      fmap ecpFromExp $+                                      amsA' (sLL $1 $> $ HsUntypedBracket [mo $1,mu AnnCloseQ $3] (PatBr noExtField p)) }+        | '[d|' cvtopbody '|]' {% fmap ecpFromExp $+                                  amsA' (sLL $1 $> $ HsUntypedBracket (mo $1:mu AnnCloseQ $3:fst $2) (DecBrL noExtField (snd $2))) }+        | quasiquote          { ECP $ mkHsSplicePV $1 }++        -- arrow notation extension+        | '(|' aexp cmdargs '|)'  {% runPV (unECP $2) >>= \ $2 ->+                                      fmap ecpFromCmd $+                                      amsA' (sLL $1 $> $ HsCmdArrForm (AnnList (glRM $1) (Just $ mu AnnOpenB $1) (Just $ mu AnnCloseB $4) [] []) $2 Prefix+                                                           Nothing (reverse $3)) }++projection :: { Located (NonEmpty (LocatedAn NoEpAnns (DotFieldOcc GhcPs))) }+projection+        -- See Note [Whitespace-sensitive operator parsing] in GHC.Parsing.Lexer+        : projection TIGHT_INFIX_PROJ field+                             { sLL $1 $> ((sLLa $2 $> $ DotFieldOcc (AnnFieldLabel (Just $ glAA $2)) $3) `NE.cons` unLoc $1) }+        | PREFIX_PROJ field  { sLL $1 $> ((sLLa $1 $> $ DotFieldOcc (AnnFieldLabel (Just $ glAA $1)) $2) :| [])}++splice_exp :: { LHsExpr GhcPs }+        : splice_untyped { fmap (HsUntypedSplice noExtField) (reLoc $1) }+        | splice_typed   { fmap (uncurry HsTypedSplice) (reLoc $1) }++splice_untyped :: { Located (HsUntypedSplice GhcPs) }+        -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer+        : PREFIX_DOLLAR aexp2   {% runPV (unECP $2) >>= \ $2 ->+                                   return (sLL $1 $> $ HsUntypedSpliceExpr [mj AnnDollar $1] $2) }++splice_typed :: { Located ([AddEpAnn], LHsExpr GhcPs) }+        -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer+        : PREFIX_DOLLAR_DOLLAR aexp2+                                {% runPV (unECP $2) >>= \ $2 ->+                                   return (sLL $1 $> $ ([mj AnnDollarDollar $1], $2)) }++cmdargs :: { [LHsCmdTop GhcPs] }+        : cmdargs acmd                  { $2 : $1 }+        | {- empty -}                   { [] }++acmd    :: { LHsCmdTop GhcPs }+        : aexp                  {% runPV (unECP $1) >>= \ (cmd :: LHsCmd GhcPs) ->+                                   runPV (checkCmdBlockArguments cmd) >>= \ _ ->+                                   return (sL1a cmd $ HsCmdTop noExtField cmd) }++cvtopbody :: { ([AddEpAnn],[LHsDecl GhcPs]) }+        :  '{'            cvtopdecls0 '}'      { ([mj AnnOpenC $1+                                                  ,mj AnnCloseC $3],$2) }+        |      vocurly    cvtopdecls0 close    { ([],$2) }++cvtopdecls0 :: { [LHsDecl GhcPs] }+        : topdecls_semi         { cvTopDecls $1 }+        | topdecls              { cvTopDecls $1 }++-----------------------------------------------------------------------------+-- Tuple expressions++-- "texp" is short for tuple expressions:+-- things that can appear unparenthesized as long as they're+-- inside parens or delimited by commas+texp :: { ECP }+        : exp                           { $1 }++        -- Note [Parsing sections]+        -- ~~~~~~~~~~~~~~~~~~~~~~~+        -- We include left and right sections here, which isn't+        -- technically right according to the Haskell standard.+        -- For example (3 +, True) isn't legal.+        -- However, we want to parse bang patterns like+        --      (!x, !y)+        -- and it's convenient to do so here as a section+        -- Then when converting expr to pattern we unravel it again+        -- Meanwhile, the renamer checks that real sections appear+        -- inside parens.+        | infixexp qop+                             {% runPV (unECP $1) >>= \ $1 ->+                                runPV (rejectPragmaPV $1) >>+                                runPV $2 >>= \ $2 ->+                                return $ ecpFromExp $+                                sLLa $1 $> $ SectionL noExtField $1 (n2l $2) }+        | qopm infixexp      { ECP $+                                superInfixOp $+                                unECP $2 >>= \ $2 ->+                                $1 >>= \ $1 ->+                                mkHsSectionR_PV (comb2 $1 $>) (n2l $1) $2 }++       -- View patterns get parenthesized above+        | exp '->' texp   { ECP $+                             unECP $1 >>= \ $1 ->+                             unECP $3 >>= \ $3 ->+                             mkHsViewPatPV (comb2 $1 $>) $1 $3 [mu AnnRarrow $2] }++-- Always at least one comma or bar.+-- Though this can parse just commas (without any expressions), it won't+-- in practice, because (,,,) is parsed as a name. See Note [ExplicitTuple]+-- in GHC.Hs.Expr.+tup_exprs :: { forall b. DisambECP b => PV (SumOrTuple b) }+           : texp commas_tup_tail+                           { unECP $1 >>= \ $1 ->+                             $2 >>= \ $2 ->+                             do { t <- amsA $1 [AddCommaAnn (srcSpan2e $ fst $2)]+                                ; return (Tuple (Right t : snd $2)) } }+           | commas tup_tail+                 { $2 >>= \ $2 ->+                   do { let {cos = map (\ll -> (Left (EpAnn (spanAsAnchor ll) True emptyComments))) (fst $1) }+                      ; return (Tuple (cos ++ $2)) } }++           | texp bars   { unECP $1 >>= \ $1 -> return $+                            (Sum 1  (snd $2 + 1) $1 [] (map srcSpan2e $ fst $2)) }++           | bars texp bars0+                { unECP $2 >>= \ $2 -> return $+                  (Sum (snd $1 + 1) (snd $1 + snd $3 + 1) $2+                    (map srcSpan2e $ fst $1)+                    (map srcSpan2e $ fst $3)) }++-- Always starts with commas; always follows an expr+commas_tup_tail :: { forall b. DisambECP b => PV (SrcSpan,[Either (EpAnn Bool) (LocatedA b)]) }+commas_tup_tail : commas tup_tail+        { $2 >>= \ $2 ->+          do { let {cos = map (\l -> (Left (EpAnn (spanAsAnchor l) True emptyComments))) (tail $ fst $1) }+             ; return ((head $ fst $1, cos ++ $2)) } }++-- Always follows a comma+tup_tail :: { forall b. DisambECP b => PV [Either (EpAnn Bool) (LocatedA b)] }+          : texp commas_tup_tail { unECP $1 >>= \ $1 ->+                                   $2 >>= \ $2 ->+                                   do { t <- amsA $1 [AddCommaAnn (srcSpan2e $ fst $2)]+                                      ; return (Right t : snd $2) } }+          | texp                 { unECP $1 >>= \ $1 ->+                                   return [Right $1] }+          -- See Note [%shift: tup_tail -> {- empty -}]+          | {- empty -} %shift   { return [Left noAnn] }++-----------------------------------------------------------------------------+-- List expressions++-- The rules below are little bit contorted to keep lexps left-recursive while+-- avoiding another shift/reduce-conflict.+-- Never empty.+list :: { forall b. DisambECP b => SrcSpan -> (AddEpAnn, AddEpAnn) -> PV (LocatedA b) }+        : texp    { \loc (ao,ac) -> unECP $1 >>= \ $1 ->+                            mkHsExplicitListPV loc [$1] (AnnList Nothing (Just ao) (Just ac) [] []) }+        | lexps   { \loc (ao,ac) -> $1 >>= \ $1 ->+                            mkHsExplicitListPV loc (reverse $1) (AnnList Nothing (Just ao) (Just ac) [] []) }+        | texp '..'  { \loc (ao,ac) -> unECP $1 >>= \ $1 ->+                                  amsA' (L loc $ ArithSeq [ao,mj AnnDotdot $2,ac] Nothing (From $1))+                                      >>= ecpFromExp' }+        | texp ',' exp '..' { \loc (ao,ac) ->+                                   unECP $1 >>= \ $1 ->+                                   unECP $3 >>= \ $3 ->+                                   amsA' (L loc $ ArithSeq [ao,mj AnnComma $2,mj AnnDotdot $4,ac] Nothing (FromThen $1 $3))+                                       >>= ecpFromExp' }+        | texp '..' exp  { \loc (ao,ac) ->+                                   unECP $1 >>= \ $1 ->+                                   unECP $3 >>= \ $3 ->+                                   amsA' (L loc $ ArithSeq [ao,mj AnnDotdot $2,ac] Nothing (FromTo $1 $3))+                                       >>= ecpFromExp' }+        | texp ',' exp '..' exp { \loc (ao,ac) ->+                                   unECP $1 >>= \ $1 ->+                                   unECP $3 >>= \ $3 ->+                                   unECP $5 >>= \ $5 ->+                                   amsA' (L loc $ ArithSeq [ao,mj AnnComma $2,mj AnnDotdot $4,ac] Nothing (FromThenTo $1 $3 $5))+                                       >>= ecpFromExp' }+        | texp '|' flattenedpquals+             { \loc (ao,ac) ->+                checkMonadComp >>= \ ctxt ->+                unECP $1 >>= \ $1 -> do { t <- addTrailingVbarA $1 (gl $2)+                ; amsA' (L loc $ mkHsCompAnns ctxt (unLoc $3) t (AnnList Nothing (Just ao) (Just ac) [] []))+                    >>= ecpFromExp' } }++lexps :: { forall b. DisambECP b => PV [LocatedA b] }+        : lexps ',' texp           { $1 >>= \ $1 ->+                                     unECP $3 >>= \ $3 ->+                                     case $1 of+                                       (h:t) -> do+                                         h' <- addTrailingCommaA h (gl $2)+                                         return (((:) $! $3) $! (h':t)) }+        | texp ',' texp             { unECP $1 >>= \ $1 ->+                                      unECP $3 >>= \ $3 ->+                                      do { h <- addTrailingCommaA $1 (gl $2)+                                         ; return [$3,h] }}++-----------------------------------------------------------------------------+-- List Comprehensions++flattenedpquals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] }+    : pquals   { case (unLoc $1) of+                    [qs] -> sL1 $1 qs+                    -- We just had one thing in our "parallel" list so+                    -- we simply return that thing directly++                    qss -> sL1 $1 [sL1a $1 $ ParStmt noExtField [ParStmtBlock noExtField qs [] noSyntaxExpr |+                                            qs <- qss]+                                            noExpr noSyntaxExpr]+                    -- We actually found some actual parallel lists so+                    -- we wrap them into as a ParStmt+                }++pquals :: { Located [[LStmt GhcPs (LHsExpr GhcPs)]] }+    : squals '|' pquals+                     {% case unLoc $1 of+                          (h:t) -> do+                            h' <- addTrailingVbarA h (gl $2)+                            return (sLL $1 $> (reverse (h':t) : unLoc $3)) }+    | squals         { L (getLoc $1) [reverse (unLoc $1)] }++squals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] }   -- In reverse order, because the last+                                        -- one can "grab" the earlier ones+    : squals ',' transformqual+             {% case unLoc $1 of+                  (h:t) -> do+                    h' <- addTrailingCommaA h (gl $2)+                    return (sLL $1 $> [sLLa $1 $> ((unLoc $3) (reverse (h':t)))]) }+    | squals ',' qual+             {% runPV $3 >>= \ $3 ->+                case unLoc $1 of+                  (h:t) -> do+                    h' <- addTrailingCommaA h (gl $2)+                    return (sLL $1 $> ($3 : (h':t))) }+    | transformqual        { sLL $1 $> [L (getLocAnn $1) ((unLoc $1) [])] }+    | qual                               {% runPV $1 >>= \ $1 ->+                                            return $ sL1 $1 [$1] }+--  | transformquals1 ',' '{|' pquals '|}'   { sLL $1 $> ($4 : unLoc $1) }+--  | '{|' pquals '|}'                       { sL1 $1 [$2] }++-- It is possible to enable bracketing (associating) qualifier lists+-- by uncommenting the lines with {| |} above. Due to a lack of+-- consensus on the syntax, this feature is not being used until we+-- get user demand.++transformqual :: { Located ([LStmt GhcPs (LHsExpr GhcPs)] -> Stmt GhcPs (LHsExpr GhcPs)) }+                        -- Function is applied to a list of stmts *in order*+    : 'then' exp              {% runPV (unECP $2) >>= \ $2 ->+                                 return (+                                 sLL $1 $> (\ss -> (mkTransformStmt [mj AnnThen $1] ss $2))) }+    | 'then' exp 'by' exp     {% runPV (unECP $2) >>= \ $2 ->+                                 runPV (unECP $4) >>= \ $4 ->+                                 return (sLL $1 $> (\ss -> (mkTransformByStmt [mj AnnThen $1,mj AnnBy $3] ss $2 $4))) }+    | 'then' 'group' 'using' exp+            {% runPV (unECP $4) >>= \ $4 ->+               return (sLL $1 $> (\ss -> (mkGroupUsingStmt [mj AnnThen $1,mj AnnGroup $2,mj AnnUsing $3] ss $4))) }++    | 'then' 'group' 'by' exp 'using' exp+            {% runPV (unECP $4) >>= \ $4 ->+               runPV (unECP $6) >>= \ $6 ->+               return (sLL $1 $> (\ss -> (mkGroupByUsingStmt [mj AnnThen $1,mj AnnGroup $2,mj AnnBy $3,mj AnnUsing $5] ss $4 $6))) }++-- Note that 'group' is a special_id, which means that you can enable+-- TransformListComp while still using Data.List.group. However, this+-- introduces a shift/reduce conflict. Happy chooses to resolve the conflict+-- in by choosing the "group by" variant, which is what we want.++-----------------------------------------------------------------------------+-- Guards++guardquals :: { Located [LStmt GhcPs (LHsExpr GhcPs)] }+    : guardquals1           { L (getLoc $1) (reverse (unLoc $1)) }++guardquals1 :: { Located [LStmt GhcPs (LHsExpr GhcPs)] }+    : guardquals1 ',' qual  {% runPV $3 >>= \ $3 ->+                               case unLoc $1 of+                                 (h:t) -> do+                                   h' <- addTrailingCommaA h (gl $2)+                                   return (sLL $1 $> ($3 : (h':t))) }+    | qual                  {% runPV $1 >>= \ $1 ->+                               return $ sL1 $1 [$1] }++-----------------------------------------------------------------------------+-- Case alternatives++altslist(PATS) :: { forall b. DisambECP b => PV (LocatedL [LMatch GhcPs (LocatedA b)]) }+        : '{'        alts(PATS) '}'    { $2 >>= \ $2 -> amsr+                                           (sLL $1 $> (reverse (snd $ unLoc $2)))+                                           (AnnList (Just $ glR $2) (Just $ moc $1) (Just $ mcc $3) (fst $ unLoc $2) []) }+        | vocurly    alts(PATS)  close { $2 >>= \ $2 -> amsr+                                           (L (getLoc $2) (reverse (snd $ unLoc $2)))+                                           (AnnList (Just $ glR $2) Nothing Nothing (fst $ unLoc $2) []) }+        | '{'              '}'   { amsr (sLL $1 $> []) (AnnList Nothing (Just $ moc $1) (Just $ mcc $2) [] []) }+        | vocurly          close { return $ noLocA [] }++alts(PATS) :: { forall b. DisambECP b => PV (Located ([AddEpAnn],[LMatch GhcPs (LocatedA b)])) }+        : alts1(PATS)              { $1 >>= \ $1 -> return $+                                     sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }+        | ';' alts(PATS)           { $2 >>= \ $2 -> return $+                                     sLL $1 $> (((mz AnnSemi $1) ++ (fst $ unLoc $2) )+                                               ,snd $ unLoc $2) }++alts1(PATS) :: { forall b. DisambECP b => PV (Located ([AddEpAnn],[LMatch GhcPs (LocatedA b)])) }+        : alts1(PATS) ';' alt(PATS) { $1 >>= \ $1 ->+                                        $3 >>= \ $3 ->+                                          case snd $ unLoc $1 of+                                            [] -> return (sLL $1 $> ((fst $ unLoc $1) ++ (mz AnnSemi $2)+                                                                            ,[$3]))+                                            (h:t) -> do+                                              h' <- addTrailingSemiA h (gl $2)+                                              return (sLL $1 $> (fst $ unLoc $1,$3 : h' : t)) }+        | alts1(PATS) ';'           {  $1 >>= \ $1 ->+                                         case snd $ unLoc $1 of+                                           [] -> return (sLZ $1 $> ((fst $ unLoc $1) ++ (mz AnnSemi $2)+                                                                           ,[]))+                                           (h:t) -> do+                                             h' <- addTrailingSemiA h (gl $2)+                                             return (sLZ $1 $> (fst $ unLoc $1, h' : t)) }+        | alt(PATS)                 { $1 >>= \ $1 -> return $ sL1 $1 ([],[$1]) }++alt(PATS) :: { forall b. DisambECP b => PV (LMatch GhcPs (LocatedA b)) }+        : PATS alt_rhs { $2 >>= \ $2 ->+                         amsA' (sLLAsl $1 $>+                                         (Match { m_ext = []+                                                , m_ctxt = CaseAlt -- for \case and \cases, this will be changed during post-processing+                                                , m_pats = $1+                                                , m_grhss = unLoc $2 }))}++alt_rhs :: { forall b. DisambECP b => PV (Located (GRHSs GhcPs (LocatedA b))) }+        : ralt wherebinds           { $1 >>= \alt ->+                                      do { let {L l (bs, csw) = adaptWhereBinds $2}+                                         ; acs (comb2 alt (L l bs)) (\loc cs -> L loc (GRHSs (cs Semi.<> csw) (unLoc alt) bs)) }}++ralt :: { forall b. DisambECP b => PV (Located [LGRHS GhcPs (LocatedA b)]) }+        : '->' exp            { unECP $2 >>= \ $2 ->+                                acs (comb2 $1 $>) (\loc cs -> L loc (unguardedRHS (EpAnn (spanAsAnchor $ comb2 $1 $2) (GrhsAnn Nothing (mu AnnRarrow $1)) cs) (comb2 $1 $2) $2)) }+        | gdpats              { $1 >>= \gdpats ->+                                return $ sL1 gdpats (reverse (unLoc gdpats)) }++gdpats :: { forall b. DisambECP b => PV (Located [LGRHS GhcPs (LocatedA b)]) }+        : gdpats gdpat { $1 >>= \gdpats ->+                         $2 >>= \gdpat ->+                         return $ sLL gdpats gdpat (gdpat : unLoc gdpats) }+        | gdpat        { $1 >>= \gdpat -> return $ sL1 gdpat [gdpat] }++-- layout for MultiWayIf doesn't begin with an open brace, because it's hard to+-- generate the open brace in addition to the vertical bar in the lexer, and+-- we don't need it.+ifgdpats :: { Located ([AddEpAnn],[LGRHS GhcPs (LHsExpr GhcPs)]) }+         : '{' gdpats '}'                 {% runPV $2 >>= \ $2 ->+                                             return $ sLL $1 $> ([moc $1,mcc $3],unLoc $2)  }+         |     gdpats close               {% runPV $1 >>= \ $1 ->+                                             return $ sL1 $1 ([],unLoc $1) }++gdpat   :: { forall b. DisambECP b => PV (LGRHS GhcPs (LocatedA b)) }+        : '|' guardquals '->' exp+                                   { unECP $4 >>= \ $4 ->+                                     acsA (comb2 $1 $>) (\loc cs -> sL loc $ GRHS (EpAnn (glEE $1 $>) (GrhsAnn (Just $ glAA $1) (mu AnnRarrow $3)) cs) (unLoc $2) $4) }++-- 'pat' recognises a pattern, including one with a bang at the top+--      e.g.  "!x" or "!(x,y)" or "C a b" etc+-- Bangs inside are parsed as infix operator applications, so that+-- we parse them right when bang-patterns are off+pat     :: { LPat GhcPs }+pat     :  exp          {% (checkPattern <=< runPV) (unECP $1) }++-- 'pats1' does the same thing as 'pat', but returns it as a singleton+-- list so that it can be used with a parameterized production rule+--+-- It is used only for parsing patterns in `\case` and `case of`+pats1   :: { [LPat GhcPs] }+pats1   : pat { [ $1 ] }++bindpat :: { LPat GhcPs }+bindpat :  exp            {% -- See Note [Parser-Validator Details] in GHC.Parser.PostProcess+                             checkPattern_details incompleteDoBlock+                                              (unECP $1) }++argpat   :: { LPat GhcPs }+argpat    : apat                  { $1 }+          | PREFIX_AT atype       { sLLa $1 $> (InvisPat (epTok $1) (mkHsTyPat $2)) }++argpats :: { [LPat GhcPs] }+          : argpat argpats            { $1 : $2 }+          | {- empty -}               { [] }+++apat   :: { LPat GhcPs }+apat    : aexp                  {% (checkPattern <=< runPV) (unECP $1) }++apats  :: { [LPat GhcPs] }+        : apat apats            { $1 : $2 }+        | {- empty -}           { [] }++-----------------------------------------------------------------------------+-- Statement sequences++stmtlist :: { forall b. DisambECP b => PV (LocatedL [LocatedA (Stmt GhcPs (LocatedA b))]) }+        : '{'           stmts '}'       { $2 >>= \ $2 ->+                                          amsr (sLL $1 $> (reverse $ snd $ unLoc $2)) (AnnList (stmtsAnchor $2) (Just $ moc $1) (Just $ mcc $3) (fromOL $ fst $ unLoc $2) []) }+        |     vocurly   stmts close     { $2 >>= \ $2 -> amsr+                                          (L (stmtsLoc $2) (reverse $ snd $ unLoc $2)) (AnnList (stmtsAnchor $2) Nothing Nothing (fromOL $ fst $ unLoc $2) []) }++--      do { ;; s ; s ; ; s ;; }+-- The last Stmt should be an expression, but that's hard to enforce+-- here, because we need too much lookahead if we see do { e ; }+-- So we use BodyStmts throughout, and switch the last one over+-- in ParseUtils.checkDo instead++stmts :: { forall b. DisambECP b => PV (Located (OrdList AddEpAnn,[LStmt GhcPs (LocatedA b)])) }+        : stmts ';' stmt  { $1 >>= \ $1 ->+                            $3 >>= \ ($3 :: LStmt GhcPs (LocatedA b)) ->+                            case (snd $ unLoc $1) of+                              [] -> return (sLL $1 $> ((fst $ unLoc $1) `snocOL` (mj AnnSemi $2)+                                                     ,$3   : (snd $ unLoc $1)))+                              (h:t) -> do+                               { h' <- addTrailingSemiA h (gl $2)+                               ; return $ sLL $1 $> (fst $ unLoc $1,$3 :(h':t)) }}++        | stmts ';'     {  $1 >>= \ $1 ->+                           case (snd $ unLoc $1) of+                             [] -> return (sLZ $1 $> ((fst $ unLoc $1) `snocOL` (mj AnnSemi $2),snd $ unLoc $1))+                             (h:t) -> do+                               { h' <- addTrailingSemiA h (gl $2)+                               ; return $ sLZ $1 $> (fst $ unLoc $1,h':t) }}+        | stmt                   { $1 >>= \ $1 ->+                                   return $ sL1 $1 (nilOL,[$1]) }+        | {- empty -}            { return $ noLoc (nilOL,[]) }+++-- For typing stmts at the GHCi prompt, where+-- the input may consist of just comments.+maybe_stmt :: { Maybe (LStmt GhcPs (LHsExpr GhcPs)) }+        : stmt                          {% fmap Just (runPV $1) }+        | {- nothing -}                 { Nothing }++-- For GHC API.+e_stmt :: { LStmt GhcPs (LHsExpr GhcPs) }+        : stmt                          {% runPV $1 }++stmt  :: { forall b. DisambECP b => PV (LStmt GhcPs (LocatedA b)) }+        : qual                          { $1 }+        | 'rec' stmtlist                {  $2 >>= \ $2 ->+                                           amsA' (sLL $1 $> $ mkRecStmt (hsDoAnn $1 $2 AnnRec) $2) }++qual  :: { forall b. DisambECP b => PV (LStmt GhcPs (LocatedA b)) }+    : bindpat '<-' exp                   { unECP $3 >>= \ $3 ->+                                           amsA' (sLL $1 $> $ mkPsBindStmt [mu AnnLarrow $2] $1 $3) }+    | exp                                { unECP $1 >>= \ $1 ->+                                           return $ sL1a $1 $ mkBodyStmt $1 }+    | 'let' binds                        { amsA' (sLL $1 $> $ mkLetStmt [mj AnnLet $1] (unLoc $2)) }++-----------------------------------------------------------------------------+-- Record Field Update/Construction++fbinds  :: { forall b. DisambECP b => PV ([Fbind b], Maybe SrcSpan) }+        : fbinds1                       { $1 }+        | {- empty -}                   { return ([], Nothing) }++fbinds1 :: { forall b. DisambECP b => PV ([Fbind b], Maybe SrcSpan) }+        : fbind ',' fbinds1+                 { $1 >>= \ $1 ->+                   $3 >>= \ $3 -> do+                   h <- addTrailingCommaFBind $1 (gl $2)+                   return (case $3 of (flds, dd) -> (h : flds, dd)) }+        | fbind                         { $1 >>= \ $1 ->+                                          return ([$1], Nothing) }+        | '..'                          { return ([],   Just (getLoc $1)) }++fbind   :: { forall b. DisambECP b => PV (Fbind b) }+        : qvar '=' texp  { unECP $3 >>= \ $3 ->+                           fmap Left $ amsA' (sLL $1 $> $ HsFieldBind [mj AnnEqual $2] (sL1a $1 $ mkFieldOcc $1) $3 False) }+                        -- RHS is a 'texp', allowing view patterns (#6038)+                        -- and, incidentally, sections.  Eg+                        -- f (R { x = show -> s }) = ...++        | qvar          { placeHolderPunRhs >>= \rhs ->+                          fmap Left $ amsA' (sL1 $1 $ HsFieldBind [] (sL1a $1 $ mkFieldOcc $1) rhs True) }+                        -- In the punning case, use a place-holder+                        -- The renamer fills in the final value++        -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer+        -- AZ: need to pull out the let block into a helper+        | field TIGHT_INFIX_PROJ fieldToUpdate '=' texp+                        { do+                            let top = sL1a $1 $ DotFieldOcc noAnn $1+                                ((L lf (DotFieldOcc _ f)):t) = reverse (unLoc $3)+                                lf' = comb2 $2 (L lf ())+                                fields = top : L (noAnnSrcSpan lf') (DotFieldOcc (AnnFieldLabel (Just $ glAA $2))  f) : t+                                final = last fields+                                l = comb2 $1 $3+                                isPun = False+                            $5 <- unECP $5+                            fmap Right $ mkHsProjUpdatePV (comb2 $1 $5) (L l fields) $5 isPun+                                            [mj AnnEqual $4]+                        }++        -- See Note [Whitespace-sensitive operator parsing] in GHC.Parser.Lexer+        -- AZ: need to pull out the let block into a helper+        | field TIGHT_INFIX_PROJ fieldToUpdate+                        { do+                            let top =  sL1a $1 $ DotFieldOcc noAnn $1+                                ((L lf (DotFieldOcc _ f)):t) = reverse (unLoc $3)+                                lf' = comb2 $2 (L lf ())+                                fields = top : L (noAnnSrcSpan lf') (DotFieldOcc (AnnFieldLabel (Just $ glAA $2)) f) : t+                                final = last fields+                                l = comb2 $1 $3+                                isPun = True+                            var <- mkHsVarPV (L (noAnnSrcSpan $ getLocA final) (mkRdrUnqual . mkVarOccFS . field_label . unLoc . dfoLabel . unLoc $ final))+                            fmap Right $ mkHsProjUpdatePV l (L l fields) var isPun []+                        }++fieldToUpdate :: { Located [LocatedAn NoEpAnns (DotFieldOcc GhcPs)] }+fieldToUpdate+        -- See Note [Whitespace-sensitive operator parsing] in Lexer.x+        : fieldToUpdate TIGHT_INFIX_PROJ field   { sLL $1 $> ((sLLa $2 $> (DotFieldOcc (AnnFieldLabel $ Just $ glAA $2) $3)) : unLoc $1) }+        | field       { sL1 $1 [sL1a $1 (DotFieldOcc (AnnFieldLabel Nothing) $1)] }++-----------------------------------------------------------------------------+-- Implicit Parameter Bindings++dbinds  :: { Located [LIPBind GhcPs] } -- reversed+        : dbinds ';' dbind+                      {% case unLoc $1 of+                           (h:t) -> do+                             h' <- addTrailingSemiA h (gl $2)+                             return (let { this = $3; rest = h':t }+                                in rest `seq` this `seq` sLL $1 $> (this : rest)) }+        | dbinds ';'  {% case unLoc $1 of+                           (h:t) -> do+                             h' <- addTrailingSemiA h (gl $2)+                             return (sLZ $1 $> (h':t)) }+        | dbind                        { let this = $1 in this `seq` (sL1 $1 [this]) }+--      | {- empty -}                  { [] }++dbind   :: { LIPBind GhcPs }+dbind   : ipvar '=' exp                {% runPV (unECP $3) >>= \ $3 ->+                                          amsA' (sLL $1 $> (IPBind [mj AnnEqual $2] (reLoc $1) $3)) }++ipvar   :: { Located HsIPName }+        : IPDUPVARID            { sL1 $1 (HsIPName (getIPDUPVARID $1)) }++-----------------------------------------------------------------------------+-- Overloaded labels++overloaded_label :: { Located (SourceText, FastString) }+        : LABELVARID          { sL1 $1 (getLABELVARIDs $1, getLABELVARID $1) }++-----------------------------------------------------------------------------+-- Warnings and deprecations++name_boolformula_opt :: { LBooleanFormula (LocatedN RdrName) }+        : name_boolformula          { $1 }+        | {- empty -}               { noLocA mkTrue }++name_boolformula :: { LBooleanFormula (LocatedN RdrName) }+        : name_boolformula_and                      { $1 }+        | name_boolformula_and '|' name_boolformula+                           {% do { h <- addTrailingVbarL $1 (gl $2)+                                 ; return (sLLa $1 $> (Or [h,$3])) } }++name_boolformula_and :: { LBooleanFormula (LocatedN RdrName) }+        : name_boolformula_and_list+                  { sLLa (head $1) (last $1) (And ($1)) }++name_boolformula_and_list :: { [LBooleanFormula (LocatedN RdrName)] }+        : name_boolformula_atom                               { [$1] }+        | name_boolformula_atom ',' name_boolformula_and_list+            {% do { h <- addTrailingCommaL $1 (gl $2)+                  ; return (h : $3) } }++name_boolformula_atom :: { LBooleanFormula (LocatedN RdrName) }+        : '(' name_boolformula ')'  {% amsr (sLL $1 $> (Parens $2))+                                      (AnnList Nothing (Just (mop $1)) (Just (mcp $3)) [] []) }+        | name_var                  { sL1a $1 (Var $1) }++namelist :: { Located [LocatedN RdrName] }+namelist : name_var              { sL1 $1 [$1] }+         | name_var ',' namelist {% do { h <- addTrailingCommaN $1 (gl $2)+                                       ; return (sLL $1 $> (h : unLoc $3)) }}++name_var :: { LocatedN RdrName }+name_var : var { $1 }+         | con { $1 }++-----------------------------------------+-- Data constructors+-- There are two different productions here as lifted list constructors+-- are parsed differently.++qcon :: { LocatedN RdrName }+  : gen_qcon              { $1}+  | sysdcon               { L (getLoc $1) $ nameRdrName (dataConName (unLoc $1)) }++gen_qcon :: { LocatedN RdrName }+  : qconid                { $1 }+  | '(' qconsym ')'       {% amsr (sLL $1 $> (unLoc $2))+                                  (NameAnn NameParens (glAA $1) (glAA $2) (glAA $3) []) }++con     :: { LocatedN RdrName }+        : conid                 { $1 }+        | '(' consym ')'        {% amsr (sLL $1 $> (unLoc $2))+                                        (NameAnn NameParens (glAA $1) (glAA $2) (glAA $3) []) }+        | sysdcon               { L (getLoc $1) $ nameRdrName (dataConName (unLoc $1)) }++con_list :: { Located (NonEmpty (LocatedN RdrName)) }+con_list : con                  { sL1 $1 (pure $1) }+         | con ',' con_list     {% sLL $1 $> . (:| toList (unLoc $3)) <\$> addTrailingCommaN $1 (gl $2) }++qcon_list :: { [LocatedN RdrName] }+qcon_list : qcon                  { [$1] }+          | qcon ',' qcon_list    {% do { h <- addTrailingCommaN $1 (gl $2)+                                        ; return (h : $3) }}++-- See Note [ExplicitTuple] in GHC.Hs.Expr+sysdcon_nolist :: { LocatedN DataCon }  -- Wired in data constructors+        : '(' commas ')'        {% amsr (sLL $1 $> $ tupleDataCon Boxed (snd $2 + 1))+                                       (NameAnnCommas NameParens (glAA $1) (map srcSpan2e (fst $2)) (glAA $3) []) }+        | '(#' '#)'             {% amsr (sLL $1 $> $ unboxedUnitDataCon) (NameAnnOnly NameParensHash (glAA $1) (glAA $2) []) }+        | '(#' commas '#)'      {% amsr (sLL $1 $> $ tupleDataCon Unboxed (snd $2 + 1))+                                       (NameAnnCommas NameParensHash (glAA $1) (map srcSpan2e (fst $2)) (glAA $3) []) }++-- See Note [Empty lists] in GHC.Hs.Expr+sysdcon :: { LocatedN DataCon }+        : sysdcon_nolist                 { $1 }+        | '(' ')'               {% amsr (sLL $1 $> unitDataCon) (NameAnnOnly NameParens (glAA $1) (glAA $2) []) }+        |  '[' ']'               {% amsr (sLL $1 $> nilDataCon) (NameAnnOnly NameSquare (glAA $1) (glAA $2) []) }++conop :: { LocatedN RdrName }+        : consym                { $1 }+        | '`' conid '`'         {% amsr (sLL $1 $> (unLoc $2))+                                          (NameAnn NameBackquotes (glAA $1) (glAA $2) (glAA $3) []) }++qconop :: { LocatedN RdrName }+        : qconsym               { $1 }+        | '`' qconid '`'        {% amsr (sLL $1 $> (unLoc $2))+                                          (NameAnn NameBackquotes (glAA $1) (glAA $2) (glAA $3) []) }++----------------------------------------------------------------------------+-- Type constructors+++-- See Note [Unit tuples] in GHC.Hs.Type for the distinction+-- between gtycon and ntgtycon+gtycon :: { LocatedN RdrName }  -- A "general" qualified tycon, including unit tuples+        : ntgtycon                     { $1 }+        | '(' ')'                      {% amsr (sLL $1 $> $ getRdrName unitTyCon)+                                                (NameAnnOnly NameParens (glAA $1) (glAA $2) []) }+        | '(#' '#)'                    {% amsr (sLL $1 $> $ getRdrName unboxedUnitTyCon)+                                                (NameAnnOnly NameParensHash (glAA $1) (glAA $2) []) }+        | '[' ']'               {% amsr (sLL $1 $> $ listTyCon_RDR)+                                      (NameAnnOnly NameSquare (glAA $1) (glAA $2) []) }++ntgtycon :: { LocatedN RdrName }  -- A "general" qualified tycon, excluding unit tuples+        : oqtycon               { $1 }+        | '(' commas ')'        {% do { n <- mkTupleSyntaxTycon Boxed (snd $2 + 1)+                                      ; amsr (sLL $1 $> n) (NameAnnCommas NameParens (glAA $1) (map srcSpan2e (fst $2)) (glAA $3) []) }}+        | '(#' commas '#)'      {% do { n <- mkTupleSyntaxTycon Unboxed (snd $2 + 1)+                                      ; amsr (sLL $1 $> n) (NameAnnCommas NameParensHash (glAA $1) (map srcSpan2e (fst $2)) (glAA $3) []) }}+        | '(#' bars '#)'        {% do { requireLTPuns PEP_SumSyntaxType $1 $>+                                      ; amsr (sLL $1 $> $ (getRdrName (sumTyCon (snd $2 + 1))))+                                       (NameAnnBars NameParensHash (glAA $1) (map srcSpan2e (fst $2)) (glAA $3) []) } }+        | '(' '->' ')'          {% amsr (sLL $1 $> $ getRdrName unrestrictedFunTyCon)+                                       (NameAnnRArrow (isUnicode $2) (Just $ glAA $1) (glAA $2) (Just $ glAA $3) []) }++oqtycon :: { LocatedN RdrName }  -- An "ordinary" qualified tycon;+                                -- These can appear in export lists+        : qtycon                        { $1 }+        | '(' qtyconsym ')'             {% amsr (sLL $1 $> (unLoc $2))+                                                  (NameAnn NameParens (glAA $1) (glAA $2) (glAA $3) []) }++oqtycon_no_varcon :: { LocatedN RdrName }  -- Type constructor which cannot be mistaken+                                          -- for variable constructor in export lists+                                          -- see Note [Type constructors in export list]+        :  qtycon            { $1 }+        | '(' QCONSYM ')'    {% let { name :: Located RdrName+                                    ; name = sL1 $2 $! mkQual tcClsName (getQCONSYM $2) }+                                in amsr (sLL $1 $> (unLoc name)) (NameAnn NameParens (glAA $1) (glAA $2) (glAA $3) []) }+        | '(' CONSYM ')'     {% let { name :: Located RdrName+                                    ; name = sL1 $2 $! mkUnqual tcClsName (getCONSYM $2) }+                                in amsr (sLL $1 $> (unLoc name)) (NameAnn NameParens (glAA $1) (glAA $2) (glAA $3) []) }+        | '(' ':' ')'        {% let { name :: Located RdrName+                                    ; name = sL1 $2 $! consDataCon_RDR }+                                in amsr (sLL $1 $> (unLoc name)) (NameAnn NameParens (glAA $1) (glAA $2) (glAA $3) []) }++{- Note [Type constructors in export list]+~~~~~~~~~~~~~~~~~~~~~+Mixing type constructors and data constructors in export lists introduces+ambiguity in grammar: e.g. (*) may be both a type constructor and a function.++-XExplicitNamespaces allows to disambiguate by explicitly prefixing type+constructors with 'type' keyword.++This ambiguity causes reduce/reduce conflicts in parser, which are always+resolved in favour of data constructors. To get rid of conflicts we demand+that ambiguous type constructors (those, which are formed by the same+productions as variable constructors) are always prefixed with 'type' keyword.+Unambiguous type constructors may occur both with or without 'type' keyword.++Note that in the parser we still parse data constructors as type+constructors. As such, they still end up in the type constructor namespace+until after renaming when we resolve the proper namespace for each exported+child.+-}++qtyconop :: { LocatedN RdrName } -- Qualified or unqualified+        -- See Note [%shift: qtyconop -> qtyconsym]+        : qtyconsym %shift              { $1 }+        | '`' qtycon '`'                {% amsr (sLL $1 $> (unLoc $2))+                                                (NameAnn NameBackquotes (glAA $1) (glAA $2) (glAA $3) []) }++qtycon :: { LocatedN RdrName }   -- Qualified or unqualified+        : QCONID            { sL1n $1 $! mkQual tcClsName (getQCONID $1) }+        | tycon             { $1 }++tycon   :: { LocatedN RdrName }  -- Unqualified+        : CONID                   { sL1n $1 $! mkUnqual tcClsName (getCONID $1) }++qtyconsym :: { LocatedN RdrName }+        : QCONSYM            { sL1n $1 $! mkQual tcClsName (getQCONSYM $1) }+        | QVARSYM            { sL1n $1 $! mkQual tcClsName (getQVARSYM $1) }+        | tyconsym           { $1 }++tyconsym :: { LocatedN RdrName }+        : CONSYM                { sL1n $1 $! mkUnqual tcClsName (getCONSYM $1) }+        | VARSYM                { sL1n $1 $! mkUnqual tcClsName (getVARSYM $1) }+        | ':'                   { sL1n $1 $! consDataCon_RDR }+        | '-'                   { sL1n $1 $! mkUnqual tcClsName (fsLit "-") }+        | '.'                   { sL1n $1 $! mkUnqual tcClsName (fsLit ".") }++-- An "ordinary" unqualified tycon. See `oqtycon` for the qualified version.+-- These can appear in `ANN type` declarations (#19374).+otycon :: { LocatedN RdrName }+        : tycon                 { $1 }+        | '(' tyconsym ')'      {% amsr (sLL $1 $> (unLoc $2))+                                        (NameAnn NameParens (glAA $1) (glAA $2) (glAA $3) []) }++-----------------------------------------------------------------------------+-- Operators++op      :: { LocatedN RdrName }   -- used in infix decls+        : varop                 { $1 }+        | conop                 { $1 }+        | '->'                  {% amsr (sLL $1 $> $ getRdrName unrestrictedFunTyCon)+                                     (NameAnnRArrow (isUnicode $1) Nothing (glAA $1) Nothing []) }++varop   :: { LocatedN RdrName }+        : varsym                { $1 }+        | '`' varid '`'         {% amsr (sLL $1 $> (unLoc $2))+                                           (NameAnn NameBackquotes (glAA $1) (glAA $2) (glAA $3) []) }++qop     :: { forall b. DisambInfixOp b => PV (LocatedN b) }   -- used in sections+        : qvarop                { mkHsVarOpPV $1 }+        | qconop                { mkHsConOpPV $1 }+        | hole_op               { mkHsInfixHolePV $1 }++qopm    :: { forall b. DisambInfixOp b => PV (LocatedN b) }   -- used in sections+        : qvaropm               { mkHsVarOpPV $1 }+        | qconop                { mkHsConOpPV $1 }+        | hole_op               { mkHsInfixHolePV $1 }++hole_op :: { LocatedN (HsExpr GhcPs) }   -- used in sections+hole_op : '`' '_' '`'           { sLLa $1 $> (hsHoleExpr (Just $ EpAnnUnboundVar (glAA $1, glAA $3) (glAA $2))) }++qvarop :: { LocatedN RdrName }+        : qvarsym               { $1 }+        | '`' qvarid '`'        {% amsr (sLL $1 $> (unLoc $2))+                                           (NameAnn NameBackquotes (glAA $1) (glAA $2) (glAA $3) []) }++qvaropm :: { LocatedN RdrName }+        : qvarsym_no_minus      { $1 }+        | '`' qvarid '`'        {% amsr (sLL $1 $> (unLoc $2))+                                           (NameAnn NameBackquotes (glAA $1) (glAA $2) (glAA $3) []) }++-----------------------------------------------------------------------------+-- Type variables++tyvar   :: { LocatedN RdrName }+tyvar   : tyvarid               { $1 }++tyvarop :: { LocatedN RdrName }+tyvarop : '`' tyvarid '`'       {% amsr (sLL $1 $> (unLoc $2))+                                           (NameAnn NameBackquotes (glAA $1) (glAA $2) (glAA $3) []) }++tyvarid :: { LocatedN RdrName }+        : VARID            { sL1n $1 $! mkUnqual tvName (getVARID $1) }+        | special_id       { sL1n $1 $! mkUnqual tvName (unLoc $1) }+        | 'unsafe'         { sL1n $1 $! mkUnqual tvName (fsLit "unsafe") }+        | 'safe'           { sL1n $1 $! mkUnqual tvName (fsLit "safe") }+        | 'interruptible'  { sL1n $1 $! mkUnqual tvName (fsLit "interruptible") }+        -- If this changes relative to varid, update 'checkRuleTyVarBndrNames'+        -- in GHC.Parser.PostProcess+        -- See Note [Parsing explicit foralls in Rules]++-----------------------------------------------------------------------------+-- Variables++var     :: { LocatedN RdrName }+        : varid                 { $1 }+        | '(' varsym ')'        {% amsr (sLL $1 $> (unLoc $2))+                                   (NameAnn NameParens (glAA $1) (glAA $2) (glAA $3) []) }++qvar    :: { LocatedN RdrName }+        : qvarid                { $1 }+        | '(' varsym ')'        {% amsr (sLL $1 $> (unLoc $2))+                                   (NameAnn NameParens (glAA $1) (glAA $2) (glAA $3) []) }+        | '(' qvarsym1 ')'      {% amsr (sLL $1 $> (unLoc $2))+                                   (NameAnn NameParens (glAA $1) (glAA $2) (glAA $3) []) }+-- We've inlined qvarsym here so that the decision about+-- whether it's a qvar or a var can be postponed until+-- *after* we see the close paren.++field :: { LocatedN FieldLabelString  }+      : varid { fmap (FieldLabelString . occNameFS . rdrNameOcc) $1 }++qvarid :: { LocatedN RdrName }+        : varid               { $1 }+        | QVARID              { sL1n $1 $! mkQual varName (getQVARID $1) }++-- Note that 'role' and 'family' get lexed separately regardless of+-- the use of extensions. However, because they are listed here,+-- this is OK and they can be used as normal varids.+-- See Note [Lexing type pseudo-keywords] in GHC.Parser.Lexer+varid :: { LocatedN RdrName }+        : VARID            { sL1n $1 $! mkUnqual varName (getVARID $1) }+        | special_id       { sL1n $1 $! mkUnqual varName (unLoc $1) }+        | 'unsafe'         { sL1n $1 $! mkUnqual varName (fsLit "unsafe") }+        | 'safe'           { sL1n $1 $! mkUnqual varName (fsLit "safe") }+        | 'interruptible'  { sL1n $1 $! mkUnqual varName (fsLit "interruptible")}+        | 'family'         { sL1n $1 $! mkUnqual varName (fsLit "family") }+        | 'role'           { sL1n $1 $! mkUnqual varName (fsLit "role") }+        -- If this changes relative to tyvarid, update 'checkRuleTyVarBndrNames'+        -- in GHC.Parser.PostProcess+        -- See Note [Parsing explicit foralls in Rules]++qvarsym :: { LocatedN RdrName }+        : varsym                { $1 }+        | qvarsym1              { $1 }++qvarsym_no_minus :: { LocatedN RdrName }+        : varsym_no_minus       { $1 }+        | qvarsym1              { $1 }++qvarsym1 :: { LocatedN RdrName }+qvarsym1 : QVARSYM              { sL1n $1 $ mkQual varName (getQVARSYM $1) }++varsym :: { LocatedN RdrName }+        : varsym_no_minus       { $1 }+        | '-'                   { sL1n $1 $ mkUnqual varName (fsLit "-") }++varsym_no_minus :: { LocatedN RdrName } -- varsym not including '-'+        : VARSYM               { sL1n $1 $ mkUnqual varName (getVARSYM $1) }+        | special_sym          { sL1n $1 $ mkUnqual varName (unLoc $1) }+++-- These special_ids are treated as keywords in various places,+-- but as ordinary ids elsewhere.   'special_id' collects all these+-- except 'unsafe', 'interruptible', 'forall', 'family', 'role', 'stock', and+-- 'anyclass', whose treatment differs depending on context+special_id :: { Located FastString }+special_id+        : 'as'                  { sL1 $1 (fsLit "as") }+        | 'qualified'           { sL1 $1 (fsLit "qualified") }+        | 'hiding'              { sL1 $1 (fsLit "hiding") }+        | 'export'              { sL1 $1 (fsLit "export") }+        | 'label'               { sL1 $1 (fsLit "label")  }+        | 'dynamic'             { sL1 $1 (fsLit "dynamic") }+        | 'stdcall'             { sL1 $1 (fsLit "stdcall") }+        | 'ccall'               { sL1 $1 (fsLit "ccall") }+        | 'capi'                { sL1 $1 (fsLit "capi") }+        | 'prim'                { sL1 $1 (fsLit "prim") }+        | 'javascript'          { sL1 $1 (fsLit "javascript") }+        -- See Note [%shift: special_id -> 'group']+        | 'group' %shift        { sL1 $1 (fsLit "group") }+        | 'stock'               { sL1 $1 (fsLit "stock") }+        | 'anyclass'            { sL1 $1 (fsLit "anyclass") }+        | 'via'                 { sL1 $1 (fsLit "via") }+        | 'unit'                { sL1 $1 (fsLit "unit") }+        | 'dependency'          { sL1 $1 (fsLit "dependency") }+        | 'signature'           { sL1 $1 (fsLit "signature") }++special_sym :: { Located FastString }+special_sym : '.'       { sL1 $1 (fsLit ".") }+            | '*'       { sL1 $1 (starSym (isUnicode $1)) }++-----------------------------------------------------------------------------+-- Data constructors++qconid :: { LocatedN RdrName }   -- Qualified or unqualified+        : conid              { $1 }+        | QCONID             { sL1n $1 $! mkQual dataName (getQCONID $1) }++conid   :: { LocatedN RdrName }+        : CONID                { sL1n $1 $ mkUnqual dataName (getCONID $1) }++qconsym :: { LocatedN RdrName }  -- Qualified or unqualified+        : consym               { $1 }+        | QCONSYM              { sL1n $1 $ mkQual dataName (getQCONSYM $1) }++consym :: { LocatedN RdrName }+        : CONSYM              { sL1n $1 $ mkUnqual dataName (getCONSYM $1) }++        -- ':' means only list cons+        | ':'                { sL1n $1 $ consDataCon_RDR }+++-----------------------------------------------------------------------------+-- Literals++literal :: { Located (HsLit GhcPs) }+        : CHAR              { sL1 $1 $ HsChar       (getCHARs $1) $ getCHAR $1 }+        | STRING            { sL1 $1 $ HsString     (getSTRINGs $1)+                                                    $ getSTRING $1 }+        | PRIMINTEGER       { sL1 $1 $ HsIntPrim    (getPRIMINTEGERs $1)+                                                    $ getPRIMINTEGER $1 }+        | PRIMWORD          { sL1 $1 $ HsWordPrim   (getPRIMWORDs $1)+                                                    $ getPRIMWORD $1 }+        | PRIMINTEGER8      { sL1 $1 $ HsInt8Prim   (getPRIMINTEGER8s $1)+                                                    $ getPRIMINTEGER8 $1 }+        | PRIMINTEGER16     { sL1 $1 $ HsInt16Prim  (getPRIMINTEGER16s $1)+                                                    $ getPRIMINTEGER16 $1 }+        | PRIMINTEGER32     { sL1 $1 $ HsInt32Prim  (getPRIMINTEGER32s $1)+                                                    $ getPRIMINTEGER32 $1 }+        | PRIMINTEGER64     { sL1 $1 $ HsInt64Prim  (getPRIMINTEGER64s $1)+                                                    $ getPRIMINTEGER64 $1 }+        | PRIMWORD8         { sL1 $1 $ HsWord8Prim  (getPRIMWORD8s $1)+                                                    $ getPRIMWORD8 $1 }+        | PRIMWORD16        { sL1 $1 $ HsWord16Prim (getPRIMWORD16s $1)+                                                    $ getPRIMWORD16 $1 }+        | PRIMWORD32        { sL1 $1 $ HsWord32Prim (getPRIMWORD32s $1)+                                                    $ getPRIMWORD32 $1 }+        | PRIMWORD64        { sL1 $1 $ HsWord64Prim (getPRIMWORD64s $1)+                                                    $ getPRIMWORD64 $1 }+        | PRIMCHAR          { sL1 $1 $ HsCharPrim   (getPRIMCHARs $1)+                                                    $ getPRIMCHAR $1 }+        | PRIMSTRING        { sL1 $1 $ HsStringPrim (getPRIMSTRINGs $1)+                                                    $ getPRIMSTRING $1 }+        | PRIMFLOAT         { sL1 $1 $ HsFloatPrim  noExtField $ getPRIMFLOAT $1 }+        | PRIMDOUBLE        { sL1 $1 $ HsDoublePrim noExtField $ getPRIMDOUBLE $1 }++-----------------------------------------------------------------------------+-- Layout++{- Note [Layout and error]+~~~~~~~~~~~~~~~~~~~~~~~~~~+The Haskell 2010 report (Section 10.3, Note 5) dictates the use of the error+token in `close`. To recall why that is necessary, consider++  f x = case x of+    True -> False+    where y = x+1++The virtual pass L inserts vocurly, semi, vccurly to return a laid-out+token stream. It must insert a vccurly before `where` to close the layout+block introduced by `of`.+But there is no good way to do so other than L becoming aware of the grammar!+Thus, L is specified to detect the ensuing parse error (implemented via+happy's `error` token) and then insert the vccurly.+Thus in effect, L is distributed between Lexer.x and Parser.y.++There are a bunch of other, less "tricky" examples:++  let x = x {- vccurly -} in x   -- could just track bracketing of+                                 -- let..in on layout stack to fix+  (case x of+   True -> False {- vccurly -})  -- ditto for surrounding delimiters such as ()++  data T = T;{- vccurly -}       -- Need insert vccurly at EOF++Many of these are not that hard to fix, but still tedious and prone to break+when the grammar changes; but the `of`/`where` example is especially gnarly,+because it demonstrates a grammatical interaction between two lexically+unrelated tokens.+-}+close :: { () }+        : vccurly               { () } -- context popped in lexer.+        | error                 {% popContext } -- See Note [Layout and error]++-----------------------------------------------------------------------------+-- Miscellaneous (mostly renamings)++modid   :: { LocatedA ModuleName }+        : CONID                 { sL1a $1 $ mkModuleNameFS (getCONID $1) }+        | QCONID                { sL1a $1 $ let (mod,c) = getQCONID $1 in+                                  mkModuleNameFS+                                   (concatFS [mod, fsLit ".", c])+                                }++commas :: { ([SrcSpan],Int) }   -- One or more commas+        : commas ','             { ((fst $1)++[gl $2],snd $1 + 1) }+        | ','                    { ([gl $1],1) }++bars0 :: { ([SrcSpan],Int) }     -- Zero or more bars+        : bars                   { $1 }+        |                        { ([], 0) }++bars :: { ([SrcSpan],Int) }     -- One or more bars+        : bars '|'               { ((fst $1)++[gl $2],snd $1 + 1) }+        | '|'                    { ([gl $1],1) }++{+happyError :: P a+happyError = srcParseFail++getVARID          (L _ (ITvarid    x)) = x+getCONID          (L _ (ITconid    x)) = x+getVARSYM         (L _ (ITvarsym   x)) = x+getCONSYM         (L _ (ITconsym   x)) = x+getDO             (L _ (ITdo      x)) = x+getMDO            (L _ (ITmdo     x)) = x+getQVARID         (L _ (ITqvarid   x)) = x+getQCONID         (L _ (ITqconid   x)) = x+getQVARSYM        (L _ (ITqvarsym  x)) = x+getQCONSYM        (L _ (ITqconsym  x)) = x+getIPDUPVARID     (L _ (ITdupipvarid   x)) = x+getLABELVARID     (L _ (ITlabelvarid _ x)) = x+getCHAR           (L _ (ITchar   _ x)) = x+getSTRING         (L _ (ITstring _ x)) = x+getINTEGER        (L _ (ITinteger x))  = x+getRATIONAL       (L _ (ITrational x)) = x+getPRIMCHAR       (L _ (ITprimchar _ x)) = x+getPRIMSTRING     (L _ (ITprimstring _ x)) = x+getPRIMINTEGER    (L _ (ITprimint  _ x)) = x+getPRIMWORD       (L _ (ITprimword _ x)) = x+getPRIMINTEGER8   (L _ (ITprimint8 _ x)) = x+getPRIMINTEGER16  (L _ (ITprimint16 _ x)) = x+getPRIMINTEGER32  (L _ (ITprimint32 _ x)) = x+getPRIMINTEGER64  (L _ (ITprimint64 _ x)) = x+getPRIMWORD8      (L _ (ITprimword8 _ x)) = x+getPRIMWORD16     (L _ (ITprimword16 _ x)) = x+getPRIMWORD32     (L _ (ITprimword32 _ x)) = x+getPRIMWORD64     (L _ (ITprimword64 _ x)) = x+getPRIMFLOAT      (L _ (ITprimfloat x)) = x+getPRIMDOUBLE     (L _ (ITprimdouble x)) = x+getINLINE         (L _ (ITinline_prag _ inl conl)) = (inl,conl)+getSPEC_INLINE    (L _ (ITspec_inline_prag src True))  = (Inline src,FunLike)+getSPEC_INLINE    (L _ (ITspec_inline_prag src False)) = (NoInline src,FunLike)+getCOMPLETE_PRAGs (L _ (ITcomplete_prag x)) = x+getVOCURLY        (L (RealSrcSpan l _) ITvocurly) = srcSpanStartCol l++getINTEGERs       (L _ (ITinteger (IL src _ _))) = src+getCHARs          (L _ (ITchar       src _)) = src+getSTRINGs        (L _ (ITstring     src _)) = src+getPRIMCHARs      (L _ (ITprimchar   src _)) = src+getPRIMSTRINGs    (L _ (ITprimstring src _)) = src+getPRIMINTEGERs   (L _ (ITprimint    src _)) = src+getPRIMWORDs      (L _ (ITprimword   src _)) = src+getPRIMINTEGER8s  (L _ (ITprimint8   src _)) = src+getPRIMINTEGER16s (L _ (ITprimint16  src _)) = src+getPRIMINTEGER32s (L _ (ITprimint32  src _)) = src+getPRIMINTEGER64s (L _ (ITprimint64  src _)) = src+getPRIMWORD8s     (L _ (ITprimword8  src _)) = src+getPRIMWORD16s    (L _ (ITprimword16 src _)) = src+getPRIMWORD32s    (L _ (ITprimword32 src _)) = src+getPRIMWORD64s    (L _ (ITprimword64 src _)) = src++getLABELVARIDs    (L _ (ITlabelvarid src _)) = src++-- See Note [Pragma source text] in "GHC.Types.SourceText" for the following+getINLINE_PRAGs       (L _ (ITinline_prag       _ inl _)) = inlineSpecSource inl+getOPAQUE_PRAGs       (L _ (ITopaque_prag       src))     = src+getSPEC_PRAGs         (L _ (ITspec_prag         src))     = src+getSPEC_INLINE_PRAGs  (L _ (ITspec_inline_prag  src _))   = src+getSOURCE_PRAGs       (L _ (ITsource_prag       src)) = src+getRULES_PRAGs        (L _ (ITrules_prag        src)) = src+getWARNING_PRAGs      (L _ (ITwarning_prag      src)) = src+getDEPRECATED_PRAGs   (L _ (ITdeprecated_prag   src)) = src+getSCC_PRAGs          (L _ (ITscc_prag          src)) = src+getUNPACK_PRAGs       (L _ (ITunpack_prag       src)) = src+getNOUNPACK_PRAGs     (L _ (ITnounpack_prag     src)) = src+getANN_PRAGs          (L _ (ITann_prag          src)) = src+getMINIMAL_PRAGs      (L _ (ITminimal_prag      src)) = src+getOVERLAPPABLE_PRAGs (L _ (IToverlappable_prag src)) = src+getOVERLAPPING_PRAGs  (L _ (IToverlapping_prag  src)) = src+getOVERLAPS_PRAGs     (L _ (IToverlaps_prag     src)) = src+getINCOHERENT_PRAGs   (L _ (ITincoherent_prag   src)) = src+getCTYPEs             (L _ (ITctype             src)) = src++getStringLiteral l = StringLiteral (getSTRINGs l) (getSTRING l) Nothing++isUnicode :: Located Token -> Bool+isUnicode (L _ (ITforall         iu)) = iu == UnicodeSyntax+isUnicode (L _ (ITdarrow         iu)) = iu == UnicodeSyntax+isUnicode (L _ (ITdcolon         iu)) = iu == UnicodeSyntax+isUnicode (L _ (ITlarrow         iu)) = iu == UnicodeSyntax+isUnicode (L _ (ITrarrow         iu)) = iu == UnicodeSyntax+isUnicode (L _ (ITlarrowtail     iu)) = iu == UnicodeSyntax+isUnicode (L _ (ITrarrowtail     iu)) = iu == UnicodeSyntax+isUnicode (L _ (ITLarrowtail     iu)) = iu == UnicodeSyntax+isUnicode (L _ (ITRarrowtail     iu)) = iu == UnicodeSyntax+isUnicode (L _ (IToparenbar      iu)) = iu == UnicodeSyntax+isUnicode (L _ (ITcparenbar      iu)) = iu == UnicodeSyntax+isUnicode (L _ (ITopenExpQuote _ iu)) = iu == UnicodeSyntax+isUnicode (L _ (ITcloseQuote     iu)) = iu == UnicodeSyntax+isUnicode (L _ (ITstar           iu)) = iu == UnicodeSyntax+isUnicode (L _ ITlolly)               = True+isUnicode _                           = False++hasE :: Located Token -> Bool+hasE (L _ (ITopenExpQuote HasE _)) = True+hasE (L _ (ITopenTExpQuote HasE))  = True+hasE _                             = False++getSCC :: Located Token -> P FastString+getSCC lt = do let s = getSTRING lt+               -- We probably actually want to be more restrictive than this+               if ' ' `elem` unpackFS s+                   then addFatalError $ mkPlainErrorMsgEnvelope (getLoc lt) $ PsErrSpaceInSCC+                   else return s++stringLiteralToHsDocWst :: Located StringLiteral -> LocatedE (WithHsDocIdentifiers StringLiteral GhcPs)+stringLiteralToHsDocWst  sl = reLoc $ lexStringLiteral parseIdentifier sl++-- Utilities for combining source spans+comb2 :: (HasLoc a, HasLoc b) => a -> b -> SrcSpan+comb2 !a !b = combineHasLocs a b++comb3 :: (HasLoc a, HasLoc b, HasLoc c) => a -> b -> c -> SrcSpan+comb3 !a !b !c = combineSrcSpans (getHasLoc a) (combineHasLocs b c)++comb4 :: (HasLoc a, HasLoc b, HasLoc c, HasLoc d) => a -> b -> c -> d -> SrcSpan+comb4 !a !b !c !d =+    combineSrcSpans (getHasLoc a) $+    combineSrcSpans (getHasLoc b) $+    combineSrcSpans (getHasLoc c) (getHasLoc d)++comb5 :: (HasLoc a, HasLoc b, HasLoc c, HasLoc d, HasLoc e) => a -> b -> c -> d -> e -> SrcSpan+comb5 !a !b !c !d !e =+    combineSrcSpans (getHasLoc a) $+    combineSrcSpans (getHasLoc b) $+    combineSrcSpans (getHasLoc c) $+    combineSrcSpans (getHasLoc d) (getHasLoc e)++-- strict constructor version:+{-# INLINE sL #-}+sL :: l -> a -> GenLocated l a+sL !loc !a = L loc a++-- See Note [Adding location info] for how these utility functions are used++-- replaced last 3 CPP macros in this file+{-# INLINE sL0 #-}+sL0 :: a -> Located a+sL0 = L noSrcSpan       -- #define L0   L noSrcSpan++{-# INLINE sL1 #-}+sL1 :: HasLoc a => a -> b -> Located b+sL1 !x = sL (getHasLoc x)   -- #define sL1   sL (getLoc $1)++{-# INLINE sL1a #-}+sL1a :: (HasLoc a, HasAnnotation t) =>  a -> b -> GenLocated t b+sL1a !x = sL (noAnnSrcSpan $ getHasLoc x)   -- #define sL1   sL (getLoc $1)++{-# INLINE sL1n #-}+sL1n :: HasLoc a => a -> b -> LocatedN b+sL1n !x = L (noAnnSrcSpan $ getHasLoc x)   -- #define sL1   sL (getLoc $1)++{-# INLINE sLL #-}+sLL :: (HasLoc a, HasLoc b) => a -> b -> c -> Located c+sLL !x !y = sL (comb2 x y) -- #define LL   sL (comb2 $1 $>)++{-# INLINE sLLa #-}+sLLa :: (HasLoc a, HasLoc b, NoAnn t) => a -> b -> c -> LocatedAn t c+sLLa !x !y = sL (noAnnSrcSpan $ comb2 x y) -- #define LL   sL (comb2 $1 $>)++{-# INLINE sLLl #-}+sLLl :: (HasLoc a, HasLoc b) => a -> b -> c -> LocatedL c+sLLl !x !y = sL (noAnnSrcSpan $ comb2 x y) -- #define LL   sL (comb2 $1 $>)++{-# INLINE sLLAsl #-}+sLLAsl :: (HasLoc a) => [a] -> Located b -> c -> Located c+sLLAsl [] = sL1+sLLAsl (!x:_) = sLL x++{-# INLINE sLZ #-}+sLZ :: (HasLoc a, HasLoc b) => a -> b -> c -> Located c+sLZ !x !y = if isZeroWidthSpan (getHasLoc y)+                 then sL (getHasLoc x)+                 else sL (comb2 x y)++{- Note [Adding location info]+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~++This is done using the three functions below, sL0, sL1+and sLL.  Note that these functions were mechanically+converted from the three macros that used to exist before,+namely L0, L1 and LL.++They each add a SrcSpan to their argument.++   sL0  adds 'noSrcSpan', used for empty productions+     -- This doesn't seem to work anymore -=chak++   sL1  for a production with a single token on the lhs.  Grabs the SrcSpan+        from that token.++   sLL  for a production with >1 token on the lhs.  Makes up a SrcSpan from+        the first and last tokens.++These suffice for the majority of cases.  However, we must be+especially careful with empty productions: sLL won't work if the first+or last token on the lhs can represent an empty span.  In these cases,+we have to calculate the span using more of the tokens from the lhs, eg.++        | 'newtype' tycl_hdr '=' newconstr deriving+                { L (comb3 $1 $4 $5)+                    (mkTyData NewType (unLoc $2) $4 (unLoc $5)) }++We provide comb3 and comb4 functions which are useful in such cases.++Be careful: there's no checking that you actually got this right, the+only symptom will be that the SrcSpans of your syntax will be+incorrect.++-}++-- Make a source location for the file.  We're a bit lazy here and just+-- make a point SrcSpan at line 1, column 0.  Strictly speaking we should+-- try to find the span of the whole file (ToDo).+fileSrcSpan :: P SrcSpan+fileSrcSpan = do+  l <- getRealSrcLoc;+  let loc = mkSrcLoc (srcLocFile l) 1 1;+  return (mkSrcSpan loc loc)++-- Hint about linear types+hintLinear :: MonadP m => SrcSpan -> m ()+hintLinear span = do+  linearEnabled <- getBit LinearTypesBit+  unless linearEnabled $ addError $ mkPlainErrorMsgEnvelope span $ PsErrLinearFunction++-- Does this look like (a %m)?+looksLikeMult :: LHsType GhcPs -> LocatedN RdrName -> LHsType GhcPs -> Bool+looksLikeMult ty1 l_op ty2+  | Unqual op_name <- unLoc l_op+  , occNameFS op_name == fsLit "%"+  , Strict.Just ty1_pos <- getBufSpan (getLocA ty1)+  , Strict.Just pct_pos <- getBufSpan (getLocA l_op)+  , Strict.Just ty2_pos <- getBufSpan (getLocA ty2)+  , bufSpanEnd ty1_pos /= bufSpanStart pct_pos+  , bufSpanEnd pct_pos == bufSpanStart ty2_pos+  = True+  | otherwise = False++-- Hint about the MultiWayIf extension+hintMultiWayIf :: SrcSpan -> P ()+hintMultiWayIf span = do+  mwiEnabled <- getBit MultiWayIfBit+  unless mwiEnabled $ addError $ mkPlainErrorMsgEnvelope span PsErrMultiWayIf++-- Hint about explicit-forall+hintExplicitForall :: Located Token -> P ()+hintExplicitForall tok = do+    explicit_forall_enabled <- getBit ExplicitForallBit+    in_rule_prag <- getBit InRulePragBit+    unless (explicit_forall_enabled || in_rule_prag) $+      addError $ mkPlainErrorMsgEnvelope (getLoc tok) $+        PsErrExplicitForall (isUnicode tok)++-- Hint about qualified-do+hintQualifiedDo :: Located Token -> P ()+hintQualifiedDo tok = do+    qualifiedDo   <- getBit QualifiedDoBit+    case maybeQDoDoc of+      Just qdoDoc | not qualifiedDo ->+        addError $ mkPlainErrorMsgEnvelope (getLoc tok) $+          (PsErrIllegalQualifiedDo qdoDoc)+      _ -> return ()+  where+    maybeQDoDoc = case unLoc tok of+      ITdo (Just m) -> Just $ ftext m <> text ".do"+      ITmdo (Just m) -> Just $ ftext m <> text ".mdo"+      t -> Nothing++-- When two single quotes don't followed by tyvar or gtycon, we report the+-- error as empty character literal, or TH quote that missing proper type+-- variable or constructor. See #13450.+reportEmptyDoubleQuotes :: SrcSpan -> P a+reportEmptyDoubleQuotes span = do+    thQuotes <- getBit ThQuotesBit+    addFatalError $ mkPlainErrorMsgEnvelope span $ PsErrEmptyDoubleQuotes thQuotes++{-+%************************************************************************+%*                                                                      *+        Helper functions for generating annotations in the parser+%*                                                                      *+%************************************************************************++For the general principles of the following routines, see Note [exact print annotations]+in GHC.Parser.Annotation++-}++-- |Construct an AddEpAnn from the annotation keyword and the location+-- of the keyword itself+mj :: AnnKeywordId -> Located e -> AddEpAnn+mj !a !l = AddEpAnn a (srcSpan2e $ gl l)++mjN :: AnnKeywordId -> LocatedN e -> AddEpAnn+mjN !a !l = AddEpAnn a (srcSpan2e $ glA l)++-- |Construct an AddEpAnn from the annotation keyword and the location+-- of the keyword itself, provided the span is not zero width+mz :: AnnKeywordId -> Located e -> [AddEpAnn]+mz !a !l = if isZeroWidthSpan (gl l) then [] else [AddEpAnn a (srcSpan2e $ gl l)]++msemi :: Located e -> [TrailingAnn]+msemi !l = if isZeroWidthSpan (gl l) then [] else [AddSemiAnn (srcSpan2e $ gl l)]++msemiA :: Located e -> [AddEpAnn]+msemiA !l = if isZeroWidthSpan (gl l) then [] else [AddEpAnn AnnSemi (srcSpan2e $ gl l)]++msemim :: Located e -> Maybe EpaLocation+msemim !l = if isZeroWidthSpan (gl l) then Nothing else Just (srcSpan2e $ gl l)++-- |Construct an AddEpAnn from the annotation keyword and the Located Token. If+-- the token has a unicode equivalent and this has been used, provide the+-- unicode variant of the annotation.+mu :: AnnKeywordId -> Located Token -> AddEpAnn+mu !a lt@(L l t) = AddEpAnn (toUnicodeAnn a lt) (srcSpan2e l)++-- | If the 'Token' is using its unicode variant return the unicode variant of+--   the annotation+toUnicodeAnn :: AnnKeywordId -> Located Token -> AnnKeywordId+toUnicodeAnn !a !t = if isUnicode t then unicodeAnn a else a++toUnicode :: Located Token -> IsUnicodeSyntax+toUnicode t = if isUnicode t then UnicodeSyntax else NormalSyntax++-- -------------------------------------++gl :: GenLocated l a -> l+gl = getLoc++glA :: HasLoc a => a -> SrcSpan+glA = getHasLoc++glR :: HasLoc a => a -> Anchor+glR !la = EpaSpan (getHasLoc la)++glEE :: (HasLoc a, HasLoc b) => a -> b -> Anchor+glEE !x !y = spanAsAnchor $ comb2 x y++glRM :: Located a -> Maybe Anchor+glRM (L !l _) = Just $ spanAsAnchor l++glAA :: HasLoc a => a -> EpaLocation+glAA = srcSpan2e . getHasLoc++n2l :: LocatedN a -> LocatedA a+n2l (L !la !a) = L (l2l la) a++-- Called at the very end to pick up the EOF position, as well as any comments not allocated yet.+acsFinal :: (EpAnnComments -> Maybe (RealSrcSpan, RealSrcSpan) -> Located a) -> P (Located a)+acsFinal a = do+  let (L l _) = a emptyComments Nothing+  !cs <- getCommentsFor l+  csf <- getFinalCommentsFor l+  meof <- getEofPos+  let ce = case meof of+             Strict.Nothing  -> Nothing+             Strict.Just (pos `Strict.And` gap) -> Just (pos,gap)+  return (a (cs Semi.<> csf) ce)++acs :: (HasLoc l, MonadP m) => l -> (l -> EpAnnComments -> GenLocated l a) -> m (GenLocated l a)+acs !l a = do+  !cs <- getCommentsFor (locA l)+  return (a l cs)++acsA :: (HasLoc l, HasAnnotation t, MonadP m) => l -> (l -> EpAnnComments -> Located a) -> m (GenLocated t a)+acsA !l a = do+  !cs <- getCommentsFor (locA l)+  return $ reLoc (a l cs)++ams1 :: MonadP m => Located a -> b -> m (LocatedA b)+ams1 (L l a) b = do+  !cs <- getCommentsFor l+  return (L (EpAnn (spanAsAnchor l) noAnn cs) b)++amsA' :: (NoAnn t, MonadP m) => Located a -> m (GenLocated (EpAnn t) a)+amsA' (L l a) = do+  !cs <- getCommentsFor l+  return (L (EpAnn (spanAsAnchor l) noAnn cs) a)++amsA :: MonadP m => LocatedA a -> [TrailingAnn] -> m (LocatedA a)+amsA (L !l a) bs = do+  !cs <- getCommentsFor (locA l)+  return (L (addAnnsA l bs cs) a)++amsAl :: MonadP m => LocatedA a -> SrcSpan -> [TrailingAnn] -> m (LocatedA a)+amsAl (L l a) loc bs = do+  !cs <- getCommentsFor loc+  return (L (addAnnsA l bs cs) a)++amsr :: MonadP m => Located a -> an -> m (LocatedAn an a)+amsr (L l a) an = do+  !cs <- getCommentsFor l+  return (L (EpAnn (spanAsAnchor l) an cs) a)++-- |Synonyms for AddEpAnn versions of AnnOpen and AnnClose+mo,mc :: Located Token -> AddEpAnn+mo !ll = mj AnnOpen ll+mc !ll = mj AnnClose ll++moc,mcc :: Located Token -> AddEpAnn+moc !ll = mj AnnOpenC ll+mcc !ll = mj AnnCloseC ll++mop,mcp :: Located Token -> AddEpAnn+mop !ll = mj AnnOpenP ll+mcp !ll = mj AnnCloseP ll++moh,mch :: Located Token -> AddEpAnn+moh !ll = mj AnnOpenPH ll+mch !ll = mj AnnClosePH ll++mos,mcs :: Located Token -> AddEpAnn+mos !ll = mj AnnOpenS ll+mcs !ll = mj AnnCloseS ll++-- | Parse a Haskell module with Haddock comments. This is done in two steps:+--+-- * 'parseModuleNoHaddock' to build the AST+-- * 'addHaddockToModule' to insert Haddock comments into it+--+-- This and the signature module parser are the only parser entry points that+-- deal with Haddock comments. The other entry points ('parseDeclaration',+-- 'parseExpression', etc) do not insert them into the AST.+parseModule :: P (Located (HsModule GhcPs))+parseModule = parseModuleNoHaddock >>= addHaddockToModule++-- | Parse a Haskell signature module with Haddock comments. This is done in two+-- steps:+--+-- * 'parseSignatureNoHaddock' to build the AST+-- * 'addHaddockToModule' to insert Haddock comments into it+--+-- This and the module parser are the only parser entry points that deal with+-- Haddock comments. The other entry points ('parseDeclaration',+-- 'parseExpression', etc) do not insert them into the AST.+parseSignature :: P (Located (HsModule GhcPs))+parseSignature = parseSignatureNoHaddock >>= addHaddockToModule++commentsA :: (NoAnn ann) => SrcSpan -> EpAnnComments -> EpAnn ann+commentsA loc cs = EpAnn (EpaSpan loc) noAnn cs++spanWithComments :: (NoAnn ann, MonadP m) => SrcSpan -> m (EpAnn ann)+spanWithComments l = do+  !cs <- getCommentsFor l+  return (commentsA l cs)++-- | Instead of getting the *enclosed* comments, this includes the+-- *preceding* ones.  It is used at the top level to get comments+-- between top level declarations.+commentsPA :: (NoAnn ann) => LocatedAn ann a -> P (LocatedAn ann a)+commentsPA la@(L l a) = do+  !cs <- getPriorCommentsFor (getLocA la)+  return (L (addCommentsToEpAnn l cs) a)++hsDoAnn :: Located a -> LocatedAn t b -> AnnKeywordId -> AnnList+hsDoAnn (L l _) (L ll _) kw+  = AnnList (Just $ spanAsAnchor (locA ll)) Nothing Nothing [AddEpAnn kw (srcSpan2e l)] []++listAsAnchor :: [LocatedAn t a] -> Located b -> Anchor+listAsAnchor [] (L l _) = spanAsAnchor l+listAsAnchor (h:_) s = spanAsAnchor (comb2 h s)++listAsAnchorM :: [LocatedAn t a] -> Maybe Anchor+listAsAnchorM [] = Nothing+listAsAnchorM (L l _:_) =+  case locA l of+    RealSrcSpan ll _ -> Just $ realSpanAsAnchor ll+    _                -> Nothing++epTok :: Located Token -> EpToken tok+epTok (L !l _) = EpTok (EpaSpan l)++epUniTok :: Located Token -> EpUniToken tok utok+epUniTok t@(L !l _) = EpUniTok (EpaSpan l) u+  where+    u = if isUnicode t then UnicodeSyntax else NormalSyntax++epExplicitBraces :: Located Token -> Located Token -> EpLayout+epExplicitBraces !t1 !t2 = EpExplicitBraces (epTok t1) (epTok t2)++-- -------------------------------------++addTrailingCommaFBind :: MonadP m => Fbind b -> SrcSpan -> m (Fbind b)+addTrailingCommaFBind (Left b)  l = fmap Left  (addTrailingCommaA b l)+addTrailingCommaFBind (Right b) l = fmap Right (addTrailingCommaA b l)++addTrailingVbarA :: MonadP m => LocatedA a -> SrcSpan -> m (LocatedA a)+addTrailingVbarA  la span = addTrailingAnnA la span AddVbarAnn++addTrailingSemiA :: MonadP m => LocatedA a -> SrcSpan -> m (LocatedA a)+addTrailingSemiA  la span = addTrailingAnnA la span AddSemiAnn++addTrailingCommaA :: MonadP m => LocatedA a -> SrcSpan -> m (LocatedA a)+addTrailingCommaA  la span = addTrailingAnnA la span AddCommaAnn++addTrailingAnnA :: MonadP m => LocatedA a -> SrcSpan -> (EpaLocation -> TrailingAnn) -> m (LocatedA a)+addTrailingAnnA (L anns a) ss ta = do+  let cs = emptyComments+  -- AZ:TODO: generalise updating comments into an annotation+  let+    anns' = if isZeroWidthSpan ss+              then anns+              else addTrailingAnnToA (ta (srcSpan2e ss)) cs anns+  return (L anns' a)++-- -------------------------------------++addTrailingVbarL :: MonadP m => LocatedL a -> SrcSpan -> m (LocatedL a)+addTrailingVbarL  la span = addTrailingAnnL la (AddVbarAnn (srcSpan2e span))++addTrailingCommaL :: MonadP m => LocatedL a -> SrcSpan -> m (LocatedL a)+addTrailingCommaL  la span = addTrailingAnnL la (AddCommaAnn (srcSpan2e span))++addTrailingAnnL :: MonadP m => LocatedL a -> TrailingAnn -> m (LocatedL a)+addTrailingAnnL (L anns a) ta = do+  !cs <- getCommentsFor (locA anns)+  let anns' = addTrailingAnnToL ta cs anns+  return (L anns' a)++-- -------------------------------------++-- Mostly use to add AnnComma, special case it to NOP if adding a zero-width annotation+addTrailingCommaN :: MonadP m => LocatedN a -> SrcSpan -> m (LocatedN a)+addTrailingCommaN (L anns a) span = do+  let cs = emptyComments+  -- AZ:TODO: generalise updating comments into an annotation+  let anns' = if isZeroWidthSpan span+                then anns+                else addTrailingCommaToN anns (srcSpan2e span)+  return (L anns' a)++addTrailingCommaS :: Located StringLiteral -> EpaLocation -> Located StringLiteral+addTrailingCommaS (L l sl) span+    = L (widenSpan l [AddEpAnn AnnComma span]) (sl { sl_tc = Just (epaToNoCommentsLocation span) })++-- -------------------------------------++addTrailingDarrowC :: LocatedC a -> Located Token -> EpAnnComments -> LocatedC a+addTrailingDarrowC (L (EpAnn lr (AnnContext _ o c) csc) a) lt cs =+  let+    u = if (isUnicode lt) then UnicodeSyntax else NormalSyntax+  in L (EpAnn lr (AnnContext (Just (u,glAA lt)) o c) (cs Semi.<> csc)) a++-- -------------------------------------++-- We need a location for the where binds, when computing the SrcSpan+-- for the AST element using them.  Where there is a span, we return+-- it, else noLoc, which is ignored in the comb2 call.+adaptWhereBinds :: Maybe (Located (HsLocalBinds GhcPs, Maybe EpAnnComments))+                ->        Located (HsLocalBinds GhcPs,       EpAnnComments)+adaptWhereBinds Nothing = noLoc (EmptyLocalBinds noExtField, emptyComments)+adaptWhereBinds (Just (L l (b, mc))) = L l (b, maybe emptyComments id mc)++combineHasLocs :: (HasLoc a, HasLoc b) => a -> b -> SrcSpan+combineHasLocs a b = combineSrcSpans (getHasLoc a) (getHasLoc b)++fromTrailingN :: SrcSpanAnnN -> SrcSpanAnnA+fromTrailingN (EpAnn anc ann cs)+    = EpAnn anc (AnnListItem (nann_trailing ann)) cs }
compiler/GHC/Parser/Annotation.hs view
@@ -1,11 +1,17 @@-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE StandaloneDeriving #-}  module GHC.Parser.Annotation (   -- * Core Exact Print Annotation types   AnnKeywordId(..),+  EpToken(..), EpUniToken(..),+  getEpTokenSrcSpan,+  EpLayout(..),   EpaComment(..), EpaCommentTok(..),   IsUnicodeSyntax(..),   unicodeAnn,@@ -13,25 +19,27 @@    -- * In-tree Exact Print Annotations   AddEpAnn(..),-  EpaLocation(..), epaLocationRealSrcSpan, epaLocationFromSrcAnn,+  EpaLocation, EpaLocation'(..), epaLocationRealSrcSpan,   TokenLocation(..),-  getTokenSrcSpan,   DeltaPos(..), deltaPos, getDeltaLine, -  EpAnn(..), Anchor(..), AnchorOperation(..),+  EpAnn(..), Anchor,+  anchor,   spanAsAnchor, realSpanAsAnchor,-  noAnn,+  noSpanAnchor,+  NoAnn(..),    -- ** Comments in Annotations -  EpAnnComments(..), LEpaComment, emptyComments,+  EpAnnComments(..), LEpaComment, NoCommentsLocation, NoComments(..), emptyComments,+  epaToNoCommentsLocation, noCommentsToEpaLocation,   getFollowingComments, setFollowingComments, setPriorComments,   EpAnnCO,    -- ** Annotations in 'GenLocated'   LocatedA, LocatedL, LocatedC, LocatedN, LocatedAn, LocatedP,   SrcSpanAnnA, SrcSpanAnnL, SrcSpanAnnP, SrcSpanAnnC, SrcSpanAnnN,-  SrcSpanAnn'(..), SrcAnn,+  LocatedE,    -- ** Annotation data types used in 'GenLocated' @@ -41,27 +49,28 @@   AnnContext(..),   NameAnn(..), NameAdornment(..),   NoEpAnns(..),-  AnnSortKey(..),+  AnnSortKey(..), DeclTag(..), BindTag(..),    -- ** Trailing annotations in lists   TrailingAnn(..), trailingAnnToAddEpAnn,   addTrailingAnnToA, addTrailingAnnToL, addTrailingCommaToN,+  noTrailingN,    -- ** Utilities for converting between different 'GenLocated' when   -- ** we do not care about the annotations.-  la2na, na2la, n2l, l2n, l2l, la2la,-  reLoc, reLocA, reLocL, reLocC, reLocN,+  l2l, la2la,+  reLoc,+  HasLoc(..), getHasLocList, -  srcSpan2e, la2e, realSrcSpan,+  srcSpan2e, realSrcSpan,    -- ** Building up annotations-  extraToAnnList, reAnn,   reAnnL, reAnnC,-  addAnns, addAnnsA, widenSpan, widenAnchor, widenAnchorR, widenLocatedAn,+  addAnns, addAnnsA, widenSpan, widenAnchor, widenAnchorS, widenLocatedAn,    -- ** Querying annotations   getLocAnn,-  epAnnAnns, epAnnAnnsL,+  epAnnAnns,   annParen2AddEpAnn,   epAnnComments, @@ -70,18 +79,21 @@   mapLocA,   combineLocsA,   combineSrcSpansA,-  addCLocA, addCLocAA,+  addCLocA,    -- ** Constructing 'GenLocated' annotation types when we do not care   -- about annotations.-  noLocA, getLocA,+  HasAnnotation(..),+  locA,+  noLocA,+  getLocA,   noSrcSpanA,-  noAnnSrcSpan,    -- ** Working with comments in annotations-  noComments, comment, addCommentsToSrcAnn, setCommentsSrcAnn,-  addCommentsToEpAnn, setCommentsEpAnn,-  transferAnnsA, commentsOnlyA, removeCommentsA,+  noComments, comment, addCommentsToEpAnn, setCommentsEpAnn,+  transferAnnsA, transferAnnsOnlyA, transferCommentsOnlyA,+  transferPriorCommentsA, transferFollowingA,+  commentsOnlyA, removeCommentsA,    placeholderRealSpan,   ) where@@ -90,9 +102,10 @@  import Data.Data import Data.Function (on)-import Data.List (sortBy)+import Data.List (sortBy, foldl1') import Data.Semigroup import GHC.Data.FastString+import GHC.TypeLits (Symbol, KnownSymbol) import GHC.Types.Name import GHC.Types.SrcLoc import GHC.Hs.DocString@@ -350,6 +363,59 @@  -- --------------------------------------------------------------------- +-- | A token stored in the syntax tree. For example, when parsing a+-- let-expression, we store @EpToken "let"@ and @EpToken "in"@.+-- The locations of those tokens can be used to faithfully reproduce+-- (exactprint) the original program text.+data EpToken (tok :: Symbol)+  = NoEpTok+  | EpTok !EpaLocation++-- | With @UnicodeSyntax@, there might be multiple ways to write the same+-- token. For example an arrow could be either @->@ or @→@. This choice must be+-- recorded in order to exactprint such tokens, so instead of @EpToken "->"@ we+-- introduce @EpUniToken "->" "→"@.+data EpUniToken (tok :: Symbol) (utok :: Symbol)+  = NoEpUniTok+  | EpUniTok !EpaLocation !IsUnicodeSyntax++deriving instance Eq (EpToken tok)+deriving instance KnownSymbol tok => Data (EpToken tok)+deriving instance (KnownSymbol tok, KnownSymbol utok) => Data (EpUniToken tok utok)++getEpTokenSrcSpan :: EpToken tok -> SrcSpan+getEpTokenSrcSpan NoEpTok = noSrcSpan+getEpTokenSrcSpan (EpTok EpaDelta{}) = noSrcSpan+getEpTokenSrcSpan (EpTok (EpaSpan span)) = span++-- | Layout information for declarations.+data EpLayout =++    -- | Explicit braces written by the user.+    --+    -- @+    -- class C a where { foo :: a; bar :: a }+    -- @+    EpExplicitBraces !(EpToken "{") !(EpToken "}")+  |+    -- | Virtual braces inserted by the layout algorithm.+    --+    -- @+    -- class C a where+    --   foo :: a+    --   bar :: a+    -- @+    EpVirtualBraces+      !Int -- ^ Layout column (indentation level, begins at 1)+  |+    -- | Empty or compiler-generated blocks do not have layout information+    -- associated with them.+    EpNoLayout++deriving instance Data EpLayout++-- ---------------------------------------------------------------------+ data EpaComment =   EpaComment     { ac_tok :: EpaCommentTok@@ -368,13 +434,6 @@   | EpaDocOptions      String     -- ^ doc options (prune, ignore-exports, etc)   | EpaLineComment     String     -- ^ comment starting by "--"   | EpaBlockComment    String     -- ^ comment in {- -}-  | EpaEofComment                 -- ^ empty comment, capturing-                                  -- location of EOF--  -- See #19697 for a discussion of EpaEofComment's use and how it-  -- should be removed in favour of capturing it in the location for-  -- 'Located HsModule' in the parser.-     deriving (Eq, Data, Show) -- Note: these are based on the Token versions, but the Token type is -- defined in GHC.Parser.Lexer and bringing it in here would create a loop@@ -395,74 +454,31 @@ -- annotation. data AddEpAnn = AddEpAnn AnnKeywordId EpaLocation deriving (Data,Eq) --- | The anchor for an @'AnnKeywordId'@. The Parser inserts the--- @'EpaSpan'@ variant, giving the exact location of the original item--- in the parsed source.  This can be replaced by the @'EpaDelta'@--- version, to provide a position for the item relative to the end of--- the previous item in the source.  This is useful when editing an--- AST prior to exact printing the changed one. The list of comments--- in the @'EpaDelta'@ variant captures any comments between the prior--- output and the thing being marked here, since we cannot otherwise--- sort the relative order.-data EpaLocation = EpaSpan !RealSrcSpan !(Strict.Maybe BufSpan)-                 | EpaDelta !DeltaPos ![LEpaComment]-               deriving (Data,Eq)+type EpaLocation = EpaLocation' [LEpaComment] +epaToNoCommentsLocation :: EpaLocation -> NoCommentsLocation+epaToNoCommentsLocation (EpaSpan ss) = EpaSpan ss+epaToNoCommentsLocation (EpaDelta dp []) = EpaDelta dp NoComments+epaToNoCommentsLocation (EpaDelta _ _ ) = panic "epaToNoCommentsLocation"++noCommentsToEpaLocation :: NoCommentsLocation -> EpaLocation+noCommentsToEpaLocation (EpaSpan ss) = EpaSpan ss+noCommentsToEpaLocation (EpaDelta dp NoComments) = EpaDelta dp []+ -- | Tokens embedded in the AST have an EpaLocation, unless they come from -- generated code (e.g. by TH). data TokenLocation = NoTokenLoc | TokenLoc !EpaLocation                deriving (Data,Eq) -getTokenSrcSpan :: TokenLocation -> SrcSpan-getTokenSrcSpan NoTokenLoc = noSrcSpan-getTokenSrcSpan (TokenLoc EpaDelta{}) = noSrcSpan-getTokenSrcSpan (TokenLoc (EpaSpan rspan mbufpos)) = RealSrcSpan rspan mbufpos- instance Outputable a => Outputable (GenLocated TokenLocation a) where   ppr (L _ x) = ppr x --- | Spacing between output items when exact printing.  It captures--- the spacing from the current print position on the page to the--- position required for the thing about to be printed.  This is--- either on the same line in which case is is simply the number of--- spaces to emit, or it is some number of lines down, with a given--- column offset.  The exact printing algorithm keeps track of the--- column offset pertaining to the current anchor position, so the--- `deltaColumn` is the additional spaces to add in this case.  See--- https://gitlab.haskell.org/ghc/ghc/wikis/api-annotations for--- details.-data DeltaPos-  = SameLine { deltaColumn :: !Int }-  | DifferentLine-      { deltaLine   :: !Int, -- ^ deltaLine should always be > 0-        deltaColumn :: !Int-      } deriving (Show,Eq,Ord,Data)---- | Smart constructor for a 'DeltaPos'. It preserves the invariant--- that for the 'DifferentLine' constructor 'deltaLine' is always > 0.-deltaPos :: Int -> Int -> DeltaPos-deltaPos l c = case l of-  0 -> SameLine c-  _ -> DifferentLine l c--getDeltaLine :: DeltaPos -> Int-getDeltaLine (SameLine _) = 0-getDeltaLine (DifferentLine r _) = r- -- | Used in the parser only, extract the 'RealSrcSpan' from an -- 'EpaLocation'. The parser will never insert a 'DeltaPos', so the -- partial function is safe. epaLocationRealSrcSpan :: EpaLocation -> RealSrcSpan-epaLocationRealSrcSpan (EpaSpan r _) = r-epaLocationRealSrcSpan (EpaDelta _ _) = panic "epaLocationRealSrcSpan"--epaLocationFromSrcAnn :: SrcAnn ann -> EpaLocation-epaLocationFromSrcAnn (SrcSpanAnn EpAnnNotUsed l) = EpaSpan (realSrcSpan l) Strict.Nothing-epaLocationFromSrcAnn (SrcSpanAnn (EpAnn anc _ _) _) = EpaSpan (anchor anc) Strict.Nothing--instance Outputable EpaLocation where-  ppr (EpaSpan r _) = text "EpaSpan" <+> ppr r-  ppr (EpaDelta d cs) = text "EpaDelta" <+> ppr d <+> ppr cs+epaLocationRealSrcSpan (EpaSpan (RealSrcSpan r _)) = r+epaLocationRealSrcSpan _ = panic "epaLocationRealSrcSpan"  instance Outputable AddEpAnn where   ppr (AddEpAnn kw ss) = text "AddEpAnn" <+> ppr kw <+> ppr ss@@ -511,40 +527,30 @@               -- ^ Comments enclosed in the SrcSpan of the element               -- this `EpAnn` is attached to            }-  | EpAnnNotUsed -- ^ No Annotation for generated code,-                  -- e.g. from TH, deriving, etc.         deriving (Data, Eq, Functor)+-- See Note [XRec and Anno in the AST]  -- | An 'Anchor' records the base location for the start of the -- syntactic element holding the annotations, and is used as the point -- of reference for calculating delta positions for contained -- annotations. -- It is also normally used as the reference point for the spacing of--- the element relative to its container. If it is moved, that--- relationship is tracked in the 'anchor_op' instead.--data Anchor = Anchor        { anchor :: RealSrcSpan-                                 -- ^ Base location for the start of-                                 -- the syntactic element holding-                                 -- the annotations.-                            , anchor_op :: AnchorOperation }-        deriving (Data, Eq, Show)+-- the element relative to its container. If the AST element is moved,+-- that relationship is tracked in the 'anchor_op' instead.+type Anchor = EpaLocation -- Transitional --- | If tools modify the parsed source, the 'MovedAnchor' variant can--- directly provide the spacing for this item relative to the previous--- one when printing. This allows AST fragments with a particular--- anchor to be freely moved, without worrying about recalculating the--- appropriate anchor span.-data AnchorOperation = UnchangedAnchor-                     | MovedAnchor DeltaPos-        deriving (Data, Eq, Show)+anchor :: (EpaLocation' a) -> RealSrcSpan+anchor (EpaSpan (RealSrcSpan r _)) = r+anchor _ = panic "anchor" +spanAsAnchor :: SrcSpan -> (EpaLocation' a)+spanAsAnchor ss  = EpaSpan ss -spanAsAnchor :: SrcSpan -> Anchor-spanAsAnchor s  = Anchor (realSrcSpan s) UnchangedAnchor+realSpanAsAnchor :: RealSrcSpan -> (EpaLocation' a)+realSpanAsAnchor s = EpaSpan (RealSrcSpan s Strict.Nothing) -realSpanAsAnchor :: RealSrcSpan -> Anchor-realSpanAsAnchor s  = Anchor s UnchangedAnchor+noSpanAnchor :: (NoAnn a) => (EpaLocation' a)+noSpanAnchor =  EpaDelta (SameLine 0) noAnn  -- --------------------------------------------------------------------- @@ -562,7 +568,7 @@                         , followingComments :: ![LEpaComment] }         deriving (Data, Eq) -type LEpaComment = GenLocated Anchor EpaComment+type LEpaComment = GenLocated NoCommentsLocation EpaComment  emptyComments :: EpAnnComments emptyComments = EpaComments []@@ -571,19 +577,6 @@ -- Annotations attached to a 'SrcSpan'. -- --------------------------------------------------------------------- --- | The 'SrcSpanAnn\'' type wraps a normal 'SrcSpan', together with--- an extra annotation type. This is mapped to a specific `GenLocated`--- usage in the AST through the `XRec` and `Anno` type families.---- Important that the fields are strict as these live inside L nodes which--- are live for a long time.-data SrcSpanAnn' a = SrcSpanAnn { ann :: !a, locA :: !SrcSpan }-        deriving (Data, Eq)--- See Note [XRec and Anno in the AST]---- | We mostly use 'SrcSpanAnn\'' with an 'EpAnn\''-type SrcAnn ann = SrcSpanAnn' (EpAnn ann)- type LocatedA = GenLocated SrcSpanAnnA type LocatedN = GenLocated SrcSpanAnnN @@ -591,16 +584,18 @@ type LocatedP = GenLocated SrcSpanAnnP type LocatedC = GenLocated SrcSpanAnnC -type SrcSpanAnnA = SrcAnn AnnListItem-type SrcSpanAnnN = SrcAnn NameAnn+type SrcSpanAnnA = EpAnn AnnListItem+type SrcSpanAnnN = EpAnn NameAnn -type SrcSpanAnnL = SrcAnn AnnList-type SrcSpanAnnP = SrcAnn AnnPragma-type SrcSpanAnnC = SrcAnn AnnContext+type SrcSpanAnnL = EpAnn AnnList+type SrcSpanAnnP = EpAnn AnnPragma+type SrcSpanAnnC = EpAnn AnnContext +type LocatedE = GenLocated EpaLocation+ -- | General representation of a 'GenLocated' type carrying a -- parameterised annotation type.-type LocatedAn an = GenLocated (SrcAnn an)+type LocatedAn an = GenLocated (EpAnn an)  {- Note [XRec and Anno in the AST]@@ -641,15 +636,19 @@ -- | Captures the location of punctuation occurring between items, -- normally in a list.  It is captured as a trailing annotation. data TrailingAnn-  = AddSemiAnn EpaLocation    -- ^ Trailing ';'-  | AddCommaAnn EpaLocation   -- ^ Trailing ','-  | AddVbarAnn EpaLocation    -- ^ Trailing '|'+  = AddSemiAnn    { ta_location :: EpaLocation }  -- ^ Trailing ';'+  | AddCommaAnn   { ta_location :: EpaLocation }  -- ^ Trailing ','+  | AddVbarAnn    { ta_location :: EpaLocation }  -- ^ Trailing '|'+  | AddDarrowAnn  { ta_location :: EpaLocation }  -- ^ Trailing '=>'+  | AddDarrowUAnn { ta_location :: EpaLocation }  -- ^ Trailing  "⇒"   deriving (Data, Eq)  instance Outputable TrailingAnn where   ppr (AddSemiAnn ss)    = text "AddSemiAnn"    <+> ppr ss   ppr (AddCommaAnn ss)   = text "AddCommaAnn"   <+> ppr ss   ppr (AddVbarAnn ss)    = text "AddVbarAnn"    <+> ppr ss+  ppr (AddDarrowAnn ss)  = text "AddDarrowAnn"  <+> ppr ss+  ppr (AddDarrowUAnn ss) = text "AddDarrowUAnn" <+> ppr ss  -- | Annotation for items appearing in a list. They can have one or -- more trailing punctuations items, such as commas or semicolons.@@ -695,7 +694,7 @@   = AnnParens       -- ^ '(', ')'   | AnnParensHash   -- ^ '(#', '#)'   | AnnParensSquare -- ^ '[', ']'-  deriving (Eq, Ord, Data)+  deriving (Eq, Ord, Data, Show)  -- | Maps the 'ParenType' to the related opening and closing -- AnnKeywordId. Used when actually printing the item.@@ -799,18 +798,119 @@       } deriving (Data,Eq)  -- ------------------------------------------------------------------------ | Captures the sort order of sub elements. This is needed when the--- sub-elements have been split (as in a HsLocalBind which holds separate--- binds and sigs) or for infix patterns where the order has been--- re-arranged. It is captured explicitly so that after the Delta phase a--- SrcSpan is used purely as an index into the annotations, allowing--- transformations of the AST including the introduction of new Located--- items or re-arranging existing ones.-data AnnSortKey++-- | Captures the sort order of sub elements for `ValBinds`,+-- `ClassDecl`, `ClsInstDecl`+data AnnSortKey tag+  -- See Note [AnnSortKey] below   = NoAnnSortKey-  | AnnSortKey [RealSrcSpan]+  | AnnSortKey [tag]   deriving (Data, Eq) +-- | Used to track of interleaving of binds and signatures for ValBind+data BindTag+  -- See Note [AnnSortKey] below+  = BindTag+  | SigDTag+  deriving (Eq,Data,Ord,Show)++-- | Used to track interleaving of class methods, class signatures,+-- associated types and associate type defaults in `ClassDecl` and+-- `ClsInstDecl`.+data DeclTag+  -- See Note [AnnSortKey] below+  = ClsMethodTag+  | ClsSigTag+  | ClsAtTag+  | ClsAtdTag+  deriving (Eq,Data,Ord,Show)++{-+Note [AnnSortKey]+~~~~~~~~~~~~~~~~~++For some constructs in the ParsedSource we have mixed lists of items+that can be freely intermingled.++An example is the binds in a where clause, captured in++    ValBinds+        (XValBinds idL idR)+        (LHsBindsLR idL idR) [LSig idR]++This keeps separate ordered collections of LHsBind GhcPs and LSig GhcPs.++But there is no constraint on the original source code as to how these+should appear, so they can have all the signatures first, then their+binds, or grouped with a signature preceding each bind.++   fa :: Int+   fa = 1++   fb :: Char+   fb = 'c'++Or++   fa :: Int+   fb :: Char++   fb = 'c'+   fa = 1++When exact printing these, we need to restore the original order. As+initially parsed we have the SrcSpan, and can sort on those. But if we+have modified the AST prior to printing, we cannot rely on the+SrcSpans for order any more.++The bag of LHsBind GhcPs is physically ordered, as is the list of LSig+GhcPs. So in effect we have a list of binds in the order we care+about, and a list of sigs in the order we care about. The only problem+is to know how to merge the lists.++This is where AnnSortKey comes in, which we store in the TTG extension+point for ValBinds.++    data AnnSortKey tag+      = NoAnnSortKey+      | AnnSortKey [tag]++When originally parsed, with SrcSpans we can rely on, we do not need+any extra information, so we tag it with NoAnnSortKey.++If the binds and signatures are updated in any way, such that we can+no longer rely on their SrcSpans (e.g. they are copied from elsewhere,+parsed from scratch for insertion, have a fake SrcSpan), we use+`AnnSortKey [BindTag]` to keep track.++    data BindTag+      = BindTag+      | SigDTag++We use it as a merge selector, and have one entry for each bind and+signature.++So for the first example we have++  binds: fa = 1 , fb = 'c'+  sigs:  fa :: Int, fb :: Char+  tags: SigTag, BindTag, SigTag, BindTag++so we draw first from the signatures, then the binds, and same again.++For the second example we have++  binds: fb = 'c', fa = 1+  sigs:  fa :: Int, fb :: Char+  tags: SigTag, SigTag, BindTag, BindTag++so we draw two signatures, then two binds.++We do similar for ClassDecl and ClsInstDecl, but we have four+different lists we must manage. For this we use DeclTag.++-}+ -- ---------------------------------------------------------------------  -- | Convert a 'TrailingAnn' to an 'AddEpAnn'@@ -818,14 +918,14 @@ trailingAnnToAddEpAnn (AddSemiAnn ss)    = AddEpAnn AnnSemi ss trailingAnnToAddEpAnn (AddCommaAnn ss)   = AddEpAnn AnnComma ss trailingAnnToAddEpAnn (AddVbarAnn ss)    = AddEpAnn AnnVbar ss+trailingAnnToAddEpAnn (AddDarrowUAnn ss) = AddEpAnn AnnDarrowU ss+trailingAnnToAddEpAnn (AddDarrowAnn ss)  = AddEpAnn AnnDarrow ss  -- | Helper function used in the parser to add a 'TrailingAnn' items -- to an existing annotation.-addTrailingAnnToL :: SrcSpan -> TrailingAnn -> EpAnnComments+addTrailingAnnToL :: TrailingAnn -> EpAnnComments                   -> EpAnn AnnList -> EpAnn AnnList-addTrailingAnnToL s t cs EpAnnNotUsed-  = EpAnn (spanAsAnchor s) (AnnList (Just $ spanAsAnchor s) Nothing Nothing [] [t]) cs-addTrailingAnnToL _ t cs n = n { anns = addTrailing (anns n)+addTrailingAnnToL t cs n = n { anns = addTrailing (anns n)                                , comments = comments n <> cs }   where     -- See Note [list append in addTrailing*]@@ -833,11 +933,9 @@  -- | Helper function used in the parser to add a 'TrailingAnn' items -- to an existing annotation.-addTrailingAnnToA :: SrcSpan -> TrailingAnn -> EpAnnComments+addTrailingAnnToA :: TrailingAnn -> EpAnnComments                   -> EpAnn AnnListItem -> EpAnn AnnListItem-addTrailingAnnToA s t cs EpAnnNotUsed-  = EpAnn (spanAsAnchor s) (AnnListItem [t]) cs-addTrailingAnnToA _ t cs n = n { anns = addTrailing (anns n)+addTrailingAnnToA t cs n = n { anns = addTrailing (anns n)                                , comments = comments n <> cs }   where     -- See Note [list append in addTrailing*]@@ -845,15 +943,16 @@  -- | Helper function used in the parser to add a comma location to an -- existing annotation.-addTrailingCommaToN :: SrcSpan -> EpAnn NameAnn -> EpaLocation -> EpAnn NameAnn-addTrailingCommaToN s EpAnnNotUsed l-  = EpAnn (spanAsAnchor s) (NameAnnTrailing [AddCommaAnn l]) emptyComments-addTrailingCommaToN _ n l = n { anns = addTrailing (anns n) l }+addTrailingCommaToN :: EpAnn NameAnn -> EpaLocation -> EpAnn NameAnn+addTrailingCommaToN  n l = n { anns = addTrailing (anns n) l }   where     -- See Note [list append in addTrailing*]     addTrailing :: NameAnn -> EpaLocation -> NameAnn     addTrailing n l = n { nann_trailing = nann_trailing n ++ [AddCommaAnn l]} +noTrailingN :: SrcSpanAnnN -> SrcSpanAnnN+noTrailingN s = s { anns = (anns s) { nann_trailing = [] } }+ {- Note [list append in addTrailing*] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -876,112 +975,109 @@  -- --------------------------------------------------------------------- --- |Helper function (temporary) during transition of names+-- |Helper function for converting annotation types. --  Discards any annotations-l2n :: LocatedAn a1 a2 -> LocatedN a2-l2n (L la a) = L (noAnnSrcSpan (locA la)) a--n2l :: LocatedN a -> LocatedA a-n2l (L la a) = L (na2la la) a+l2l :: (HasLoc a, HasAnnotation b) => a -> b+l2l a = noAnnSrcSpan (getHasLoc a) --- |Helper function (temporary) during transition of names+-- |Helper function for converting annotation types. --  Discards any annotations-la2na :: SrcSpanAnn' a -> SrcSpanAnnN-la2na l = noAnnSrcSpan (locA l)+la2la :: (HasLoc l, HasAnnotation l2) => GenLocated l a -> GenLocated l2 a+la2la (L la a) = L (noAnnSrcSpan (getHasLoc la)) a --- |Helper function (temporary) during transition of names---  Discards any annotations-la2la :: LocatedAn ann1 a2 -> LocatedAn ann2 a2-la2la (L la a) = L (noAnnSrcSpan (locA la)) a+locA :: (HasLoc a) => a -> SrcSpan+locA = getHasLoc -l2l :: SrcSpanAnn' a -> SrcAnn ann-l2l l = noAnnSrcSpan (locA l)+reLoc :: (HasLoc (GenLocated a e), HasAnnotation b)+      => GenLocated a e -> GenLocated b e+reLoc (L la a) = L (noAnnSrcSpan $ locA (L la a) ) a --- |Helper function (temporary) during transition of names---  Discards any annotations-na2la :: SrcSpanAnn' a -> SrcAnn ann-na2la l = noAnnSrcSpan (locA l) -reLoc :: LocatedAn a e -> Located e-reLoc (L (SrcSpanAnn _ l) a) = L l a+-- --------------------------------------------------------------------- -reLocA :: Located e -> LocatedAn ann e-reLocA (L l a) = (L (SrcSpanAnn EpAnnNotUsed l) a)+class HasAnnotation e where+  noAnnSrcSpan :: SrcSpan -> e -reLocL :: LocatedN e -> LocatedA e-reLocL (L l a) = (L (na2la l) a)+instance HasAnnotation SrcSpan where+  noAnnSrcSpan l = l -reLocC :: LocatedN e -> LocatedC e-reLocC (L l a) = (L (na2la l) a)+instance HasAnnotation EpaLocation where+  noAnnSrcSpan l = EpaSpan l -reLocN :: LocatedN a -> Located a-reLocN (L (SrcSpanAnn _ l) a) = L l a+instance (NoAnn ann) => HasAnnotation (EpAnn ann) where+  noAnnSrcSpan l = EpAnn (spanAsAnchor l) noAnn emptyComments +noLocA :: (HasAnnotation e) => a -> GenLocated e a+noLocA = L (noAnnSrcSpan noSrcSpan)++getLocA :: (HasLoc a) => GenLocated a e -> SrcSpan+getLocA = getHasLoc++noSrcSpanA :: (HasAnnotation e) => e+noSrcSpanA = noAnnSrcSpan noSrcSpan+ -- --------------------------------------------------------------------- -realSrcSpan :: SrcSpan -> RealSrcSpan-realSrcSpan (RealSrcSpan s _) = s-realSrcSpan _ = mkRealSrcSpan l l -- AZ temporary-  where-    l = mkRealSrcLoc (fsLit "realSrcSpan") (-1) (-1)+class NoAnn a where+  -- | equivalent of `mempty`, but does not need Semigroup+  noAnn :: a -srcSpan2e :: SrcSpan -> EpaLocation-srcSpan2e (RealSrcSpan s mb) = EpaSpan s mb-srcSpan2e span = EpaSpan (realSrcSpan span) Strict.Nothing+-- --------------------------------------------------------------------- -la2e :: SrcSpanAnn' a -> EpaLocation-la2e = srcSpan2e . locA+class HasLoc a where+  -- ^ conveniently calculate locations for things without locations attached+  getHasLoc :: a -> SrcSpan -extraToAnnList :: AnnList -> [AddEpAnn] -> AnnList-extraToAnnList (AnnList a o c e t) as = AnnList a o c (e++as) t+instance (HasLoc l) => HasLoc (GenLocated l a) where+  getHasLoc (L l _) = getHasLoc l -reAnn :: [TrailingAnn] -> EpAnnComments -> Located a -> LocatedA a-reAnn anns cs (L l a) = L (SrcSpanAnn (EpAnn (spanAsAnchor l) (AnnListItem anns) cs) l) a+instance HasLoc SrcSpan where+  getHasLoc l = l -reAnnC :: AnnContext -> EpAnnComments -> Located a -> LocatedC a-reAnnC anns cs (L l a) = L (SrcSpanAnn (EpAnn (spanAsAnchor l) anns cs) l) a+instance (HasLoc a) => (HasLoc (Maybe a)) where+  getHasLoc (Just a) = getHasLoc a+  getHasLoc Nothing = noSrcSpan -reAnnL :: ann -> EpAnnComments -> Located e -> GenLocated (SrcAnn ann) e-reAnnL anns cs (L l a) = L (SrcSpanAnn (EpAnn (spanAsAnchor l) anns cs) l) a+instance HasLoc (EpAnn a) where+  getHasLoc (EpAnn l _ _) = getHasLoc l -getLocAnn :: Located a  -> SrcSpanAnnA-getLocAnn (L l _) = SrcSpanAnn EpAnnNotUsed l+instance HasLoc EpaLocation where+  getHasLoc (EpaSpan l) = l+  getHasLoc (EpaDelta _ _) = noSrcSpan +getHasLocList :: HasLoc a => [a] -> SrcSpan+getHasLocList [] = noSrcSpan+getHasLocList xs = foldl1' combineSrcSpans $ map getHasLoc xs -getLocA :: GenLocated (SrcSpanAnn' a) e -> SrcSpan-getLocA (L (SrcSpanAnn _ l) _) = l+-- --------------------------------------------------------------------- -noLocA :: a -> LocatedAn an a-noLocA = L (SrcSpanAnn EpAnnNotUsed noSrcSpan)+realSrcSpan :: SrcSpan -> RealSrcSpan+realSrcSpan (RealSrcSpan s _) = s+realSrcSpan _ = mkRealSrcSpan l l -- AZ temporary+  where+    l = mkRealSrcLoc (fsLit "realSrcSpan") (-1) (-1) -noAnnSrcSpan :: SrcSpan -> SrcAnn ann-noAnnSrcSpan l = SrcSpanAnn EpAnnNotUsed l+srcSpan2e :: SrcSpan -> EpaLocation+srcSpan2e ss@(RealSrcSpan _ _) = EpaSpan ss+srcSpan2e span = EpaSpan (RealSrcSpan (realSrcSpan span) Strict.Nothing) -noSrcSpanA :: SrcAnn ann-noSrcSpanA = noAnnSrcSpan noSrcSpan+reAnnC :: AnnContext -> EpAnnComments -> Located a -> LocatedC a+reAnnC anns cs (L l a) = L (EpAnn (spanAsAnchor l) anns cs) a --- | Short form for 'EpAnnNotUsed'-noAnn :: EpAnn a-noAnn = EpAnnNotUsed+reAnnL :: ann -> EpAnnComments -> Located e -> GenLocated (EpAnn ann) e+reAnnL anns cs (L l a) = L (EpAnn (spanAsAnchor l) anns cs) a +getLocAnn :: Located a  -> SrcSpanAnnA+getLocAnn (L l _) = noAnnSrcSpan l  addAnns :: EpAnn [AddEpAnn] -> [AddEpAnn] -> EpAnnComments -> EpAnn [AddEpAnn] addAnns (EpAnn l as1 cs) as2 cs2   = EpAnn (widenAnchor l (as1 ++ as2)) (as1 ++ as2) (cs <> cs2)-addAnns EpAnnNotUsed [] (EpaComments []) = EpAnnNotUsed-addAnns EpAnnNotUsed [] (EpaCommentsBalanced [] []) = EpAnnNotUsed-addAnns EpAnnNotUsed as cs = EpAnn (Anchor placeholderRealSpan UnchangedAnchor) as cs  -- AZ:TODO use widenSpan here too addAnnsA :: SrcSpanAnnA -> [TrailingAnn] -> EpAnnComments -> SrcSpanAnnA-addAnnsA (SrcSpanAnn (EpAnn l as1 cs) loc) as2 cs2-  = SrcSpanAnn (EpAnn l (AnnListItem (lann_trailing as1 ++ as2)) (cs <> cs2)) loc-addAnnsA (SrcSpanAnn EpAnnNotUsed loc) [] (EpaComments [])-  = SrcSpanAnn EpAnnNotUsed loc-addAnnsA (SrcSpanAnn EpAnnNotUsed loc) [] (EpaCommentsBalanced [] [])-  = SrcSpanAnn EpAnnNotUsed loc-addAnnsA (SrcSpanAnn EpAnnNotUsed loc) as cs-  = SrcSpanAnn (EpAnn (spanAsAnchor loc) (AnnListItem as) cs) loc+addAnnsA (EpAnn l as1 cs) as2 cs2+  = EpAnn l (AnnListItem (lann_trailing as1 ++ as2)) (cs <> cs2)  -- | The annotations need to all come after the anchor.  Make sure -- this is the case.@@ -989,7 +1085,8 @@ widenSpan s as = foldl combineSrcSpans s (go as)   where     go [] = []-    go (AddEpAnn _ (EpaSpan s mb):rest) = RealSrcSpan s mb : go rest+    go (AddEpAnn _ (EpaSpan (RealSrcSpan s mb)):rest) = RealSrcSpan s mb : go rest+    go (AddEpAnn _ (EpaSpan _):rest) = go rest     go (AddEpAnn _ (EpaDelta _ _):rest) = go rest  -- | The annotations need to all come after the anchor.  Make sure@@ -998,63 +1095,80 @@ widenRealSpan s as = foldl combineRealSrcSpans s (go as)   where     go [] = []-    go (AddEpAnn _ (EpaSpan s _):rest) = s : go rest-    go (AddEpAnn _ (EpaDelta _ _):rest) =     go rest+    go (AddEpAnn _ (EpaSpan (RealSrcSpan s _)):rest) = s : go rest+    go (AddEpAnn _ _:rest) = go rest -widenAnchor :: Anchor -> [AddEpAnn] -> Anchor-widenAnchor (Anchor s op) as = Anchor (widenRealSpan s as) op+realSpanFromAnns :: [AddEpAnn] -> Strict.Maybe RealSrcSpan+realSpanFromAnns as = go Strict.Nothing as+  where+    combine Strict.Nothing r  = Strict.Just r+    combine (Strict.Just l) r = Strict.Just $ combineRealSrcSpans l r -widenAnchorR :: Anchor -> RealSrcSpan -> Anchor-widenAnchorR (Anchor s op) r = Anchor (combineRealSrcSpans s r) op+    go acc [] = acc+    go acc (AddEpAnn _ (EpaSpan (RealSrcSpan s _b)):rest) = go (combine acc s) rest+    go acc (AddEpAnn _ _             :rest) = go acc rest -widenLocatedAn :: SrcSpanAnn' an -> [AddEpAnn] -> SrcSpanAnn' an-widenLocatedAn (SrcSpanAnn a l) as = SrcSpanAnn a (widenSpan l as)+bufSpanFromAnns :: [AddEpAnn] -> Strict.Maybe BufSpan+bufSpanFromAnns as =  go Strict.Nothing as+  where+    combine Strict.Nothing r  = Strict.Just r+    combine (Strict.Just l) r = Strict.Just $ combineBufSpans l r -epAnnAnnsL :: EpAnn a -> [a]-epAnnAnnsL EpAnnNotUsed = []-epAnnAnnsL (EpAnn _ anns _) = [anns]+    go acc [] = acc+    go acc (AddEpAnn _ (EpaSpan (RealSrcSpan _ (Strict.Just mb))):rest) = go (combine acc mb) rest+    go acc (AddEpAnn _ _:rest) = go acc rest +widenAnchor :: Anchor -> [AddEpAnn] -> Anchor+widenAnchor (EpaSpan (RealSrcSpan s mb)) as+  = EpaSpan (RealSrcSpan (widenRealSpan s as) (liftA2 combineBufSpans mb  (bufSpanFromAnns as)))+widenAnchor (EpaSpan us) _ = EpaSpan us+widenAnchor a@(EpaDelta _ _) as = case (realSpanFromAnns as) of+                                    Strict.Nothing -> a+                                    Strict.Just r -> EpaSpan (RealSrcSpan r Strict.Nothing)++widenAnchorS :: Anchor -> SrcSpan -> Anchor+widenAnchorS (EpaSpan (RealSrcSpan s mbe)) (RealSrcSpan r mbr)+  = EpaSpan (RealSrcSpan (combineRealSrcSpans s r) (liftA2 combineBufSpans mbe mbr))+widenAnchorS (EpaSpan us) _ = EpaSpan us+widenAnchorS (EpaDelta _ _) (RealSrcSpan r mb) = EpaSpan (RealSrcSpan r mb)+widenAnchorS anc _ = anc++widenLocatedAn :: EpAnn an -> [AddEpAnn] -> EpAnn an+widenLocatedAn (EpAnn (EpaSpan l) a cs) as = EpAnn (spanAsAnchor l') a cs+  where+    l' = widenSpan l as+widenLocatedAn (EpAnn anc a cs) _as = EpAnn anc a cs+ epAnnAnns :: EpAnn [AddEpAnn] -> [AddEpAnn]-epAnnAnns EpAnnNotUsed = [] epAnnAnns (EpAnn _ anns _) = anns -annParen2AddEpAnn :: EpAnn AnnParen -> [AddEpAnn]-annParen2AddEpAnn EpAnnNotUsed = []-annParen2AddEpAnn (EpAnn _ (AnnParen pt o c) _)+annParen2AddEpAnn :: AnnParen -> [AddEpAnn]+annParen2AddEpAnn (AnnParen pt o c)   = [AddEpAnn ai o, AddEpAnn ac c]   where     (ai,ac) = parenTypeKws pt  epAnnComments :: EpAnn an -> EpAnnComments-epAnnComments EpAnnNotUsed = EpaComments [] epAnnComments (EpAnn _ _ cs) = cs  -- ------------------------------------------------------------------------ sortLocatedA :: [LocatedA a] -> [LocatedA a]-sortLocatedA :: [GenLocated (SrcSpanAnn' a) e] -> [GenLocated (SrcSpanAnn' a) e]+sortLocatedA :: (HasLoc (EpAnn a)) => [GenLocated (EpAnn a) e] -> [GenLocated (EpAnn a) e] sortLocatedA = sortBy (leftmost_smallest `on` getLocA) -mapLocA :: (a -> b) -> GenLocated SrcSpan a -> GenLocated (SrcAnn ann) b+mapLocA :: (NoAnn ann) => (a -> b) -> GenLocated SrcSpan a -> GenLocated (EpAnn ann) b mapLocA f (L l a) = L (noAnnSrcSpan l) (f a)  -- AZ:TODO: move this somewhere sane--combineLocsA :: Semigroup a => GenLocated (SrcAnn a) e1 -> GenLocated (SrcAnn a) e2 -> SrcAnn a+combineLocsA :: Semigroup a => GenLocated (EpAnn a) e1 -> GenLocated (EpAnn a) e2 -> EpAnn a combineLocsA (L a _) (L b _) = combineSrcSpansA a b -combineSrcSpansA :: Semigroup a => SrcAnn a -> SrcAnn a -> SrcAnn a-combineSrcSpansA (SrcSpanAnn aa la) (SrcSpanAnn ab lb)-  = case SrcSpanAnn (aa <> ab) (combineSrcSpans la lb) of-      SrcSpanAnn EpAnnNotUsed l -> SrcSpanAnn EpAnnNotUsed l-      SrcSpanAnn (EpAnn anc an cs) l ->-        SrcSpanAnn (EpAnn (widenAnchorR anc (realSrcSpan l)) an cs) l+combineSrcSpansA :: Semigroup a => EpAnn a -> EpAnn a -> EpAnn a+combineSrcSpansA aa ab = aa <> ab  -- | Combine locations from two 'Located' things and add them to a third thing-addCLocA :: GenLocated (SrcSpanAnn' a) e1 -> GenLocated SrcSpan e2 -> e3 -> GenLocated (SrcAnn ann) e3-addCLocA a b c = L (noAnnSrcSpan $ combineSrcSpans (locA $ getLoc a) (getLoc b)) c--addCLocAA :: GenLocated (SrcSpanAnn' a1) e1 -> GenLocated (SrcSpanAnn' a2) e2 -> e3 -> GenLocated (SrcAnn ann) e3-addCLocAA a b c = L (noAnnSrcSpan $ combineSrcSpans (locA $ getLoc a) (locA $ getLoc b)) c+addCLocA :: (HasLoc a, HasLoc b, HasAnnotation l)+         => a -> b -> c -> GenLocated l c+addCLocA a b c = L (noAnnSrcSpan $ combineSrcSpans (getHasLoc a) (getHasLoc b)) c  -- --------------------------------------------------------------------- -- Utilities for manipulating EpAnnComments@@ -1082,99 +1196,94 @@   deriving (Data,Eq,Ord)  noComments ::EpAnnCO-noComments = EpAnn (Anchor placeholderRealSpan UnchangedAnchor) NoEpAnns emptyComments+noComments = EpAnn noSpanAnchor NoEpAnns emptyComments  -- TODO:AZ get rid of this placeholderRealSpan :: RealSrcSpan placeholderRealSpan = realSrcLocSpan (mkRealSrcLoc (mkFastString "placeholder") (-1) (-1))  comment :: RealSrcSpan -> EpAnnComments -> EpAnnCO-comment loc cs = EpAnn (Anchor loc UnchangedAnchor) NoEpAnns cs+comment loc cs = EpAnn (EpaSpan (RealSrcSpan loc Strict.Nothing)) NoEpAnns cs  -- --------------------------------------------------------------------- -- Utilities for managing comments in an `EpAnn a` structure. -- --------------------------------------------------------------------- --- | Add additional comments to a 'SrcAnn', used for manipulating the--- AST prior to exact printing the changed one.-addCommentsToSrcAnn :: (Monoid ann) => SrcAnn ann -> EpAnnComments -> SrcAnn ann-addCommentsToSrcAnn (SrcSpanAnn EpAnnNotUsed loc) cs-  = SrcSpanAnn (EpAnn (Anchor (realSrcSpan loc) UnchangedAnchor) mempty cs) loc-addCommentsToSrcAnn (SrcSpanAnn (EpAnn a an cs) loc) cs'-  = SrcSpanAnn (EpAnn a an (cs <> cs')) loc---- | Replace any existing comments on a 'SrcAnn', used for manipulating the--- AST prior to exact printing the changed one.-setCommentsSrcAnn :: (Monoid ann) => SrcAnn ann -> EpAnnComments -> SrcAnn ann-setCommentsSrcAnn (SrcSpanAnn EpAnnNotUsed loc) cs-  = SrcSpanAnn (EpAnn (Anchor (realSrcSpan loc) UnchangedAnchor) mempty cs) loc-setCommentsSrcAnn (SrcSpanAnn (EpAnn a an _) loc) cs-  = SrcSpanAnn (EpAnn a an cs) loc---- | Add additional comments, used for manipulating the+-- | Add additional comments to a 'EpAnn', used for manipulating the -- AST prior to exact printing the changed one.-addCommentsToEpAnn :: (Monoid a)-  => SrcSpan -> EpAnn a -> EpAnnComments -> EpAnn a-addCommentsToEpAnn loc EpAnnNotUsed cs-  = EpAnn (Anchor (realSrcSpan loc) UnchangedAnchor) mempty cs-addCommentsToEpAnn _ (EpAnn a an ocs) ncs = EpAnn a an (ocs <> ncs)+addCommentsToEpAnn :: (NoAnn ann) => EpAnn ann -> EpAnnComments -> EpAnn ann+addCommentsToEpAnn (EpAnn a an cs) cs' = EpAnn a an (cs <> cs') --- | Replace any existing comments, used for manipulating the+-- | Replace any existing comments on a 'EpAnn', used for manipulating the -- AST prior to exact printing the changed one.-setCommentsEpAnn :: (Monoid a)-  => SrcSpan -> EpAnn a -> EpAnnComments -> EpAnn a-setCommentsEpAnn loc EpAnnNotUsed cs-  = EpAnn (Anchor (realSrcSpan loc) UnchangedAnchor) mempty cs-setCommentsEpAnn _ (EpAnn a an _) cs = EpAnn a an cs+setCommentsEpAnn :: (NoAnn ann) => EpAnn ann -> EpAnnComments -> EpAnn ann+setCommentsEpAnn (EpAnn a an _) cs = (EpAnn a an cs)  -- | Transfer comments and trailing items from the annotations in the -- first 'SrcSpanAnnA' argument to those in the second. transferAnnsA :: SrcSpanAnnA -> SrcSpanAnnA -> (SrcSpanAnnA,  SrcSpanAnnA)-transferAnnsA from@(SrcSpanAnn EpAnnNotUsed _) to = (from, to)-transferAnnsA (SrcSpanAnn (EpAnn a an cs) l) to-  = ((SrcSpanAnn (EpAnn a mempty emptyComments) l), to')+transferAnnsA (EpAnn a an cs) (EpAnn a' an' cs')+  = (EpAnn a noAnn emptyComments, EpAnn a' (an' <> an) (cs' <> cs))++-- | Transfer trailing items but not comments from the annotations in the+-- first 'SrcSpanAnnA' argument to those in the second.+transferFollowingA :: SrcSpanAnnA -> SrcSpanAnnA -> (SrcSpanAnnA,  SrcSpanAnnA)+transferFollowingA (EpAnn a1 an1 cs1) (EpAnn a2 an2 cs2)+  = (EpAnn a1 noAnn cs1', EpAnn a2 (an1 <> an2) cs2')   where-    to' = case to of-      (SrcSpanAnn EpAnnNotUsed loc)-        ->  SrcSpanAnn (EpAnn (Anchor (realSrcSpan loc) UnchangedAnchor) an cs) loc-      (SrcSpanAnn (EpAnn a an' cs') loc)-        -> SrcSpanAnn (EpAnn a (an' <> an) (cs' <> cs)) loc+    pc = priorComments cs1+    fc = getFollowingComments cs1+    cs1' = setPriorComments emptyComments pc+    cs2' = setFollowingComments cs2 fc +-- | Transfer trailing items from the annotations in the+-- first 'SrcSpanAnnA' argument to those in the second.+transferAnnsOnlyA :: SrcSpanAnnA -> SrcSpanAnnA -> (SrcSpanAnnA,  SrcSpanAnnA)+transferAnnsOnlyA (EpAnn a an cs) (EpAnn a' an' cs')+  = (EpAnn a noAnn cs, EpAnn a' (an' <> an) cs')++-- | Transfer comments from the annotations in the+-- first 'SrcSpanAnnA' argument to those in the second.+transferCommentsOnlyA :: EpAnn a -> EpAnn b -> (EpAnn a,  EpAnn b)+transferCommentsOnlyA (EpAnn a an cs) (EpAnn a' an' cs')+  = (EpAnn a an emptyComments, EpAnn a' an' (cs <> cs'))++-- | Transfer prior comments only from the annotations in the+-- first 'SrcSpanAnnA' argument to those in the second.+transferPriorCommentsA :: SrcSpanAnnA -> SrcSpanAnnA -> (SrcSpanAnnA,  SrcSpanAnnA)+transferPriorCommentsA (EpAnn a1 an1 cs1) (EpAnn a2 an2 cs2)+  = (EpAnn a1 an1 cs1', EpAnn a2 an2 cs2')+  where+    pc = priorComments cs1+    fc = getFollowingComments cs1+    cs1' = setFollowingComments emptyComments fc+    cs2' = setPriorComments cs2 (priorComments cs2 <> pc)++ -- | Remove the exact print annotations payload, leaving only the -- anchor and comments.-commentsOnlyA :: Monoid ann => SrcAnn ann -> SrcAnn ann-commentsOnlyA (SrcSpanAnn EpAnnNotUsed loc) = SrcSpanAnn EpAnnNotUsed loc-commentsOnlyA (SrcSpanAnn (EpAnn a _ cs) loc) = (SrcSpanAnn (EpAnn a mempty cs) loc)+commentsOnlyA :: NoAnn ann => EpAnn ann -> EpAnn ann+commentsOnlyA (EpAnn a _ cs) = EpAnn a noAnn cs  -- | Remove the comments, leaving the exact print annotations payload-removeCommentsA :: SrcAnn ann -> SrcAnn ann-removeCommentsA (SrcSpanAnn EpAnnNotUsed loc) = SrcSpanAnn EpAnnNotUsed loc-removeCommentsA (SrcSpanAnn (EpAnn a an _) loc)-  = (SrcSpanAnn (EpAnn a an emptyComments) loc)+removeCommentsA :: EpAnn ann -> EpAnn ann+removeCommentsA (EpAnn a an _) = EpAnn a an emptyComments  -- ------------------------------------------------------------------------ Semigroup instances, to allow easy combination of annotaion elements+-- Semigroup instances, to allow easy combination of annotation elements -- --------------------------------------------------------------------- -instance (Semigroup an) => Semigroup (SrcSpanAnn' an) where-  (SrcSpanAnn a1 l1) <> (SrcSpanAnn a2 l2) = SrcSpanAnn (a1 <> a2) (combineSrcSpans l1 l2)-   -- The critical part about the location is its left edge, and all-   -- annotations must follow it. So we combine them which yields the-   -- largest span- instance (Semigroup a) => Semigroup (EpAnn a) where-  EpAnnNotUsed <> x = x-  x <> EpAnnNotUsed = x   (EpAnn l1 a1 b1) <> (EpAnn l2 a2 b2) = EpAnn (l1 <> l2) (a1 <> a2) (b1 <> b2)    -- The critical part about the anchor is its left edge, and all    -- annotations must follow it. So we combine them which yields the    -- largest span -instance Ord Anchor where-  compare (Anchor s1 _) (Anchor s2 _) = compare s1 s2--instance Semigroup Anchor where-  Anchor r1 o1 <> Anchor r2 _ = Anchor (combineRealSrcSpans r1 r2) o1+instance Semigroup EpaLocation where+  EpaSpan s1       <> EpaSpan s2        = EpaSpan (combineSrcSpans s1 s2)+  EpaSpan s1       <> _                 = EpaSpan s1+  _                <> EpaSpan s2        = EpaSpan s2+  EpaDelta dp1 cs1 <> EpaDelta _dp2 cs2 = EpaDelta dp1 (cs1<>cs2)  instance Semigroup EpAnnComments where   EpaComments cs1 <> EpaComments cs2 = EpaComments (cs1 ++ cs2)@@ -1182,66 +1291,81 @@   EpaCommentsBalanced cs1 as1 <> EpaComments cs2 = EpaCommentsBalanced (cs1 ++ cs2) as1   EpaCommentsBalanced cs1 as1 <> EpaCommentsBalanced cs2 as2 = EpaCommentsBalanced (cs1 ++ cs2) (as1++as2) +instance Semigroup AnnListItem where+  (AnnListItem l1) <> (AnnListItem l2) = AnnListItem (l1 <> l2) -instance (Monoid a) => Monoid (EpAnn a) where-  mempty = EpAnnNotUsed+instance Semigroup (AnnSortKey tag) where+  NoAnnSortKey <> x = x+  x <> NoAnnSortKey = x+  AnnSortKey ls1 <> AnnSortKey ls2 = AnnSortKey (ls1 <> ls2) -instance Semigroup NoEpAnns where-  _ <> _ = NoEpAnns+instance Monoid (AnnSortKey tag) where+  mempty = NoAnnSortKey -instance Semigroup AnnListItem where-  (AnnListItem l1) <> (AnnListItem l2) = AnnListItem (l1 <> l2)+-- ---------------------------------------------------------------------+-- NoAnn instances+-- --------------------------------------------------------------------- -instance Monoid AnnListItem where-  mempty = AnnListItem []+instance NoAnn EpaLocation where+  noAnn = EpaDelta (SameLine 0) [] +instance NoAnn AnnKeywordId where+  noAnn = Annlarrowtail  {- gotta pick one -} -instance Semigroup AnnList where-  (AnnList a1 o1 c1 r1 t1) <> (AnnList a2 o2 c2 r2 t2)-    = AnnList (a1 <> a2) (c o1 o2) (c c1 c2) (r1 <> r2) (t1 <> t2)-    where-      -- Left biased combination for the open and close annotations-      c Nothing x = x-      c x Nothing = x-      c f _       = f+instance NoAnn AddEpAnn where+  noAnn = AddEpAnn noAnn noAnn -instance Monoid AnnList where-  mempty = AnnList Nothing Nothing Nothing [] []+instance NoAnn [a] where+  noAnn = [] -instance Semigroup NameAnn where-  _ <> _ = panic "semigroup nameann"+instance NoAnn (Maybe a) where+  noAnn = Nothing -instance Monoid NameAnn where-  mempty = NameAnnTrailing []+instance (NoAnn a, NoAnn b) => NoAnn (a, b) where+  noAnn = (noAnn, noAnn) +instance NoAnn Bool where+  noAnn = False -instance Semigroup AnnSortKey where-  NoAnnSortKey <> x = x-  x <> NoAnnSortKey = x-  AnnSortKey ls1 <> AnnSortKey ls2 = AnnSortKey (ls1 <> ls2)+instance (NoAnn ann) => NoAnn (EpAnn ann) where+  noAnn = EpAnn noSpanAnchor noAnn emptyComments -instance Monoid AnnSortKey where-  mempty = NoAnnSortKey+instance NoAnn NoEpAnns where+  noAnn = NoEpAnns +instance NoAnn AnnListItem where+  noAnn = AnnListItem []++instance NoAnn AnnContext where+  noAnn = AnnContext Nothing [] []++instance NoAnn AnnList where+  noAnn = AnnList Nothing Nothing Nothing [] []++instance NoAnn NameAnn where+  noAnn = NameAnnTrailing []++instance NoAnn AnnPragma where+  noAnn = AnnPragma noAnn noAnn []++instance NoAnn AnnParen where+  noAnn = AnnParen AnnParens noAnn noAnn++instance NoAnn (EpToken s) where+  noAnn = NoEpTok++instance NoAnn (EpUniToken s t) where+  noAnn = NoEpUniTok++-- ---------------------------------------------------------------------+ instance (Outputable a) => Outputable (EpAnn a) where   ppr (EpAnn l a c)  = text "EpAnn" <+> ppr l <+> ppr a <+> ppr c-  ppr EpAnnNotUsed = text "EpAnnNotUsed"  instance Outputable NoEpAnns where   ppr NoEpAnns = text "NoEpAnns" -instance Outputable Anchor where-  ppr (Anchor a o)        = text "Anchor" <+> ppr a <+> ppr o--instance Outputable AnchorOperation where-  ppr UnchangedAnchor   = text "UnchangedAnchor"-  ppr (MovedAnchor d)   = text "MovedAnchor" <+> ppr d--instance Outputable DeltaPos where-  ppr (SameLine c) = text "SameLine" <+> ppr c-  ppr (DifferentLine l c) = text "DifferentLine" <+> ppr l <+> ppr c--instance Outputable (GenLocated Anchor EpaComment) where+instance Outputable (GenLocated NoCommentsLocation EpaComment) where   ppr (L l c) = text "L" <+> ppr l <+> ppr c  instance Outputable EpAnnComments where@@ -1254,24 +1378,34 @@ instance Outputable AnnContext where   ppr (AnnContext a o c) = text "AnnContext" <+> ppr a <+> ppr o <+> ppr c -instance Outputable AnnSortKey where+instance Outputable BindTag where+  ppr tag = text $ show tag++instance Outputable DeclTag where+  ppr tag = text $ show tag++instance Outputable tag => Outputable (AnnSortKey tag) where   ppr NoAnnSortKey    = text "NoAnnSortKey"   ppr (AnnSortKey ls) = text "AnnSortKey" <+> ppr ls  instance Outputable IsUnicodeSyntax where   ppr = text . show -instance (Outputable a) => Outputable (SrcSpanAnn' a) where-  ppr (SrcSpanAnn a l) = text "SrcSpanAnn" <+> ppr a <+> ppr l- instance (Outputable a, Outputable e)-     => Outputable (GenLocated (SrcSpanAnn' a) e) where+     => Outputable (GenLocated (EpAnn a) e) where   ppr = pprLocated  instance (Outputable a, OutputableBndr e)-     => OutputableBndr (GenLocated (SrcSpanAnn' a) e) where+     => OutputableBndr (GenLocated (EpAnn a) e) where   pprInfixOcc = pprInfixOcc . unLoc   pprPrefixOcc = pprPrefixOcc . unLoc++instance (Outputable e)+     => Outputable (GenLocated EpaLocation e) where+  ppr = pprLocated++instance Outputable ParenType where+  ppr t = text (show t)  instance Outputable AnnListItem where   ppr (AnnListItem ts) = text "AnnListItem" <+> ppr ts
compiler/GHC/Parser/Errors/Ppr.hs view
@@ -22,14 +22,14 @@ import GHC.Types.Error import GHC.Types.Hint.Ppr (perhapsAsPat) import GHC.Types.SrcLoc-import GHC.Types.Error.Codes ( constructorCode )+import GHC.Types.Error.Codes import GHC.Types.Name.Reader ( opIsAt, rdrNameOcc, mkUnqual ) import GHC.Types.Name.Occurrence (isSymOcc, occNameFS, varName) import GHC.Utils.Outputable import GHC.Utils.Misc import GHC.Data.FastString import GHC.Data.Maybe (catMaybes)-import GHC.Hs.Expr (prependQualified, HsExpr(..), LamCaseVariant(..), lamCaseKeyword)+import GHC.Hs.Expr (prependQualified, HsExpr(..), HsLamVariant(..), lamCaseKeyword) import GHC.Hs.Type (pprLHsContext) import GHC.Builtin.Names (allNameStringList) import GHC.Builtin.Types (filterCTuple)@@ -327,16 +327,12 @@       -> mkSimpleDecorated $ text "do-notation in pattern"     PsErrIfThenElseInPat       -> mkSimpleDecorated $ text "(if ... then ... else ...)-syntax in pattern"-    (PsErrLambdaCaseInPat lc_variant)-      -> mkSimpleDecorated $ lamCaseKeyword lc_variant <+> text "...-syntax in pattern"     PsErrCaseInPat       -> mkSimpleDecorated $ text "(case ... of ...)-syntax in pattern"     PsErrLetInPat       -> mkSimpleDecorated $ text "(let ... in ...)-syntax in pattern"-    PsErrLambdaInPat-      -> mkSimpleDecorated $-           text "Lambda-syntax in pattern."-           $$ text "Pattern matching on functions is not possible."+    PsErrLambdaInPat lam_variant+      -> mkSimpleDecorated $ text "Illegal" <+> lamCaseKeyword lam_variant <> text "-syntax in pattern"     PsErrArrowExprInPat e       -> mkSimpleDecorated $ text "Expression syntax in pattern:" <+> ppr e     PsErrArrowCmdInPat c@@ -352,13 +348,11 @@            sep [ text "View pattern in expression context:"                , nest 4 (ppr a <+> text "->" <+> ppr b)                ]-    PsErrLambdaCmdInFunAppCmd a-      -> mkSimpleDecorated $ pp_unexpected_fun_app (text "lambda command") a     PsErrCaseCmdInFunAppCmd a       -> mkSimpleDecorated $ pp_unexpected_fun_app (text "case command") a-    PsErrLambdaCaseCmdInFunAppCmd lc_variant a+    PsErrLambdaCmdInFunAppCmd lam_variant a       -> mkSimpleDecorated $-           pp_unexpected_fun_app (lamCaseKeyword lc_variant <+> text "command") a+           pp_unexpected_fun_app (lamCaseKeyword lam_variant <+> text "command") a     PsErrIfCmdInFunAppCmd a       -> mkSimpleDecorated $ pp_unexpected_fun_app (text "if command") a     PsErrLetCmdInFunAppCmd a@@ -369,12 +363,10 @@       -> mkSimpleDecorated $ pp_unexpected_fun_app (prependQualified m (text "do block")) a     PsErrMDoInFunAppExpr m a       -> mkSimpleDecorated $ pp_unexpected_fun_app (prependQualified m (text "mdo block")) a-    PsErrLambdaInFunAppExpr a-      -> mkSimpleDecorated $ pp_unexpected_fun_app (text "lambda expression") a     PsErrCaseInFunAppExpr a       -> mkSimpleDecorated $ pp_unexpected_fun_app (text "case expression") a-    PsErrLambdaCaseInFunAppExpr lc_variant a-      -> mkSimpleDecorated $ pp_unexpected_fun_app (lamCaseKeyword lc_variant <+> text "expression") a+    PsErrLambdaInFunAppExpr lam_variant a+      -> mkSimpleDecorated $ pp_unexpected_fun_app (lamCaseKeyword lam_variant <+> text "expression") a     PsErrLetInFunAppExpr a       -> mkSimpleDecorated $ pp_unexpected_fun_app (text "let expression") a     PsErrIfInFunAppExpr a@@ -394,7 +386,8 @@       -> mkSimpleDecorated $ text "primitive string literal must contain only characters <= \'\\xFF\'"     PsErrSuffixAT       -> mkSimpleDecorated $-           text "Suffix occurrence of @. For an as-pattern, remove the leading whitespace."+           text "The symbol '@' occurs as a suffix." $$+           text "For an as-pattern, there must not be any whitespace surrounding '@'."     PsErrPrecedenceOutOfRange i       -> mkSimpleDecorated $ text "Precedence out of range: " <> int i     PsErrSemiColonsInCondExpr c st t se e@@ -462,11 +455,17 @@     PsErrIllegalRoleName role _nearby       -> mkSimpleDecorated $            text "Illegal role name" <+> quotes (ppr role)-    PsErrInvalidTypeSignature lhs-      -> mkSimpleDecorated $-           text "Invalid type signature:"-           <+> ppr lhs-           <+> text ":: ..."+    PsErrInvalidTypeSignature reason lhs+      -> mkSimpleDecorated $ case reason of+           PsErrInvalidTypeSig_DataCon   -> text "Invalid data constructor" <+> quotes (ppr lhs) <+>+                                            text "in type signature" <> colon $$+                                            text "You can only define data constructors in data type declarations."+           PsErrInvalidTypeSig_Qualified -> text "Invalid qualified name in type signature."+           PsErrInvalidTypeSig_Other     -> text "Invalid type signature" <> colon $$+                                            text "A type signature should be of form" <+>+                                            placeHolder "variables" <+> dcolon <+> placeHolder "type" <>+                                            dot+            where placeHolder = angleBrackets . text     PsErrUnexpectedTypeInDecl t what tc tparms equals_or_where        -> mkSimpleDecorated $             vcat [ text "Unexpected type" <+> quotes (ppr t)@@ -514,7 +513,25 @@                 , text "'" <> text [looks_like_char] <> text "' (" <> text looks_like_char_name <> text ")" <> comma                 , text "but it is not" ] -  diagnosticReason = \case+    PsErrInvalidPun PEP_QuoteDisambiguation+      -> mkSimpleDecorated $ vcat+        [ text "Disambiguating data constructors of tuples and lists is disabled."+        , text "Remove the quote to use the data constructor."+        ]++    PsErrInvalidPun PEP_TupleSyntaxType+      -> mkSimpleDecorated $ vcat+        [ text "Unboxed tuple data constructors are not supported in types."+        , text "Use" <+> quotes (text "Tuple<n># a b c ...") <+> text "to refer to the type constructor."+        ]++    PsErrInvalidPun PEP_SumSyntaxType+      -> mkSimpleDecorated $ vcat+        [ text "Unboxed sum data constructors are not supported in types."+        , text "Use" <+> quotes (text "Sum<n># a b c ...") <+> text "to refer to the type constructor."+        ]++  diagnosticReason  = \case     PsUnknownMessage m                            -> diagnosticReason m     PsHeaderMessage  m                            -> psHeaderMessageReason m     PsWarnBidirectionalFormatChars{}              -> WarningWithFlag Opt_WarnUnicodeBidirectionalFormatCharacters@@ -584,17 +601,15 @@     PsErrIllegalUnboxedFloatingLitInPat{}         -> ErrorWithoutFlag     PsErrDoNotationInPat{}                        -> ErrorWithoutFlag     PsErrIfThenElseInPat                          -> ErrorWithoutFlag-    PsErrLambdaCaseInPat{}                        -> ErrorWithoutFlag     PsErrCaseInPat                                -> ErrorWithoutFlag     PsErrLetInPat                                 -> ErrorWithoutFlag-    PsErrLambdaInPat                              -> ErrorWithoutFlag+    PsErrLambdaInPat{}                            -> ErrorWithoutFlag     PsErrArrowExprInPat{}                         -> ErrorWithoutFlag     PsErrArrowCmdInPat{}                          -> ErrorWithoutFlag     PsErrArrowCmdInExpr{}                         -> ErrorWithoutFlag     PsErrViewPatInExpr{}                          -> ErrorWithoutFlag-    PsErrLambdaCmdInFunAppCmd{}                   -> ErrorWithoutFlag     PsErrCaseCmdInFunAppCmd{}                     -> ErrorWithoutFlag-    PsErrLambdaCaseCmdInFunAppCmd{}               -> ErrorWithoutFlag+    PsErrLambdaCmdInFunAppCmd{}                   -> ErrorWithoutFlag     PsErrIfCmdInFunAppCmd{}                       -> ErrorWithoutFlag     PsErrLetCmdInFunAppCmd{}                      -> ErrorWithoutFlag     PsErrDoCmdInFunAppCmd{}                       -> ErrorWithoutFlag@@ -602,7 +617,6 @@     PsErrMDoInFunAppExpr{}                        -> ErrorWithoutFlag     PsErrLambdaInFunAppExpr{}                     -> ErrorWithoutFlag     PsErrCaseInFunAppExpr{}                       -> ErrorWithoutFlag-    PsErrLambdaCaseInFunAppExpr{}                 -> ErrorWithoutFlag     PsErrLetInFunAppExpr{}                        -> ErrorWithoutFlag     PsErrIfInFunAppExpr{}                         -> ErrorWithoutFlag     PsErrProcInFunAppExpr{}                       -> ErrorWithoutFlag@@ -631,6 +645,7 @@     PsErrInvalidCApiImport {}                     -> ErrorWithoutFlag     PsErrMultipleConForNewtype {}                 -> ErrorWithoutFlag     PsErrUnicodeCharLooksLike{}                   -> ErrorWithoutFlag+    PsErrInvalidPun {}                            -> ErrorWithoutFlag    diagnosticHints = \case     PsUnknownMessage m                            -> diagnosticHints m@@ -722,17 +737,15 @@     PsErrIllegalUnboxedFloatingLitInPat{}         -> noHints     PsErrDoNotationInPat{}                        -> noHints     PsErrIfThenElseInPat                          -> noHints-    PsErrLambdaCaseInPat{}                        -> noHints     PsErrCaseInPat                                -> noHints     PsErrLetInPat                                 -> noHints-    PsErrLambdaInPat                              -> noHints+    PsErrLambdaInPat{}                            -> noHints     PsErrArrowExprInPat{}                         -> noHints     PsErrArrowCmdInPat{}                          -> noHints     PsErrArrowCmdInExpr{}                         -> noHints     PsErrViewPatInExpr{}                          -> noHints     PsErrLambdaCmdInFunAppCmd{}                   -> suggestParensAndBlockArgs     PsErrCaseCmdInFunAppCmd{}                     -> suggestParensAndBlockArgs-    PsErrLambdaCaseCmdInFunAppCmd{}               -> suggestParensAndBlockArgs     PsErrIfCmdInFunAppCmd{}                       -> suggestParensAndBlockArgs     PsErrLetCmdInFunAppCmd{}                      -> suggestParensAndBlockArgs     PsErrDoCmdInFunAppCmd{}                       -> suggestParensAndBlockArgs@@ -740,7 +753,6 @@     PsErrMDoInFunAppExpr{}                        -> suggestParensAndBlockArgs     PsErrLambdaInFunAppExpr{}                     -> suggestParensAndBlockArgs     PsErrCaseInFunAppExpr{}                       -> suggestParensAndBlockArgs-    PsErrLambdaCaseInFunAppExpr{}                 -> suggestParensAndBlockArgs     PsErrLetInFunAppExpr{}                        -> suggestParensAndBlockArgs     PsErrIfInFunAppExpr{}                         -> suggestParensAndBlockArgs     PsErrProcInFunAppExpr{}                       -> suggestParensAndBlockArgs@@ -773,15 +785,17 @@         sug_missingdo _                                     = Nothing     PsErrParseRightOpSectionInPat{}               -> noHints     PsErrIllegalRoleName _ nearby                 -> [SuggestRoles nearby]-    PsErrInvalidTypeSignature lhs                 ->+    PsErrInvalidTypeSignature reason lhs          ->         if | foreign_RDR `looks_like` lhs            -> [suggestExtension LangExt.ForeignFunctionInterface]            | default_RDR `looks_like` lhs            -> [suggestExtension LangExt.DefaultSignatures]            | pattern_RDR `looks_like` lhs            -> [suggestExtension LangExt.PatternSynonyms]+           | PsErrInvalidTypeSig_Qualified <- reason+           -> [SuggestTypeSignatureRemoveQualifier]            | otherwise-           -> [SuggestTypeSignatureForm]+           -> []       where         -- A common error is to forget the ForeignFunctionInterface flag         -- so check for that, and suggest.  cf #3805@@ -801,6 +815,7 @@     PsErrInvalidCApiImport {}                     -> noHints     PsErrMultipleConForNewtype {}                 -> noHints     PsErrUnicodeCharLooksLike{}                   -> noHints+    PsErrInvalidPun {}                            -> [suggestExtension LangExt.ListTuplePuns]    diagnosticCode = constructorCode
compiler/GHC/Parser/Errors/Types.hs view
@@ -249,8 +249,8 @@    -- | If-then-else syntax in pattern    | PsErrIfThenElseInPat -   -- | Lambda-case in pattern-   | PsErrLambdaCaseInPat LamCaseVariant+   -- | Lambda or Lambda-case in pattern+   | PsErrLambdaInPat HsLamVariant     -- | case..of in pattern    | PsErrCaseInPat@@ -258,9 +258,6 @@    -- | let-syntax in pattern    | PsErrLetInPat -   -- | Lambda-syntax in pattern-   | PsErrLambdaInPat-    -- | Arrow expression-syntax in pattern    | PsErrArrowExprInPat !(HsExpr GhcPs) @@ -310,14 +307,11 @@    -- | @-operator in a pattern position    | PsErrAtInPatPos -   -- | Unexpected lambda command in function application-   | PsErrLambdaCmdInFunAppCmd !(LHsCmd GhcPs)-    -- | Unexpected case command in function application    | PsErrCaseCmdInFunAppCmd !(LHsCmd GhcPs) -   -- | Unexpected \case(s) command in function application-   | PsErrLambdaCaseCmdInFunAppCmd !LamCaseVariant !(LHsCmd GhcPs)+   -- | Unexpected lambda or \case(s) command in function application+   | PsErrLambdaCmdInFunAppCmd !HsLamVariant !(LHsCmd GhcPs)     -- | Unexpected if command in function application    | PsErrIfCmdInFunAppCmd !(LHsCmd GhcPs)@@ -334,14 +328,11 @@    -- | Unexpected mdo block in function application    | PsErrMDoInFunAppExpr !(Maybe ModuleName) !(LHsExpr GhcPs) -   -- | Unexpected lambda expression in function application-   | PsErrLambdaInFunAppExpr !(LHsExpr GhcPs)-    -- | Unexpected case expression in function application    | PsErrCaseInFunAppExpr !(LHsExpr GhcPs) -   -- | Unexpected \case(s) expression in function application-   | PsErrLambdaCaseInFunAppExpr !LamCaseVariant !(LHsExpr GhcPs)+   -- | Unexpected lambda or \case(s) expression in function application+   | PsErrLambdaInFunAppExpr !HsLamVariant !(LHsExpr GhcPs)     -- | Unexpected let expression in function application    | PsErrLetInFunAppExpr !(LHsExpr GhcPs)@@ -398,7 +389,7 @@    | PsErrIllegalRoleName !FastString [Role]     -- | Invalid type signature-   | PsErrInvalidTypeSignature !(LHsExpr GhcPs)+   | PsErrInvalidTypeSignature !PsInvalidTypeSignature !(LHsExpr GhcPs)     -- | Unexpected type in declaration    | PsErrUnexpectedTypeInDecl !(LHsType GhcPs)@@ -468,6 +459,8 @@       Char -- ^ the character it looks like       String -- ^ the name of the character that it looks like +   | PsErrInvalidPun !PsErrPunDetails+    deriving Generic  -- | Extra details about a parse error, which helps@@ -487,6 +480,11 @@     -- ^ Did we parse a \"pattern\" keyword?   } +data PsInvalidTypeSignature+  = PsErrInvalidTypeSig_Qualified+  | PsErrInvalidTypeSig_DataCon+  | PsErrInvalidTypeSig_Other+ -- | Is the parsed pattern recursive? data PatIsRecursive   = YesPatIsRecursive@@ -518,6 +516,11 @@                     !ParseContext   | PEIP_OtherPatDetails !ParseContext +data PsErrPunDetails+  = PEP_QuoteDisambiguation+  | PEP_TupleSyntaxType+  | PEP_SumSyntaxType+ noParseContext :: ParseContext noParseContext = ParseContext Nothing NoIncompleteDoBlock @@ -532,6 +535,7 @@    = NumUnderscore_Integral    | NumUnderscore_Float    deriving (Show,Eq,Ord)+  data LexErrKind    = LexErrKind_EOF        -- ^ End of input
compiler/GHC/Parser/HaddockLex.x view
@@ -1,6 +1,4 @@ {-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -funbox-strict-fields #-}  module GHC.Parser.HaddockLex (lexHsDoc, lexStringLiteral) where
compiler/GHC/Parser/Lexer.x view
@@ -41,7 +41,6 @@ -- Alex "Haskell code fragment top"  {-{-# LANGUAGE BangPatterns #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-}@@ -1785,6 +1784,21 @@ qvarsym buf len = ITqvarsym $! splitQualName buf len False qconsym buf len = ITqconsym $! splitQualName buf len False ++errSuffixAt :: PsSpan -> P a+errSuffixAt span = do+    input <- getInput+    failLocMsgP start (go input start) (\srcSpan -> mkPlainErrorMsgEnvelope srcSpan $ PsErrSuffixAT)+  where+    start = psRealLoc (psSpanStart span)+    go inp loc+      | Just (c, i) <- alexGetChar inp+      , let next = advanceSrcLoc loc c =+          if c == ' '+          then go i next+          else next+      | otherwise = loc+ -- See Note [Whitespace-sensitive operator parsing] varsym :: OpWs -> Action varsym opws@OpWsPrefix = sym $ \span exts s ->@@ -1818,7 +1832,7 @@          do { warnOperatorWhitespace opws span s             ; return (ITvarsym s) } varsym opws@OpWsSuffix = sym $ \span _ s ->-  if | s == fsLit "@" -> failMsgP (\srcLoc -> mkPlainErrorMsgEnvelope srcLoc $ PsErrSuffixAT)+  if | s == fsLit "@" -> errSuffixAt span      | s == fsLit "." -> return ITdot      | otherwise ->          do { warnOperatorWhitespace opws span s@@ -3039,6 +3053,7 @@   | OverloadedRecordDotBit   | OverloadedRecordUpdateBit   | ExtendedLiteralsBit+  | ListTuplePunsBit    -- Flags that are updated once parsing starts   | InRulePragBit@@ -3119,6 +3134,7 @@       .|. OverloadedRecordDotBit      `xoptBit` LangExt.OverloadedRecordDot       .|. OverloadedRecordUpdateBit   `xoptBit` LangExt.OverloadedRecordUpdate  -- Enable testing via 'getBit OverloadedRecordUpdateBit' in the parser (RecordDotSyntax parsing uses that information).       .|. ExtendedLiteralsBit         `xoptBit` LangExt.ExtendedLiterals+      .|. ListTuplePunsBit            `xoptBit` LangExt.ListTuplePuns     optBits =           HaddockBit        `setBitIf` isHaddock       .|. RawTokenStreamBit `setBitIf` rawTokStream@@ -3236,6 +3252,7 @@   getBit ext = P $ \s -> let b =  ext `xtest` pExtsBitmap (options s)                          in b `seq` POk s b   allocateCommentsP ss = P $ \s ->+    if null (comment_q s) then POk s emptyComments else  -- fast path     let (comment_q', newAnns) = allocateComments ss (comment_q s) in       POk s {          comment_q = comment_q'@@ -3780,7 +3797,8 @@ -- 'AddEpAnn' values for the opening and closing bordering on the start -- and end of the span mkParensEpAnn :: RealSrcSpan -> (AddEpAnn, AddEpAnn)-mkParensEpAnn ss = (AddEpAnn AnnOpenP (EpaSpan lo Strict.Nothing),AddEpAnn AnnCloseP (EpaSpan lc Strict.Nothing))+mkParensEpAnn ss = (AddEpAnn AnnOpenP (EpaSpan (RealSrcSpan lo Strict.Nothing)),+                    AddEpAnn AnnCloseP (EpaSpan (RealSrcSpan lc Strict.Nothing)))   where     f = srcSpanFile ss     sl = srcSpanStartLine ss
compiler/GHC/Parser/PostProcess.hs view
@@ -1,3193 +1,3415 @@ -{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE ViewPatterns #-}-{-# LANGUAGE DataKinds #-}-------  (c) The University of Glasgow 2002-2006------- Functions over HsSyn specialised to RdrName.--module GHC.Parser.PostProcess (-        mkRdrGetField, mkRdrProjection, Fbind, -- RecordDot-        mkHsOpApp,-        mkHsIntegral, mkHsFractional, mkHsIsString,-        mkHsDo, mkSpliceDecl,-        mkRoleAnnotDecl,-        mkClassDecl,-        mkTyData, mkDataFamInst,-        mkTySynonym, mkTyFamInstEqn,-        mkStandaloneKindSig,-        mkTyFamInst,-        mkFamDecl,-        mkInlinePragma,-        mkOpaquePragma,-        mkPatSynMatchGroup,-        mkRecConstrOrUpdate,-        mkTyClD, mkInstD,-        mkRdrRecordCon, mkRdrRecordUpd,-        setRdrNameSpace,-        fromSpecTyVarBndr, fromSpecTyVarBndrs,-        annBinds,-        fixValbindsAnn,-        stmtsAnchor, stmtsLoc,--        cvBindGroup,-        cvBindsAndSigs,-        cvTopDecls,-        placeHolderPunRhs,--        -- Stuff to do with Foreign declarations-        mkImport,-        parseCImport,-        mkExport,-        mkExtName,    -- RdrName -> CLabelString-        mkGadtDecl,   -- [LocatedA RdrName] -> LHsType RdrName -> ConDecl RdrName-        mkConDeclH98,--        -- Bunch of functions in the parser monad for-        -- checking and constructing values-        checkImportDecl,-        checkExpBlockArguments, checkCmdBlockArguments,-        checkPrecP,           -- Int -> P Int-        checkContext,         -- HsType -> P HsContext-        checkPattern,         -- HsExp -> P HsPat-        checkPattern_details,-        incompleteDoBlock,-        ParseContext(..),-        checkMonadComp,       -- P (HsStmtContext GhcPs)-        checkValDef,          -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl-        checkValSigLhs,-        LRuleTyTmVar, RuleTyTmVar(..),-        mkRuleBndrs, mkRuleTyVarBndrs,-        checkRuleTyVarBndrNames,-        checkRecordSyntax,-        checkEmptyGADTs,-        addFatalError, hintBangPat,-        mkBangTy,-        UnpackednessPragma(..),-        mkMultTy,--        -- Token location-        mkTokenLocation,--        -- Help with processing exports-        ImpExpSubSpec(..),-        ImpExpQcSpec(..),-        mkModuleImpExp,-        mkTypeImpExp,-        mkImpExpSubSpec,-        checkImportSpec,--        -- Token symbols-        starSym,--        -- Warnings and errors-        warnStarIsType,-        warnPrepositiveQualifiedModule,-        failOpFewArgs,-        failNotEnabledImportQualifiedPost,-        failImportQualifiedTwice,--        SumOrTuple (..),--        -- Expression/command/pattern ambiguity resolution-        PV,-        runPV,-        ECP(ECP, unECP),-        DisambInfixOp(..),-        DisambECP(..),-        ecpFromExp,-        ecpFromCmd,-        PatBuilder,--        -- Type/datacon ambiguity resolution-        DisambTD(..),-        addUnpackednessP,-        dataConBuilderCon,-        dataConBuilderDetails,-    ) where--import GHC.Prelude-import GHC.Hs           -- Lots of it-import GHC.Core.TyCon          ( TyCon, isTupleTyCon, tyConSingleDataCon_maybe )-import GHC.Core.DataCon        ( DataCon, dataConTyCon )-import GHC.Core.ConLike        ( ConLike(..) )-import GHC.Core.Coercion.Axiom ( Role, fsFromRole )-import GHC.Types.Name.Reader-import GHC.Types.Name-import GHC.Types.Basic-import GHC.Types.Error-import GHC.Types.Fixity-import GHC.Types.Hint-import GHC.Types.SourceText-import GHC.Parser.Types-import GHC.Parser.Lexer-import GHC.Parser.Errors.Types-import GHC.Parser.Errors.Ppr ()-import GHC.Utils.Lexeme ( okConOcc )-import GHC.Types.TyThing-import GHC.Core.Type    ( Specificity(..) )-import GHC.Builtin.Types( cTupleTyConName, tupleTyCon, tupleDataCon,-                          nilDataConName, nilDataConKey,-                          listTyConName, listTyConKey,-                          unrestrictedFunTyCon )-import GHC.Types.ForeignCall-import GHC.Types.SrcLoc-import GHC.Types.Unique ( hasKey )-import GHC.Data.OrdList-import GHC.Utils.Outputable as Outputable-import GHC.Data.FastString-import GHC.Data.Maybe-import GHC.Utils.Error-import GHC.Utils.Misc-import Data.Either-import Data.List        ( findIndex )-import Data.Foldable-import qualified Data.Semigroup as Semi-import GHC.Unit.Module.Warnings-import GHC.Utils.Panic-import GHC.Utils.Panic.Plain-import qualified GHC.Data.Strict as Strict--import Language.Haskell.Syntax.Basic (FieldLabelString(..))--import Control.Monad-import Text.ParserCombinators.ReadP as ReadP-import Data.Char-import Data.Data       ( dataTypeOf, fromConstr, dataTypeConstrs )-import Data.Kind       ( Type )-import Data.List.NonEmpty (NonEmpty)--{- **********************************************************************--  Construction functions for Rdr stuff--  ********************************************************************* -}---- | mkClassDecl builds a RdrClassDecl, filling in the names for tycon and--- datacon by deriving them from the name of the class.  We fill in the names--- for the tycon and datacon corresponding to the class, by deriving them--- from the name of the class itself.  This saves recording the names in the--- interface file (which would be equally good).---- Similarly for mkConDecl, mkClassOpSig and default-method names.----         *** See Note [The Naming story] in GHC.Hs.Decls ****--mkTyClD :: LTyClDecl (GhcPass p) -> LHsDecl (GhcPass p)-mkTyClD (L loc d) = L loc (TyClD noExtField d)--mkInstD :: LInstDecl (GhcPass p) -> LHsDecl (GhcPass p)-mkInstD (L loc d) = L loc (InstD noExtField d)--mkClassDecl :: SrcSpan-            -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs)-            -> Located (a,[LHsFunDep GhcPs])-            -> OrdList (LHsDecl GhcPs)-            -> LayoutInfo GhcPs-            -> [AddEpAnn]-            -> P (LTyClDecl GhcPs)--mkClassDecl loc' (L _ (mcxt, tycl_hdr)) fds where_cls layoutInfo annsIn-  = do { let loc = noAnnSrcSpan loc'-       ; (binds, sigs, ats, at_defs, _, docs) <- cvBindsAndSigs where_cls-       ; (cls, tparams, fixity, ann) <- checkTyClHdr True tycl_hdr-       ; tyvars <- checkTyVars (text "class") whereDots cls tparams-       ; cs <- getCommentsFor (locA loc) -- Get any remaining comments-       ; let anns' = addAnns (EpAnn (spanAsAnchor $ locA loc) annsIn emptyComments) ann cs-       ; return (L loc (ClassDecl { tcdCExt = (anns', NoAnnSortKey)-                                  , tcdLayout = layoutInfo-                                  , tcdCtxt = mcxt-                                  , tcdLName = cls, tcdTyVars = tyvars-                                  , tcdFixity = fixity-                                  , tcdFDs = snd (unLoc fds)-                                  , tcdSigs = mkClassOpSigs sigs-                                  , tcdMeths = binds-                                  , tcdATs = ats, tcdATDefs = at_defs-                                  , tcdDocs  = docs })) }--mkTyData :: SrcSpan-         -> Bool-         -> NewOrData-         -> Maybe (LocatedP CType)-         -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs)-         -> Maybe (LHsKind GhcPs)-         -> [LConDecl GhcPs]-         -> Located (HsDeriving GhcPs)-         -> [AddEpAnn]-         -> P (LTyClDecl GhcPs)-mkTyData loc' is_type_data new_or_data cType (L _ (mcxt, tycl_hdr))-         ksig data_cons (L _ maybe_deriv) annsIn-  = do { let loc = noAnnSrcSpan loc'-       ; (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr-       ; tyvars <- checkTyVars (ppr new_or_data) equalsDots tc tparams-       ; cs <- getCommentsFor (locA loc) -- Get any remaining comments-       ; let anns' = addAnns (EpAnn (spanAsAnchor $ locA loc) annsIn emptyComments) ann cs-       ; data_cons <- checkNewOrData (locA loc) (unLoc tc) is_type_data new_or_data data_cons-       ; defn <- mkDataDefn cType mcxt ksig data_cons maybe_deriv-       ; return (L loc (DataDecl { tcdDExt = anns',-                                   tcdLName = tc, tcdTyVars = tyvars,-                                   tcdFixity = fixity,-                                   tcdDataDefn = defn })) }--mkDataDefn :: Maybe (LocatedP CType)-           -> Maybe (LHsContext GhcPs)-           -> Maybe (LHsKind GhcPs)-           -> DataDefnCons (LConDecl GhcPs)-           -> HsDeriving GhcPs-           -> P (HsDataDefn GhcPs)-mkDataDefn cType mcxt ksig data_cons maybe_deriv-  = do { checkDatatypeContext mcxt-       ; return (HsDataDefn { dd_ext = noExtField-                            , dd_cType = cType-                            , dd_ctxt = mcxt-                            , dd_cons = data_cons-                            , dd_kindSig = ksig-                            , dd_derivs = maybe_deriv }) }--mkTySynonym :: SrcSpan-            -> LHsType GhcPs  -- LHS-            -> LHsType GhcPs  -- RHS-            -> [AddEpAnn]-            -> P (LTyClDecl GhcPs)-mkTySynonym loc lhs rhs annsIn-  = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs-       ; cs1 <- getCommentsFor loc -- Add any API Annotations to the top SrcSpan [temp]-       ; tyvars <- checkTyVars (text "type") equalsDots tc tparams-       ; cs2 <- getCommentsFor loc -- Add any API Annotations to the top SrcSpan [temp]-       ; let anns' = addAnns (EpAnn (spanAsAnchor loc) annsIn emptyComments) ann (cs1 Semi.<> cs2)-       ; return (L (noAnnSrcSpan loc) (SynDecl-                                { tcdSExt = anns'-                                , tcdLName = tc, tcdTyVars = tyvars-                                , tcdFixity = fixity-                                , tcdRhs = rhs })) }--mkStandaloneKindSig-  :: SrcSpan-  -> Located [LocatedN RdrName]   -- LHS-  -> LHsSigType GhcPs             -- RHS-  -> [AddEpAnn]-  -> P (LStandaloneKindSig GhcPs)-mkStandaloneKindSig loc lhs rhs anns =-  do { vs <- mapM check_lhs_name (unLoc lhs)-     ; v <- check_singular_lhs (reverse vs)-     ; cs <- getCommentsFor loc-     ; return $ L (noAnnSrcSpan loc)-       $ StandaloneKindSig (EpAnn (spanAsAnchor loc) anns cs) v rhs }-  where-    check_lhs_name v@(unLoc->name) =-      if isUnqual name && isTcOcc (rdrNameOcc name)-      then return v-      else addFatalError $ mkPlainErrorMsgEnvelope (getLocA v) $-             (PsErrUnexpectedQualifiedConstructor (unLoc v))-    check_singular_lhs vs =-      case vs of-        [] -> panic "mkStandaloneKindSig: empty left-hand side"-        [v] -> return v-        _ -> addFatalError $ mkPlainErrorMsgEnvelope (getLoc lhs) $-               (PsErrMultipleNamesInStandaloneKindSignature vs)--mkTyFamInstEqn :: SrcSpan-               -> HsOuterFamEqnTyVarBndrs GhcPs-               -> LHsType GhcPs-               -> LHsType GhcPs-               -> [AddEpAnn]-               -> P (LTyFamInstEqn GhcPs)-mkTyFamInstEqn loc bndrs lhs rhs anns-  = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs-       ; cs <- getCommentsFor loc-       ; return (L (noAnnSrcSpan loc) $ FamEqn-                        { feqn_ext    = EpAnn (spanAsAnchor loc) (anns `mappend` ann) cs-                        , feqn_tycon  = tc-                        , feqn_bndrs  = bndrs-                        , feqn_pats   = tparams-                        , feqn_fixity = fixity-                        , feqn_rhs    = rhs })}--mkDataFamInst :: SrcSpan-              -> NewOrData-              -> Maybe (LocatedP CType)-              -> (Maybe ( LHsContext GhcPs), HsOuterFamEqnTyVarBndrs GhcPs-                        , LHsType GhcPs)-              -> Maybe (LHsKind GhcPs)-              -> [LConDecl GhcPs]-              -> Located (HsDeriving GhcPs)-              -> [AddEpAnn]-              -> P (LInstDecl GhcPs)-mkDataFamInst loc new_or_data cType (mcxt, bndrs, tycl_hdr)-              ksig data_cons (L _ maybe_deriv) anns-  = do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr-       ; cs <- getCommentsFor loc -- Add any API Annotations to the top SrcSpan-       ; let fam_eqn_ans = addAnns (EpAnn (spanAsAnchor loc) ann cs) anns emptyComments-       ; data_cons <- checkNewOrData loc (unLoc tc) False new_or_data data_cons-       ; defn <- mkDataDefn cType mcxt ksig data_cons maybe_deriv-       ; return (L (noAnnSrcSpan loc) (DataFamInstD noExtField (DataFamInstDecl-                  (FamEqn { feqn_ext    = fam_eqn_ans-                          , feqn_tycon  = tc-                          , feqn_bndrs  = bndrs-                          , feqn_pats   = tparams-                          , feqn_fixity = fixity-                          , feqn_rhs    = defn })))) }---- mkDataFamInst loc new_or_data cType (mcxt, bndrs, tycl_hdr)---               ksig data_cons (L _ maybe_deriv) anns---   = do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr---        ; cs <- getCommentsFor loc -- Add any API Annotations to the top SrcSpan---        ; let anns' = addAnns (EpAnn (spanAsAnchor loc) ann cs) anns emptyComments---        ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv---        ; return (L (noAnnSrcSpan loc) (DataFamInstD anns' (DataFamInstDecl---                   (FamEqn { feqn_ext    = anns'---                           , feqn_tycon  = tc---                           , feqn_bndrs  = bndrs---                           , feqn_pats   = tparams---                           , feqn_fixity = fixity---                           , feqn_rhs    = defn })))) }----mkTyFamInst :: SrcSpan-            -> TyFamInstEqn GhcPs-            -> [AddEpAnn]-            -> P (LInstDecl GhcPs)-mkTyFamInst loc eqn anns = do-  cs <- getCommentsFor loc-  return (L (noAnnSrcSpan loc) (TyFamInstD noExtField-              (TyFamInstDecl (EpAnn (spanAsAnchor loc) anns cs) eqn)))--mkFamDecl :: SrcSpan-          -> FamilyInfo GhcPs-          -> TopLevelFlag-          -> LHsType GhcPs                   -- LHS-          -> LFamilyResultSig GhcPs          -- Optional result signature-          -> Maybe (LInjectivityAnn GhcPs)   -- Injectivity annotation-          -> [AddEpAnn]-          -> P (LTyClDecl GhcPs)-mkFamDecl loc info topLevel lhs ksig injAnn annsIn-  = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs-       ; cs1 <- getCommentsFor loc -- Add any API Annotations to the top SrcSpan [temp]-       ; tyvars <- checkTyVars (ppr info) equals_or_where tc tparams-       ; cs2 <- getCommentsFor loc -- Add any API Annotations to the top SrcSpan [temp]-       ; let anns' = addAnns (EpAnn (spanAsAnchor loc) annsIn emptyComments) ann (cs1 Semi.<> cs2)-       ; return (L (noAnnSrcSpan loc) (FamDecl noExtField-                                         (FamilyDecl-                                           { fdExt       = anns'-                                           , fdTopLevel  = topLevel-                                           , fdInfo      = info, fdLName = tc-                                           , fdTyVars    = tyvars-                                           , fdFixity    = fixity-                                           , fdResultSig = ksig-                                           , fdInjectivityAnn = injAnn }))) }-  where-    equals_or_where = case info of-                        DataFamily          -> empty-                        OpenTypeFamily      -> empty-                        ClosedTypeFamily {} -> whereDots--mkSpliceDecl :: LHsExpr GhcPs -> P (LHsDecl GhcPs)--- If the user wrote---      [pads| ... ]   then return a QuasiQuoteD---      $(e)           then return a SpliceD--- but if they wrote, say,---      f x            then behave as if they'd written $(f x)---                     ie a SpliceD------ Typed splices are not allowed at the top level, thus we do not represent them--- as spliced declaration.  See #10945-mkSpliceDecl lexpr@(L loc expr)-  | HsUntypedSplice _ splice@(HsUntypedSpliceExpr {}) <- expr = do-    cs <- getCommentsFor (locA loc)-    return $ L (addCommentsToSrcAnn loc cs) $ SpliceD noExtField (SpliceDecl noExtField (L loc splice) DollarSplice)--  | HsUntypedSplice _ splice@(HsQuasiQuote {}) <- expr = do-    cs <- getCommentsFor (locA loc)-    return $ L (addCommentsToSrcAnn loc cs) $ SpliceD noExtField (SpliceDecl noExtField (L loc splice) DollarSplice)--  | otherwise = do-    cs <- getCommentsFor (locA loc)-    return $ L (addCommentsToSrcAnn loc cs) $ SpliceD noExtField (SpliceDecl noExtField-                                 (L loc (HsUntypedSpliceExpr noAnn lexpr))-                                       BareSplice)--mkRoleAnnotDecl :: SrcSpan-                -> LocatedN RdrName                -- type being annotated-                -> [Located (Maybe FastString)]    -- roles-                -> [AddEpAnn]-                -> P (LRoleAnnotDecl GhcPs)-mkRoleAnnotDecl loc tycon roles anns-  = do { roles' <- mapM parse_role roles-       ; cs <- getCommentsFor loc-       ; return $ L (noAnnSrcSpan loc)-         $ RoleAnnotDecl (EpAnn (spanAsAnchor loc) anns cs) tycon roles' }-  where-    role_data_type = dataTypeOf (undefined :: Role)-    all_roles = map fromConstr $ dataTypeConstrs role_data_type-    possible_roles = [(fsFromRole role, role) | role <- all_roles]--    parse_role (L loc_role Nothing) = return $ L (noAnnSrcSpan loc_role) Nothing-    parse_role (L loc_role (Just role))-      = case lookup role possible_roles of-          Just found_role -> return $ L (noAnnSrcSpan loc_role) $ Just found_role-          Nothing         ->-            let nearby = fuzzyLookup (unpackFS role)-                  (mapFst unpackFS possible_roles)-            in-            addFatalError $ mkPlainErrorMsgEnvelope loc_role $-              (PsErrIllegalRoleName role nearby)---- | Converts a list of 'LHsTyVarBndr's annotated with their 'Specificity' to--- binders without annotations. Only accepts specified variables, and errors if--- any of the provided binders has an 'InferredSpec' annotation.-fromSpecTyVarBndrs :: [LHsTyVarBndr Specificity GhcPs] -> P [LHsTyVarBndr () GhcPs]-fromSpecTyVarBndrs = mapM fromSpecTyVarBndr---- | Converts 'LHsTyVarBndr' annotated with its 'Specificity' to one without--- annotations. Only accepts specified variables, and errors if the provided--- binder has an 'InferredSpec' annotation.-fromSpecTyVarBndr :: LHsTyVarBndr Specificity GhcPs -> P (LHsTyVarBndr () GhcPs)-fromSpecTyVarBndr bndr = case bndr of-  (L loc (UserTyVar xtv flag idp))     -> (check_spec flag loc)-                                          >> return (L loc $ UserTyVar xtv () idp)-  (L loc (KindedTyVar xtv flag idp k)) -> (check_spec flag loc)-                                          >> return (L loc $ KindedTyVar xtv () idp k)-  where-    check_spec :: Specificity -> SrcSpanAnnA -> P ()-    check_spec SpecifiedSpec _   = return ()-    check_spec InferredSpec  loc = addFatalError $ mkPlainErrorMsgEnvelope (locA loc) $-                                     PsErrInferredTypeVarNotAllowed---- | Add the annotation for a 'where' keyword to existing @HsLocalBinds@-annBinds :: AddEpAnn -> EpAnnComments -> HsLocalBinds GhcPs-  -> (HsLocalBinds GhcPs, Maybe EpAnnComments)-annBinds a cs (HsValBinds an bs)  = (HsValBinds (add_where a an cs) bs, Nothing)-annBinds a cs (HsIPBinds an bs)   = (HsIPBinds (add_where a an cs) bs, Nothing)-annBinds _ cs  (EmptyLocalBinds x) = (EmptyLocalBinds x, Just cs)--add_where :: AddEpAnn -> EpAnn AnnList -> EpAnnComments -> EpAnn AnnList-add_where an@(AddEpAnn _ (EpaSpan rs _)) (EpAnn a (AnnList anc o c r t) cs) cs2-  | valid_anchor (anchor a)-  = EpAnn (widenAnchor a [an]) (AnnList anc o c (an:r) t) (cs Semi.<> cs2)-  | otherwise-  = EpAnn (patch_anchor rs a)-          (AnnList (fmap (patch_anchor rs) anc) o c (an:r) t) (cs Semi.<> cs2)-add_where an@(AddEpAnn _ (EpaSpan rs _)) EpAnnNotUsed cs-  = EpAnn (Anchor rs UnchangedAnchor)-           (AnnList (Just $ Anchor rs UnchangedAnchor) Nothing Nothing [an] []) cs-add_where (AddEpAnn _ (EpaDelta _ _)) _ _ = panic "add_where"- -- EpaDelta should only be used for transformations--valid_anchor :: RealSrcSpan -> Bool-valid_anchor r = srcSpanStartLine r >= 0---- If the decl list for where binds is empty, the anchor ends up--- invalid. In this case, use the parent one-patch_anchor :: RealSrcSpan -> Anchor -> Anchor-patch_anchor r1 (Anchor r0 op) = Anchor r op-  where-    r = if srcSpanStartLine r0 < 0 then r1 else r0--fixValbindsAnn :: EpAnn AnnList -> EpAnn AnnList-fixValbindsAnn EpAnnNotUsed = EpAnnNotUsed-fixValbindsAnn (EpAnn anchor (AnnList ma o c r t) cs)-  = (EpAnn (widenAnchor anchor (map trailingAnnToAddEpAnn t)) (AnnList ma o c r t) cs)---- | The 'Anchor' for a stmtlist is based on either the location or--- the first semicolon annotion.-stmtsAnchor :: Located (OrdList AddEpAnn,a) -> Anchor-stmtsAnchor (L l ((ConsOL (AddEpAnn _ (EpaSpan r _)) _), _))-  = widenAnchorR (Anchor (realSrcSpan l) UnchangedAnchor) r-stmtsAnchor (L l _) = Anchor (realSrcSpan l) UnchangedAnchor--stmtsLoc :: Located (OrdList AddEpAnn,a) -> SrcSpan-stmtsLoc (L l ((ConsOL aa _), _))-  = widenSpan l [aa]-stmtsLoc (L l _) = l--{- **********************************************************************--  #cvBinds-etc# Converting to @HsBinds@, etc.--  ********************************************************************* -}---- | Function definitions are restructured here. Each is assumed to be recursive--- initially, and non recursive definitions are discovered by the dependency--- analyser.-----  | Groups together bindings for a single function-cvTopDecls :: OrdList (LHsDecl GhcPs) -> [LHsDecl GhcPs]-cvTopDecls decls = getMonoBindAll (fromOL decls)---- Declaration list may only contain value bindings and signatures.-cvBindGroup :: OrdList (LHsDecl GhcPs) -> P (HsValBinds GhcPs)-cvBindGroup binding-  = do { (mbs, sigs, fam_ds, tfam_insts-         , dfam_insts, _) <- cvBindsAndSigs binding-       ; massert (null fam_ds && null tfam_insts && null dfam_insts)-       ; return $ ValBinds NoAnnSortKey mbs sigs }--cvBindsAndSigs :: OrdList (LHsDecl GhcPs)-  -> P (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs]-          , [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl GhcPs])--- Input decls contain just value bindings and signatures--- and in case of class or instance declarations also--- associated type declarations. They might also contain Haddock comments.-cvBindsAndSigs fb = do-  fb' <- drop_bad_decls (fromOL fb)-  return (partitionBindsAndSigs (getMonoBindAll fb'))-  where-    -- cvBindsAndSigs is called in several places in the parser,-    -- and its items can be produced by various productions:-    ---    --    * decl       (when parsing a where clause or a let-expression)-    --    * decl_inst  (when parsing an instance declaration)-    --    * decl_cls   (when parsing a class declaration)-    ---    -- partitionBindsAndSigs can handle almost all declaration forms produced-    -- by the aforementioned productions, except for SpliceD, which we filter-    -- out here (in drop_bad_decls).-    ---    -- We're not concerned with every declaration form possible, such as those-    -- produced by the topdecl parser production, because cvBindsAndSigs is not-    -- called on top-level declarations.-    drop_bad_decls [] = return []-    drop_bad_decls (L l (SpliceD _ d) : ds) = do-      addError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrDeclSpliceNotAtTopLevel d-      drop_bad_decls ds-    drop_bad_decls (d:ds) = (d:) <$> drop_bad_decls ds---------------------------------------------------------------------------------- Group function bindings into equation groups--getMonoBind :: LHsBind GhcPs -> [LHsDecl GhcPs]-  -> (LHsBind GhcPs, [LHsDecl GhcPs])--- Suppose      (b',ds') = getMonoBind b ds---      ds is a list of parsed bindings---      b is a MonoBinds that has just been read off the front---- Then b' is the result of grouping more equations from ds that--- belong with b into a single MonoBinds, and ds' is the depleted--- list of parsed bindings.------ All Haddock comments between equations inside the group are--- discarded.------ No AndMonoBinds or EmptyMonoBinds here; just single equations--getMonoBind (L loc1 (FunBind { fun_id = fun_id1@(L _ f1)-                             , fun_matches =-                               MG { mg_alts = (L _ m1@[L _ mtchs1]) } }))-            binds-  | has_args m1-  = go [L (removeCommentsA loc1) mtchs1] (commentsOnlyA loc1) binds []-  where-    go :: [LMatch GhcPs (LHsExpr GhcPs)] -> SrcSpanAnnA-       -> [LHsDecl GhcPs] -> [LHsDecl GhcPs]-       -> (LHsBind GhcPs,[LHsDecl GhcPs]) -- AZ-    go mtchs loc-       ((L loc2 (ValD _ (FunBind { fun_id = (L _ f2)-                                 , fun_matches =-                                    MG { mg_alts = (L _ [L lm2 mtchs2]) } })))-         : binds) _-        | f1 == f2 =-          let (loc2', lm2') = transferAnnsA loc2 lm2-          in go (L lm2' mtchs2 : mtchs)-                        (combineSrcSpansA loc loc2') binds []-    go mtchs loc (doc_decl@(L loc2 (DocD {})) : binds) doc_decls-        = let doc_decls' = doc_decl : doc_decls-          in go mtchs (combineSrcSpansA loc loc2) binds doc_decls'-    go mtchs loc binds doc_decls-        = ( L loc (makeFunBind fun_id1 (mkLocatedList $ reverse mtchs))-          , (reverse doc_decls) ++ binds)-        -- Reverse the final matches, to get it back in the right order-        -- Do the same thing with the trailing doc comments--getMonoBind bind binds = (bind, binds)---- Group together adjacent FunBinds for every function.-getMonoBindAll :: [LHsDecl GhcPs] -> [LHsDecl GhcPs]-getMonoBindAll [] = []-getMonoBindAll (L l (ValD _ b) : ds) =-  let (L l' b', ds') = getMonoBind (L l b) ds-  in L l' (ValD noExtField b') : getMonoBindAll ds'-getMonoBindAll (d : ds) = d : getMonoBindAll ds--has_args :: [LMatch GhcPs (LHsExpr GhcPs)] -> Bool-has_args []                                  = panic "GHC.Parser.PostProcess.has_args"-has_args (L _ (Match { m_pats = args }) : _) = not (null args)-        -- Don't group together FunBinds if they have-        -- no arguments.  This is necessary now that variable bindings-        -- with no arguments are now treated as FunBinds rather-        -- than pattern bindings (tests/rename/should_fail/rnfail002).--{- **********************************************************************--  #PrefixToHS-utils# Utilities for conversion--  ********************************************************************* -}--{- Note [Parsing data constructors is hard]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--The problem with parsing data constructors is that they look a lot like types.-Compare:--  (s1)   data T = C t1 t2-  (s2)   type T = C t1 t2--Syntactically, there's little difference between these declarations, except in-(s1) 'C' is a data constructor, but in (s2) 'C' is a type constructor.--This similarity would pose no problem if we knew ahead of time if we are-parsing a type or a constructor declaration. Looking at (s1) and (s2), a simple-(but wrong!) rule comes to mind: in 'data' declarations assume we are parsing-data constructors, and in other contexts (e.g. 'type' declarations) assume we-are parsing type constructors.--This simple rule does not work because of two problematic cases:--  (p1)   data T = C t1 t2 :+ t3-  (p2)   data T = C t1 t2 => t3--In (p1) we encounter (:+) and it turns out we are parsing an infix data-declaration, so (C t1 t2) is a type and 'C' is a type constructor.-In (p2) we encounter (=>) and it turns out we are parsing an existential-context, so (C t1 t2) is a constraint and 'C' is a type constructor.--As the result, in order to determine whether (C t1 t2) declares a data-constructor, a type, or a context, we would need unlimited lookahead which-'happy' is not so happy with.--}---- | Reinterpret a type constructor, including type operators, as a data---   constructor.--- See Note [Parsing data constructors is hard]-tyConToDataCon :: LocatedN RdrName -> Either (MsgEnvelope PsMessage) (LocatedN RdrName)-tyConToDataCon (L loc tc)-  | okConOcc (occNameString occ)-  = return (L loc (setRdrNameSpace tc srcDataName))--  | otherwise-  = Left $ mkPlainErrorMsgEnvelope (locA loc) $ (PsErrNotADataCon tc)-  where-    occ = rdrNameOcc tc--mkPatSynMatchGroup :: LocatedN RdrName-                   -> LocatedL (OrdList (LHsDecl GhcPs))-                   -> P (MatchGroup GhcPs (LHsExpr GhcPs))-mkPatSynMatchGroup (L loc patsyn_name) (L ld decls) =-    do { matches <- mapM fromDecl (fromOL decls)-       ; when (null matches) (wrongNumberErr (locA loc))-       ; return $ mkMatchGroup FromSource (L ld matches) }-  where-    fromDecl (L loc decl@(ValD _ (PatBind _-                                 -- AZ: where should these anns come from?-                         pat@(L _ (ConPat noAnn ln@(L _ name) details))-                               rhs))) =-        do { unless (name == patsyn_name) $-               wrongNameBindingErr (locA loc) decl-           ; match <- case details of-               PrefixCon _ pats -> return $ Match { m_ext = noAnn-                                                  , m_ctxt = ctxt, m_pats = pats-                                                  , m_grhss = rhs }-                   where-                     ctxt = FunRhs { mc_fun = ln-                                   , mc_fixity = Prefix-                                   , mc_strictness = NoSrcStrict }--               InfixCon p1 p2 -> return $ Match { m_ext = noAnn-                                                , m_ctxt = ctxt-                                                , m_pats = [p1, p2]-                                                , m_grhss = rhs }-                   where-                     ctxt = FunRhs { mc_fun = ln-                                   , mc_fixity = Infix-                                   , mc_strictness = NoSrcStrict }--               RecCon{} -> recordPatSynErr (locA loc) pat-           ; return $ L loc match }-    fromDecl (L loc decl) = extraDeclErr (locA loc) decl--    extraDeclErr loc decl =-        addFatalError $ mkPlainErrorMsgEnvelope loc $-          (PsErrNoSingleWhereBindInPatSynDecl patsyn_name decl)--    wrongNameBindingErr loc decl =-      addFatalError $ mkPlainErrorMsgEnvelope loc $-          (PsErrInvalidWhereBindInPatSynDecl patsyn_name decl)--    wrongNumberErr loc =-      addFatalError $ mkPlainErrorMsgEnvelope loc $-        (PsErrEmptyWhereInPatSynDecl patsyn_name)--recordPatSynErr :: SrcSpan -> LPat GhcPs -> P a-recordPatSynErr loc pat =-    addFatalError $ mkPlainErrorMsgEnvelope loc $-      (PsErrRecordSyntaxInPatSynDecl pat)--mkConDeclH98 :: EpAnn [AddEpAnn] -> LocatedN RdrName -> Maybe [LHsTyVarBndr Specificity GhcPs]-                -> Maybe (LHsContext GhcPs) -> HsConDeclH98Details GhcPs-                -> ConDecl GhcPs--mkConDeclH98 ann name mb_forall mb_cxt args-  = ConDeclH98 { con_ext    = ann-               , con_name   = name-               , con_forall = isJust mb_forall-               , con_ex_tvs = mb_forall `orElse` []-               , con_mb_cxt = mb_cxt-               , con_args   = args-               , con_doc    = Nothing }---- | Construct a GADT-style data constructor from the constructor names and--- their type. Some interesting aspects of this function:------ * This splits up the constructor type into its quantified type variables (if---   provided), context (if provided), argument types, and result type, and---   records whether this is a prefix or record GADT constructor. See---   Note [GADT abstract syntax] in "GHC.Hs.Decls" for more details.-mkGadtDecl :: SrcSpan-           -> NonEmpty (LocatedN RdrName)-           -> LHsUniToken "::" "∷" GhcPs-           -> LHsSigType GhcPs-           -> P (LConDecl GhcPs)-mkGadtDecl loc names dcol ty = do-  cs <- getCommentsFor loc-  let l = noAnnSrcSpan loc--  (args, res_ty, annsa, csa) <--    case body_ty of-     L ll (HsFunTy af hsArr (L loc' (HsRecTy an rf)) res_ty) -> do-       let an' = addCommentsToEpAnn (locA loc') an (comments af)-       arr <- case hsArr of-         HsUnrestrictedArrow arr -> return arr-         _ -> do addError $ mkPlainErrorMsgEnvelope (getLocA body_ty) $-                                 (PsErrIllegalGadtRecordMultiplicity hsArr)-                 return noHsUniTok--       return ( RecConGADT (L (SrcSpanAnn an' (locA loc')) rf) arr, res_ty-              , [], epAnnComments (ann ll))-     _ -> do-       let (anns, cs, arg_types, res_type) = splitHsFunType body_ty-       return (PrefixConGADT arg_types, res_type, anns, cs)--  let an = EpAnn (spanAsAnchor loc) annsa (cs Semi.<> csa)--  pure $ L l ConDeclGADT-                     { con_g_ext  = an-                     , con_names  = names-                     , con_dcolon = dcol-                     , con_bndrs  = L (getLoc ty) outer_bndrs-                     , con_mb_cxt = mcxt-                     , con_g_args = args-                     , con_res_ty = res_ty-                     , con_doc    = Nothing }-  where-    (outer_bndrs, mcxt, body_ty) = splitLHsGadtTy ty--setRdrNameSpace :: RdrName -> NameSpace -> RdrName--- ^ This rather gruesome function is used mainly by the parser.--- When parsing:------ > data T a = T | T1 Int------ we parse the data constructors as /types/ because of parser ambiguities,--- so then we need to change the /type constr/ to a /data constr/------ The exact-name case /can/ occur when parsing:------ > data [] a = [] | a : [a]------ For the exact-name case we return an original name.-setRdrNameSpace (Unqual occ) ns = Unqual (setOccNameSpace ns occ)-setRdrNameSpace (Qual m occ) ns = Qual m (setOccNameSpace ns occ)-setRdrNameSpace (Orig m occ) ns = Orig m (setOccNameSpace ns occ)-setRdrNameSpace (Exact n)    ns-  | Just thing <- wiredInNameTyThing_maybe n-  = setWiredInNameSpace thing ns-    -- Preserve Exact Names for wired-in things,-    -- notably tuples and lists--  | isExternalName n-  = Orig (nameModule n) occ--  | otherwise   -- This can happen when quoting and then-                -- splicing a fixity declaration for a type-  = Exact (mkSystemNameAt (nameUnique n) occ (nameSrcSpan n))-  where-    occ = setOccNameSpace ns (nameOccName n)--setWiredInNameSpace :: TyThing -> NameSpace -> RdrName-setWiredInNameSpace (ATyCon tc) ns-  | isDataConNameSpace ns-  = ty_con_data_con tc-  | isTcClsNameSpace ns-  = Exact (getName tc)      -- No-op--setWiredInNameSpace (AConLike (RealDataCon dc)) ns-  | isTcClsNameSpace ns-  = data_con_ty_con dc-  | isDataConNameSpace ns-  = Exact (getName dc)      -- No-op--setWiredInNameSpace thing ns-  = pprPanic "setWiredinNameSpace" (pprNameSpace ns <+> ppr thing)--ty_con_data_con :: TyCon -> RdrName-ty_con_data_con tc-  | isTupleTyCon tc-  , Just dc <- tyConSingleDataCon_maybe tc-  = Exact (getName dc)--  | tc `hasKey` listTyConKey-  = Exact nilDataConName--  | otherwise  -- See Note [setRdrNameSpace for wired-in names]-  = Unqual (setOccNameSpace srcDataName (getOccName tc))--data_con_ty_con :: DataCon -> RdrName-data_con_ty_con dc-  | let tc = dataConTyCon dc-  , isTupleTyCon tc-  = Exact (getName tc)--  | dc `hasKey` nilDataConKey-  = Exact listTyConName--  | otherwise  -- See Note [setRdrNameSpace for wired-in names]-  = Unqual (setOccNameSpace tcClsName (getOccName dc))----{- Note [setRdrNameSpace for wired-in names]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-In GHC.Types, which declares (:), we have-  infixr 5 :-The ambiguity about which ":" is meant is resolved by parsing it as a-data constructor, but then using dataTcOccs to try the type constructor too;-and that in turn calls setRdrNameSpace to change the name-space of ":" to-tcClsName.  There isn't a corresponding ":" type constructor, but it's painful-to make setRdrNameSpace partial, so we just make an Unqual name instead. It-really doesn't matter!--}--eitherToP :: MonadP m => Either (MsgEnvelope PsMessage) a -> m a--- Adapts the Either monad to the P monad-eitherToP (Left err)    = addFatalError err-eitherToP (Right thing) = return thing--checkTyVars :: SDoc -> SDoc -> LocatedN RdrName -> [LHsTypeArg GhcPs]-            -> P (LHsQTyVars GhcPs)  -- the synthesized type variables--- ^ Check whether the given list of type parameters are all type variables--- (possibly with a kind signature).-checkTyVars pp_what equals_or_where tc tparms-  = do { tvs <- mapM check tparms-       ; return (mkHsQTvs tvs) }-  where-    check (HsTypeArg at ki) = chkParens [] [] emptyComments (HsBndrInvisible at) ki-    check (HsValArg ty) = chkParens [] [] emptyComments HsBndrRequired ty-    check (HsArgPar sp) = addFatalError $ mkPlainErrorMsgEnvelope sp $-                            (PsErrMalformedDecl pp_what (unLoc tc))-        -- Keep around an action for adjusting the annotations of extra parens-    chkParens :: [AddEpAnn] -> [AddEpAnn] -> EpAnnComments -> HsBndrVis GhcPs -> LHsType GhcPs-              -> P (LHsTyVarBndr (HsBndrVis GhcPs) GhcPs)-    chkParens ops cps cs bvis (L l (HsParTy an ty))-      = let-          (o,c) = mkParensEpAnn (realSrcSpan $ locA l)-        in-          chkParens (o:ops) (c:cps) (cs Semi.<> epAnnComments an) bvis ty-    chkParens ops cps cs bvis ty = chk ops cps cs bvis ty--        -- Check that the name space is correct!-    chk :: [AddEpAnn] -> [AddEpAnn] -> EpAnnComments -> HsBndrVis GhcPs -> LHsType GhcPs -> P (LHsTyVarBndr (HsBndrVis GhcPs) GhcPs)-    chk ops cps cs bvis (L l (HsKindSig annk (L annt (HsTyVar ann _ (L lv tv))) k))-        | isRdrTyVar tv-            = let-                an = (reverse ops) ++ cps-              in-                return (L (widenLocatedAn (l Semi.<> annt) (for_widening bvis:an))-                       (KindedTyVar (addAnns (annk Semi.<> ann Semi.<> for_widening_ann bvis) an cs)-                                    bvis (L lv tv) k))-    chk ops cps cs bvis (L l (HsTyVar ann _ (L ltv tv)))-        | isRdrTyVar tv-            = let-                an = (reverse ops) ++ cps-              in-                return (L (widenLocatedAn l (for_widening bvis:an))-                                     (UserTyVar (addAnns (ann Semi.<> for_widening_ann bvis) an cs)-                                                bvis (L ltv tv)))-    chk _ _ _ _ t@(L loc _)-        = addFatalError $ mkPlainErrorMsgEnvelope (locA loc) $-            (PsErrUnexpectedTypeInDecl t pp_what (unLoc tc) tparms equals_or_where)--    -- Return an AddEpAnn for use in widenLocatedAn. The AnnKeywordId is not used.-    for_widening :: HsBndrVis GhcPs -> AddEpAnn-    for_widening (HsBndrInvisible (L (TokenLoc loc) _)) = AddEpAnn AnnAnyclass loc-    for_widening  _                                     = AddEpAnn AnnAnyclass (EpaDelta (SameLine 0) [])--    for_widening_ann :: HsBndrVis GhcPs -> EpAnn [AddEpAnn]-    for_widening_ann (HsBndrInvisible (L (TokenLoc (EpaSpan r _mb)) _)) = EpAnn (realSpanAsAnchor r) [] emptyComments-    for_widening_ann  _                                     = EpAnnNotUsed---whereDots, equalsDots :: SDoc--- Second argument to checkTyVars-whereDots  = text "where ..."-equalsDots = text "= ..."--checkDatatypeContext :: Maybe (LHsContext GhcPs) -> P ()-checkDatatypeContext Nothing = return ()-checkDatatypeContext (Just c)-    = do allowed <- getBit DatatypeContextsBit-         unless allowed $ addError $ mkPlainErrorMsgEnvelope (getLocA c) $-                                       (PsErrIllegalDataTypeContext c)--type LRuleTyTmVar = LocatedAn NoEpAnns RuleTyTmVar-data RuleTyTmVar = RuleTyTmVar (EpAnn [AddEpAnn]) (LocatedN RdrName) (Maybe (LHsType GhcPs))--- ^ Essentially a wrapper for a @RuleBndr GhcPs@---- turns RuleTyTmVars into RuleBnrs - this is straightforward-mkRuleBndrs :: [LRuleTyTmVar] -> [LRuleBndr GhcPs]-mkRuleBndrs = fmap (fmap cvt_one)-  where cvt_one (RuleTyTmVar ann v Nothing) = RuleBndr ann v-        cvt_one (RuleTyTmVar ann v (Just sig)) =-          RuleBndrSig ann v (mkHsPatSigType noAnn sig)---- turns RuleTyTmVars into HsTyVarBndrs - this is more interesting-mkRuleTyVarBndrs :: [LRuleTyTmVar] -> [LHsTyVarBndr () GhcPs]-mkRuleTyVarBndrs = fmap cvt_one-  where cvt_one (L l (RuleTyTmVar ann v Nothing))-          = L (l2l l) (UserTyVar ann () (fmap tm_to_ty v))-        cvt_one (L l (RuleTyTmVar ann v (Just sig)))-          = L (l2l l) (KindedTyVar ann () (fmap tm_to_ty v) sig)-    -- takes something in namespace 'varName' to something in namespace 'tvName'-        tm_to_ty (Unqual occ) = Unqual (setOccNameSpace tvName occ)-        tm_to_ty _ = panic "mkRuleTyVarBndrs"---- See Note [Parsing explicit foralls in Rules] in Parser.y-checkRuleTyVarBndrNames :: [LHsTyVarBndr flag GhcPs] -> P ()-checkRuleTyVarBndrNames = mapM_ (check . fmap hsTyVarName)-  where check (L loc (Unqual occ)) =-          when (occNameFS occ `elem` [fsLit "forall",fsLit "family",fsLit "role"])-            (addFatalError $ mkPlainErrorMsgEnvelope (locA loc) $-               (PsErrParseErrorOnInput occ))-        check _ = panic "checkRuleTyVarBndrNames"--checkRecordSyntax :: (MonadP m, Outputable a) => LocatedA a -> m (LocatedA a)-checkRecordSyntax lr@(L loc r)-    = do allowed <- getBit TraditionalRecordSyntaxBit-         unless allowed $ addError $ mkPlainErrorMsgEnvelope (locA loc) $-                                       (PsErrIllegalTraditionalRecordSyntax (ppr r))-         return lr---- | Check if the gadt_constrlist is empty. Only raise parse error for--- `data T where` to avoid affecting existing error message, see #8258.-checkEmptyGADTs :: Located ([AddEpAnn], [LConDecl GhcPs])-                -> P (Located ([AddEpAnn], [LConDecl GhcPs]))-checkEmptyGADTs gadts@(L span (_, []))           -- Empty GADT declaration.-    = do gadtSyntax <- getBit GadtSyntaxBit   -- GADTs implies GADTSyntax-         unless gadtSyntax $ addError $ mkPlainErrorMsgEnvelope span $-                                          PsErrIllegalWhereInDataDecl-         return gadts-checkEmptyGADTs gadts = return gadts              -- Ordinary GADT declaration.--checkTyClHdr :: Bool               -- True  <=> class header-                                   -- False <=> type header-             -> LHsType GhcPs-             -> P (LocatedN RdrName,     -- the head symbol (type or class name)-                   [LHsTypeArg GhcPs],   -- parameters of head symbol-                   LexicalFixity,        -- the declaration is in infix format-                   [AddEpAnn])           -- API Annotation for HsParTy-                                         -- when stripping parens--- Well-formedness check and decomposition of type and class heads.--- Decomposes   T ty1 .. tyn   into    (T, [ty1, ..., tyn])---              Int :*: Bool   into    (:*:, [Int, Bool])--- returning the pieces-checkTyClHdr is_cls ty-  = goL ty [] [] [] Prefix-  where-    goL (L l ty) acc ops cps fix = go (locA l) ty acc ops cps fix--    -- workaround to define '*' despite StarIsType-    go _ (HsParTy an (L l (HsStarTy _ isUni))) acc ops' cps' fix-      = do { addPsMessage (locA l) PsWarnStarBinder-           ; let name = mkOccNameFS tcClsName (starSym isUni)-           ; let a' = newAnns l an-           ; return (L a' (Unqual name), acc, fix-                    , (reverse ops') ++ cps') }--    go _ (HsTyVar _ _ ltc@(L _ tc)) acc ops cps fix-      | isRdrTc tc               = return (ltc, acc, fix, (reverse ops) ++ cps)-    go _ (HsOpTy _ _ t1 ltc@(L _ tc) t2) acc ops cps _fix-      | isRdrTc tc               = return (ltc, HsValArg t1:HsValArg t2:acc, Infix, (reverse ops) ++ cps)-    go l (HsParTy _ ty)    acc ops cps fix = goL ty acc (o:ops) (c:cps) fix-      where-        (o,c) = mkParensEpAnn (realSrcSpan l)-    go _ (HsAppTy _ t1 t2) acc ops cps fix = goL t1 (HsValArg t2:acc) ops cps fix-    go _ (HsAppKindTy _ ty at ki) acc ops cps fix = goL ty (HsTypeArg at ki:acc) ops cps fix-    go l (HsTupleTy _ HsBoxedOrConstraintTuple ts) [] ops cps fix-      = return (L (noAnnSrcSpan l) (nameRdrName tup_name)-               , map HsValArg ts, fix, (reverse ops)++cps)-      where-        arity = length ts-        tup_name | is_cls    = cTupleTyConName arity-                 | otherwise = getName (tupleTyCon Boxed arity)-          -- See Note [Unit tuples] in GHC.Hs.Type  (TODO: is this still relevant?)-    go l _ _ _ _ _-      = addFatalError $ mkPlainErrorMsgEnvelope l $-          (PsErrMalformedTyOrClDecl ty)--    -- Combine the annotations from the HsParTy and HsStarTy into a-    -- new one for the LocatedN RdrName-    newAnns :: SrcSpanAnnA -> EpAnn AnnParen -> SrcSpanAnnN-    newAnns (SrcSpanAnn EpAnnNotUsed l) (EpAnn as (AnnParen _ o c) cs) =-      let-        lr = combineRealSrcSpans (realSrcSpan l) (anchor as)-        an = (EpAnn (Anchor lr UnchangedAnchor) (NameAnn NameParens o (srcSpan2e l) c []) cs)-      in SrcSpanAnn an (RealSrcSpan lr Strict.Nothing)-    newAnns _ EpAnnNotUsed = panic "missing AnnParen"-    newAnns (SrcSpanAnn (EpAnn ap (AnnListItem ta) csp) l) (EpAnn as (AnnParen _ o c) cs) =-      let-        lr = combineRealSrcSpans (anchor ap) (anchor as)-        an = (EpAnn (Anchor lr UnchangedAnchor) (NameAnn NameParens o (srcSpan2e l) c ta) (csp Semi.<> cs))-      in SrcSpanAnn an (RealSrcSpan lr Strict.Nothing)---- | Yield a parse error if we have a function applied directly to a do block--- etc. and BlockArguments is not enabled.-checkExpBlockArguments :: LHsExpr GhcPs -> PV ()-checkCmdBlockArguments :: LHsCmd GhcPs -> PV ()-(checkExpBlockArguments, checkCmdBlockArguments) = (checkExpr, checkCmd)-  where-    checkExpr :: LHsExpr GhcPs -> PV ()-    checkExpr expr = case unLoc expr of-      HsDo _ (DoExpr m) _      -> check (PsErrDoInFunAppExpr m)                  expr-      HsDo _ (MDoExpr m) _     -> check (PsErrMDoInFunAppExpr m)                 expr-      HsLam {}                 -> check PsErrLambdaInFunAppExpr                  expr-      HsCase {}                -> check PsErrCaseInFunAppExpr                    expr-      HsLamCase _ lc_variant _ -> check (PsErrLambdaCaseInFunAppExpr lc_variant) expr-      HsLet {}                 -> check PsErrLetInFunAppExpr                     expr-      HsIf {}                  -> check PsErrIfInFunAppExpr                      expr-      HsProc {}                -> check PsErrProcInFunAppExpr                    expr-      _                        -> return ()--    checkCmd :: LHsCmd GhcPs -> PV ()-    checkCmd cmd = case unLoc cmd of-      HsCmdLam {}                 -> check PsErrLambdaCmdInFunAppCmd                  cmd-      HsCmdCase {}                -> check PsErrCaseCmdInFunAppCmd                    cmd-      HsCmdLamCase _ lc_variant _ -> check (PsErrLambdaCaseCmdInFunAppCmd lc_variant) cmd-      HsCmdIf {}                  -> check PsErrIfCmdInFunAppCmd                      cmd-      HsCmdLet {}                 -> check PsErrLetCmdInFunAppCmd                     cmd-      HsCmdDo {}                  -> check PsErrDoCmdInFunAppCmd                      cmd-      _                           -> return ()--    check err a = do-      blockArguments <- getBit BlockArgumentsBit-      unless blockArguments $-        addError $ mkPlainErrorMsgEnvelope (getLocA a) $ (err a)---- | Validate the context constraints and break up a context into a list--- of predicates.------ @---     (Eq a, Ord b)        -->  [Eq a, Ord b]---     Eq a                 -->  [Eq a]---     (Eq a)               -->  [Eq a]---     (((Eq a)))           -->  [Eq a]--- @-checkContext :: LHsType GhcPs -> P (LHsContext GhcPs)-checkContext orig_t@(L (SrcSpanAnn _ l) _orig_t) =-  check ([],[],emptyComments) orig_t- where-  check :: ([EpaLocation],[EpaLocation],EpAnnComments)-        -> LHsType GhcPs -> P (LHsContext GhcPs)-  check (oparens,cparens,cs) (L _l (HsTupleTy ann' HsBoxedOrConstraintTuple ts))-    -- (Eq a, Ord b) shows up as a tuple type. Only boxed tuples can-    -- be used as context constraints.-    -- Ditto ()-    = do-        let (op,cp,cs') = case ann' of-              EpAnnNotUsed -> ([],[],emptyComments)-              EpAnn _ (AnnParen _ o c) cs -> ([o],[c],cs)-        return (L (SrcSpanAnn (EpAnn (spanAsAnchor l)-                              -- Append parens so that the original order in the source is maintained-                               (AnnContext Nothing (oparens ++ op) (cp ++ cparens)) (cs Semi.<> cs')) l) ts)--  check (opi,cpi,csi) (L _lp1 (HsParTy ann' ty))-                                  -- to be sure HsParTy doesn't get into the way-    = do-        let (op,cp,cs') = case ann' of-                    EpAnnNotUsed -> ([],[],emptyComments)-                    EpAnn _ (AnnParen _ open close ) cs -> ([open],[close],cs)-        check (op++opi,cp++cpi,cs' Semi.<> csi) ty--  -- No need for anns, returning original-  check (_opi,_cpi,_csi) _t =-                 return (L (SrcSpanAnn (EpAnn (spanAsAnchor l) (AnnContext Nothing [] []) emptyComments) l) [orig_t])--checkImportDecl :: Maybe EpaLocation-                -> Maybe EpaLocation-                -> P ()-checkImportDecl mPre mPost = do-  let whenJust mg f = maybe (pure ()) f mg--  importQualifiedPostEnabled <- getBit ImportQualifiedPostBit--  -- Error if 'qualified' found in postpositive position and-  -- 'ImportQualifiedPost' is not in effect.-  whenJust mPost $ \post ->-    when (not importQualifiedPostEnabled) $-      failNotEnabledImportQualifiedPost (RealSrcSpan (epaLocationRealSrcSpan post) Strict.Nothing)--  -- Error if 'qualified' occurs in both pre and postpositive-  -- positions.-  whenJust mPost $ \post ->-    when (isJust mPre) $-      failImportQualifiedTwice (RealSrcSpan (epaLocationRealSrcSpan post) Strict.Nothing)--  -- Warn if 'qualified' found in prepositive position and-  -- 'Opt_WarnPrepositiveQualifiedModule' is enabled.-  whenJust mPre $ \pre ->-    warnPrepositiveQualifiedModule (RealSrcSpan (epaLocationRealSrcSpan pre) Strict.Nothing)---- ---------------------------------------------------------------------------- Checking Patterns.---- We parse patterns as expressions and check for valid patterns below,--- converting the expression into a pattern at the same time.--checkPattern :: LocatedA (PatBuilder GhcPs) -> P (LPat GhcPs)-checkPattern = runPV . checkLPat--checkPattern_details :: ParseContext -> PV (LocatedA (PatBuilder GhcPs)) -> P (LPat GhcPs)-checkPattern_details extraDetails pp = runPV_details extraDetails (pp >>= checkLPat)--checkLPat :: LocatedA (PatBuilder GhcPs) -> PV (LPat GhcPs)-checkLPat e@(L l _) = checkPat l e [] []--checkPat :: SrcSpanAnnA -> LocatedA (PatBuilder GhcPs) -> [HsConPatTyArg GhcPs] -> [LPat GhcPs]-         -> PV (LPat GhcPs)-checkPat loc (L l e@(PatBuilderVar (L ln c))) tyargs args-  | isRdrDataCon c = return . L loc $ ConPat-      { pat_con_ext = noAnn -- AZ: where should this come from?-      , pat_con = L ln c-      , pat_args = PrefixCon tyargs args-      }-  | not (null tyargs) =-      patFail (locA l) . PsErrInPat e $ PEIP_TypeArgs tyargs-  | (not (null args) && patIsRec c) = do-      ctx <- askParseContext-      patFail (locA l) . PsErrInPat e $ PEIP_RecPattern args YesPatIsRecursive ctx-checkPat loc (L _ (PatBuilderAppType f at t)) tyargs args =-  checkPat loc f (HsConPatTyArg at t : tyargs) args-checkPat loc (L _ (PatBuilderApp f e)) [] args = do-  p <- checkLPat e-  checkPat loc f [] (p : args)-checkPat loc (L l e) [] [] = do-  p <- checkAPat loc e-  return (L l p)-checkPat loc e _ _ = do-  details <- fromParseContext <$> askParseContext-  patFail (locA loc) (PsErrInPat (unLoc e) details)--checkAPat :: SrcSpanAnnA -> PatBuilder GhcPs -> PV (Pat GhcPs)-checkAPat loc e0 = do- nPlusKPatterns <- getBit NPlusKPatternsBit- case e0 of-   PatBuilderPat p -> return p-   PatBuilderVar x -> return (VarPat noExtField x)--   -- Overloaded numeric patterns (e.g. f 0 x = x)-   -- Negation is recorded separately, so that the literal is zero or +ve-   -- NB. Negative *primitive* literals are already handled by the lexer-   PatBuilderOverLit pos_lit -> return (mkNPat (L (l2l loc) pos_lit) Nothing noAnn)--   -- n+k patterns-   PatBuilderOpApp-           (L _ (PatBuilderVar (L nloc n)))-           (L l plus)-           (L lloc (PatBuilderOverLit lit@(OverLit {ol_val = HsIntegral {}})))-           (EpAnn anc _ cs)-                     | nPlusKPatterns && (plus == plus_RDR)-                     -> return (mkNPlusKPat (L nloc n) (L (l2l lloc) lit)-                                (EpAnn anc (epaLocationFromSrcAnn l) cs))--   -- Improve error messages for the @-operator when the user meant an @-pattern-   PatBuilderOpApp _ op _ _ | opIsAt (unLoc op) -> do-     addError $ mkPlainErrorMsgEnvelope (getLocA op) PsErrAtInPatPos-     return (WildPat noExtField)--   PatBuilderOpApp l (L cl c) r anns-     | isRdrDataCon c -> do-         l <- checkLPat l-         r <- checkLPat r-         return $ ConPat-           { pat_con_ext = anns-           , pat_con = L cl c-           , pat_args = InfixCon l r-           }--   PatBuilderPar lpar e rpar -> do-     p <- checkLPat e-     return (ParPat (EpAnn (spanAsAnchor (locA loc)) NoEpAnns emptyComments) lpar p rpar)--   _           -> do-     details <- fromParseContext <$> askParseContext-     patFail (locA loc) (PsErrInPat e0 details)--placeHolderPunRhs :: DisambECP b => PV (LocatedA b)--- The RHS of a punned record field will be filled in by the renamer--- It's better not to make it an error, in case we want to print it when--- debugging-placeHolderPunRhs = mkHsVarPV (noLocA pun_RDR)--plus_RDR, pun_RDR :: RdrName-plus_RDR = mkUnqual varName (fsLit "+") -- Hack-pun_RDR  = mkUnqual varName (fsLit "pun-right-hand-side")--checkPatField :: LHsRecField GhcPs (LocatedA (PatBuilder GhcPs))-              -> PV (LHsRecField GhcPs (LPat GhcPs))-checkPatField (L l fld) = do p <- checkLPat (hfbRHS fld)-                             return (L l (fld { hfbRHS = p }))--patFail :: SrcSpan -> PsMessage -> PV a-patFail loc msg = addFatalError $ mkPlainErrorMsgEnvelope loc $ msg--patIsRec :: RdrName -> Bool-patIsRec e = e == mkUnqual varName (fsLit "rec")-------------------------------------------------------------------------------- Check Equation Syntax--checkValDef :: SrcSpan-            -> LocatedA (PatBuilder GhcPs)-            -> Maybe (AddEpAnn, LHsType GhcPs)-            -> Located (GRHSs GhcPs (LHsExpr GhcPs))-            -> P (HsBind GhcPs)--checkValDef loc lhs (Just (sigAnn, sig)) grhss-        -- x :: ty = rhs  parses as a *pattern* binding-  = do lhs' <- runPV $ mkHsTySigPV (combineLocsA lhs sig) lhs sig [sigAnn]-                        >>= checkLPat-       checkPatBind loc [] lhs' grhss--checkValDef loc lhs Nothing g-  = do  { mb_fun <- isFunLhs lhs-        ; case mb_fun of-            Just (fun, is_infix, pats, ann) ->-              checkFunBind NoSrcStrict loc ann-                           fun is_infix pats g-            Nothing -> do-              lhs' <- checkPattern lhs-              checkPatBind loc [] lhs' g }--checkFunBind :: SrcStrictness-             -> SrcSpan-             -> [AddEpAnn]-             -> LocatedN RdrName-             -> LexicalFixity-             -> [LocatedA (PatBuilder GhcPs)]-             -> Located (GRHSs GhcPs (LHsExpr GhcPs))-             -> P (HsBind GhcPs)-checkFunBind strictness locF ann fun is_infix pats (L _ grhss)-  = do  ps <- runPV_details extraDetails (mapM checkLPat pats)-        let match_span = noAnnSrcSpan $ locF-        cs <- getCommentsFor locF-        return (makeFunBind fun (L (noAnnSrcSpan $ locA match_span)-                 [L match_span (Match { m_ext = EpAnn (spanAsAnchor locF) ann cs-                                      , m_ctxt = FunRhs-                                          { mc_fun    = fun-                                          , mc_fixity = is_infix-                                          , mc_strictness = strictness }-                                      , m_pats = ps-                                      , m_grhss = grhss })]))-        -- The span of the match covers the entire equation.-        -- That isn't quite right, but it'll do for now.-  where-    extraDetails-      | Infix <- is_infix = ParseContext (Just $ unLoc fun) NoIncompleteDoBlock-      | otherwise         = noParseContext--makeFunBind :: LocatedN RdrName -> LocatedL [LMatch GhcPs (LHsExpr GhcPs)]-            -> HsBind GhcPs--- Like GHC.Hs.Utils.mkFunBind, but we need to be able to set the fixity too-makeFunBind fn ms-  = FunBind { fun_ext = noExtField,-              fun_id = fn,-              fun_matches = mkMatchGroup FromSource ms }---- See Note [FunBind vs PatBind]-checkPatBind :: SrcSpan-             -> [AddEpAnn]-             -> LPat GhcPs-             -> Located (GRHSs GhcPs (LHsExpr GhcPs))-             -> P (HsBind GhcPs)-checkPatBind loc annsIn (L _ (BangPat (EpAnn _ ans cs) (L _ (VarPat _ v))))-                        (L _match_span grhss)-      = return (makeFunBind v (L (noAnnSrcSpan loc)-                [L (noAnnSrcSpan loc) (m (EpAnn (spanAsAnchor loc) (ans++annsIn) cs) v)]))-  where-    m a v = Match { m_ext = a-                  , m_ctxt = FunRhs { mc_fun    = v-                                    , mc_fixity = Prefix-                                    , mc_strictness = SrcStrict }-                  , m_pats = []-                 , m_grhss = grhss }--checkPatBind loc annsIn lhs (L _ grhss) = do-  cs <- getCommentsFor loc-  return (PatBind (EpAnn (spanAsAnchor loc) annsIn cs) lhs grhss)--checkValSigLhs :: LHsExpr GhcPs -> P (LocatedN RdrName)-checkValSigLhs (L _ (HsVar _ lrdr@(L _ v)))-  | isUnqual v-  , not (isDataOcc (rdrNameOcc v))-  = return lrdr--checkValSigLhs lhs@(L l _)-  = addFatalError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrInvalidTypeSignature lhs--checkDoAndIfThenElse-  :: (Outputable a, Outputable b, Outputable c)-  => (a -> Bool -> b -> Bool -> c -> PsMessage)-  -> LocatedA a -> Bool -> LocatedA b -> Bool -> LocatedA c -> PV ()-checkDoAndIfThenElse err guardExpr semiThen thenExpr semiElse elseExpr- | semiThen || semiElse = do-      doAndIfThenElse <- getBit DoAndIfThenElseBit-      let e   = err (unLoc guardExpr)-                    semiThen (unLoc thenExpr)-                    semiElse (unLoc elseExpr)-          loc = combineLocs (reLoc guardExpr) (reLoc elseExpr)--      unless doAndIfThenElse $ addError (mkPlainErrorMsgEnvelope loc e)-  | otherwise = return ()--isFunLhs :: LocatedA (PatBuilder GhcPs)-      -> P (Maybe (LocatedN RdrName, LexicalFixity,-                   [LocatedA (PatBuilder GhcPs)],[AddEpAnn]))--- A variable binding is parsed as a FunBind.--- Just (fun, is_infix, arg_pats) if e is a function LHS-isFunLhs e = go e [] [] []- where-   go (L _ (PatBuilderVar (L loc f))) es ops cps-       | not (isRdrDataCon f)        = return (Just (L loc f, Prefix, es, (reverse ops) ++ cps))-   go (L _ (PatBuilderApp f e)) es       ops cps = go f (e:es) ops cps-   go (L l (PatBuilderPar _ e _)) es@(_:_) ops cps-                                      = let-                                          (o,c) = mkParensEpAnn (realSrcSpan $ locA l)-                                        in-                                          go e es (o:ops) (c:cps)-   go (L loc (PatBuilderOpApp l (L loc' op) r (EpAnn loca anns cs))) es ops cps-        | not (isRdrDataCon op)         -- We have found the function!-        = return (Just (L loc' op, Infix, (l:r:es), (anns ++ reverse ops ++ cps)))-        | otherwise                     -- Infix data con; keep going-        = do { mb_l <- go l es ops cps-             ; case mb_l of-                 Just (op', Infix, j : k : es', anns')-                   -> return (Just (op', Infix, j : op_app : es', anns'))-                   where-                     op_app = L loc (PatBuilderOpApp k-                               (L loc' op) r (EpAnn loca (reverse ops++cps) cs))-                 _ -> return Nothing }-   go _ _ _ _ = return Nothing--mkBangTy :: EpAnn [AddEpAnn] -> SrcStrictness -> LHsType GhcPs -> HsType GhcPs-mkBangTy anns strictness =-  HsBangTy anns (HsSrcBang NoSourceText NoSrcUnpack strictness)---- | Result of parsing @{-\# UNPACK \#-}@ or @{-\# NOUNPACK \#-}@.-data UnpackednessPragma =-  UnpackednessPragma [AddEpAnn] SourceText SrcUnpackedness---- | Annotate a type with either an @{-\# UNPACK \#-}@ or a @{-\# NOUNPACK \#-}@ pragma.-addUnpackednessP :: MonadP m => Located UnpackednessPragma -> LHsType GhcPs -> m (LHsType GhcPs)-addUnpackednessP (L lprag (UnpackednessPragma anns prag unpk)) ty = do-    let l' = combineSrcSpans lprag (getLocA ty)-    cs <- getCommentsFor l'-    let an = EpAnn (spanAsAnchor l') anns cs-        t' = addUnpackedness an ty-    return (L (noAnnSrcSpan l') t')-  where-    -- If we have a HsBangTy that only has a strictness annotation,-    -- such as ~T or !T, then add the pragma to the existing HsBangTy.-    ---    -- Otherwise, wrap the type in a new HsBangTy constructor.-    addUnpackedness an (L _ (HsBangTy x bang t))-      | HsSrcBang NoSourceText NoSrcUnpack strictness <- bang-      = HsBangTy (addAnns an (epAnnAnns x) (epAnnComments x)) (HsSrcBang prag unpk strictness) t-    addUnpackedness an t-      = HsBangTy an (HsSrcBang prag unpk NoSrcStrict) t-------------------------------------------------------------------------------- | Check for monad comprehensions------ If the flag MonadComprehensions is set, return a 'MonadComp' context,--- otherwise use the usual 'ListComp' context--checkMonadComp :: PV HsDoFlavour-checkMonadComp = do-    monadComprehensions <- getBit MonadComprehensionsBit-    return $ if monadComprehensions-                then MonadComp-                else ListComp---- ---------------------------------------------------------------------------- Expression/command/pattern ambiguity.--- See Note [Ambiguous syntactic categories]------- See Note [Ambiguous syntactic categories]------ This newtype is required to avoid impredicative types in monadic--- productions. That is, in a production that looks like------    | ... {% return (ECP ...) }------ we are dealing with---    P ECP--- whereas without a newtype we would be dealing with---    P (forall b. DisambECP b => PV (Located b))----newtype ECP =-  ECP { unECP :: forall b. DisambECP b => PV (LocatedA b) }--ecpFromExp :: LHsExpr GhcPs -> ECP-ecpFromExp a = ECP (ecpFromExp' a)--ecpFromCmd :: LHsCmd GhcPs -> ECP-ecpFromCmd a = ECP (ecpFromCmd' a)---- The 'fbinds' parser rule produces values of this type. See Note--- [RecordDotSyntax field updates].-type Fbind b = Either (LHsRecField GhcPs (LocatedA b)) (LHsRecProj GhcPs (LocatedA b))---- | Disambiguate infix operators.--- See Note [Ambiguous syntactic categories]-class DisambInfixOp b where-  mkHsVarOpPV :: LocatedN RdrName -> PV (LocatedN b)-  mkHsConOpPV :: LocatedN RdrName -> PV (LocatedN b)-  mkHsInfixHolePV :: SrcSpan -> (EpAnnComments -> EpAnn EpAnnUnboundVar) -> PV (Located b)--instance DisambInfixOp (HsExpr GhcPs) where-  mkHsVarOpPV v = return $ L (getLoc v) (HsVar noExtField v)-  mkHsConOpPV v = return $ L (getLoc v) (HsVar noExtField v)-  mkHsInfixHolePV l ann = do-    cs <- getCommentsFor l-    return $ L l (hsHoleExpr (ann cs))--instance DisambInfixOp RdrName where-  mkHsConOpPV (L l v) = return $ L l v-  mkHsVarOpPV (L l v) = return $ L l v-  mkHsInfixHolePV l _ = addFatalError $ mkPlainErrorMsgEnvelope l $ PsErrInvalidInfixHole--type AnnoBody b-  = ( Anno (GRHS GhcPs (LocatedA (Body b GhcPs))) ~ SrcAnn NoEpAnns-    , Anno [LocatedA (Match GhcPs (LocatedA (Body b GhcPs)))] ~ SrcSpanAnnL-    , Anno (Match GhcPs (LocatedA (Body b GhcPs))) ~ SrcSpanAnnA-    , Anno (StmtLR GhcPs GhcPs (LocatedA (Body (Body b GhcPs) GhcPs))) ~ SrcSpanAnnA-    , Anno [LocatedA (StmtLR GhcPs GhcPs-                       (LocatedA (Body (Body (Body b GhcPs) GhcPs) GhcPs)))] ~ SrcSpanAnnL-    )---- | Disambiguate constructs that may appear when we do not know ahead of time whether we are--- parsing an expression, a command, or a pattern.--- See Note [Ambiguous syntactic categories]-class (b ~ (Body b) GhcPs, AnnoBody b) => DisambECP b where-  -- | See Note [Body in DisambECP]-  type Body b :: Type -> Type-  -- | Return a command without ambiguity, or fail in a non-command context.-  ecpFromCmd' :: LHsCmd GhcPs -> PV (LocatedA b)-  -- | Return an expression without ambiguity, or fail in a non-expression context.-  ecpFromExp' :: LHsExpr GhcPs -> PV (LocatedA b)-  mkHsProjUpdatePV :: SrcSpan -> Located [LocatedAn NoEpAnns (DotFieldOcc GhcPs)]-    -> LocatedA b -> Bool -> [AddEpAnn] -> PV (LHsRecProj GhcPs (LocatedA b))-  -- | Disambiguate "\... -> ..." (lambda)-  mkHsLamPV-    :: SrcSpan -> (EpAnnComments -> MatchGroup GhcPs (LocatedA b)) -> PV (LocatedA b)-  -- | Disambiguate "let ... in ..."-  mkHsLetPV-    :: SrcSpan-    -> LHsToken "let" GhcPs-    -> HsLocalBinds GhcPs-    -> LHsToken "in" GhcPs-    -> LocatedA b-    -> PV (LocatedA b)-  -- | Infix operator representation-  type InfixOp b-  -- | Bring superclass constraints on InfixOp into scope.-  -- See Note [UndecidableSuperClasses for associated types]-  superInfixOp-    :: (DisambInfixOp (InfixOp b) => PV (LocatedA b )) -> PV (LocatedA b)-  -- | Disambiguate "f # x" (infix operator)-  mkHsOpAppPV :: SrcSpan -> LocatedA b -> LocatedN (InfixOp b) -> LocatedA b-              -> PV (LocatedA b)-  -- | Disambiguate "case ... of ..."-  mkHsCasePV :: SrcSpan -> LHsExpr GhcPs -> (LocatedL [LMatch GhcPs (LocatedA b)])-             -> EpAnnHsCase -> PV (LocatedA b)-  -- | Disambiguate "\case" and "\cases"-  mkHsLamCasePV :: SrcSpan -> LamCaseVariant-                -> (LocatedL [LMatch GhcPs (LocatedA b)]) -> [AddEpAnn]-                -> PV (LocatedA b)-  -- | Function argument representation-  type FunArg b-  -- | Bring superclass constraints on FunArg into scope.-  -- See Note [UndecidableSuperClasses for associated types]-  superFunArg :: (DisambECP (FunArg b) => PV (LocatedA b)) -> PV (LocatedA b)-  -- | Disambiguate "f x" (function application)-  mkHsAppPV :: SrcSpanAnnA -> LocatedA b -> LocatedA (FunArg b) -> PV (LocatedA b)-  -- | Disambiguate "f @t" (visible type application)-  mkHsAppTypePV :: SrcSpanAnnA -> LocatedA b -> LHsToken "@" GhcPs -> LHsType GhcPs -> PV (LocatedA b)-  -- | Disambiguate "if ... then ... else ..."-  mkHsIfPV :: SrcSpan-         -> LHsExpr GhcPs-         -> Bool  -- semicolon?-         -> LocatedA b-         -> Bool  -- semicolon?-         -> LocatedA b-         -> AnnsIf-         -> PV (LocatedA b)-  -- | Disambiguate "do { ... }" (do notation)-  mkHsDoPV ::-    SrcSpan ->-    Maybe ModuleName ->-    LocatedL [LStmt GhcPs (LocatedA b)] ->-    AnnList ->-    PV (LocatedA b)-  -- | Disambiguate "( ... )" (parentheses)-  mkHsParPV :: SrcSpan -> LHsToken "(" GhcPs -> LocatedA b -> LHsToken ")" GhcPs -> PV (LocatedA b)-  -- | Disambiguate a variable "f" or a data constructor "MkF".-  mkHsVarPV :: LocatedN RdrName -> PV (LocatedA b)-  -- | Disambiguate a monomorphic literal-  mkHsLitPV :: Located (HsLit GhcPs) -> PV (Located b)-  -- | Disambiguate an overloaded literal-  mkHsOverLitPV :: LocatedAn a (HsOverLit GhcPs) -> PV (LocatedAn a b)-  -- | Disambiguate a wildcard-  mkHsWildCardPV :: SrcSpan -> PV (Located b)-  -- | Disambiguate "a :: t" (type annotation)-  mkHsTySigPV-    :: SrcSpanAnnA -> LocatedA b -> LHsType GhcPs -> [AddEpAnn] -> PV (LocatedA b)-  -- | Disambiguate "[a,b,c]" (list syntax)-  mkHsExplicitListPV :: SrcSpan -> [LocatedA b] -> AnnList -> PV (LocatedA b)-  -- | Disambiguate "$(...)" and "[quasi|...|]" (TH splices)-  mkHsSplicePV :: Located (HsUntypedSplice GhcPs) -> PV (Located b)-  -- | Disambiguate "f { a = b, ... }" syntax (record construction and record updates)-  mkHsRecordPV ::-    Bool -> -- Is OverloadedRecordUpdate in effect?-    SrcSpan ->-    SrcSpan ->-    LocatedA b ->-    ([Fbind b], Maybe SrcSpan) ->-    [AddEpAnn] ->-    PV (LocatedA b)-  -- | Disambiguate "-a" (negation)-  mkHsNegAppPV :: SrcSpan -> LocatedA b -> [AddEpAnn] -> PV (LocatedA b)-  -- | Disambiguate "(# a)" (right operator section)-  mkHsSectionR_PV-    :: SrcSpan -> LocatedA (InfixOp b) -> LocatedA b -> PV (Located b)-  -- | Disambiguate "(a -> b)" (view pattern)-  mkHsViewPatPV-    :: SrcSpan -> LHsExpr GhcPs -> LocatedA b -> [AddEpAnn] -> PV (LocatedA b)-  -- | Disambiguate "a@b" (as-pattern)-  mkHsAsPatPV-    :: SrcSpan -> LocatedN RdrName -> LHsToken "@" GhcPs -> LocatedA b -> PV (LocatedA b)-  -- | Disambiguate "~a" (lazy pattern)-  mkHsLazyPatPV :: SrcSpan -> LocatedA b -> [AddEpAnn] -> PV (LocatedA b)-  -- | Disambiguate "!a" (bang pattern)-  mkHsBangPatPV :: SrcSpan -> LocatedA b -> [AddEpAnn] -> PV (LocatedA b)-  -- | Disambiguate tuple sections and unboxed sums-  mkSumOrTuplePV-    :: SrcSpanAnnA -> Boxity -> SumOrTuple b -> [AddEpAnn] -> PV (LocatedA b)-  -- | Validate infixexp LHS to reject unwanted {-# SCC ... #-} pragmas-  rejectPragmaPV :: LocatedA b -> PV ()--{- Note [UndecidableSuperClasses for associated types]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-(This Note is about the code in GHC, not about the user code that we are parsing)--Assume we have a class C with an associated type T:--  class C a where-    type T a-    ...--If we want to add 'C (T a)' as a superclass, we need -XUndecidableSuperClasses:--  {-# LANGUAGE UndecidableSuperClasses #-}-  class C (T a) => C a where-    type T a-    ...--Unfortunately, -XUndecidableSuperClasses don't work all that well, sometimes-making GHC loop. The workaround is to bring this constraint into scope-manually with a helper method:--  class C a where-    type T a-    superT :: (C (T a) => r) -> r--In order to avoid ambiguous types, 'r' must mention 'a'.--For consistency, we use this approach for all constraints on associated types,-even when -XUndecidableSuperClasses are not required.--}--{- Note [Body in DisambECP]-~~~~~~~~~~~~~~~~~~~~~~~~~~~-There are helper functions (mkBodyStmt, mkBindStmt, unguardedRHS, etc) that-require their argument to take a form of (body GhcPs) for some (body :: Type ->-*). To satisfy this requirement, we say that (b ~ Body b GhcPs) in the-superclass constraints of DisambECP.--The alternative is to change mkBodyStmt, mkBindStmt, unguardedRHS, etc, to drop-this requirement. It is possible and would allow removing the type index of-PatBuilder, but leads to worse type inference, breaking some code in the-typechecker.--}--instance DisambECP (HsCmd GhcPs) where-  type Body (HsCmd GhcPs) = HsCmd-  ecpFromCmd' = return-  ecpFromExp' (L l e) = cmdFail (locA l) (ppr e)-  mkHsProjUpdatePV l _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l $-                                                 PsErrOverloadedRecordDotInvalid-  mkHsLamPV l mg = do-    cs <- getCommentsFor l-    return $ L (noAnnSrcSpan l) (HsCmdLam NoExtField (mg cs))-  mkHsLetPV l tkLet bs tkIn e = do-    cs <- getCommentsFor l-    return $ L (noAnnSrcSpan l) (HsCmdLet (EpAnn (spanAsAnchor l) NoEpAnns cs) tkLet bs tkIn e)-  type InfixOp (HsCmd GhcPs) = HsExpr GhcPs-  superInfixOp m = m-  mkHsOpAppPV l c1 op c2 = do-    let cmdArg c = L (l2l $ getLoc c) $ HsCmdTop noExtField c-    cs <- getCommentsFor l-    return $ L (noAnnSrcSpan l) $ HsCmdArrForm (EpAnn (spanAsAnchor l) (AnnList Nothing Nothing Nothing [] []) cs) (reLocL op) Infix Nothing [cmdArg c1, cmdArg c2]-  mkHsCasePV l c (L lm m) anns = do-    cs <- getCommentsFor l-    let mg = mkMatchGroup FromSource (L lm m)-    return $ L (noAnnSrcSpan l) (HsCmdCase (EpAnn (spanAsAnchor l) anns cs) c mg)-  mkHsLamCasePV l lc_variant (L lm m) anns = do-    cs <- getCommentsFor l-    let mg = mkLamCaseMatchGroup FromSource lc_variant (L lm m)-    return $ L (noAnnSrcSpan l) (HsCmdLamCase (EpAnn (spanAsAnchor l) anns cs) lc_variant mg)-  type FunArg (HsCmd GhcPs) = HsExpr GhcPs-  superFunArg m = m-  mkHsAppPV l c e = do-    cs <- getCommentsFor (locA l)-    checkCmdBlockArguments c-    checkExpBlockArguments e-    return $ L l (HsCmdApp (comment (realSrcSpan $ locA l) cs) c e)-  mkHsAppTypePV l c _ t = cmdFail (locA l) (ppr c <+> text "@" <> ppr t)-  mkHsIfPV l c semi1 a semi2 b anns = do-    checkDoAndIfThenElse PsErrSemiColonsInCondCmd c semi1 a semi2 b-    cs <- getCommentsFor l-    return $ L (noAnnSrcSpan l) (mkHsCmdIf c a b (EpAnn (spanAsAnchor l) anns cs))-  mkHsDoPV l Nothing stmts anns = do-    cs <- getCommentsFor l-    return $ L (noAnnSrcSpan l) (HsCmdDo (EpAnn (spanAsAnchor l) anns cs) stmts)-  mkHsDoPV l (Just m)    _ _ = addFatalError $ mkPlainErrorMsgEnvelope l $ PsErrQualifiedDoInCmd m-  mkHsParPV l lpar c rpar = do-    cs <- getCommentsFor l-    return $ L (noAnnSrcSpan l) (HsCmdPar (EpAnn (spanAsAnchor l) NoEpAnns cs) lpar c rpar)-  mkHsVarPV (L l v) = cmdFail (locA l) (ppr v)-  mkHsLitPV (L l a) = cmdFail l (ppr a)-  mkHsOverLitPV (L l a) = cmdFail (locA l) (ppr a)-  mkHsWildCardPV l = cmdFail l (text "_")-  mkHsTySigPV l a sig _ = cmdFail (locA l) (ppr a <+> text "::" <+> ppr sig)-  mkHsExplicitListPV l xs _ = cmdFail l $-    brackets (pprWithCommas ppr xs)-  mkHsSplicePV (L l sp) = cmdFail l (pprUntypedSplice True Nothing sp)-  mkHsRecordPV _ l _ a (fbinds, ddLoc) _ = do-    let (fs, ps) = partitionEithers fbinds-    if not (null ps)-      then addFatalError $ mkPlainErrorMsgEnvelope l $ PsErrOverloadedRecordDotInvalid-      else cmdFail l $ ppr a <+> ppr (mk_rec_fields fs ddLoc)-  mkHsNegAppPV l a _ = cmdFail l (text "-" <> ppr a)-  mkHsSectionR_PV l op c = cmdFail l $-    let pp_op = fromMaybe (panic "cannot print infix operator")-                          (ppr_infix_expr (unLoc op))-    in pp_op <> ppr c-  mkHsViewPatPV l a b _ = cmdFail l $-    ppr a <+> text "->" <+> ppr b-  mkHsAsPatPV l v _ c = cmdFail l $-    pprPrefixOcc (unLoc v) <> text "@" <> ppr c-  mkHsLazyPatPV l c _ = cmdFail l $-    text "~" <> ppr c-  mkHsBangPatPV l c _ = cmdFail l $-    text "!" <> ppr c-  mkSumOrTuplePV l boxity a _ = cmdFail (locA l) (pprSumOrTuple boxity a)-  rejectPragmaPV _ = return ()--cmdFail :: SrcSpan -> SDoc -> PV a-cmdFail loc e = addFatalError $ mkPlainErrorMsgEnvelope loc $ PsErrParseErrorInCmd e--checkLamMatchGroup :: SrcSpan -> MatchGroup GhcPs (LHsExpr GhcPs) -> PV ()-checkLamMatchGroup l (MG { mg_alts = (L _ (matches:_))}) = do-  when (null (hsLMatchPats matches)) $ addError $ mkPlainErrorMsgEnvelope l PsErrEmptyLambda-checkLamMatchGroup _ _ = return ()--instance DisambECP (HsExpr GhcPs) where-  type Body (HsExpr GhcPs) = HsExpr-  ecpFromCmd' (L l c) = do-    addError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrArrowCmdInExpr c-    return (L l (hsHoleExpr noAnn))-  ecpFromExp' = return-  mkHsProjUpdatePV l fields arg isPun anns = do-    cs <- getCommentsFor l-    return $ mkRdrProjUpdate (noAnnSrcSpan l) fields arg isPun (EpAnn (spanAsAnchor l) anns cs)-  mkHsLamPV l mg = do-    cs <- getCommentsFor l-    let mg' = mg cs-    checkLamMatchGroup l mg'-    return $ L (noAnnSrcSpan l) (HsLam NoExtField mg')-  mkHsLetPV l tkLet bs tkIn c = do-    cs <- getCommentsFor l-    return $ L (noAnnSrcSpan l) (HsLet (EpAnn (spanAsAnchor l) NoEpAnns cs) tkLet bs tkIn c)-  type InfixOp (HsExpr GhcPs) = HsExpr GhcPs-  superInfixOp m = m-  mkHsOpAppPV l e1 op e2 = do-    cs <- getCommentsFor l-    return $ L (noAnnSrcSpan l) $ OpApp (EpAnn (spanAsAnchor l) [] cs) e1 (reLocL op) e2-  mkHsCasePV l e (L lm m) anns = do-    cs <- getCommentsFor l-    let mg = mkMatchGroup FromSource (L lm m)-    return $ L (noAnnSrcSpan l) (HsCase (EpAnn (spanAsAnchor l) anns cs) e mg)-  mkHsLamCasePV l lc_variant (L lm m) anns = do-    cs <- getCommentsFor l-    let mg = mkLamCaseMatchGroup FromSource lc_variant (L lm m)-    return $ L (noAnnSrcSpan l) (HsLamCase (EpAnn (spanAsAnchor l) anns cs) lc_variant mg)-  type FunArg (HsExpr GhcPs) = HsExpr GhcPs-  superFunArg m = m-  mkHsAppPV l e1 e2 = do-    cs <- getCommentsFor (locA l)-    checkExpBlockArguments e1-    checkExpBlockArguments e2-    return $ L l (HsApp (comment (realSrcSpan $ locA l) cs) e1 e2)-  mkHsAppTypePV l e at t = do-    checkExpBlockArguments e-    return $ L l (HsAppType noExtField e at (mkHsWildCardBndrs t))-  mkHsIfPV l c semi1 a semi2 b anns = do-    checkDoAndIfThenElse PsErrSemiColonsInCondExpr c semi1 a semi2 b-    cs <- getCommentsFor l-    return $ L (noAnnSrcSpan l) (mkHsIf c a b (EpAnn (spanAsAnchor l) anns cs))-  mkHsDoPV l mod stmts anns = do-    cs <- getCommentsFor l-    return $ L (noAnnSrcSpan l) (HsDo (EpAnn (spanAsAnchor l) anns cs) (DoExpr mod) stmts)-  mkHsParPV l lpar e rpar = do-    cs <- getCommentsFor l-    return $ L (noAnnSrcSpan l) (HsPar (EpAnn (spanAsAnchor l) NoEpAnns cs) lpar e rpar)-  mkHsVarPV v@(L l _) = return $ L (na2la l) (HsVar noExtField v)-  mkHsLitPV (L l a) = do-    cs <- getCommentsFor l-    return $ L l (HsLit (comment (realSrcSpan l) cs) a)-  mkHsOverLitPV (L l a) = do-    cs <- getCommentsFor (locA l)-    return $ L l (HsOverLit (comment (realSrcSpan (locA l)) cs) a)-  mkHsWildCardPV l = return $ L l (hsHoleExpr noAnn)-  mkHsTySigPV l a sig anns = do-    cs <- getCommentsFor (locA l)-    return $ L l (ExprWithTySig (EpAnn (spanAsAnchor $ locA l) anns cs) a (hsTypeToHsSigWcType sig))-  mkHsExplicitListPV l xs anns = do-    cs <- getCommentsFor l-    return $ L (noAnnSrcSpan l) (ExplicitList (EpAnn (spanAsAnchor l) anns cs) xs)-  mkHsSplicePV sp@(L l _) = do-    cs <- getCommentsFor l-    return $ fmap (HsUntypedSplice (EpAnn (spanAsAnchor l) NoEpAnns cs)) sp-  mkHsRecordPV opts l lrec a (fbinds, ddLoc) anns = do-    cs <- getCommentsFor l-    r <- mkRecConstrOrUpdate opts a lrec (fbinds, ddLoc) (EpAnn (spanAsAnchor l) anns cs)-    checkRecordSyntax (L (noAnnSrcSpan l) r)-  mkHsNegAppPV l a anns = do-    cs <- getCommentsFor l-    return $ L (noAnnSrcSpan l) (NegApp (EpAnn (spanAsAnchor l) anns cs) a noSyntaxExpr)-  mkHsSectionR_PV l op e = do-    cs <- getCommentsFor l-    return $ L l (SectionR (comment (realSrcSpan l) cs) op e)-  mkHsViewPatPV l a b _ = addError (mkPlainErrorMsgEnvelope l $ PsErrViewPatInExpr a b)-                          >> return (L (noAnnSrcSpan l) (hsHoleExpr noAnn))-  mkHsAsPatPV l v _ e   = addError (mkPlainErrorMsgEnvelope l $ PsErrTypeAppWithoutSpace (unLoc v) e)-                          >> return (L (noAnnSrcSpan l) (hsHoleExpr noAnn))-  mkHsLazyPatPV l e   _ = addError (mkPlainErrorMsgEnvelope l $ PsErrLazyPatWithoutSpace e)-                          >> return (L (noAnnSrcSpan l) (hsHoleExpr noAnn))-  mkHsBangPatPV l e   _ = addError (mkPlainErrorMsgEnvelope l $ PsErrBangPatWithoutSpace e)-                          >> return (L (noAnnSrcSpan l) (hsHoleExpr noAnn))-  mkSumOrTuplePV = mkSumOrTupleExpr-  rejectPragmaPV (L _ (OpApp _ _ _ e)) =-    -- assuming left-associative parsing of operators-    rejectPragmaPV e-  rejectPragmaPV (L l (HsPragE _ prag _)) = addError $ mkPlainErrorMsgEnvelope (locA l) $-                                                         (PsErrUnallowedPragma prag)-  rejectPragmaPV _                        = return ()--hsHoleExpr :: EpAnn EpAnnUnboundVar -> HsExpr GhcPs-hsHoleExpr anns = HsUnboundVar anns (mkRdrUnqual (mkVarOccFS (fsLit "_")))--instance DisambECP (PatBuilder GhcPs) where-  type Body (PatBuilder GhcPs) = PatBuilder-  ecpFromCmd' (L l c)    = addFatalError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrArrowCmdInPat c-  ecpFromExp' (L l e)    = addFatalError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrArrowExprInPat e-  mkHsLamPV l _          = addFatalError $ mkPlainErrorMsgEnvelope l PsErrLambdaInPat-  mkHsLetPV l _ _ _ _    = addFatalError $ mkPlainErrorMsgEnvelope l PsErrLetInPat-  mkHsProjUpdatePV l _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrOverloadedRecordDotInvalid-  type InfixOp (PatBuilder GhcPs) = RdrName-  superInfixOp m = m-  mkHsOpAppPV l p1 op p2 = do-    cs <- getCommentsFor l-    let anns = EpAnn (spanAsAnchor l) [] cs-    return $ L (noAnnSrcSpan l) $ PatBuilderOpApp p1 op p2 anns-  mkHsCasePV l _ _ _          = addFatalError $ mkPlainErrorMsgEnvelope l PsErrCaseInPat-  mkHsLamCasePV l lc_variant _ _ = addFatalError $ mkPlainErrorMsgEnvelope l (PsErrLambdaCaseInPat lc_variant)-  type FunArg (PatBuilder GhcPs) = PatBuilder GhcPs-  superFunArg m = m-  mkHsAppPV l p1 p2      = return $ L l (PatBuilderApp p1 p2)-  mkHsAppTypePV l p at t = do-    cs <- getCommentsFor (locA l)-    let anns = EpAnn (spanAsAnchor (getLocA t)) NoEpAnns cs-    return $ L l (PatBuilderAppType p at (mkHsPatSigType anns t))-  mkHsIfPV l _ _ _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrIfThenElseInPat-  mkHsDoPV l _ _ _       = addFatalError $ mkPlainErrorMsgEnvelope l PsErrDoNotationInPat-  mkHsParPV l lpar p rpar   = return $ L (noAnnSrcSpan l) (PatBuilderPar lpar p rpar)-  mkHsVarPV v@(getLoc -> l) = return $ L (na2la l) (PatBuilderVar v)-  mkHsLitPV lit@(L l a) = do-    checkUnboxedLitPat lit-    return $ L l (PatBuilderPat (LitPat noExtField a))-  mkHsOverLitPV (L l a) = return $ L l (PatBuilderOverLit a)-  mkHsWildCardPV l = return $ L l (PatBuilderPat (WildPat noExtField))-  mkHsTySigPV l b sig anns = do-    p <- checkLPat b-    cs <- getCommentsFor (locA l)-    return $ L l (PatBuilderPat (SigPat (EpAnn (spanAsAnchor $ locA l) anns cs) p (mkHsPatSigType noAnn sig)))-  mkHsExplicitListPV l xs anns = do-    ps <- traverse checkLPat xs-    cs <- getCommentsFor l-    return (L (noAnnSrcSpan l) (PatBuilderPat (ListPat (EpAnn (spanAsAnchor l) anns cs) ps)))-  mkHsSplicePV (L l sp) = return $ L l (PatBuilderPat (SplicePat noExtField sp))-  mkHsRecordPV _ l _ a (fbinds, ddLoc) anns = do-    let (fs, ps) = partitionEithers fbinds-    if not (null ps)-     then addFatalError $ mkPlainErrorMsgEnvelope l PsErrOverloadedRecordDotInvalid-     else do-       cs <- getCommentsFor l-       r <- mkPatRec a (mk_rec_fields fs ddLoc) (EpAnn (spanAsAnchor l) anns cs)-       checkRecordSyntax (L (noAnnSrcSpan l) r)-  mkHsNegAppPV l (L lp p) anns = do-    lit <- case p of-      PatBuilderOverLit pos_lit -> return (L (l2l lp) pos_lit)-      _ -> patFail l $ PsErrInPat p PEIP_NegApp-    cs <- getCommentsFor l-    let an = EpAnn (spanAsAnchor l) anns cs-    return $ L (noAnnSrcSpan l) (PatBuilderPat (mkNPat lit (Just noSyntaxExpr) an))-  mkHsSectionR_PV l op p = patFail l (PsErrParseRightOpSectionInPat (unLoc op) (unLoc p))-  mkHsViewPatPV l a b anns = do-    p <- checkLPat b-    cs <- getCommentsFor l-    return $ L (noAnnSrcSpan l) (PatBuilderPat (ViewPat (EpAnn (spanAsAnchor l) anns cs) a p))-  mkHsAsPatPV l v at e = do-    p <- checkLPat e-    cs <- getCommentsFor l-    return $ L (noAnnSrcSpan l) (PatBuilderPat (AsPat (EpAnn (spanAsAnchor l) NoEpAnns cs) v at p))-  mkHsLazyPatPV l e a = do-    p <- checkLPat e-    cs <- getCommentsFor l-    return $ L (noAnnSrcSpan l) (PatBuilderPat (LazyPat (EpAnn (spanAsAnchor l) a cs) p))-  mkHsBangPatPV l e an = do-    p <- checkLPat e-    cs <- getCommentsFor l-    let pb = BangPat (EpAnn (spanAsAnchor l) an cs) p-    hintBangPat l pb-    return $ L (noAnnSrcSpan l) (PatBuilderPat pb)-  mkSumOrTuplePV = mkSumOrTuplePat-  rejectPragmaPV _ = return ()---- | Ensure that a literal pattern isn't of type Addr#, Float#, Double#.-checkUnboxedLitPat :: Located (HsLit GhcPs) -> PV ()-checkUnboxedLitPat (L loc lit) =-  case lit of-    -- Don't allow primitive string literal patterns.-    -- See #13260.-    HsStringPrim {}-      -> addError $ mkPlainErrorMsgEnvelope loc $-                           (PsErrIllegalUnboxedStringInPat lit)--   -- Don't allow Float#/Double# literal patterns.-   -- See #9238 and Note [Rules for floating-point comparisons]-   -- in GHC.Core.Opt.ConstantFold.-    _ | is_floating_lit lit-      -> addError $ mkPlainErrorMsgEnvelope loc $-                           (PsErrIllegalUnboxedFloatingLitInPat lit)--      | otherwise-      -> return ()--  where-    is_floating_lit :: HsLit GhcPs -> Bool-    is_floating_lit (HsFloatPrim  {}) = True-    is_floating_lit (HsDoublePrim {}) = True-    is_floating_lit _                 = False--mkPatRec ::-  LocatedA (PatBuilder GhcPs) ->-  HsRecFields GhcPs (LocatedA (PatBuilder GhcPs)) ->-  EpAnn [AddEpAnn] ->-  PV (PatBuilder GhcPs)-mkPatRec (unLoc -> PatBuilderVar c) (HsRecFields fs dd) anns-  | isRdrDataCon (unLoc c)-  = do fs <- mapM checkPatField fs-       return $ PatBuilderPat $ ConPat-         { pat_con_ext = anns-         , pat_con = c-         , pat_args = RecCon (HsRecFields fs dd)-         }-mkPatRec p _ _ =-  addFatalError $ mkPlainErrorMsgEnvelope (getLocA p) $-                    (PsErrInvalidRecordCon (unLoc p))---- | Disambiguate constructs that may appear when we do not know--- ahead of time whether we are parsing a type or a newtype/data constructor.------ See Note [Ambiguous syntactic categories] for the general idea.------ See Note [Parsing data constructors is hard] for the specific issue this--- particular class is solving.----class DisambTD b where-  -- | Process the head of a type-level function/constructor application,-  -- i.e. the @H@ in @H a b c@.-  mkHsAppTyHeadPV :: LHsType GhcPs -> PV (LocatedA b)-  -- | Disambiguate @f x@ (function application or prefix data constructor).-  mkHsAppTyPV :: LocatedA b -> LHsType GhcPs -> PV (LocatedA b)-  -- | Disambiguate @f \@t@ (visible kind application)-  mkHsAppKindTyPV :: LocatedA b -> LHsToken "@" GhcPs -> LHsType GhcPs -> PV (LocatedA b)-  -- | Disambiguate @f \# x@ (infix operator)-  mkHsOpTyPV :: PromotionFlag -> LHsType GhcPs -> LocatedN RdrName -> LHsType GhcPs -> PV (LocatedA b)-  -- | Disambiguate @{-\# UNPACK \#-} t@ (unpack/nounpack pragma)-  mkUnpackednessPV :: Located UnpackednessPragma -> LocatedA b -> PV (LocatedA b)--instance DisambTD (HsType GhcPs) where-  mkHsAppTyHeadPV = return-  mkHsAppTyPV t1 t2 = return (mkHsAppTy t1 t2)-  mkHsAppKindTyPV t at ki = return (mkHsAppKindTy t at ki)-  mkHsOpTyPV prom t1 op t2 = return (mkLHsOpTy prom t1 op t2)-  mkUnpackednessPV = addUnpackednessP--dataConBuilderCon :: DataConBuilder -> LocatedN RdrName-dataConBuilderCon (PrefixDataConBuilder _ dc) = dc-dataConBuilderCon (InfixDataConBuilder _ dc _) = dc--dataConBuilderDetails :: DataConBuilder -> HsConDeclH98Details GhcPs---- Detect when the record syntax is used:---   data T = MkT { ... }-dataConBuilderDetails (PrefixDataConBuilder flds _)-  | [L l_t (HsRecTy an fields)] <- toList flds-  = RecCon (L (SrcSpanAnn an (locA l_t)) fields)---- Normal prefix constructor, e.g.  data T = MkT A B C-dataConBuilderDetails (PrefixDataConBuilder flds _)-  = PrefixCon noTypeArgs (map hsLinear (toList flds))---- Infix constructor, e.g. data T = Int :! Bool-dataConBuilderDetails (InfixDataConBuilder lhs _ rhs)-  = InfixCon (hsLinear lhs) (hsLinear rhs)--instance DisambTD DataConBuilder where-  mkHsAppTyHeadPV = tyToDataConBuilder--  mkHsAppTyPV (L l (PrefixDataConBuilder flds fn)) t =-    return $-      L (noAnnSrcSpan $ combineSrcSpans (locA l) (getLocA t))-        (PrefixDataConBuilder (flds `snocOL` t) fn)-  mkHsAppTyPV (L _ InfixDataConBuilder{}) _ =-    -- This case is impossible because of the way-    -- the grammar in Parser.y is written (see infixtype/ftype).-    panic "mkHsAppTyPV: InfixDataConBuilder"--  mkHsAppKindTyPV lhs at ki =-    addFatalError $ mkPlainErrorMsgEnvelope (getTokenSrcSpan (getLoc at)) $-                      (PsErrUnexpectedKindAppInDataCon (unLoc lhs) (unLoc ki))--  mkHsOpTyPV prom lhs tc rhs = do-      check_no_ops (unLoc rhs)  -- check the RHS because parsing type operators is right-associative-      data_con <- eitherToP $ tyConToDataCon tc-      checkNotPromotedDataCon prom data_con-      return $ L l (InfixDataConBuilder lhs data_con rhs)-    where-      l = combineLocsA lhs rhs-      check_no_ops (HsBangTy _ _ t) = check_no_ops (unLoc t)-      check_no_ops (HsOpTy{}) =-        addError $ mkPlainErrorMsgEnvelope (locA l) $-                     (PsErrInvalidInfixDataCon (unLoc lhs) (unLoc tc) (unLoc rhs))-      check_no_ops _ = return ()--  mkUnpackednessPV unpk constr_stuff-    | L _ (InfixDataConBuilder lhs data_con rhs) <- constr_stuff-    = -- When the user writes  data T = {-# UNPACK #-} Int :+ Bool-      --   we apply {-# UNPACK #-} to the LHS-      do lhs' <- addUnpackednessP unpk lhs-         let l = combineLocsA (reLocA unpk) constr_stuff-         return $ L l (InfixDataConBuilder lhs' data_con rhs)-    | otherwise =-      do addError $ mkPlainErrorMsgEnvelope (getLoc unpk) PsErrUnpackDataCon-         return constr_stuff--tyToDataConBuilder :: LHsType GhcPs -> PV (LocatedA DataConBuilder)-tyToDataConBuilder (L l (HsTyVar _ prom v)) = do-  data_con <- eitherToP $ tyConToDataCon v-  checkNotPromotedDataCon prom data_con-  return $ L l (PrefixDataConBuilder nilOL data_con)-tyToDataConBuilder (L l (HsTupleTy _ HsBoxedOrConstraintTuple ts)) = do-  let data_con = L (l2l l) (getRdrName (tupleDataCon Boxed (length ts)))-  return $ L l (PrefixDataConBuilder (toOL ts) data_con)-tyToDataConBuilder t =-  addFatalError $ mkPlainErrorMsgEnvelope (getLocA t) $-                    (PsErrInvalidDataCon (unLoc t))---- | Rejects declarations such as @data T = 'MkT@ (note the leading tick).-checkNotPromotedDataCon :: PromotionFlag -> LocatedN RdrName -> PV ()-checkNotPromotedDataCon NotPromoted _ = return ()-checkNotPromotedDataCon IsPromoted (L l name) =-  addError $ mkPlainErrorMsgEnvelope (locA l) $-    PsErrIllegalPromotionQuoteDataCon name--{- Note [Ambiguous syntactic categories]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-There are places in the grammar where we do not know whether we are parsing an-expression or a pattern without unlimited lookahead (which we do not have in-'happy'):--View patterns:--    f (Con a b     ) = ...  -- 'Con a b' is a pattern-    f (Con a b -> x) = ...  -- 'Con a b' is an expression--do-notation:--    do { Con a b <- x } -- 'Con a b' is a pattern-    do { Con a b }      -- 'Con a b' is an expression--Guards:--    x | True <- p && q = ...  -- 'True' is a pattern-    x | True           = ...  -- 'True' is an expression--Top-level value/function declarations (FunBind/PatBind):--    f ! a         -- TH splice-    f ! a = ...   -- function declaration--    Until we encounter the = sign, we don't know if it's a top-level-    TemplateHaskell splice where ! is used, or if it's a function declaration-    where ! is bound.--There are also places in the grammar where we do not know whether we are-parsing an expression or a command:--    proc x -> do { (stuff) -< x }   -- 'stuff' is an expression-    proc x -> do { (stuff) }        -- 'stuff' is a command--    Until we encounter arrow syntax (-<) we don't know whether to parse 'stuff'-    as an expression or a command.--In fact, do-notation is subject to both ambiguities:--    proc x -> do { (stuff) -< x }        -- 'stuff' is an expression-    proc x -> do { (stuff) <- f -< x }   -- 'stuff' is a pattern-    proc x -> do { (stuff) }             -- 'stuff' is a command--There are many possible solutions to this problem. For an overview of the ones-we decided against, see Note [Resolving parsing ambiguities: non-taken alternatives]--The solution that keeps basic definitions (such as HsExpr) clean, keeps the-concerns local to the parser, and does not require duplication of hsSyn types,-or an extra pass over the entire AST, is to parse into an overloaded-parser-validator (a so-called tagless final encoding):--    class DisambECP b where ...-    instance DisambECP (HsCmd GhcPs) where ...-    instance DisambECP (HsExp GhcPs) where ...-    instance DisambECP (PatBuilder GhcPs) where ...--The 'DisambECP' class contains functions to build and validate 'b'. For example,-to add parentheses we have:--  mkHsParPV :: DisambECP b => SrcSpan -> Located b -> PV (Located b)--'mkHsParPV' will wrap the inner value in HsCmdPar for commands, HsPar for-expressions, and 'PatBuilderPar' for patterns (later transformed into ParPat,-see Note [PatBuilder]).--Consider the 'alts' production used to parse case-of alternatives:--  alts :: { Located ([AddEpAnn],[LMatch GhcPs (LHsExpr GhcPs)]) }-    : alts1     { sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }-    | ';' alts  { sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) }--We abstract over LHsExpr GhcPs, and it becomes:--  alts :: { forall b. DisambECP b => PV (Located ([AddEpAnn],[LMatch GhcPs (Located b)])) }-    : alts1     { $1 >>= \ $1 ->-                  return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }-    | ';' alts  { $2 >>= \ $2 ->-                  return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) }--Compared to the initial definition, the added bits are:--    forall b. DisambECP b => PV ( ... ) -- in the type signature-    $1 >>= \ $1 -> return $             -- in one reduction rule-    $2 >>= \ $2 -> return $             -- in another reduction rule--The overhead is constant relative to the size of the rest of the reduction-rule, so this approach scales well to large parser productions.--Note that we write ($1 >>= \ $1 -> ...), so the second $1 is in a binding-position and shadows the previous $1. We can do this because internally-'happy' desugars $n to happy_var_n, and the rationale behind this idiom-is to be able to write (sLL $1 $>) later on. The alternative would be to-write this as ($1 >>= \ fresh_name -> ...), but then we couldn't refer-to the last fresh name as $>.--Finally, we instantiate the polymorphic type to a concrete one, and run the-parser-validator, for example:--    stmt   :: { forall b. DisambECP b => PV (LStmt GhcPs (Located b)) }-    e_stmt :: { LStmt GhcPs (LHsExpr GhcPs) }-            : stmt {% runPV $1 }--In e_stmt, three things happen:--  1. we instantiate: b ~ HsExpr GhcPs-  2. we embed the PV computation into P by using runPV-  3. we run validation by using a monadic production, {% ... }--At this point the ambiguity is resolved.--}---{- Note [Resolving parsing ambiguities: non-taken alternatives]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--Alternative I, extra constructors in GHC.Hs.Expr--------------------------------------------------We could add extra constructors to HsExpr to represent command-specific and-pattern-specific syntactic constructs. Under this scheme, we parse patterns-and commands as expressions and rejig later.  This is what GHC used to do, and-it polluted 'HsExpr' with irrelevant constructors:--  * for commands: 'HsArrForm', 'HsArrApp'-  * for patterns: 'EWildPat', 'EAsPat', 'EViewPat', 'ELazyPat'--(As of now, we still do that for patterns, but we plan to fix it).--There are several issues with this:--  * The implementation details of parsing are leaking into hsSyn definitions.--  * Code that uses HsExpr has to panic on these impossible-after-parsing cases.--  * HsExpr is arbitrarily selected as the extension basis. Why not extend-    HsCmd or HsPat with extra constructors instead?--Alternative II, extra constructors in GHC.Hs.Expr for GhcPs-------------------------------------------------------------We could address some of the problems with Alternative I by using Trees That-Grow and extending HsExpr only in the GhcPs pass. However, GhcPs corresponds to-the output of parsing, not to its intermediate results, so we wouldn't want-them there either.--Alternative III, extra constructors in GHC.Hs.Expr for GhcPrePs-----------------------------------------------------------------We could introduce a new pass, GhcPrePs, to keep GhcPs pristine.-Unfortunately, creating a new pass would significantly bloat conversion code-and slow down the compiler by adding another linear-time pass over the entire-AST. For example, in order to build HsExpr GhcPrePs, we would need to build-HsLocalBinds GhcPrePs (as part of HsLet), and we never want HsLocalBinds-GhcPrePs.---Alternative IV, sum type and bottom-up data flow--------------------------------------------------Expressions and commands are disjoint. There are no user inputs that could be-interpreted as either an expression or a command depending on outer context:--  5        -- definitely an expression-  x -< y   -- definitely a command--Even though we have both 'HsLam' and 'HsCmdLam', we can look at-the body to disambiguate:--  \p -> 5        -- definitely an expression-  \p -> x -< y   -- definitely a command--This means we could use a bottom-up flow of information to determine-whether we are parsing an expression or a command, using a sum type-for intermediate results:--  Either (LHsExpr GhcPs) (LHsCmd GhcPs)--There are two problems with this:--  * We cannot handle the ambiguity between expressions and-    patterns, which are not disjoint.--  * Bottom-up flow of information leads to poor error messages. Consider--        if ... then 5 else (x -< y)--    Do we report that '5' is not a valid command or that (x -< y) is not a-    valid expression?  It depends on whether we want the entire node to be-    'HsIf' or 'HsCmdIf', and this information flows top-down, from the-    surrounding parsing context (are we in 'proc'?)--Alternative V, backtracking with parser combinators-----------------------------------------------------One might think we could sidestep the issue entirely by using a backtracking-parser and doing something along the lines of (try pExpr <|> pPat).--Turns out, this wouldn't work very well, as there can be patterns inside-expressions (e.g. via 'case', 'let', 'do') and expressions inside patterns-(e.g. view patterns). To handle this, we would need to backtrack while-backtracking, and unbound levels of backtracking lead to very fragile-performance.--Alternative VI, an intermediate data type-------------------------------------------There are common syntactic elements of expressions, commands, and patterns-(e.g. all of them must have balanced parentheses), and we can capture this-common structure in an intermediate data type, Frame:--data Frame-  = FrameVar RdrName-    -- ^ Identifier: Just, map, BS.length-  | FrameTuple [LTupArgFrame] Boxity-    -- ^ Tuple (section): (a,b) (a,b,c) (a,,) (,a,)-  | FrameTySig LFrame (LHsSigWcType GhcPs)-    -- ^ Type signature: x :: ty-  | FramePar (SrcSpan, SrcSpan) LFrame-    -- ^ Parentheses-  | FrameIf LFrame LFrame LFrame-    -- ^ If-expression: if p then x else y-  | FrameCase LFrame [LFrameMatch]-    -- ^ Case-expression: case x of { p1 -> e1; p2 -> e2 }-  | FrameDo (HsStmtContext GhcRn) [LFrameStmt]-    -- ^ Do-expression: do { s1; a <- s2; s3 }-  ...-  | FrameExpr (HsExpr GhcPs)   -- unambiguously an expression-  | FramePat (HsPat GhcPs)     -- unambiguously a pattern-  | FrameCommand (HsCmd GhcPs) -- unambiguously a command--To determine which constructors 'Frame' needs to have, we take the union of-intersections between HsExpr, HsCmd, and HsPat.--The intersection between HsPat and HsExpr:--  HsPat  =  VarPat   | TuplePat      | SigPat        | ParPat   | ...-  HsExpr =  HsVar    | ExplicitTuple | ExprWithTySig | HsPar    | ...-  --------------------------------------------------------------------  Frame  =  FrameVar | FrameTuple    | FrameTySig    | FramePar | ...--The intersection between HsCmd and HsExpr:--  HsCmd  = HsCmdIf | HsCmdCase | HsCmdDo | HsCmdPar-  HsExpr = HsIf    | HsCase    | HsDo    | HsPar-  -------------------------------------------------  Frame = FrameIf  | FrameCase | FrameDo | FramePar--The intersection between HsCmd and HsPat:--  HsPat  = ParPat   | ...-  HsCmd  = HsCmdPar | ...-  ------------------------  Frame  = FramePar | ...--Take the union of each intersection and this yields the final 'Frame' data-type. The problem with this approach is that we end up duplicating a good-portion of hsSyn:--    Frame         for  HsExpr, HsPat, HsCmd-    TupArgFrame   for  HsTupArg-    FrameMatch    for  Match-    FrameStmt     for  StmtLR-    FrameGRHS     for  GRHS-    FrameGRHSs    for  GRHSs-    ...--Alternative VII, a product type---------------------------------We could avoid the intermediate representation of Alternative VI by parsing-into a product of interpretations directly:--    type ExpCmdPat = ( PV (LHsExpr GhcPs)-                     , PV (LHsCmd GhcPs)-                     , PV (LHsPat GhcPs) )--This means that in positions where we do not know whether to produce-expression, a pattern, or a command, we instead produce a parser-validator for-each possible option.--Then, as soon as we have parsed far enough to resolve the ambiguity, we pick-the appropriate component of the product, discarding the rest:--    checkExpOf3 (e, _, _) = e  -- interpret as an expression-    checkCmdOf3 (_, c, _) = c  -- interpret as a command-    checkPatOf3 (_, _, p) = p  -- interpret as a pattern--We can easily define ambiguities between arbitrary subsets of interpretations.-For example, when we know ahead of type that only an expression or a command is-possible, but not a pattern, we can use a smaller type:--    type ExpCmd = (PV (LHsExpr GhcPs), PV (LHsCmd GhcPs))--    checkExpOf2 (e, _) = e  -- interpret as an expression-    checkCmdOf2 (_, c) = c  -- interpret as a command--However, there is a slight problem with this approach, namely code duplication-in parser productions. Consider the 'alts' production used to parse case-of-alternatives:--  alts :: { Located ([AddEpAnn],[LMatch GhcPs (LHsExpr GhcPs)]) }-    : alts1     { sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }-    | ';' alts  { sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) }--Under the new scheme, we have to completely duplicate its type signature and-each reduction rule:--  alts :: { ( PV (Located ([AddEpAnn],[LMatch GhcPs (LHsExpr GhcPs)])) -- as an expression-            , PV (Located ([AddEpAnn],[LMatch GhcPs (LHsCmd GhcPs)]))  -- as a command-            ) }-    : alts1-        { ( checkExpOf2 $1 >>= \ $1 ->-            return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1)-          , checkCmdOf2 $1 >>= \ $1 ->-            return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1)-          ) }-    | ';' alts-        { ( checkExpOf2 $2 >>= \ $2 ->-            return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2)-          , checkCmdOf2 $2 >>= \ $2 ->-            return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2)-          ) }--And the same goes for other productions: 'altslist', 'alts1', 'alt', 'alt_rhs',-'ralt', 'gdpats', 'gdpat', 'exp', ... and so on. That is a lot of code!--Alternative VIII, a function from a GADT------------------------------------------We could avoid code duplication of the Alternative VII by representing the product-as a function from a GADT:--    data ExpCmdG b where-      ExpG :: ExpCmdG HsExpr-      CmdG :: ExpCmdG HsCmd--    type ExpCmd = forall b. ExpCmdG b -> PV (Located (b GhcPs))--    checkExp :: ExpCmd -> PV (LHsExpr GhcPs)-    checkCmd :: ExpCmd -> PV (LHsCmd GhcPs)-    checkExp f = f ExpG  -- interpret as an expression-    checkCmd f = f CmdG  -- interpret as a command--Consider the 'alts' production used to parse case-of alternatives:--  alts :: { Located ([AddEpAnn],[LMatch GhcPs (LHsExpr GhcPs)]) }-    : alts1     { sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }-    | ';' alts  { sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) }--We abstract over LHsExpr, and it becomes:--  alts :: { forall b. ExpCmdG b -> PV (Located ([AddEpAnn],[LMatch GhcPs (Located (b GhcPs))])) }-    : alts1-        { \tag -> $1 tag >>= \ $1 ->-                  return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }-    | ';' alts-        { \tag -> $2 tag >>= \ $2 ->-                  return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) }--Note that 'ExpCmdG' is a singleton type, the value is completely-determined by the type:--  when (b~HsExpr),  tag = ExpG-  when (b~HsCmd),   tag = CmdG--This is a clear indication that we can use a class to pass this value behind-the scenes:--  class    ExpCmdI b      where expCmdG :: ExpCmdG b-  instance ExpCmdI HsExpr where expCmdG = ExpG-  instance ExpCmdI HsCmd  where expCmdG = CmdG--And now the 'alts' production is simplified, as we no longer need to-thread 'tag' explicitly:--  alts :: { forall b. ExpCmdI b => PV (Located ([AddEpAnn],[LMatch GhcPs (Located (b GhcPs))])) }-    : alts1     { $1 >>= \ $1 ->-                  return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }-    | ';' alts  { $2 >>= \ $2 ->-                  return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) }--This encoding works well enough, but introduces an extra GADT unlike the-tagless final encoding, and there's no need for this complexity.---}--{- Note [PatBuilder]-~~~~~~~~~~~~~~~~~~~~-Unlike HsExpr or HsCmd, the Pat type cannot accommodate all intermediate forms,-so we introduce the notion of a PatBuilder.--Consider a pattern like this:--  Con a b c--We parse arguments to "Con" one at a time in the  fexp aexp  parser production,-building the result with mkHsAppPV, so the intermediate forms are:--  1. Con-  2. Con a-  3. Con a b-  4. Con a b c--In 'HsExpr', we have 'HsApp', so the intermediate forms are represented like-this (pseudocode):--  1. "Con"-  2. HsApp "Con" "a"-  3. HsApp (HsApp "Con" "a") "b"-  3. HsApp (HsApp (HsApp "Con" "a") "b") "c"--Similarly, in 'HsCmd' we have 'HsCmdApp'. In 'Pat', however, what we have-instead is 'ConPatIn', which is very awkward to modify and thus unsuitable for-the intermediate forms.--We also need an intermediate representation to postpone disambiguation between-FunBind and PatBind. Consider:--  a `Con` b = ...-  a `fun` b = ...--How do we know that (a `Con` b) is a PatBind but (a `fun` b) is a FunBind? We-learn this by inspecting an intermediate representation in 'isFunLhs' and-seeing that 'Con' is a data constructor but 'f' is not. We need an intermediate-representation capable of representing both a FunBind and a PatBind, so Pat is-insufficient.--PatBuilder is an extension of Pat that is capable of representing intermediate-parsing results for patterns and function bindings:--  data PatBuilder p-    = PatBuilderPat (Pat p)-    | PatBuilderApp (LocatedA (PatBuilder p)) (LocatedA (PatBuilder p))-    | PatBuilderOpApp (LocatedA (PatBuilder p)) (LocatedA RdrName) (LocatedA (PatBuilder p))-    ...--It can represent any pattern via 'PatBuilderPat', but it also has a variety of-other constructors which were added by following a simple principle: we never-pattern match on the pattern stored inside 'PatBuilderPat'.--}-------------------------------------------------------------------------------- Miscellaneous utilities---- | Check if a fixity is valid. We support bypassing the usual bound checks--- for some special operators.-checkPrecP-        :: Located (SourceText,Int)              -- ^ precedence-        -> Located (OrdList (LocatedN RdrName))  -- ^ operators-        -> P ()-checkPrecP (L l (_,i)) (L _ ol)- | 0 <= i, i <= maxPrecedence = pure ()- | all specialOp ol = pure ()- | otherwise = addFatalError $ mkPlainErrorMsgEnvelope l (PsErrPrecedenceOutOfRange i)-  where-    -- If you change this, consider updating Note [Fixity of (->)] in GHC/Types.hs-    specialOp op = unLoc op == getRdrName unrestrictedFunTyCon--mkRecConstrOrUpdate-        :: Bool-        -> LHsExpr GhcPs-        -> SrcSpan-        -> ([Fbind (HsExpr GhcPs)], Maybe SrcSpan)-        -> EpAnn [AddEpAnn]-        -> PV (HsExpr GhcPs)-mkRecConstrOrUpdate _ (L _ (HsVar _ (L l c))) _lrec (fbinds,dd) anns-  | isRdrDataCon c-  = do-      let (fs, ps) = partitionEithers fbinds-      case ps of-          p:_ -> addFatalError $ mkPlainErrorMsgEnvelope (getLocA p) $-              PsErrOverloadedRecordDotInvalid-          _ -> return (mkRdrRecordCon (L l c) (mk_rec_fields fs dd) anns)-mkRecConstrOrUpdate overloaded_update exp _ (fs,dd) anns-  | Just dd_loc <- dd = addFatalError $ mkPlainErrorMsgEnvelope dd_loc $-                                          PsErrDotsInRecordUpdate-  | otherwise = mkRdrRecordUpd overloaded_update exp fs anns--mkRdrRecordUpd :: Bool -> LHsExpr GhcPs -> [Fbind (HsExpr GhcPs)] -> EpAnn [AddEpAnn] -> PV (HsExpr GhcPs)-mkRdrRecordUpd overloaded_on exp@(L loc _) fbinds anns = do-  -- We do not need to know if OverloadedRecordDot is in effect. We do-  -- however need to know if OverloadedRecordUpdate (passed in-  -- overloaded_on) is in effect because it affects the Left/Right nature-  -- of the RecordUpd value we calculate.-  let (fs, ps) = partitionEithers fbinds-      fs' :: [LHsRecUpdField GhcPs GhcPs]-      fs' = map (fmap mk_rec_upd_field) fs-  case overloaded_on of-    False | not $ null ps ->-      -- A '.' was found in an update and OverloadedRecordUpdate isn't on.-      addFatalError $ mkPlainErrorMsgEnvelope (locA loc) PsErrOverloadedRecordUpdateNotEnabled-    False ->-      -- This is just a regular record update.-      return RecordUpd {-        rupd_ext = anns-      , rupd_expr = exp-      , rupd_flds =-          RegularRecUpdFields-            { xRecUpdFields = noExtField-            , recUpdFields  = fs' } }-    -- This is a RecordDotSyntax update.-    True -> do-      let qualifiedFields =-            [ L l lbl | L _ (HsFieldBind _ (L l lbl) _ _) <- fs'-                      , isQual . ambiguousFieldOccRdrName $ lbl-            ]-      case qualifiedFields of-          qf:_ -> addFatalError $ mkPlainErrorMsgEnvelope (getLocA qf) $-                  PsErrOverloadedRecordUpdateNoQualifiedFields-          _ -> return $-               RecordUpd-                { rupd_ext = anns-                , rupd_expr = exp-                , rupd_flds =-                   OverloadedRecUpdFields-                     { xOLRecUpdFields = noExtField-                     , olRecUpdFields  = toProjUpdates fbinds } }-  where-    toProjUpdates :: [Fbind (HsExpr GhcPs)] -> [LHsRecUpdProj GhcPs]-    toProjUpdates = map (\case { Right p -> p; Left f -> recFieldToProjUpdate f })--    -- Convert a top-level field update like {foo=2} or {bar} (punned)-    -- to a projection update.-    recFieldToProjUpdate :: LHsRecField GhcPs  (LHsExpr GhcPs) -> LHsRecUpdProj GhcPs-    recFieldToProjUpdate (L l (HsFieldBind anns (L _ (FieldOcc _ (L loc rdr))) arg pun)) =-        -- The idea here is to convert the label to a singleton [FastString].-        let f = occNameFS . rdrNameOcc $ rdr-            fl = DotFieldOcc noAnn (L loc (FieldLabelString f))-            lf = locA loc-        in mkRdrProjUpdate l (L lf [L (l2l loc) fl]) (punnedVar f) pun anns-        where-          -- If punning, compute HsVar "f" otherwise just arg. This-          -- has the effect that sentinel HsVar "pun-rhs" is replaced-          -- by HsVar "f" here, before the update is written to a-          -- setField expressions.-          punnedVar :: FastString -> LHsExpr GhcPs-          punnedVar f  = if not pun then arg else noLocA . HsVar noExtField . noLocA . mkRdrUnqual . mkVarOccFS $ f--mkRdrRecordCon-  :: LocatedN RdrName -> HsRecordBinds GhcPs -> EpAnn [AddEpAnn] -> HsExpr GhcPs-mkRdrRecordCon con flds anns-  = RecordCon { rcon_ext = anns, rcon_con = con, rcon_flds = flds }--mk_rec_fields :: [LocatedA (HsRecField (GhcPass p) arg)] -> Maybe SrcSpan -> HsRecFields (GhcPass p) arg-mk_rec_fields fs Nothing = HsRecFields { rec_flds = fs, rec_dotdot = Nothing }-mk_rec_fields fs (Just s)  = HsRecFields { rec_flds = fs-                                     , rec_dotdot = Just (L s (RecFieldsDotDot $ length fs)) }--mk_rec_upd_field :: HsRecField GhcPs (LHsExpr GhcPs) -> HsRecUpdField GhcPs GhcPs-mk_rec_upd_field (HsFieldBind noAnn (L loc (FieldOcc _ rdr)) arg pun)-  = HsFieldBind noAnn (L loc (Unambiguous noExtField rdr)) arg pun--mkInlinePragma :: SourceText -> (InlineSpec, RuleMatchInfo) -> Maybe Activation-               -> InlinePragma--- The (Maybe Activation) is because the user can omit--- the activation spec (and usually does)-mkInlinePragma src (inl, match_info) mb_act-  = InlinePragma { inl_src = src -- Note [Pragma source text] in "GHC.Types.SourceText"-                 , inl_inline = inl-                 , inl_sat    = Nothing-                 , inl_act    = act-                 , inl_rule   = match_info }-  where-    act = case mb_act of-            Just act -> act-            Nothing  -> -- No phase specified-                        case inl of-                          NoInline _  -> NeverActive-                          Opaque _    -> NeverActive-                          _other      -> AlwaysActive--mkOpaquePragma :: SourceText -> InlinePragma-mkOpaquePragma src-  = InlinePragma { inl_src    = src-                 , inl_inline = Opaque src-                 , inl_sat    = Nothing-                 -- By marking the OPAQUE pragma NeverActive we stop-                 -- (constructor) specialisation on OPAQUE things.-                 ---                 -- See Note [OPAQUE pragma]-                 , inl_act    = NeverActive-                 , inl_rule   = FunLike-                 }--checkNewOrData :: SrcSpan -> RdrName -> Bool -> NewOrData -> [LConDecl GhcPs]-               -> P (DataDefnCons (LConDecl GhcPs))-checkNewOrData span name is_type_data = curry $ \ case-    (NewType, [a]) -> pure $ NewTypeCon a-    (DataType, as) -> pure $ DataTypeCons is_type_data (handle_type_data as)-    (NewType, as) -> addFatalError $ mkPlainErrorMsgEnvelope span $ PsErrMultipleConForNewtype name (length as)-  where-    -- In a "type data" declaration, the constructors are in the type/class-    -- namespace rather than the data constructor namespace.-    -- See Note [Type data declarations] in GHC.Rename.Module.-    handle_type_data-      | is_type_data = map (fmap promote_constructor)-      | otherwise = id--    promote_constructor (dc@ConDeclGADT { con_names = cons })-      = dc { con_names = fmap (fmap promote_name) cons }-    promote_constructor (dc@ConDeclH98 { con_name = con })-      = dc { con_name = fmap promote_name con }-    promote_constructor dc = dc--    promote_name name = fromMaybe name (promoteRdrName name)---------------------------------------------------------------------------------- utilities for foreign declarations---- construct a foreign import declaration----mkImport :: Located CCallConv-         -> Located Safety-         -> (Located StringLiteral, LocatedN RdrName, LHsSigType GhcPs)-         -> P (EpAnn [AddEpAnn] -> HsDecl GhcPs)-mkImport cconv safety (L loc (StringLiteral esrc entity _), v, ty) =-    case unLoc cconv of-      CCallConv          -> returnSpec =<< mkCImport-      CApiConv           -> do-        imp <- mkCImport-        if isCWrapperImport imp-          then addFatalError $ mkPlainErrorMsgEnvelope loc PsErrInvalidCApiImport-          else returnSpec imp-      StdCallConv        -> returnSpec =<< mkCImport-      PrimCallConv       -> mkOtherImport-      JavaScriptCallConv -> mkOtherImport-  where-    -- Parse a C-like entity string of the following form:-    --   "[static] [chname] [&] [cid]" | "dynamic" | "wrapper"-    -- If 'cid' is missing, the function name 'v' is used instead as symbol-    -- name (cf section 8.5.1 in Haskell 2010 report).-    mkCImport = do-      let e = unpackFS entity-      case parseCImport cconv safety (mkExtName (unLoc v)) e (L loc esrc) of-        Nothing         -> addFatalError $ mkPlainErrorMsgEnvelope loc $-                             PsErrMalformedEntityString-        Just importSpec -> return importSpec--    isCWrapperImport (CImport _ _ _ _ CWrapper) = True-    isCWrapperImport _ = False--    -- currently, all the other import conventions only support a symbol name in-    -- the entity string. If it is missing, we use the function name instead.-    mkOtherImport = returnSpec importSpec-      where-        entity'    = if nullFS entity-                        then mkExtName (unLoc v)-                        else entity-        funcTarget = CFunction (StaticTarget esrc entity' Nothing True)-        importSpec = CImport (L loc esrc) cconv safety Nothing funcTarget--    returnSpec spec = return $ \ann -> ForD noExtField $ ForeignImport-          { fd_i_ext  = ann-          , fd_name   = v-          , fd_sig_ty = ty-          , fd_fi     = spec-          }------ the string "foo" is ambiguous: either a header or a C identifier.  The--- C identifier case comes first in the alternatives below, so we pick--- that one.-parseCImport :: Located CCallConv -> Located Safety -> FastString -> String-             -> Located SourceText-             -> Maybe (ForeignImport (GhcPass p))-parseCImport cconv safety nm str sourceText =- listToMaybe $ map fst $ filter (null.snd) $-     readP_to_S parse str- where-   parse = do-       skipSpaces-       r <- choice [-          string "dynamic" >> return (mk Nothing (CFunction DynamicTarget)),-          string "wrapper" >> return (mk Nothing CWrapper),-          do optional (token "static" >> skipSpaces)-             ((mk Nothing <$> cimp nm) +++-              (do h <- munch1 hdr_char-                  skipSpaces-                  let src = mkFastString h-                  mk (Just (Header (SourceText src) src))-                      <$> cimp nm))-         ]-       skipSpaces-       return r--   token str = do _ <- string str-                  toks <- look-                  case toks of-                      c : _-                       | id_char c -> pfail-                      _            -> return ()--   mk h n = CImport sourceText cconv safety h n--   hdr_char c = not (isSpace c)-   -- header files are filenames, which can contain-   -- pretty much any char (depending on the platform),-   -- so just accept any non-space character-   id_first_char c = isAlpha    c || c == '_'-   id_char       c = isAlphaNum c || c == '_'--   cimp nm = (ReadP.char '&' >> skipSpaces >> CLabel <$> cid)-             +++ (do isFun <- case unLoc cconv of-                               CApiConv ->-                                  option True-                                         (do token "value"-                                             skipSpaces-                                             return False)-                               _ -> return True-                     cid' <- cid-                     return (CFunction (StaticTarget NoSourceText cid'-                                        Nothing isFun)))-          where-            cid = return nm +++-                  (do c  <- satisfy id_first_char-                      cs <-  many (satisfy id_char)-                      return (mkFastString (c:cs)))----- construct a foreign export declaration----mkExport :: Located CCallConv-         -> (Located StringLiteral, LocatedN RdrName, LHsSigType GhcPs)-         -> P (EpAnn [AddEpAnn] -> HsDecl GhcPs)-mkExport (L lc cconv) (L le (StringLiteral esrc entity _), v, ty)- = return $ \ann -> ForD noExtField $-   ForeignExport { fd_e_ext = ann, fd_name = v, fd_sig_ty = ty-                 , fd_fe = CExport (L le esrc) (L lc (CExportStatic esrc entity' cconv)) }-  where-    entity' | nullFS entity = mkExtName (unLoc v)-            | otherwise     = entity---- Supplying the ext_name in a foreign decl is optional; if it--- isn't there, the Haskell name is assumed. Note that no transformation--- of the Haskell name is then performed, so if you foreign export (++),--- it's external name will be "++". Too bad; it's important because we don't--- want z-encoding (e.g. names with z's in them shouldn't be doubled)----mkExtName :: RdrName -> CLabelString-mkExtName rdrNm = occNameFS (rdrNameOcc rdrNm)------------------------------------------------------------------------------------- Help with module system imports/exports--data ImpExpSubSpec = ImpExpAbs-                   | ImpExpAll-                   | ImpExpList [LocatedA ImpExpQcSpec]-                   | ImpExpAllWith [LocatedA ImpExpQcSpec]--data ImpExpQcSpec = ImpExpQcName (LocatedN RdrName)-                  | ImpExpQcType EpaLocation (LocatedN RdrName)-                  | ImpExpQcWildcard--mkModuleImpExp :: Maybe (LocatedP (WarningTxt GhcPs)) -> [AddEpAnn] -> LocatedA ImpExpQcSpec-               -> ImpExpSubSpec -> P (IE GhcPs)-mkModuleImpExp warning anns (L l specname) subs = do-  cs <- getCommentsFor (locA l) -- AZ: IEVar can discard comments-  let ann = EpAnn (spanAsAnchor $ maybe (locA l) getLocA warning) anns cs-  case subs of-    ImpExpAbs-      | isVarNameSpace (rdrNameSpace name)-                       -> return $ IEVar warning-                           (L l (ieNameFromSpec specname))-      | otherwise      -> IEThingAbs (warning, ann) . L l <$> nameT-    ImpExpAll          -> IEThingAll (warning, ann) . L l <$> nameT-    ImpExpList xs      ->-      (\newName -> IEThingWith (warning, ann) (L l newName)-        NoIEWildcard (wrapped xs)) <$> nameT-    ImpExpAllWith xs                       ->-      do allowed <- getBit PatternSynonymsBit-         if allowed-          then-            let withs = map unLoc xs-                pos   = maybe NoIEWildcard IEWildcard-                          (findIndex isImpExpQcWildcard withs)-                ies :: [LocatedA (IEWrappedName GhcPs)]-                ies   = wrapped $ filter (not . isImpExpQcWildcard . unLoc) xs-            in (\newName-                        -> IEThingWith (warning, ann) (L l newName) pos ies)-               <$> nameT-          else addFatalError $ mkPlainErrorMsgEnvelope (locA l) $-                 PsErrIllegalPatSynExport-  where-    name = ieNameVal specname-    nameT =-      if isVarNameSpace (rdrNameSpace name)-        then addFatalError $ mkPlainErrorMsgEnvelope (locA l) $-               (PsErrVarForTyCon name)-        else return $ ieNameFromSpec specname--    ieNameVal (ImpExpQcName ln)   = unLoc ln-    ieNameVal (ImpExpQcType _ ln) = unLoc ln-    ieNameVal (ImpExpQcWildcard)  = panic "ieNameVal got wildcard"--    ieNameFromSpec :: ImpExpQcSpec -> IEWrappedName GhcPs-    ieNameFromSpec (ImpExpQcName   (L l n)) = IEName noExtField (L l n)-    ieNameFromSpec (ImpExpQcType r (L l n)) = IEType r (L l n)-    ieNameFromSpec (ImpExpQcWildcard)  = panic "ieName got wildcard"--    wrapped = map (fmap ieNameFromSpec)--mkTypeImpExp :: LocatedN RdrName   -- TcCls or Var name space-             -> P (LocatedN RdrName)-mkTypeImpExp name =-  do allowed <- getBit ExplicitNamespacesBit-     unless allowed $ addError $ mkPlainErrorMsgEnvelope (getLocA name) $-                                   PsErrIllegalExplicitNamespace-     return (fmap (`setRdrNameSpace` tcClsName) name)--checkImportSpec :: LocatedL [LIE GhcPs] -> P (LocatedL [LIE GhcPs])-checkImportSpec ie@(L _ specs) =-    case [l | (L l (IEThingWith _ _ (IEWildcard _) _)) <- specs] of-      [] -> return ie-      (l:_) -> importSpecError (locA l)-  where-    importSpecError l =-      addFatalError $ mkPlainErrorMsgEnvelope l PsErrIllegalImportBundleForm---- In the correct order-mkImpExpSubSpec :: [LocatedA ImpExpQcSpec] -> P ([AddEpAnn], ImpExpSubSpec)-mkImpExpSubSpec [] = return ([], ImpExpList [])-mkImpExpSubSpec [L la ImpExpQcWildcard] =-  return ([AddEpAnn AnnDotdot (la2e la)], ImpExpAll)-mkImpExpSubSpec xs =-  if (any (isImpExpQcWildcard . unLoc) xs)-    then return $ ([], ImpExpAllWith xs)-    else return $ ([], ImpExpList xs)--isImpExpQcWildcard :: ImpExpQcSpec -> Bool-isImpExpQcWildcard ImpExpQcWildcard = True-isImpExpQcWildcard _                = False---------------------------------------------------------------------------------- Warnings and failures--warnPrepositiveQualifiedModule :: SrcSpan -> P ()-warnPrepositiveQualifiedModule span =-  addPsMessage span PsWarnImportPreQualified--failNotEnabledImportQualifiedPost :: SrcSpan -> P ()-failNotEnabledImportQualifiedPost loc =-  addError $ mkPlainErrorMsgEnvelope loc $ PsErrImportPostQualified--failImportQualifiedTwice :: SrcSpan -> P ()-failImportQualifiedTwice loc =-  addError $ mkPlainErrorMsgEnvelope loc $ PsErrImportQualifiedTwice--warnStarIsType :: SrcSpan -> P ()-warnStarIsType span = addPsMessage span PsWarnStarIsType--failOpFewArgs :: MonadP m => LocatedN RdrName -> m a-failOpFewArgs (L loc op) =-  do { star_is_type <- getBit StarIsTypeBit-     ; let is_star_type = if star_is_type then StarIsType else StarIsNotType-     ; addFatalError $ mkPlainErrorMsgEnvelope (locA loc) $-         (PsErrOpFewArgs is_star_type op) }---------------------------------------------------------------------------------- Misc utils--data PV_Context =-  PV_Context-    { pv_options :: ParserOpts-    , pv_details :: ParseContext -- See Note [Parser-Validator Details]-    }--data PV_Accum =-  PV_Accum-    { pv_warnings        :: Messages PsMessage-    , pv_errors          :: Messages PsMessage-    , pv_header_comments :: Strict.Maybe [LEpaComment]-    , pv_comment_q       :: [LEpaComment]-    }--data PV_Result a = PV_Ok PV_Accum a | PV_Failed PV_Accum-  deriving (Foldable, Functor, Traversable)---- During parsing, we make use of several monadic effects: reporting parse errors,--- accumulating warnings, adding API annotations, and checking for extensions. These--- effects are captured by the 'MonadP' type class.------ Sometimes we need to postpone some of these effects to a later stage due to--- ambiguities described in Note [Ambiguous syntactic categories].--- We could use two layers of the P monad, one for each stage:------   abParser :: forall x. DisambAB x => P (P x)------ The outer layer of P consumes the input and builds the inner layer, which--- validates the input. But this type is not particularly helpful, as it obscures--- the fact that the inner layer of P never consumes any input.------ For clarity, we introduce the notion of a parser-validator: a parser that does--- not consume any input, but may fail or use other effects. Thus we have:------   abParser :: forall x. DisambAB x => P (PV x)----newtype PV a = PV { unPV :: PV_Context -> PV_Accum -> PV_Result a }-  deriving (Functor)--instance Applicative PV where-  pure a = a `seq` PV (\_ acc -> PV_Ok acc a)-  (<*>) = ap--instance Monad PV where-  m >>= f = PV $ \ctx acc ->-    case unPV m ctx acc of-      PV_Ok acc' a -> unPV (f a) ctx acc'-      PV_Failed acc' -> PV_Failed acc'--runPV :: PV a -> P a-runPV = runPV_details noParseContext--askParseContext :: PV ParseContext-askParseContext = PV $ \(PV_Context _ details) acc -> PV_Ok acc details--runPV_details :: ParseContext -> PV a -> P a-runPV_details details m =-  P $ \s ->-    let-      pv_ctx = PV_Context-        { pv_options = options s-        , pv_details = details }-      pv_acc = PV_Accum-        { pv_warnings = warnings s-        , pv_errors   = errors s-        , pv_header_comments = header_comments s-        , pv_comment_q = comment_q s }-      mkPState acc' =-        s { warnings = pv_warnings acc'-          , errors   = pv_errors acc'-          , comment_q = pv_comment_q acc' }-    in-      case unPV m pv_ctx pv_acc of-        PV_Ok acc' a -> POk (mkPState acc') a-        PV_Failed acc' -> PFailed (mkPState acc')--instance MonadP PV where-  addError err =-    PV $ \_ctx acc -> PV_Ok acc{pv_errors = err `addMessage` pv_errors acc} ()-  addWarning w =-    PV $ \_ctx acc ->-      -- No need to check for the warning flag to be set, GHC will correctly discard suppressed-      -- diagnostics.-      PV_Ok acc{pv_warnings= w `addMessage` pv_warnings acc} ()-  addFatalError err =-    addError err >> PV (const PV_Failed)-  getBit ext =-    PV $ \ctx acc ->-      let b = ext `xtest` pExtsBitmap (pv_options ctx) in-      PV_Ok acc $! b-  allocateCommentsP ss = PV $ \_ s ->-    let (comment_q', newAnns) = allocateComments ss (pv_comment_q s) in-      PV_Ok s {-         pv_comment_q = comment_q'-       } (EpaComments newAnns)-  allocatePriorCommentsP ss = PV $ \_ s ->-    let (header_comments', comment_q', newAnns)-          = allocatePriorComments ss (pv_comment_q s) (pv_header_comments s) in-      PV_Ok s {-         pv_header_comments = header_comments',-         pv_comment_q = comment_q'-       } (EpaComments newAnns)-  allocateFinalCommentsP ss = PV $ \_ s ->-    let (header_comments', comment_q', newAnns)-          = allocateFinalComments ss (pv_comment_q s) (pv_header_comments s) in-      PV_Ok s {-         pv_header_comments = header_comments',-         pv_comment_q = comment_q'-       } (EpaCommentsBalanced (Strict.fromMaybe [] header_comments') newAnns)--{- Note [Parser-Validator Details]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-A PV computation is parameterized by some 'ParseContext' for diagnostic messages, which can be set-depending on validation context. We use this in checkPattern to fix #984.--Consider this example, where the user has forgotten a 'do':--  f _ = do-    x <- computation-    case () of-      _ ->-        result <- computation-        case () of () -> undefined--GHC parses it as follows:--  f _ = do-    x <- computation-    (case () of-      _ ->-        result) <- computation-        case () of () -> undefined--Note that this fragment is parsed as a pattern:--  case () of-    _ ->-      result--We attempt to detect such cases and add a hint to the diagnostic messages:--  T984.hs:6:9:-    Parse error in pattern: case () of { _ -> result }-    Possibly caused by a missing 'do'?--The "Possibly caused by a missing 'do'?" suggestion is the hint that is computed-out of the 'ParseContext', which are read by functions like 'patFail' when-constructing the 'PsParseErrorInPatDetails' data structure. When validating in a-context other than 'bindpat' (a pattern to the left of <-), we set the-details to 'noParseContext' and it has no effect on the diagnostic messages.---}---- | Hint about bang patterns, assuming @BangPatterns@ is off.-hintBangPat :: SrcSpan -> Pat GhcPs -> PV ()-hintBangPat span e = do-    bang_on <- getBit BangPatBit-    unless bang_on $-      addError $ mkPlainErrorMsgEnvelope span $ PsErrIllegalBangPattern e--mkSumOrTupleExpr :: SrcSpanAnnA -> Boxity -> SumOrTuple (HsExpr GhcPs)-                 -> [AddEpAnn]-                 -> PV (LHsExpr GhcPs)---- Tuple-mkSumOrTupleExpr l boxity (Tuple es) anns = do-    cs <- getCommentsFor (locA l)-    return $ L l (ExplicitTuple (EpAnn (spanAsAnchor $ locA l) anns cs) (map toTupArg es) boxity)-  where-    toTupArg :: Either (EpAnn EpaLocation) (LHsExpr GhcPs) -> HsTupArg GhcPs-    toTupArg (Left ann) = missingTupArg ann-    toTupArg (Right a)  = Present noAnn a---- Sum--- mkSumOrTupleExpr l Unboxed (Sum alt arity e) =---     return $ L l (ExplicitSum noExtField alt arity e)-mkSumOrTupleExpr l Unboxed (Sum alt arity e barsp barsa) anns = do-    let an = case anns of-               [AddEpAnn AnnOpenPH o, AddEpAnn AnnClosePH c] ->-                 AnnExplicitSum o barsp barsa c-               _ -> panic "mkSumOrTupleExpr"-    cs <- getCommentsFor (locA l)-    return $ L l (ExplicitSum (EpAnn (spanAsAnchor $ locA l) an cs) alt arity e)-mkSumOrTupleExpr l Boxed a@Sum{} _ =-    addFatalError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrUnsupportedBoxedSumExpr a--mkSumOrTuplePat-  :: SrcSpanAnnA -> Boxity -> SumOrTuple (PatBuilder GhcPs) -> [AddEpAnn]-  -> PV (LocatedA (PatBuilder GhcPs))---- Tuple-mkSumOrTuplePat l boxity (Tuple ps) anns = do-  ps' <- traverse toTupPat ps-  cs <- getCommentsFor (locA l)-  return $ L l (PatBuilderPat (TuplePat (EpAnn (spanAsAnchor $ locA l) anns cs) ps' boxity))-  where-    toTupPat :: Either (EpAnn EpaLocation) (LocatedA (PatBuilder GhcPs)) -> PV (LPat GhcPs)-    -- Ignore the element location so that the error message refers to the-    -- entire tuple. See #19504 (and the discussion) for details.-    toTupPat p = case p of-      Left _ -> addFatalError $-                  mkPlainErrorMsgEnvelope (locA l) PsErrTupleSectionInPat-      Right p' -> checkLPat p'---- Sum-mkSumOrTuplePat l Unboxed (Sum alt arity p barsb barsa) anns = do-   p' <- checkLPat p-   cs <- getCommentsFor (locA l)-   let an = EpAnn (spanAsAnchor $ locA l) (EpAnnSumPat anns barsb barsa) cs-   return $ L l (PatBuilderPat (SumPat an p' alt arity))-mkSumOrTuplePat l Boxed a@Sum{} _ =-    addFatalError $-      mkPlainErrorMsgEnvelope (locA l) $ PsErrUnsupportedBoxedSumPat a--mkLHsOpTy :: PromotionFlag -> LHsType GhcPs -> LocatedN RdrName -> LHsType GhcPs -> LHsType GhcPs-mkLHsOpTy prom x op y =-  let loc = getLoc x `combineSrcSpansA` (noAnnSrcSpan $ getLocA op) `combineSrcSpansA` getLoc y-  in L loc (mkHsOpTy prom x op y)--mkMultTy :: LHsToken "%" GhcPs -> LHsType GhcPs -> LHsUniToken "->" "→" GhcPs -> HsArrow GhcPs-mkMultTy pct t@(L _ (HsTyLit _ (HsNumTy (SourceText (unpackFS -> "1")) 1))) arr-  -- See #18888 for the use of (SourceText "1") above-  = HsLinearArrow (HsPct1 (L locOfPct1 HsTok) arr)-  where-    -- The location of "%" combined with the location of "1".-    locOfPct1 :: TokenLocation-    locOfPct1 = token_location_widenR (getLoc pct) (locA (getLoc t))-mkMultTy pct t arr = HsExplicitMult pct t arr--mkTokenLocation :: SrcSpan -> TokenLocation-mkTokenLocation (UnhelpfulSpan _) = NoTokenLoc-mkTokenLocation (RealSrcSpan r mb) = TokenLoc (EpaSpan r mb)---- Precondition: the TokenLocation has EpaSpan, never EpaDelta.-token_location_widenR :: TokenLocation -> SrcSpan -> TokenLocation-token_location_widenR NoTokenLoc _ = NoTokenLoc-token_location_widenR tl (UnhelpfulSpan _) = tl-token_location_widenR (TokenLoc (EpaSpan r1 mb1)) (RealSrcSpan r2 mb2) =-                      (TokenLoc (EpaSpan (combineRealSrcSpans r1 r2) (liftA2 combineBufSpans mb1 mb2)))-token_location_widenR (TokenLoc (EpaDelta _ _)) _ =-  -- Never happens because the parser does not produce EpaDelta.-  panic "token_location_widenR: EpaDelta"----------------------------------------------------------------------------------- Token symbols--starSym :: Bool -> FastString-starSym True = fsLit "★"-starSym False = fsLit "*"---------------------------------------------- Bits and pieces for RecordDotSyntax.--mkRdrGetField :: SrcSpanAnnA -> LHsExpr GhcPs -> LocatedAn NoEpAnns (DotFieldOcc GhcPs)-  -> EpAnnCO -> LHsExpr GhcPs-mkRdrGetField loc arg field anns =-  L loc HsGetField {-      gf_ext = anns-    , gf_expr = arg-    , gf_field = field-    }--mkRdrProjection :: NonEmpty (LocatedAn NoEpAnns (DotFieldOcc GhcPs)) -> EpAnn AnnProjection -> HsExpr GhcPs-mkRdrProjection flds anns =-  HsProjection {-      proj_ext = anns-    , proj_flds = flds-    }--mkRdrProjUpdate :: SrcSpanAnnA -> Located [LocatedAn NoEpAnns (DotFieldOcc GhcPs)]-                -> LHsExpr GhcPs -> Bool -> EpAnn [AddEpAnn]-                -> LHsRecProj GhcPs (LHsExpr GhcPs)-mkRdrProjUpdate _ (L _ []) _ _ _ = panic "mkRdrProjUpdate: The impossible has happened!"-mkRdrProjUpdate loc (L l flds) arg isPun anns =-  L loc HsFieldBind {-      hfbAnn = anns-    , hfbLHS = L (noAnnSrcSpan l) (FieldLabelStrings flds)-    , hfbRHS = arg-    , hfbPun = isPun-  }+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE DataKinds #-}++--+--  (c) The University of Glasgow 2002-2006+--++-- Functions over HsSyn specialised to RdrName.++module GHC.Parser.PostProcess (+        mkRdrGetField, mkRdrProjection, Fbind, -- RecordDot+        mkHsOpApp,+        mkHsIntegral, mkHsFractional, mkHsIsString,+        mkHsDo, mkSpliceDecl,+        mkRoleAnnotDecl,+        mkClassDecl,+        mkTyData, mkDataFamInst,+        mkTySynonym, mkTyFamInstEqn,+        mkStandaloneKindSig,+        mkTyFamInst,+        mkFamDecl,+        mkInlinePragma,+        mkOpaquePragma,+        mkPatSynMatchGroup,+        mkRecConstrOrUpdate,+        mkTyClD, mkInstD,+        mkRdrRecordCon, mkRdrRecordUpd,+        setRdrNameSpace,+        fromSpecTyVarBndr, fromSpecTyVarBndrs,+        annBinds,+        fixValbindsAnn,+        stmtsAnchor, stmtsLoc,++        cvBindGroup,+        cvBindsAndSigs,+        cvTopDecls,+        placeHolderPunRhs,++        -- Stuff to do with Foreign declarations+        mkImport,+        parseCImport,+        mkExport,+        mkExtName,    -- RdrName -> CLabelString+        mkGadtDecl,   -- [LocatedA RdrName] -> LHsType RdrName -> ConDecl RdrName+        mkConDeclH98,++        -- Bunch of functions in the parser monad for+        -- checking and constructing values+        checkImportDecl,+        checkExpBlockArguments, checkCmdBlockArguments,+        checkPrecP,           -- Int -> P Int+        checkContext,         -- HsType -> P HsContext+        checkPattern,         -- HsExp -> P HsPat+        checkPattern_details,+        incompleteDoBlock,+        ParseContext(..),+        checkMonadComp,+        checkValDef,          -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl+        checkValSigLhs,+        LRuleTyTmVar, RuleTyTmVar(..),+        mkRuleBndrs, mkRuleTyVarBndrs,+        checkRuleTyVarBndrNames,+        checkRecordSyntax,+        checkEmptyGADTs,+        addFatalError, hintBangPat,+        mkBangTy,+        UnpackednessPragma(..),+        mkMultTy,+        mkMultAnn,++        -- Token location+        mkTokenLocation,++        -- Help with processing exports+        ImpExpSubSpec(..),+        ImpExpQcSpec(..),+        mkModuleImpExp,+        mkTypeImpExp,+        mkImpExpSubSpec,+        checkImportSpec,++        -- Token symbols+        starSym,++        -- Warnings and errors+        warnStarIsType,+        warnPrepositiveQualifiedModule,+        failOpFewArgs,+        failNotEnabledImportQualifiedPost,+        failImportQualifiedTwice,+        requireExplicitNamespaces,++        SumOrTuple (..),++        -- Expression/command/pattern ambiguity resolution+        PV,+        runPV,+        ECP(ECP, unECP),+        DisambInfixOp(..),+        DisambECP(..),+        ecpFromExp,+        ecpFromCmd,+        PatBuilder,+        hsHoleExpr,++        -- Type/datacon ambiguity resolution+        DisambTD(..),+        addUnpackednessP,+        dataConBuilderCon,+        dataConBuilderDetails,+        mkUnboxedSumCon,++        -- ListTuplePuns related parsers+        mkTupleSyntaxTy,+        mkTupleSyntaxTycon,+        mkListSyntaxTy0,+        mkListSyntaxTy1,+        withCombinedComments,+        requireLTPuns,+    ) where++import GHC.Prelude+import GHC.Hs           -- Lots of it+import GHC.Core.TyCon          ( TyCon, isTupleTyCon, tyConSingleDataCon_maybe )+import GHC.Core.DataCon        ( DataCon, dataConTyCon )+import GHC.Core.ConLike        ( ConLike(..) )+import GHC.Core.Coercion.Axiom ( Role, fsFromRole )+import GHC.Types.Name.Reader+import GHC.Types.Name+import GHC.Types.Basic+import GHC.Types.Error+import GHC.Types.Fixity+import GHC.Types.Hint+import GHC.Types.SourceText+import GHC.Parser.Types+import GHC.Parser.Lexer+import GHC.Parser.Errors.Types+import GHC.Parser.Errors.Ppr ()+import GHC.Utils.Lexeme ( okConOcc )+import GHC.Types.TyThing+import GHC.Core.Type    ( Specificity(..) )+import GHC.Builtin.Types( cTupleTyConName, tupleTyCon, tupleDataCon,+                          nilDataConName, nilDataConKey,+                          listTyConName, listTyConKey, sumDataCon,+                          unrestrictedFunTyCon , listTyCon_RDR )+import GHC.Types.ForeignCall+import GHC.Types.SrcLoc+import GHC.Types.Unique ( hasKey )+import GHC.Data.OrdList+import GHC.Utils.Outputable as Outputable+import GHC.Data.FastString+import GHC.Data.Maybe+import GHC.Utils.Error+import GHC.Utils.Misc+import GHC.Utils.Monad (unlessM)+import Data.Either+import Data.List        ( findIndex )+import Data.Foldable+import qualified Data.Semigroup as Semi+import GHC.Unit.Module.Warnings+import GHC.Utils.Panic+import qualified GHC.Data.Strict as Strict++import Language.Haskell.Syntax.Basic (FieldLabelString(..))++import Control.Monad+import Text.ParserCombinators.ReadP as ReadP+import Data.Char+import Data.Data       ( dataTypeOf, fromConstr, dataTypeConstrs )+import Data.Kind       ( Type )+import Data.List.NonEmpty (NonEmpty)++{- **********************************************************************++  Construction functions for Rdr stuff++  ********************************************************************* -}++-- | mkClassDecl builds a RdrClassDecl, filling in the names for tycon and+-- datacon by deriving them from the name of the class.  We fill in the names+-- for the tycon and datacon corresponding to the class, by deriving them+-- from the name of the class itself.  This saves recording the names in the+-- interface file (which would be equally good).++-- Similarly for mkConDecl, mkClassOpSig and default-method names.++--         *** See Note [The Naming story] in GHC.Hs.Decls ****++mkTyClD :: LTyClDecl (GhcPass p) -> LHsDecl (GhcPass p)+mkTyClD (L loc d) = L loc (TyClD noExtField d)++mkInstD :: LInstDecl (GhcPass p) -> LHsDecl (GhcPass p)+mkInstD (L loc d) = L loc (InstD noExtField d)++mkClassDecl :: SrcSpan+            -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs)+            -> Located (a,[LHsFunDep GhcPs])+            -> OrdList (LHsDecl GhcPs)+            -> EpLayout+            -> [AddEpAnn]+            -> P (LTyClDecl GhcPs)++mkClassDecl loc' (L _ (mcxt, tycl_hdr)) fds where_cls layout annsIn+  = do { (binds, sigs, ats, at_defs, _, docs) <- cvBindsAndSigs where_cls+       ; (cls, tparams, fixity, ann, cs) <- checkTyClHdr True tycl_hdr+       ; tyvars <- checkTyVars (text "class") whereDots cls tparams+       ; let anns' = annsIn Semi.<> ann+       ; let loc = EpAnn (spanAsAnchor loc') noAnn cs+       ; return (L loc (ClassDecl { tcdCExt = (anns', layout, NoAnnSortKey)+                                  , tcdCtxt = mcxt+                                  , tcdLName = cls, tcdTyVars = tyvars+                                  , tcdFixity = fixity+                                  , tcdFDs = snd (unLoc fds)+                                  , tcdSigs = mkClassOpSigs sigs+                                  , tcdMeths = binds+                                  , tcdATs = ats, tcdATDefs = at_defs+                                  , tcdDocs  = docs })) }++mkTyData :: SrcSpan+         -> Bool+         -> NewOrData+         -> Maybe (LocatedP CType)+         -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs)+         -> Maybe (LHsKind GhcPs)+         -> [LConDecl GhcPs]+         -> Located (HsDeriving GhcPs)+         -> [AddEpAnn]+         -> P (LTyClDecl GhcPs)+mkTyData loc' is_type_data new_or_data cType (L _ (mcxt, tycl_hdr))+         ksig data_cons (L _ maybe_deriv) annsIn+  = do { (tc, tparams, fixity, ann, cs) <- checkTyClHdr False tycl_hdr+       ; tyvars <- checkTyVars (ppr new_or_data) equalsDots tc tparams+       ; let anns' = annsIn Semi.<> ann+       ; data_cons <- checkNewOrData loc' (unLoc tc) is_type_data new_or_data data_cons+       ; defn <- mkDataDefn cType mcxt ksig data_cons maybe_deriv+       ; !cs' <- getCommentsFor loc'+       ; let loc = EpAnn (spanAsAnchor loc') noAnn (cs' Semi.<> cs)+       ; return (L loc (DataDecl { tcdDExt = anns',+                                   tcdLName = tc, tcdTyVars = tyvars,+                                   tcdFixity = fixity,+                                   tcdDataDefn = defn })) }++mkDataDefn :: Maybe (LocatedP CType)+           -> Maybe (LHsContext GhcPs)+           -> Maybe (LHsKind GhcPs)+           -> DataDefnCons (LConDecl GhcPs)+           -> HsDeriving GhcPs+           -> P (HsDataDefn GhcPs)+mkDataDefn cType mcxt ksig data_cons maybe_deriv+  = do { checkDatatypeContext mcxt+       ; return (HsDataDefn { dd_ext = noExtField+                            , dd_cType = cType+                            , dd_ctxt = mcxt+                            , dd_cons = data_cons+                            , dd_kindSig = ksig+                            , dd_derivs = maybe_deriv }) }++mkTySynonym :: SrcSpan+            -> LHsType GhcPs  -- LHS+            -> LHsType GhcPs  -- RHS+            -> [AddEpAnn]+            -> P (LTyClDecl GhcPs)+mkTySynonym loc lhs rhs annsIn+  = do { (tc, tparams, fixity, ann, cs) <- checkTyClHdr False lhs+       ; tyvars <- checkTyVars (text "type") equalsDots tc tparams+       ; let anns' = annsIn Semi.<> ann+       ; let loc' = EpAnn (spanAsAnchor loc) noAnn cs+       ; return (L loc' (SynDecl { tcdSExt = anns'+                                 , tcdLName = tc, tcdTyVars = tyvars+                                 , tcdFixity = fixity+                                 , tcdRhs = rhs })) }++mkStandaloneKindSig+  :: SrcSpan+  -> Located [LocatedN RdrName]   -- LHS+  -> LHsSigType GhcPs             -- RHS+  -> [AddEpAnn]+  -> P (LStandaloneKindSig GhcPs)+mkStandaloneKindSig loc lhs rhs anns =+  do { vs <- mapM check_lhs_name (unLoc lhs)+     ; v <- check_singular_lhs (reverse vs)+     ; return $ L (noAnnSrcSpan loc)+       $ StandaloneKindSig anns v rhs }+  where+    check_lhs_name v@(unLoc->name) =+      if isUnqual name && isTcOcc (rdrNameOcc name)+      then return v+      else addFatalError $ mkPlainErrorMsgEnvelope (getLocA v) $+             (PsErrUnexpectedQualifiedConstructor (unLoc v))+    check_singular_lhs vs =+      case vs of+        [] -> panic "mkStandaloneKindSig: empty left-hand side"+        [v] -> return v+        _ -> addFatalError $ mkPlainErrorMsgEnvelope (getLoc lhs) $+               (PsErrMultipleNamesInStandaloneKindSignature vs)++mkTyFamInstEqn :: SrcSpan+               -> HsOuterFamEqnTyVarBndrs GhcPs+               -> LHsType GhcPs+               -> LHsType GhcPs+               -> [AddEpAnn]+               -> P (LTyFamInstEqn GhcPs)+mkTyFamInstEqn loc bndrs lhs rhs anns+  = do { (tc, tparams, fixity, ann, cs) <- checkTyClHdr False lhs+       ; let loc' = EpAnn (spanAsAnchor loc) noAnn cs+       ; return (L loc' $ FamEqn+                        { feqn_ext    = anns `mappend` ann+                        , feqn_tycon  = tc+                        , feqn_bndrs  = bndrs+                        , feqn_pats   = tparams+                        , feqn_fixity = fixity+                        , feqn_rhs    = rhs })}++mkDataFamInst :: SrcSpan+              -> NewOrData+              -> Maybe (LocatedP CType)+              -> (Maybe ( LHsContext GhcPs), HsOuterFamEqnTyVarBndrs GhcPs+                        , LHsType GhcPs)+              -> Maybe (LHsKind GhcPs)+              -> [LConDecl GhcPs]+              -> Located (HsDeriving GhcPs)+              -> [AddEpAnn]+              -> P (LInstDecl GhcPs)+mkDataFamInst loc new_or_data cType (mcxt, bndrs, tycl_hdr)+              ksig data_cons (L _ maybe_deriv) anns+  = do { (tc, tparams, fixity, ann, cs) <- checkTyClHdr False tycl_hdr+       ; data_cons <- checkNewOrData loc (unLoc tc) False new_or_data data_cons+       ; defn <- mkDataDefn cType mcxt ksig data_cons maybe_deriv+       ; let loc' = EpAnn (spanAsAnchor loc) noAnn cs+       ; return (L loc' (DataFamInstD noExtField (DataFamInstDecl+                  (FamEqn { feqn_ext    = ann Semi.<> anns+                          , feqn_tycon  = tc+                          , feqn_bndrs  = bndrs+                          , feqn_pats   = tparams+                          , feqn_fixity = fixity+                          , feqn_rhs    = defn })))) }++-- mkDataFamInst loc new_or_data cType (mcxt, bndrs, tycl_hdr)+--               ksig data_cons (L _ maybe_deriv) anns+--   = do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr+--        ; cs <- getCommentsFor loc -- Add any API Annotations to the top SrcSpan+--        ; let anns' = addAnns (EpAnn (spanAsAnchor loc) ann cs) anns emptyComments+--        ; defn <- mkDataDefn new_or_data cType mcxt ksig data_cons maybe_deriv+--        ; return (L (noAnnSrcSpan loc) (DataFamInstD anns' (DataFamInstDecl+--                   (FamEqn { feqn_ext    = anns'+--                           , feqn_tycon  = tc+--                           , feqn_bndrs  = bndrs+--                           , feqn_pats   = tparams+--                           , feqn_fixity = fixity+--                           , feqn_rhs    = defn })))) }++++mkTyFamInst :: SrcSpan+            -> TyFamInstEqn GhcPs+            -> [AddEpAnn]+            -> P (LInstDecl GhcPs)+mkTyFamInst loc eqn anns = do+  return (L (noAnnSrcSpan loc) (TyFamInstD noExtField+              (TyFamInstDecl anns eqn)))++mkFamDecl :: SrcSpan+          -> FamilyInfo GhcPs+          -> TopLevelFlag+          -> LHsType GhcPs                   -- LHS+          -> LFamilyResultSig GhcPs          -- Optional result signature+          -> Maybe (LInjectivityAnn GhcPs)   -- Injectivity annotation+          -> [AddEpAnn]+          -> P (LTyClDecl GhcPs)+mkFamDecl loc info topLevel lhs ksig injAnn annsIn+  = do { (tc, tparams, fixity, ann, cs) <- checkTyClHdr False lhs+       ; tyvars <- checkTyVars (ppr info) equals_or_where tc tparams+       ; let loc' = EpAnn (spanAsAnchor loc) noAnn cs+       ; return (L loc' (FamDecl noExtField (FamilyDecl+                                           { fdExt       = annsIn Semi.<> ann+                                           , fdTopLevel  = topLevel+                                           , fdInfo      = info, fdLName = tc+                                           , fdTyVars    = tyvars+                                           , fdFixity    = fixity+                                           , fdResultSig = ksig+                                           , fdInjectivityAnn = injAnn }))) }+  where+    equals_or_where = case info of+                        DataFamily          -> empty+                        OpenTypeFamily      -> empty+                        ClosedTypeFamily {} -> whereDots++mkSpliceDecl :: LHsExpr GhcPs -> (LHsDecl GhcPs)+-- If the user wrote+--      [pads| ... ]   then return a QuasiQuoteD+--      $(e)           then return a SpliceD+-- but if they wrote, say,+--      f x            then behave as if they'd written $(f x)+--                     ie a SpliceD+--+-- Typed splices are not allowed at the top level, thus we do not represent them+-- as spliced declaration.  See #10945+mkSpliceDecl lexpr@(L loc expr)+  | HsUntypedSplice _ splice@(HsUntypedSpliceExpr {}) <- expr+    = L loc $ SpliceD noExtField (SpliceDecl noExtField (L (l2l loc) splice) DollarSplice)++  | HsUntypedSplice _ splice@(HsQuasiQuote {}) <- expr+    = L loc $ SpliceD noExtField (SpliceDecl noExtField (L (l2l loc) splice) DollarSplice)++  | otherwise+    = L loc $ SpliceD noExtField (SpliceDecl noExtField+                                 (L (l2l loc) (HsUntypedSpliceExpr noAnn (la2la lexpr)))+                                       BareSplice)++mkRoleAnnotDecl :: SrcSpan+                -> LocatedN RdrName                -- type being annotated+                -> [Located (Maybe FastString)]    -- roles+                -> [AddEpAnn]+                -> P (LRoleAnnotDecl GhcPs)+mkRoleAnnotDecl loc tycon roles anns+  = do { roles' <- mapM parse_role roles+       ; !cs <- getCommentsFor loc+       ; return $ L (EpAnn (spanAsAnchor loc) noAnn cs)+         $ RoleAnnotDecl anns tycon roles' }+  where+    role_data_type = dataTypeOf (undefined :: Role)+    all_roles = map fromConstr $ dataTypeConstrs role_data_type+    possible_roles = [(fsFromRole role, role) | role <- all_roles]++    parse_role (L loc_role Nothing) = return $ L (noAnnSrcSpan loc_role) Nothing+    parse_role (L loc_role (Just role))+      = case lookup role possible_roles of+          Just found_role -> return $ L (noAnnSrcSpan loc_role) $ Just found_role+          Nothing         ->+            let nearby = fuzzyLookup (unpackFS role)+                  (mapFst unpackFS possible_roles)+            in+            addFatalError $ mkPlainErrorMsgEnvelope loc_role $+              (PsErrIllegalRoleName role nearby)++-- | Converts a list of 'LHsTyVarBndr's annotated with their 'Specificity' to+-- binders without annotations. Only accepts specified variables, and errors if+-- any of the provided binders has an 'InferredSpec' annotation.+fromSpecTyVarBndrs :: [LHsTyVarBndr Specificity GhcPs] -> P [LHsTyVarBndr () GhcPs]+fromSpecTyVarBndrs = mapM fromSpecTyVarBndr++-- | Converts 'LHsTyVarBndr' annotated with its 'Specificity' to one without+-- annotations. Only accepts specified variables, and errors if the provided+-- binder has an 'InferredSpec' annotation.+fromSpecTyVarBndr :: LHsTyVarBndr Specificity GhcPs -> P (LHsTyVarBndr () GhcPs)+fromSpecTyVarBndr bndr = case bndr of+  (L loc (UserTyVar xtv flag idp))     -> (check_spec flag loc)+                                          >> return (L loc $ UserTyVar xtv () idp)+  (L loc (KindedTyVar xtv flag idp k)) -> (check_spec flag loc)+                                          >> return (L loc $ KindedTyVar xtv () idp k)+  where+    check_spec :: Specificity -> SrcSpanAnnA -> P ()+    check_spec SpecifiedSpec _   = return ()+    check_spec InferredSpec  loc = addFatalError $ mkPlainErrorMsgEnvelope (locA loc) $+                                     PsErrInferredTypeVarNotAllowed++-- | Add the annotation for a 'where' keyword to existing @HsLocalBinds@+annBinds :: AddEpAnn -> EpAnnComments -> HsLocalBinds GhcPs+  -> (HsLocalBinds GhcPs, Maybe EpAnnComments)+annBinds a cs (HsValBinds an bs)  = (HsValBinds (add_where a an cs) bs, Nothing)+annBinds a cs (HsIPBinds an bs)   = (HsIPBinds (add_where a an cs) bs, Nothing)+annBinds _ cs  (EmptyLocalBinds x) = (EmptyLocalBinds x, Just cs)++add_where :: AddEpAnn -> EpAnn AnnList -> EpAnnComments -> EpAnn AnnList+add_where an@(AddEpAnn _ (EpaSpan (RealSrcSpan rs _))) (EpAnn a (AnnList anc o c r t) cs) cs2+  | valid_anchor a+  = EpAnn (widenAnchor a [an]) (AnnList anc o c (an:r) t) (cs Semi.<> cs2)+  | otherwise+  = EpAnn (patch_anchor rs a)+          (AnnList (fmap (patch_anchor rs) anc) o c (an:r) t) (cs Semi.<> cs2)+add_where (AddEpAnn _ _) _ _ = panic "add_where"+ -- EpaDelta should only be used for transformations++valid_anchor :: Anchor -> Bool+valid_anchor (EpaSpan (RealSrcSpan r _)) = srcSpanStartLine r >= 0+valid_anchor _ = False++-- If the decl list for where binds is empty, the anchor ends up+-- invalid. In this case, use the parent one+patch_anchor :: RealSrcSpan -> Anchor -> Anchor+patch_anchor r (EpaDelta _ _) = EpaSpan (RealSrcSpan r Strict.Nothing)+patch_anchor r1 (EpaSpan (RealSrcSpan r0 mb)) = EpaSpan (RealSrcSpan r mb)+  where+    r = if srcSpanStartLine r0 < 0 then r1 else r0+patch_anchor _ (EpaSpan ss) = EpaSpan ss++fixValbindsAnn :: EpAnn AnnList -> EpAnn AnnList+fixValbindsAnn (EpAnn anchor (AnnList ma o c r t) cs)+  = (EpAnn (widenAnchor anchor (r ++ map trailingAnnToAddEpAnn t)) (AnnList ma o c r t) cs)++-- | The 'Anchor' for a stmtlist is based on either the location or+-- the first semicolon annotion.+stmtsAnchor :: Located (OrdList AddEpAnn,a) -> Maybe Anchor+stmtsAnchor (L (RealSrcSpan l mb) ((ConsOL (AddEpAnn _ (EpaSpan (RealSrcSpan r rb))) _), _))+  = Just $ widenAnchorS (EpaSpan (RealSrcSpan l mb)) (RealSrcSpan r rb)+stmtsAnchor (L (RealSrcSpan l mb) _) = Just $ EpaSpan (RealSrcSpan l mb)+stmtsAnchor _ = Nothing++stmtsLoc :: Located (OrdList AddEpAnn,a) -> SrcSpan+stmtsLoc (L l ((ConsOL aa _), _))+  = widenSpan l [aa]+stmtsLoc (L l _) = l++{- **********************************************************************++  #cvBinds-etc# Converting to @HsBinds@, etc.++  ********************************************************************* -}++-- | Function definitions are restructured here. Each is assumed to be recursive+-- initially, and non recursive definitions are discovered by the dependency+-- analyser.+++--  | Groups together bindings for a single function+cvTopDecls :: OrdList (LHsDecl GhcPs) -> [LHsDecl GhcPs]+cvTopDecls decls = getMonoBindAll (fromOL decls)++-- Declaration list may only contain value bindings and signatures.+cvBindGroup :: OrdList (LHsDecl GhcPs) -> P (HsValBinds GhcPs)+cvBindGroup binding+  = do { (mbs, sigs, fam_ds, tfam_insts+         , dfam_insts, _) <- cvBindsAndSigs binding+       ; massert (null fam_ds && null tfam_insts && null dfam_insts)+       ; return $ ValBinds NoAnnSortKey mbs sigs }++cvBindsAndSigs :: OrdList (LHsDecl GhcPs)+  -> P (LHsBinds GhcPs, [LSig GhcPs], [LFamilyDecl GhcPs]+          , [LTyFamInstDecl GhcPs], [LDataFamInstDecl GhcPs], [LDocDecl GhcPs])+-- Input decls contain just value bindings and signatures+-- and in case of class or instance declarations also+-- associated type declarations. They might also contain Haddock comments.+cvBindsAndSigs fb = do+  fb' <- drop_bad_decls (fromOL fb)+  return (partitionBindsAndSigs (getMonoBindAll fb'))+  where+    -- cvBindsAndSigs is called in several places in the parser,+    -- and its items can be produced by various productions:+    --+    --    * decl       (when parsing a where clause or a let-expression)+    --    * decl_inst  (when parsing an instance declaration)+    --    * decl_cls   (when parsing a class declaration)+    --+    -- partitionBindsAndSigs can handle almost all declaration forms produced+    -- by the aforementioned productions, except for SpliceD, which we filter+    -- out here (in drop_bad_decls).+    --+    -- We're not concerned with every declaration form possible, such as those+    -- produced by the topdecl parser production, because cvBindsAndSigs is not+    -- called on top-level declarations.+    drop_bad_decls [] = return []+    drop_bad_decls (L l (SpliceD _ d) : ds) = do+      addError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrDeclSpliceNotAtTopLevel d+      drop_bad_decls ds+    drop_bad_decls (d:ds) = (d:) <$> drop_bad_decls ds++-----------------------------------------------------------------------------+-- Group function bindings into equation groups++getMonoBind :: LHsBind GhcPs -> [LHsDecl GhcPs]+  -> (LHsBind GhcPs, [LHsDecl GhcPs])+-- Suppose      (b',ds') = getMonoBind b ds+--      ds is a list of parsed bindings+--      b is a MonoBinds that has just been read off the front++-- Then b' is the result of grouping more equations from ds that+-- belong with b into a single MonoBinds, and ds' is the depleted+-- list of parsed bindings.+--+-- All Haddock comments between equations inside the group are+-- discarded.+--+-- No AndMonoBinds or EmptyMonoBinds here; just single equations++getMonoBind (L loc1 (FunBind { fun_id = fun_id1@(L _ f1)+                             , fun_matches =+                               MG { mg_alts = (L _ m1@[L _ mtchs1]) } }))+            binds+  | has_args m1+  = go [L loc1 mtchs1] (noAnnSrcSpan $ locA loc1) binds []+  where+    -- See Note [Exact Print Annotations for FunBind]+    go :: [LMatch GhcPs (LHsExpr GhcPs)] -- accumulates matches for current fun+       -> SrcSpanAnnA                    -- current top level loc+       -> [LHsDecl GhcPs]                -- Any docbinds seen+       -> [LHsDecl GhcPs]                -- rest of decls to be processed+       -> (LHsBind GhcPs, [LHsDecl GhcPs]) -- FunBind, rest of decls+    go mtchs loc+       ((L loc2 (ValD _ (FunBind { fun_id = (L _ f2)+                                 , fun_matches =+                                    MG { mg_alts = (L _ [L lm2 mtchs2]) } })))+         : binds) _+        | f1 == f2 =+          let (loc2', lm2') = transferAnnsA loc2 lm2+          in go (L lm2' mtchs2 : mtchs)+                        (combineSrcSpansA loc loc2') binds []+    go mtchs loc (doc_decl@(L loc2 (DocD {})) : binds) doc_decls+        = let doc_decls' = doc_decl : doc_decls+          in go mtchs (combineSrcSpansA loc loc2) binds doc_decls'+    go mtchs loc binds doc_decls+        = let+            L llm last_m = head mtchs -- Guaranteed at least one+            (llm',loc') = transferAnnsOnlyA llm loc -- Keep comments, transfer trailing++            matches' = reverse (L llm' last_m:tail mtchs)+            L lfm first_m =  head matches'+            (lfm', loc'') = transferCommentsOnlyA lfm loc'+          in+            ( L loc'' (makeFunBind fun_id1 (mkLocatedList $ (L lfm' first_m:tail matches')))+              , (reverse doc_decls) ++ binds)+        -- Reverse the final matches, to get it back in the right order+        -- Do the same thing with the trailing doc comments++getMonoBind bind binds = (bind, binds)++{- Note [Exact Print Annotations for FunBind]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++An individual Match that ends up in a FunBind MatchGroup is initially+parsed as a LHsDecl. This takes the form++   L loc (ValD NoExtField (FunBind ... [L lm (Match ..)]))++The loc contains the annotations, in particular comments, which are to+precede the declaration when printed, and [TrailingAnn] which are to+follow it. The [TrailingAnn] captures semicolons that may appear after+it when using the braces and semis style of coding.++The match location (lm) has only a location in it at this point, no+annotations. Its location is the same as the top level location in+loc.++What getMonoBind does it to take a sequence of FunBind LHsDecls that+belong to the same function and group them into a single function with+the component declarations all combined into the single MatchGroup as+[LMatch GhcPs].++Given that when exact printing a FunBind the exact printer simply+iterates over all the matches and prints each in turn, the simplest+behaviour would be to simply take the top level annotations (loc) for+each declaration, and use them for the individual component matches+(lm).++The problem is the exact printer first has to deal with the top level+LHsDecl, which means annotations for the loc. This needs to be able to+be exact printed in the context of surrounding declarations, and if+some refactor decides to move the declaration elsewhere, the leading+comments and trailing semicolons need to be handled at that level.++So the solution is to combine all the matches into one, pushing the+annotations into the LMatch's, and then at the end extract the+comments from the first match and [TrailingAnn] from the last to go in+the top level LHsDecl.+-}++-- Group together adjacent FunBinds for every function.+getMonoBindAll :: [LHsDecl GhcPs] -> [LHsDecl GhcPs]+getMonoBindAll [] = []+getMonoBindAll (L l (ValD _ b) : ds) =+  let (L l' b', ds') = getMonoBind (L l b) ds+  in L l' (ValD noExtField b') : getMonoBindAll ds'+getMonoBindAll (d : ds) = d : getMonoBindAll ds++has_args :: [LMatch GhcPs (LHsExpr GhcPs)] -> Bool+has_args []                                  = panic "GHC.Parser.PostProcess.has_args"+has_args (L _ (Match { m_pats = args }) : _) = not (null args)+        -- Don't group together FunBinds if they have+        -- no arguments.  This is necessary now that variable bindings+        -- with no arguments are now treated as FunBinds rather+        -- than pattern bindings (tests/rename/should_fail/rnfail002).++{- **********************************************************************++  #PrefixToHS-utils# Utilities for conversion++  ********************************************************************* -}++{- Note [Parsing data constructors is hard]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++The problem with parsing data constructors is that they look a lot like types.+Compare:++  (s1)   data T = C t1 t2+  (s2)   type T = C t1 t2++Syntactically, there's little difference between these declarations, except in+(s1) 'C' is a data constructor, but in (s2) 'C' is a type constructor.++This similarity would pose no problem if we knew ahead of time if we are+parsing a type or a constructor declaration. Looking at (s1) and (s2), a simple+(but wrong!) rule comes to mind: in 'data' declarations assume we are parsing+data constructors, and in other contexts (e.g. 'type' declarations) assume we+are parsing type constructors.++This simple rule does not work because of two problematic cases:++  (p1)   data T = C t1 t2 :+ t3+  (p2)   data T = C t1 t2 => t3++In (p1) we encounter (:+) and it turns out we are parsing an infix data+declaration, so (C t1 t2) is a type and 'C' is a type constructor.+In (p2) we encounter (=>) and it turns out we are parsing an existential+context, so (C t1 t2) is a constraint and 'C' is a type constructor.++As the result, in order to determine whether (C t1 t2) declares a data+constructor, a type, or a context, we would need unlimited lookahead which+'happy' is not so happy with.+-}++-- | Reinterpret a type constructor, including type operators, as a data+--   constructor.+-- See Note [Parsing data constructors is hard]+tyConToDataCon :: LocatedN RdrName -> Either (MsgEnvelope PsMessage) (LocatedN RdrName)+tyConToDataCon (L loc tc)+  | okConOcc (occNameString occ)+  = return (L loc (setRdrNameSpace tc srcDataName))++  | otherwise+  = Left $ mkPlainErrorMsgEnvelope (locA loc) $ (PsErrNotADataCon tc)+  where+    occ = rdrNameOcc tc++mkPatSynMatchGroup :: LocatedN RdrName+                   -> LocatedL (OrdList (LHsDecl GhcPs))+                   -> P (MatchGroup GhcPs (LHsExpr GhcPs))+mkPatSynMatchGroup (L loc patsyn_name) (L ld decls) =+    do { matches <- mapM fromDecl (fromOL decls)+       ; when (null matches) (wrongNumberErr (locA loc))+       ; return $ mkMatchGroup FromSource (L ld matches) }+  where+    fromDecl (L loc decl@(ValD _ (PatBind _+                                 -- AZ: where should these anns come from?+                         pat@(L _ (ConPat noAnn ln@(L _ name) details))+                               _ rhs))) =+        do { unless (name == patsyn_name) $+               wrongNameBindingErr (locA loc) decl+           ; match <- case details of+               PrefixCon _ pats -> return $ Match { m_ext = noAnn+                                                  , m_ctxt = ctxt, m_pats = pats+                                                  , m_grhss = rhs }+                   where+                     ctxt = FunRhs { mc_fun = ln+                                   , mc_fixity = Prefix+                                   , mc_strictness = NoSrcStrict }++               InfixCon p1 p2 -> return $ Match { m_ext = noAnn+                                                , m_ctxt = ctxt+                                                , m_pats = [p1, p2]+                                                , m_grhss = rhs }+                   where+                     ctxt = FunRhs { mc_fun = ln+                                   , mc_fixity = Infix+                                   , mc_strictness = NoSrcStrict }++               RecCon{} -> recordPatSynErr (locA loc) pat+           ; return $ L loc match }+    fromDecl (L loc decl) = extraDeclErr (locA loc) decl++    extraDeclErr loc decl =+        addFatalError $ mkPlainErrorMsgEnvelope loc $+          (PsErrNoSingleWhereBindInPatSynDecl patsyn_name decl)++    wrongNameBindingErr loc decl =+      addFatalError $ mkPlainErrorMsgEnvelope loc $+          (PsErrInvalidWhereBindInPatSynDecl patsyn_name decl)++    wrongNumberErr loc =+      addFatalError $ mkPlainErrorMsgEnvelope loc $+        (PsErrEmptyWhereInPatSynDecl patsyn_name)++recordPatSynErr :: SrcSpan -> LPat GhcPs -> P a+recordPatSynErr loc pat =+    addFatalError $ mkPlainErrorMsgEnvelope loc $+      (PsErrRecordSyntaxInPatSynDecl pat)++mkConDeclH98 :: [AddEpAnn] -> LocatedN RdrName -> Maybe [LHsTyVarBndr Specificity GhcPs]+                -> Maybe (LHsContext GhcPs) -> HsConDeclH98Details GhcPs+                -> ConDecl GhcPs++mkConDeclH98 ann name mb_forall mb_cxt args+  = ConDeclH98 { con_ext    = ann+               , con_name   = name+               , con_forall = isJust mb_forall+               , con_ex_tvs = mb_forall `orElse` []+               , con_mb_cxt = mb_cxt+               , con_args   = args+               , con_doc    = Nothing }++-- | Construct a GADT-style data constructor from the constructor names and+-- their type. Some interesting aspects of this function:+--+-- * This splits up the constructor type into its quantified type variables (if+--   provided), context (if provided), argument types, and result type, and+--   records whether this is a prefix or record GADT constructor. See+--   Note [GADT abstract syntax] in "GHC.Hs.Decls" for more details.+mkGadtDecl :: SrcSpan+           -> NonEmpty (LocatedN RdrName)+           -> EpUniToken "::" "∷"+           -> LHsSigType GhcPs+           -> P (LConDecl GhcPs)+mkGadtDecl loc names dcol ty = do++  (args, res_ty, annsa, csa) <-+    case body_ty of+     L ll (HsFunTy _ hsArr (L (EpAnn anc _ cs) (HsRecTy an rf)) res_ty) -> do+       arr <- case hsArr of+         HsUnrestrictedArrow arr -> return arr+         _ -> do addError $ mkPlainErrorMsgEnvelope (getLocA body_ty) $+                                 (PsErrIllegalGadtRecordMultiplicity hsArr)+                 return noAnn++       return ( RecConGADT arr (L (EpAnn anc an cs) rf), res_ty+              , [], epAnnComments ll)+     _ -> do+       let (anns, cs, arg_types, res_type) = splitHsFunType body_ty+       return (PrefixConGADT noExtField arg_types, res_type, anns, cs)++  let bndrs_loc = case outer_bndrs of+        HsOuterImplicit{} -> getLoc ty+        HsOuterExplicit an _ -> EpAnn (entry an) noAnn emptyComments++  let l = EpAnn (spanAsAnchor loc) noAnn csa++  pure $ L l ConDeclGADT+                     { con_g_ext  = (dcol, annsa)+                     , con_names  = names+                     , con_bndrs  = L bndrs_loc outer_bndrs+                     , con_mb_cxt = mcxt+                     , con_g_args = args+                     , con_res_ty = res_ty+                     , con_doc    = Nothing }+  where+    (outer_bndrs, mcxt, body_ty) = splitLHsGadtTy ty++setRdrNameSpace :: RdrName -> NameSpace -> RdrName+-- ^ This rather gruesome function is used mainly by the parser.+-- When parsing:+--+-- > data T a = T | T1 Int+--+-- we parse the data constructors as /types/ because of parser ambiguities,+-- so then we need to change the /type constr/ to a /data constr/+--+-- The exact-name case /can/ occur when parsing:+--+-- > data [] a = [] | a : [a]+--+-- For the exact-name case we return an original name.+setRdrNameSpace (Unqual occ) ns = Unqual (setOccNameSpace ns occ)+setRdrNameSpace (Qual m occ) ns = Qual m (setOccNameSpace ns occ)+setRdrNameSpace (Orig m occ) ns = Orig m (setOccNameSpace ns occ)+setRdrNameSpace (Exact n)    ns+  | Just thing <- wiredInNameTyThing_maybe n+  = setWiredInNameSpace thing ns+    -- Preserve Exact Names for wired-in things,+    -- notably tuples and lists++  | isExternalName n+  = Orig (nameModule n) occ++  | otherwise   -- This can happen when quoting and then+                -- splicing a fixity declaration for a type+  = Exact (mkSystemNameAt (nameUnique n) occ (nameSrcSpan n))+  where+    occ = setOccNameSpace ns (nameOccName n)++setWiredInNameSpace :: TyThing -> NameSpace -> RdrName+setWiredInNameSpace (ATyCon tc) ns+  | isDataConNameSpace ns+  = ty_con_data_con tc+  | isTcClsNameSpace ns+  = Exact (getName tc)      -- No-op++setWiredInNameSpace (AConLike (RealDataCon dc)) ns+  | isTcClsNameSpace ns+  = data_con_ty_con dc+  | isDataConNameSpace ns+  = Exact (getName dc)      -- No-op++setWiredInNameSpace thing ns+  = pprPanic "setWiredinNameSpace" (pprNameSpace ns <+> ppr thing)++ty_con_data_con :: TyCon -> RdrName+ty_con_data_con tc+  | isTupleTyCon tc+  , Just dc <- tyConSingleDataCon_maybe tc+  = Exact (getName dc)++  | tc `hasKey` listTyConKey+  = Exact nilDataConName++  | otherwise  -- See Note [setRdrNameSpace for wired-in names]+  = Unqual (setOccNameSpace srcDataName (getOccName tc))++data_con_ty_con :: DataCon -> RdrName+data_con_ty_con dc+  | let tc = dataConTyCon dc+  , isTupleTyCon tc+  = Exact (getName tc)++  | dc `hasKey` nilDataConKey+  = Exact listTyConName++  | otherwise  -- See Note [setRdrNameSpace for wired-in names]+  = Unqual (setOccNameSpace tcClsName (getOccName dc))++++{- Note [setRdrNameSpace for wired-in names]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+In GHC.Types, which declares (:), we have+  infixr 5 :+The ambiguity about which ":" is meant is resolved by parsing it as a+data constructor, but then using dataTcOccs to try the type constructor too;+and that in turn calls setRdrNameSpace to change the name-space of ":" to+tcClsName.  There isn't a corresponding ":" type constructor, but it's painful+to make setRdrNameSpace partial, so we just make an Unqual name instead. It+really doesn't matter!+-}++eitherToP :: MonadP m => Either (MsgEnvelope PsMessage) a -> m a+-- Adapts the Either monad to the P monad+eitherToP (Left err)    = addFatalError err+eitherToP (Right thing) = return thing++checkTyVars :: SDoc -> SDoc -> LocatedN RdrName -> [LHsTypeArg GhcPs]+            -> P (LHsQTyVars GhcPs)  -- the synthesized type variables+-- ^ Check whether the given list of type parameters are all type variables+-- (possibly with a kind signature).+checkTyVars pp_what equals_or_where tc tparms+  = do { tvs <- mapM check tparms+       ; return (mkHsQTvs tvs) }+  where+    check (HsTypeArg at ki) = chkParens [] [] (HsBndrInvisible at) ki+    check (HsValArg _ ty) = chkParens [] [] (HsBndrRequired noExtField) ty+    check (HsArgPar sp) = addFatalError $ mkPlainErrorMsgEnvelope sp $+                            (PsErrMalformedDecl pp_what (unLoc tc))+        -- Keep around an action for adjusting the annotations of extra parens+    chkParens :: [AddEpAnn] -> [AddEpAnn] -> HsBndrVis GhcPs -> LHsType GhcPs+              -> P (LHsTyVarBndr (HsBndrVis GhcPs) GhcPs)+    chkParens ops cps bvis (L l (HsParTy _ (L lt ty)))+      = let+          (o,c) = mkParensEpAnn (realSrcSpan $ locA l)+          (_,lt') = transferCommentsOnlyA l lt+        in+          chkParens (o:ops) (c:cps) bvis (L lt' ty)+    chkParens ops cps bvis ty = chk ops cps bvis ty++        -- Check that the name space is correct!+    chk :: [AddEpAnn] -> [AddEpAnn] -> HsBndrVis GhcPs -> LHsType GhcPs -> P (LHsTyVarBndr (HsBndrVis GhcPs) GhcPs)+    chk ops cps bvis (L l (HsKindSig annk (L annt (HsTyVar ann _ (L lv tv))) k))+        | isRdrTyVar tv+            = let+                an = (reverse ops) ++ cps+              in+                return (L (widenLocatedAn (l Semi.<> annt) (for_widening bvis:an))+                       (KindedTyVar (an ++ annk ++ ann) bvis (L lv tv) k))+    chk ops cps bvis (L l (HsTyVar ann _ (L ltv tv)))+        | isRdrTyVar tv+            = let+                an = (reverse ops) ++ cps+              in+                return (L (widenLocatedAn l (for_widening bvis:an))+                                     (UserTyVar (an ++ ann) bvis (L ltv tv)))+    chk _ _ _ t@(L loc _)+        = addFatalError $ mkPlainErrorMsgEnvelope (locA loc) $+            (PsErrUnexpectedTypeInDecl t pp_what (unLoc tc) tparms equals_or_where)++    -- Return an AddEpAnn for use in widenLocatedAn. The AnnKeywordId is not used.+    for_widening :: HsBndrVis GhcPs -> AddEpAnn+    for_widening (HsBndrInvisible (EpTok loc)) = AddEpAnn AnnAnyclass loc+    for_widening  _                            = AddEpAnn AnnAnyclass (EpaDelta (SameLine 0) [])+++whereDots, equalsDots :: SDoc+-- Second argument to checkTyVars+whereDots  = text "where ..."+equalsDots = text "= ..."++checkDatatypeContext :: Maybe (LHsContext GhcPs) -> P ()+checkDatatypeContext Nothing = return ()+checkDatatypeContext (Just c)+    = do allowed <- getBit DatatypeContextsBit+         unless allowed $ addError $ mkPlainErrorMsgEnvelope (getLocA c) $+                                       (PsErrIllegalDataTypeContext c)++type LRuleTyTmVar = LocatedAn NoEpAnns RuleTyTmVar+data RuleTyTmVar = RuleTyTmVar [AddEpAnn] (LocatedN RdrName) (Maybe (LHsType GhcPs))+-- ^ Essentially a wrapper for a @RuleBndr GhcPs@++-- turns RuleTyTmVars into RuleBnrs - this is straightforward+mkRuleBndrs :: [LRuleTyTmVar] -> [LRuleBndr GhcPs]+mkRuleBndrs = fmap (fmap cvt_one)+  where cvt_one (RuleTyTmVar ann v Nothing) = RuleBndr ann v+        cvt_one (RuleTyTmVar ann v (Just sig)) =+          RuleBndrSig ann v (mkHsPatSigType noAnn sig)++-- turns RuleTyTmVars into HsTyVarBndrs - this is more interesting+mkRuleTyVarBndrs :: [LRuleTyTmVar] -> [LHsTyVarBndr () GhcPs]+mkRuleTyVarBndrs = fmap cvt_one+  where cvt_one (L l (RuleTyTmVar ann v Nothing))+          = L (l2l l) (UserTyVar ann () (fmap tm_to_ty v))+        cvt_one (L l (RuleTyTmVar ann v (Just sig)))+          = L (l2l l) (KindedTyVar ann () (fmap tm_to_ty v) sig)+    -- takes something in namespace 'varName' to something in namespace 'tvName'+        tm_to_ty (Unqual occ) = Unqual (setOccNameSpace tvName occ)+        tm_to_ty _ = panic "mkRuleTyVarBndrs"++-- See Note [Parsing explicit foralls in Rules] in Parser.y+checkRuleTyVarBndrNames :: [LHsTyVarBndr flag GhcPs] -> P ()+checkRuleTyVarBndrNames = mapM_ (check . fmap hsTyVarName)+  where check (L loc (Unqual occ)) =+          when (occNameFS occ `elem` [fsLit "family",fsLit "role"])+            (addFatalError $ mkPlainErrorMsgEnvelope (locA loc) $+               (PsErrParseErrorOnInput occ))+        check _ = panic "checkRuleTyVarBndrNames"++checkRecordSyntax :: (MonadP m, Outputable a) => LocatedA a -> m (LocatedA a)+checkRecordSyntax lr@(L loc r)+    = do allowed <- getBit TraditionalRecordSyntaxBit+         unless allowed $ addError $ mkPlainErrorMsgEnvelope (locA loc) $+                                       (PsErrIllegalTraditionalRecordSyntax (ppr r))+         return lr++-- | Check if the gadt_constrlist is empty. Only raise parse error for+-- `data T where` to avoid affecting existing error message, see #8258.+checkEmptyGADTs :: Located ([AddEpAnn], [LConDecl GhcPs])+                -> P (Located ([AddEpAnn], [LConDecl GhcPs]))+checkEmptyGADTs gadts@(L span (_, []))           -- Empty GADT declaration.+    = do gadtSyntax <- getBit GadtSyntaxBit   -- GADTs implies GADTSyntax+         unless gadtSyntax $ addError $ mkPlainErrorMsgEnvelope span $+                                          PsErrIllegalWhereInDataDecl+         return gadts+checkEmptyGADTs gadts = return gadts              -- Ordinary GADT declaration.++checkTyClHdr :: Bool               -- True  <=> class header+                                   -- False <=> type header+             -> LHsType GhcPs+             -> P (LocatedN RdrName,     -- the head symbol (type or class name)+                   [LHsTypeArg GhcPs],   -- parameters of head symbol+                   LexicalFixity,        -- the declaration is in infix format+                   [AddEpAnn],           -- API Annotation for HsParTy+                                         -- when stripping parens+                   EpAnnComments)        -- Accumulated comments from re-arranging+-- Well-formedness check and decomposition of type and class heads.+-- Decomposes   T ty1 .. tyn   into    (T, [ty1, ..., tyn])+--              Int :*: Bool   into    (:*:, [Int, Bool])+-- returning the pieces+checkTyClHdr is_cls ty+  = goL emptyComments ty [] [] [] Prefix+  where+    goL cs (L l ty) acc ops cps fix = go cs l ty acc ops cps fix++    -- workaround to define '*' despite StarIsType+    go cs ll (HsParTy an (L l (HsStarTy _ isUni))) acc ops' cps' fix+      = do { addPsMessage (locA l) PsWarnStarBinder+           ; let name = mkOccNameFS tcClsName (starSym isUni)+           ; let a' = newAnns ll l an+           ; return (L a' (Unqual name), acc, fix+                    , (reverse ops') ++ cps', cs) }++    go cs l (HsTyVar _ _ ltc@(L _ tc)) acc ops cps fix+      | isRdrTc tc               = return (ltc, acc, fix, (reverse ops) ++ cps, cs Semi.<> comments l)+    go cs l (HsOpTy _ _ t1 ltc@(L _ tc) t2) acc ops cps _fix+      | isRdrTc tc               = return (ltc, lhs:rhs:acc, Infix, (reverse ops) ++ cps, cs Semi.<> comments l)+      where lhs = HsValArg noExtField t1+            rhs = HsValArg noExtField t2+    go cs l (HsParTy _ ty)    acc ops cps fix = goL (cs Semi.<> comments l) ty acc (o:ops) (c:cps) fix+      where+        (o,c) = mkParensEpAnn (realSrcSpan (locA l))+    go cs l (HsAppTy _ t1 t2) acc ops cps fix = goL (cs Semi.<> comments l) t1 (HsValArg noExtField t2:acc) ops cps fix+    go cs l (HsAppKindTy at ty ki) acc ops cps fix = goL (cs Semi.<> comments l) ty (HsTypeArg at ki:acc) ops cps fix+    go cs l (HsTupleTy _ HsBoxedOrConstraintTuple ts) [] ops cps fix+      = return (L (l2l l) (nameRdrName tup_name)+               , map (HsValArg noExtField) ts, fix, (reverse ops)++cps, cs Semi.<> comments l)+      where+        arity = length ts+        tup_name | is_cls    = cTupleTyConName arity+                 | otherwise = getName (tupleTyCon Boxed arity)+          -- See Note [Unit tuples] in GHC.Hs.Type  (TODO: is this still relevant?)+    go _ l _ _ _ _ _+      = addFatalError $ mkPlainErrorMsgEnvelope (locA l) $+          (PsErrMalformedTyOrClDecl ty)++    -- Combine the annotations from the HsParTy and HsStarTy into a+    -- new one for the LocatedN RdrName+    newAnns :: SrcSpanAnnA -> SrcSpanAnnA -> AnnParen -> SrcSpanAnnN+    newAnns l@(EpAnn _ (AnnListItem _) csp0) l1@(EpAnn ap (AnnListItem ta) csp) (AnnParen _ o c) =+      let+        lr = combineSrcSpans (locA l1) (locA l)+      in+        EpAnn (EpaSpan lr) (NameAnn NameParens o ap c ta) (csp0 Semi.<> csp)++-- | Yield a parse error if we have a function applied directly to a do block+-- etc. and BlockArguments is not enabled.+checkExpBlockArguments :: LHsExpr GhcPs -> PV ()+checkCmdBlockArguments :: LHsCmd GhcPs -> PV ()+(checkExpBlockArguments, checkCmdBlockArguments) = (checkExpr, checkCmd)+  where+    checkExpr :: LHsExpr GhcPs -> PV ()+    checkExpr expr = case unLoc expr of+      HsDo _ (DoExpr m) _      -> check (PsErrDoInFunAppExpr m)               expr+      HsDo _ (MDoExpr m) _     -> check (PsErrMDoInFunAppExpr m)              expr+      HsCase {}                -> check PsErrCaseInFunAppExpr                 expr+      HsLam _ lam_variant _    -> check (PsErrLambdaInFunAppExpr lam_variant) expr+      HsLet {}                 -> check PsErrLetInFunAppExpr                  expr+      HsIf {}                  -> check PsErrIfInFunAppExpr                   expr+      HsProc {}                -> check PsErrProcInFunAppExpr                 expr+      _                        -> return ()++    checkCmd :: LHsCmd GhcPs -> PV ()+    checkCmd cmd = case unLoc cmd of+      HsCmdLam _ lam_variant _ -> check (PsErrLambdaCmdInFunAppCmd lam_variant) cmd+      HsCmdCase {}             -> check PsErrCaseCmdInFunAppCmd                 cmd+      HsCmdIf {}               -> check PsErrIfCmdInFunAppCmd                   cmd+      HsCmdLet {}              -> check PsErrLetCmdInFunAppCmd                  cmd+      HsCmdDo {}               -> check PsErrDoCmdInFunAppCmd                   cmd+      _                        -> return ()++    check err a = do+      blockArguments <- getBit BlockArgumentsBit+      unless blockArguments $+        addError $ mkPlainErrorMsgEnvelope (getLocA a) $ (err a)++-- | Validate the context constraints and break up a context into a list+-- of predicates.+--+-- @+--     (Eq a, Ord b)        -->  [Eq a, Ord b]+--     Eq a                 -->  [Eq a]+--     (Eq a)               -->  [Eq a]+--     (((Eq a)))           -->  [Eq a]+-- @+checkContext :: LHsType GhcPs -> P (LHsContext GhcPs)+checkContext orig_t@(L (EpAnn l _ cs) _orig_t) =+  check ([],[],cs) orig_t+ where+  check :: ([EpaLocation],[EpaLocation],EpAnnComments)+        -> LHsType GhcPs -> P (LHsContext GhcPs)+  check (oparens,cparens,cs) (L _l (HsTupleTy ann' HsBoxedOrConstraintTuple ts))+    -- (Eq a, Ord b) shows up as a tuple type. Only boxed tuples can+    -- be used as context constraints.+    -- Ditto ()+    = mkCTuple (oparens ++ [ap_open ann'], ap_close ann' : cparens, cs) ts++  -- With NoListTuplePuns, contexts are parsed as data constructors, which causes failure+  -- downstream.+  -- This converts them just like when they are parsed as types in the punned case.+  check (oparens,cparens,cs) (L _l (HsExplicitTupleTy anns ts))+    = punsAllowed >>= \case+      True -> unprocessed+      False -> do+        let+          (op, cp) = case anns of+            [o, c] -> ([o], [c])+            [q, _, c] -> ([q], [c])+            _ -> ([], [])+        mkCTuple (oparens ++ (addLoc <$> op), (addLoc <$> cp) ++ cparens, cs) ts+  check (opi,cpi,csi) (L _lp1 (HsParTy ann' ty))+                                  -- to be sure HsParTy doesn't get into the way+    = check (ap_open ann':opi, ap_close ann':cpi, csi) ty++  -- No need for anns, returning original+  check (_opi,_cpi,_csi) _t = unprocessed++  unprocessed =+    return (L (EpAnn l (AnnContext Nothing [] []) emptyComments) [orig_t])++  addLoc (AddEpAnn _ l) = l++  mkCTuple (oparens, cparens, cs) ts =+    -- Append parens so that the original order in the source is maintained+    return (L (EpAnn l (AnnContext Nothing oparens cparens) cs) ts)++checkImportDecl :: Maybe EpaLocation+                -> Maybe EpaLocation+                -> P ()+checkImportDecl mPre mPost = do+  let whenJust mg f = maybe (pure ()) f mg++  importQualifiedPostEnabled <- getBit ImportQualifiedPostBit++  -- Error if 'qualified' found in postpositive position and+  -- 'ImportQualifiedPost' is not in effect.+  whenJust mPost $ \post ->+    when (not importQualifiedPostEnabled) $+      failNotEnabledImportQualifiedPost (RealSrcSpan (epaLocationRealSrcSpan post) Strict.Nothing)++  -- Error if 'qualified' occurs in both pre and postpositive+  -- positions.+  whenJust mPost $ \post ->+    when (isJust mPre) $+      failImportQualifiedTwice (RealSrcSpan (epaLocationRealSrcSpan post) Strict.Nothing)++  -- Warn if 'qualified' found in prepositive position and+  -- 'Opt_WarnPrepositiveQualifiedModule' is enabled.+  whenJust mPre $ \pre ->+    warnPrepositiveQualifiedModule (RealSrcSpan (epaLocationRealSrcSpan pre) Strict.Nothing)++-- -------------------------------------------------------------------------+-- Checking Patterns.++-- We parse patterns as expressions and check for valid patterns below,+-- converting the expression into a pattern at the same time.++checkPattern :: LocatedA (PatBuilder GhcPs) -> P (LPat GhcPs)+checkPattern = runPV . checkLPat++checkPattern_details :: ParseContext -> PV (LocatedA (PatBuilder GhcPs)) -> P (LPat GhcPs)+checkPattern_details extraDetails pp = runPV_details extraDetails (pp >>= checkLPat)++checkLArgPat :: LocatedA (ArgPatBuilder GhcPs) -> PV (LPat GhcPs)+checkLArgPat (L l (ArgPatBuilderVisPat p)) = checkLPat (L l p)+checkLArgPat (L l (ArgPatBuilderArgPat p)) = return (L l p)++checkLPat :: LocatedA (PatBuilder GhcPs) -> PV (LPat GhcPs)+checkLPat (L l@(EpAnn anc an _) p) = do+  (L l' p', cs) <- checkPat (EpAnn anc an emptyComments) emptyComments (L l p) [] []+  return (L (addCommentsToEpAnn l' cs) p')++checkPat :: SrcSpanAnnA -> EpAnnComments -> LocatedA (PatBuilder GhcPs) -> [HsConPatTyArg GhcPs] -> [LPat GhcPs]+         -> PV (LPat GhcPs, EpAnnComments)+checkPat loc cs (L l e@(PatBuilderVar (L ln c))) tyargs args+  | isRdrDataCon c = return (L loc $ ConPat+      { pat_con_ext = noAnn -- AZ: where should this come from?+      , pat_con = L ln c+      , pat_args = PrefixCon tyargs args+      }, comments l Semi.<> cs)+  | (not (null args) && patIsRec c) = do+      ctx <- askParseContext+      patFail (locA l) . PsErrInPat e $ PEIP_RecPattern args YesPatIsRecursive ctx+checkPat loc cs (L la (PatBuilderAppType f at t)) tyargs args =+  checkPat loc (cs Semi.<> comments la) f (HsConPatTyArg at t : tyargs) args+checkPat loc cs (L la (PatBuilderApp f e)) [] args = do+  p <- checkLPat e+  checkPat loc (cs Semi.<> comments la) f [] (p : args)+checkPat loc cs (L l e) [] [] = do+  p <- checkAPat loc e+  return (L l p, cs)+checkPat loc _ e _ _ = do+  details <- fromParseContext <$> askParseContext+  patFail (locA loc) (PsErrInPat (unLoc e) details)++checkAPat :: SrcSpanAnnA -> PatBuilder GhcPs -> PV (Pat GhcPs)+checkAPat loc e0 = do+ nPlusKPatterns <- getBit NPlusKPatternsBit+ case e0 of+   PatBuilderPat p -> return p+   PatBuilderVar x -> return (VarPat noExtField x)++   -- Overloaded numeric patterns (e.g. f 0 x = x)+   -- Negation is recorded separately, so that the literal is zero or +ve+   -- NB. Negative *primitive* literals are already handled by the lexer+   PatBuilderOverLit pos_lit -> return (mkNPat (L (l2l loc) pos_lit) Nothing noAnn)++   -- n+k patterns+   PatBuilderOpApp+           (L _ (PatBuilderVar (L nloc n)))+           (L l plus)+           (L lloc (PatBuilderOverLit lit@(OverLit {ol_val = HsIntegral {}})))+           _+                     | nPlusKPatterns && (plus == plus_RDR)+                     -> return (mkNPlusKPat (L nloc n) (L (l2l lloc) lit)+                                (entry l))++   -- Improve error messages for the @-operator when the user meant an @-pattern+   PatBuilderOpApp _ op _ _ | opIsAt (unLoc op) -> do+     addError $ mkPlainErrorMsgEnvelope (getLocA op) PsErrAtInPatPos+     return (WildPat noExtField)++   PatBuilderOpApp l (L cl c) r anns+     | isRdrDataCon c -> do+         l <- checkLPat l+         r <- checkLPat r+         return $ ConPat+           { pat_con_ext = anns+           , pat_con = L cl c+           , pat_args = InfixCon l r+           }++   PatBuilderPar lpar e rpar -> do+     p <- checkLPat e+     return (ParPat (lpar, rpar) p)++   _           -> do+     details <- fromParseContext <$> askParseContext+     patFail (locA loc) (PsErrInPat e0 details)++placeHolderPunRhs :: DisambECP b => PV (LocatedA b)+-- The RHS of a punned record field will be filled in by the renamer+-- It's better not to make it an error, in case we want to print it when+-- debugging+placeHolderPunRhs = mkHsVarPV (noLocA pun_RDR)++plus_RDR, pun_RDR :: RdrName+plus_RDR = mkUnqual varName (fsLit "+") -- Hack+pun_RDR  = mkUnqual varName (fsLit "pun-right-hand-side")++checkPatField :: LHsRecField GhcPs (LocatedA (PatBuilder GhcPs))+              -> PV (LHsRecField GhcPs (LPat GhcPs))+checkPatField (L l fld) = do p <- checkLPat (hfbRHS fld)+                             return (L l (fld { hfbRHS = p }))++patFail :: SrcSpan -> PsMessage -> PV a+patFail loc msg = addFatalError $ mkPlainErrorMsgEnvelope loc $ msg++patIsRec :: RdrName -> Bool+patIsRec e = e == mkUnqual varName (fsLit "rec")++---------------------------------------------------------------------------+-- Check Equation Syntax++checkValDef :: SrcSpan+            -> LocatedA (PatBuilder GhcPs)+            -> (HsMultAnn GhcPs, Maybe (AddEpAnn, LHsType GhcPs))+            -> Located (GRHSs GhcPs (LHsExpr GhcPs))+            -> P (HsBind GhcPs)++checkValDef loc lhs (mult, Just (sigAnn, sig)) grhss+        -- x :: ty = rhs  parses as a *pattern* binding+  = do lhs' <- runPV $ mkHsTySigPV (combineLocsA lhs sig) lhs sig [sigAnn]+                        >>= checkLPat+       checkPatBind loc lhs' grhss mult++checkValDef loc lhs (mult_ann, Nothing) grhss+  | HsNoMultAnn{} <- mult_ann+  = do  { mb_fun <- isFunLhs lhs+        ; case mb_fun of+            Just (fun, is_infix, pats, ann) ->+              checkFunBind NoSrcStrict loc ann+                           fun is_infix pats grhss+            Nothing -> do+              lhs' <- checkPattern lhs+              checkPatBind loc lhs' grhss mult_ann }++checkValDef loc lhs (mult_ann, Nothing) ghrss+        -- %p x = rhs  parses as a *pattern* binding+  = do lhs' <- checkPattern lhs+       checkPatBind loc lhs' ghrss mult_ann++checkFunBind :: SrcStrictness+             -> SrcSpan+             -> [AddEpAnn]+             -> LocatedN RdrName+             -> LexicalFixity+             -> [LocatedA (ArgPatBuilder GhcPs)]+             -> Located (GRHSs GhcPs (LHsExpr GhcPs))+             -> P (HsBind GhcPs)+checkFunBind strictness locF ann (L lf fun) is_infix pats (L _ grhss)+  = do  ps <- runPV_details extraDetails (mapM checkLArgPat pats)+        let match_span = noAnnSrcSpan $ locF+        return (makeFunBind (L (l2l lf) fun) (L (noAnnSrcSpan $ locA match_span)+                 [L match_span (Match { m_ext = ann+                                      , m_ctxt = FunRhs+                                          { mc_fun    = L lf fun+                                          , mc_fixity = is_infix+                                          , mc_strictness = strictness }+                                      , m_pats = ps+                                      , m_grhss = grhss })]))+        -- The span of the match covers the entire equation.+        -- That isn't quite right, but it'll do for now.+  where+    extraDetails+      | Infix <- is_infix = ParseContext (Just fun) NoIncompleteDoBlock+      | otherwise         = noParseContext++makeFunBind :: LocatedN RdrName -> LocatedL [LMatch GhcPs (LHsExpr GhcPs)]+            -> HsBind GhcPs+-- Like GHC.Hs.Utils.mkFunBind, but we need to be able to set the fixity too+makeFunBind fn ms+  = FunBind { fun_ext = noExtField,+              fun_id = fn,+              fun_matches = mkMatchGroup FromSource ms }++-- See Note [FunBind vs PatBind]+checkPatBind :: SrcSpan+             -> LPat GhcPs+             -> Located (GRHSs GhcPs (LHsExpr GhcPs))+             -> HsMultAnn GhcPs+             -> P (HsBind GhcPs)+checkPatBind loc (L _ (BangPat ans (L _ (VarPat _ v))))+                        (L _match_span grhss) (HsNoMultAnn _)+      = return (makeFunBind v (L (noAnnSrcSpan loc)+                [L (noAnnSrcSpan loc) (m ans v)]))+  where+    m a v = Match { m_ext = a+                  , m_ctxt = FunRhs { mc_fun    = v+                                    , mc_fixity = Prefix+                                    , mc_strictness = SrcStrict }+                  , m_pats = []+                 , m_grhss = grhss }++checkPatBind _loc lhs (L _ grhss) mult = do+  return (PatBind noExtField lhs mult grhss)+++checkValSigLhs :: LHsExpr GhcPs -> P (LocatedN RdrName)+checkValSigLhs lhs@(L l lhs_expr) =+  case lhs_expr of+    HsVar _ lrdr@(L _ v) -> check_var v lrdr+    _                    -> make_err PsErrInvalidTypeSig_Other+  where+    check_var v lrdr+      | not (isUnqual v) = make_err PsErrInvalidTypeSig_Qualified+      | isDataOcc occ_n  = make_err PsErrInvalidTypeSig_DataCon+      | otherwise        = pure lrdr+      where occ_n = rdrNameOcc v+    make_err reason = addFatalError $+      mkPlainErrorMsgEnvelope (locA l) (PsErrInvalidTypeSignature reason lhs)+++checkDoAndIfThenElse+  :: (Outputable a, Outputable b, Outputable c)+  => (a -> Bool -> b -> Bool -> c -> PsMessage)+  -> LocatedA a -> Bool -> LocatedA b -> Bool -> LocatedA c -> PV ()+checkDoAndIfThenElse err guardExpr semiThen thenExpr semiElse elseExpr+ | semiThen || semiElse = do+      doAndIfThenElse <- getBit DoAndIfThenElseBit+      let e   = err (unLoc guardExpr)+                    semiThen (unLoc thenExpr)+                    semiElse (unLoc elseExpr)+          loc = combineLocs (reLoc guardExpr) (reLoc elseExpr)++      unless doAndIfThenElse $ addError (mkPlainErrorMsgEnvelope loc e)+  | otherwise = return ()++isFunLhs :: LocatedA (PatBuilder GhcPs)+      -> P (Maybe (LocatedN RdrName, LexicalFixity,+                   [LocatedA (ArgPatBuilder GhcPs)],[AddEpAnn]))+-- A variable binding is parsed as a FunBind.+-- Just (fun, is_infix, arg_pats) if e is a function LHS+isFunLhs e = go e [] [] []+ where+   mk = fmap ArgPatBuilderVisPat++   go (L l (PatBuilderVar (L loc f))) es ops cps+       | not (isRdrDataCon f)        = do+           let (_l, loc') = transferCommentsOnlyA l loc+           return (Just (L loc' f, Prefix, es, (reverse ops) ++ cps))+   go (L l (PatBuilderApp (L lf f) e))   es       ops cps = do+     let (_l, lf') = transferCommentsOnlyA l lf+     go (L lf' f) (mk e:es) ops cps+   go (L l (PatBuilderPar _ (L le e) _)) es@(_:_) ops cps = go (L le' e) es (o:ops) (c:cps)+      -- NB: es@(_:_) means that there must be an arg after the parens for the+      -- LHS to be a function LHS. This corresponds to the Haskell Report's definition+      -- of funlhs.+     where+       (_l, le') = transferCommentsOnlyA l le+       (o,c) = mkParensEpAnn (realSrcSpan $ locA l)+   go (L loc (PatBuilderOpApp (L ll l) (L loc' op) r anns)) es ops cps+      | not (isRdrDataCon op)         -- We have found the function!+      = do { let (_l, ll') = transferCommentsOnlyA loc ll+           ; return (Just (L loc' op, Infix, (mk (L ll' l):mk r:es), (anns ++ reverse ops ++ cps))) }+      | otherwise                     -- Infix data con; keep going+      = do { let (_l, ll') = transferCommentsOnlyA loc ll+           ; mb_l <- go (L ll' l) es ops cps+           ; return (reassociate =<< mb_l) }+        where+          reassociate (op', Infix, j : L k_loc (ArgPatBuilderVisPat k) : es', anns')+            = Just (op', Infix, j : op_app : es', anns')+            where+              op_app = mk $ L loc (PatBuilderOpApp (L k_loc k)+                                    (L loc' op) r (reverse ops ++ cps))+          reassociate _other = Nothing+   go (L l (PatBuilderAppType (L lp pat) tok ty_pat@(HsTP _ (L (EpAnn anc ann cs) _)))) es ops cps+             = go (L lp' pat) (L (EpAnn anc' ann cs) (ArgPatBuilderArgPat invis_pat) : es) ops cps+             where invis_pat = InvisPat tok ty_pat+                   anc' = case tok of+                     NoEpTok -> anc+                     EpTok l -> widenAnchor anc [AddEpAnn AnnAnyclass l]+                   (_l, lp') = transferCommentsOnlyA l lp+   go _ _ _ _ = return Nothing++data ArgPatBuilder p+  = ArgPatBuilderVisPat (PatBuilder p)+  | ArgPatBuilderArgPat (Pat p)++instance Outputable (ArgPatBuilder GhcPs) where+  ppr (ArgPatBuilderVisPat p) = ppr p+  ppr (ArgPatBuilderArgPat p) = ppr p++mkBangTy :: [AddEpAnn] -> SrcStrictness -> LHsType GhcPs -> HsType GhcPs+mkBangTy anns strictness =+  HsBangTy anns (HsSrcBang NoSourceText NoSrcUnpack strictness)++-- | Result of parsing @{-\# UNPACK \#-}@ or @{-\# NOUNPACK \#-}@.+data UnpackednessPragma =+  UnpackednessPragma [AddEpAnn] SourceText SrcUnpackedness++-- | Annotate a type with either an @{-\# UNPACK \#-}@ or a @{-\# NOUNPACK \#-}@ pragma.+addUnpackednessP :: MonadP m => Located UnpackednessPragma -> LHsType GhcPs -> m (LHsType GhcPs)+addUnpackednessP (L lprag (UnpackednessPragma anns prag unpk)) ty = do+    let l' = combineSrcSpans lprag (getLocA ty)+    let t' = addUnpackedness anns ty+    return (L (noAnnSrcSpan l') t')+  where+    -- If we have a HsBangTy that only has a strictness annotation,+    -- such as ~T or !T, then add the pragma to the existing HsBangTy.+    --+    -- Otherwise, wrap the type in a new HsBangTy constructor.+    addUnpackedness an (L _ (HsBangTy x bang t))+      | HsSrcBang NoSourceText NoSrcUnpack strictness <- bang+      = HsBangTy (an Semi.<> x) (HsSrcBang prag unpk strictness) t+    addUnpackedness an t+      = HsBangTy an (HsSrcBang prag unpk NoSrcStrict) t++---------------------------------------------------------------------------+-- | Check for monad comprehensions+--+-- If the flag MonadComprehensions is set, return a 'MonadComp' context,+-- otherwise use the usual 'ListComp' context++checkMonadComp :: PV HsDoFlavour+checkMonadComp = do+    monadComprehensions <- getBit MonadComprehensionsBit+    return $ if monadComprehensions+                then MonadComp+                else ListComp++-- -------------------------------------------------------------------------+-- Expression/command/pattern ambiguity.+-- See Note [Ambiguous syntactic categories]+--++-- See Note [Ambiguous syntactic categories]+--+-- This newtype is required to avoid impredicative types in monadic+-- productions. That is, in a production that looks like+--+--    | ... {% return (ECP ...) }+--+-- we are dealing with+--    P ECP+-- whereas without a newtype we would be dealing with+--    P (forall b. DisambECP b => PV (Located b))+--+newtype ECP =+  ECP { unECP :: forall b. DisambECP b => PV (LocatedA b) }++ecpFromExp :: LHsExpr GhcPs -> ECP+ecpFromExp a = ECP (ecpFromExp' a)++ecpFromCmd :: LHsCmd GhcPs -> ECP+ecpFromCmd a = ECP (ecpFromCmd' a)++-- The 'fbinds' parser rule produces values of this type. See Note+-- [RecordDotSyntax field updates].+type Fbind b = Either (LHsRecField GhcPs (LocatedA b)) (LHsRecProj GhcPs (LocatedA b))++-- | Disambiguate infix operators.+-- See Note [Ambiguous syntactic categories]+class DisambInfixOp b where+  mkHsVarOpPV :: LocatedN RdrName -> PV (LocatedN b)+  mkHsConOpPV :: LocatedN RdrName -> PV (LocatedN b)+  mkHsInfixHolePV :: LocatedN (HsExpr GhcPs) -> PV (LocatedN b)++instance DisambInfixOp (HsExpr GhcPs) where+  mkHsVarOpPV v = return $ L (getLoc v) (HsVar noExtField v)+  mkHsConOpPV v = return $ L (getLoc v) (HsVar noExtField v)+  mkHsInfixHolePV h = return h++instance DisambInfixOp RdrName where+  mkHsConOpPV (L l v) = return $ L l v+  mkHsVarOpPV (L l v) = return $ L l v+  mkHsInfixHolePV (L l _) = addFatalError $ mkPlainErrorMsgEnvelope (getHasLoc l) $ PsErrInvalidInfixHole++type AnnoBody b+  = ( Anno (GRHS GhcPs (LocatedA (Body b GhcPs))) ~ EpAnnCO+    , Anno [LocatedA (Match GhcPs (LocatedA (Body b GhcPs)))] ~ SrcSpanAnnL+    , Anno (Match GhcPs (LocatedA (Body b GhcPs))) ~ SrcSpanAnnA+    , Anno (StmtLR GhcPs GhcPs (LocatedA (Body (Body b GhcPs) GhcPs))) ~ SrcSpanAnnA+    , Anno [LocatedA (StmtLR GhcPs GhcPs+                       (LocatedA (Body (Body (Body b GhcPs) GhcPs) GhcPs)))] ~ SrcSpanAnnL+    )++-- | Disambiguate constructs that may appear when we do not know ahead of time whether we are+-- parsing an expression, a command, or a pattern.+-- See Note [Ambiguous syntactic categories]+class (b ~ (Body b) GhcPs, AnnoBody b) => DisambECP b where+  -- | See Note [Body in DisambECP]+  type Body b :: Type -> Type+  -- | Return a command without ambiguity, or fail in a non-command context.+  ecpFromCmd' :: LHsCmd GhcPs -> PV (LocatedA b)+  -- | Return an expression without ambiguity, or fail in a non-expression context.+  ecpFromExp' :: LHsExpr GhcPs -> PV (LocatedA b)+  mkHsProjUpdatePV :: SrcSpan -> Located [LocatedAn NoEpAnns (DotFieldOcc GhcPs)]+    -> LocatedA b -> Bool -> [AddEpAnn] -> PV (LHsRecProj GhcPs (LocatedA b))+  -- | Disambiguate "let ... in ..."+  mkHsLetPV+    :: SrcSpan+    -> EpToken "let"+    -> HsLocalBinds GhcPs+    -> EpToken "in"+    -> LocatedA b+    -> PV (LocatedA b)+  -- | Infix operator representation+  type InfixOp b+  -- | Bring superclass constraints on InfixOp into scope.+  -- See Note [UndecidableSuperClasses for associated types]+  superInfixOp+    :: (DisambInfixOp (InfixOp b) => PV (LocatedA b )) -> PV (LocatedA b)+  -- | Disambiguate "f # x" (infix operator)+  mkHsOpAppPV :: SrcSpan -> LocatedA b -> LocatedN (InfixOp b) -> LocatedA b+              -> PV (LocatedA b)+  -- | Disambiguate "case ... of ..."+  mkHsCasePV :: SrcSpan -> LHsExpr GhcPs -> (LocatedL [LMatch GhcPs (LocatedA b)])+             -> EpAnnHsCase -> PV (LocatedA b)+  -- | Disambiguate "\... -> ..." (lambda), "\case" and "\cases"+  mkHsLamPV :: SrcSpan -> HsLamVariant+            -> (LocatedL [LMatch GhcPs (LocatedA b)]) -> [AddEpAnn]+            -> PV (LocatedA b)+  -- | Function argument representation+  type FunArg b+  -- | Bring superclass constraints on FunArg into scope.+  -- See Note [UndecidableSuperClasses for associated types]+  superFunArg :: (DisambECP (FunArg b) => PV (LocatedA b)) -> PV (LocatedA b)+  -- | Disambiguate "f x" (function application)+  mkHsAppPV :: SrcSpanAnnA -> LocatedA b -> LocatedA (FunArg b) -> PV (LocatedA b)+  -- | Disambiguate "f @t" (visible type application)+  mkHsAppTypePV :: SrcSpanAnnA -> LocatedA b -> EpToken "@" -> LHsType GhcPs -> PV (LocatedA b)+  -- | Disambiguate "if ... then ... else ..."+  mkHsIfPV :: SrcSpan+         -> LHsExpr GhcPs+         -> Bool  -- semicolon?+         -> LocatedA b+         -> Bool  -- semicolon?+         -> LocatedA b+         -> AnnsIf+         -> PV (LocatedA b)+  -- | Disambiguate "do { ... }" (do notation)+  mkHsDoPV ::+    SrcSpan ->+    Maybe ModuleName ->+    LocatedL [LStmt GhcPs (LocatedA b)] ->+    AnnList ->+    PV (LocatedA b)+  -- | Disambiguate "( ... )" (parentheses)+  mkHsParPV :: SrcSpan -> EpToken "(" -> LocatedA b -> EpToken ")" -> PV (LocatedA b)+  -- | Disambiguate a variable "f" or a data constructor "MkF".+  mkHsVarPV :: LocatedN RdrName -> PV (LocatedA b)+  -- | Disambiguate a monomorphic literal+  mkHsLitPV :: Located (HsLit GhcPs) -> PV (LocatedA b)+  -- | Disambiguate an overloaded literal+  mkHsOverLitPV :: LocatedAn a (HsOverLit GhcPs) -> PV (LocatedAn a b)+  -- | Disambiguate a wildcard+  mkHsWildCardPV :: (NoAnn a) => SrcSpan -> PV (LocatedAn a b)+  -- | Disambiguate "a :: t" (type annotation)+  mkHsTySigPV+    :: SrcSpanAnnA -> LocatedA b -> LHsType GhcPs -> [AddEpAnn] -> PV (LocatedA b)+  -- | Disambiguate "[a,b,c]" (list syntax)+  mkHsExplicitListPV :: SrcSpan -> [LocatedA b] -> AnnList -> PV (LocatedA b)+  -- | Disambiguate "$(...)" and "[quasi|...|]" (TH splices)+  mkHsSplicePV :: Located (HsUntypedSplice GhcPs) -> PV (LocatedA b)+  -- | Disambiguate "f { a = b, ... }" syntax (record construction and record updates)+  mkHsRecordPV ::+    Bool -> -- Is OverloadedRecordUpdate in effect?+    SrcSpan ->+    SrcSpan ->+    LocatedA b ->+    ([Fbind b], Maybe SrcSpan) ->+    [AddEpAnn] ->+    PV (LocatedA b)+  -- | Disambiguate "-a" (negation)+  mkHsNegAppPV :: SrcSpan -> LocatedA b -> [AddEpAnn] -> PV (LocatedA b)+  -- | Disambiguate "(# a)" (right operator section)+  mkHsSectionR_PV+    :: SrcSpan -> LocatedA (InfixOp b) -> LocatedA b -> PV (LocatedA b)+  -- | Disambiguate "(a -> b)" (view pattern)+  mkHsViewPatPV+    :: SrcSpan -> LHsExpr GhcPs -> LocatedA b -> [AddEpAnn] -> PV (LocatedA b)+  -- | Disambiguate "a@b" (as-pattern)+  mkHsAsPatPV+    :: SrcSpan -> LocatedN RdrName -> EpToken "@" -> LocatedA b -> PV (LocatedA b)+  -- | Disambiguate "~a" (lazy pattern)+  mkHsLazyPatPV :: SrcSpan -> LocatedA b -> [AddEpAnn] -> PV (LocatedA b)+  -- | Disambiguate "!a" (bang pattern)+  mkHsBangPatPV :: SrcSpan -> LocatedA b -> [AddEpAnn] -> PV (LocatedA b)+  -- | Disambiguate tuple sections and unboxed sums+  mkSumOrTuplePV+    :: SrcSpanAnnA -> Boxity -> SumOrTuple b -> [AddEpAnn] -> PV (LocatedA b)+  -- | Disambiguate "type t" (embedded type)+  mkHsEmbTyPV :: SrcSpan -> EpToken "type" -> LHsType GhcPs -> PV (LocatedA b)+  -- | Validate infixexp LHS to reject unwanted {-# SCC ... #-} pragmas+  rejectPragmaPV :: LocatedA b -> PV ()++{- Note [UndecidableSuperClasses for associated types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+(This Note is about the code in GHC, not about the user code that we are parsing)++Assume we have a class C with an associated type T:++  class C a where+    type T a+    ...++If we want to add 'C (T a)' as a superclass, we need -XUndecidableSuperClasses:++  {-# LANGUAGE UndecidableSuperClasses #-}+  class C (T a) => C a where+    type T a+    ...++Unfortunately, -XUndecidableSuperClasses don't work all that well, sometimes+making GHC loop. The workaround is to bring this constraint into scope+manually with a helper method:++  class C a where+    type T a+    superT :: (C (T a) => r) -> r++In order to avoid ambiguous types, 'r' must mention 'a'.++For consistency, we use this approach for all constraints on associated types,+even when -XUndecidableSuperClasses are not required.+-}++{- Note [Body in DisambECP]+~~~~~~~~~~~~~~~~~~~~~~~~~~~+There are helper functions (mkBodyStmt, mkBindStmt, unguardedRHS, etc) that+require their argument to take a form of (body GhcPs) for some (body :: Type ->+*). To satisfy this requirement, we say that (b ~ Body b GhcPs) in the+superclass constraints of DisambECP.++The alternative is to change mkBodyStmt, mkBindStmt, unguardedRHS, etc, to drop+this requirement. It is possible and would allow removing the type index of+PatBuilder, but leads to worse type inference, breaking some code in the+typechecker.+-}++instance DisambECP (HsCmd GhcPs) where+  type Body (HsCmd GhcPs) = HsCmd+  ecpFromCmd' = return+  ecpFromExp' (L l e) = cmdFail (locA l) (ppr e)+  mkHsProjUpdatePV l _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l $+                                                 PsErrOverloadedRecordDotInvalid+  mkHsLamPV l lam_variant (L lm m) anns = do+    !cs <- getCommentsFor l+    let mg = mkLamCaseMatchGroup FromSource lam_variant (L lm m)+    return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsCmdLam anns lam_variant mg)++  mkHsLetPV l tkLet bs tkIn e = do+    !cs <- getCommentsFor l+    return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsCmdLet (tkLet, tkIn) bs e)++  type InfixOp (HsCmd GhcPs) = HsExpr GhcPs++  superInfixOp m = m++  mkHsOpAppPV l c1 op c2 = do+    let cmdArg c = L (l2l $ getLoc c) $ HsCmdTop noExtField c+    !cs <- getCommentsFor l+    return $ L (EpAnn (spanAsAnchor l) noAnn cs) $ HsCmdArrForm (AnnList Nothing Nothing Nothing [] []) (reLoc op) Infix Nothing [cmdArg c1, cmdArg c2]++  mkHsCasePV l c (L lm m) anns = do+    !cs <- getCommentsFor l+    let mg = mkMatchGroup FromSource (L lm m)+    return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsCmdCase anns c mg)++  type FunArg (HsCmd GhcPs) = HsExpr GhcPs+  superFunArg m = m+  mkHsAppPV l c e = do+    checkCmdBlockArguments c+    checkExpBlockArguments e+    return $ L l (HsCmdApp noExtField c e)+  mkHsAppTypePV l c _ t = cmdFail (locA l) (ppr c <+> text "@" <> ppr t)+  mkHsIfPV l c semi1 a semi2 b anns = do+    checkDoAndIfThenElse PsErrSemiColonsInCondCmd c semi1 a semi2 b+    !cs <- getCommentsFor l+    return $ L (EpAnn (spanAsAnchor l) noAnn cs) (mkHsCmdIf c a b anns)+  mkHsDoPV l Nothing stmts anns = do+    !cs <- getCommentsFor l+    return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsCmdDo anns stmts)+  mkHsDoPV l (Just m)    _ _ = addFatalError $ mkPlainErrorMsgEnvelope l $ PsErrQualifiedDoInCmd m+  mkHsParPV l lpar c rpar = do+    !cs <- getCommentsFor l+    return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsCmdPar (lpar, rpar) c)+  mkHsVarPV (L l v) = cmdFail (locA l) (ppr v)+  mkHsLitPV (L l a) = cmdFail l (ppr a)+  mkHsOverLitPV (L l a) = cmdFail (locA l) (ppr a)+  mkHsWildCardPV l = cmdFail l (text "_")+  mkHsTySigPV l a sig _ = cmdFail (locA l) (ppr a <+> text "::" <+> ppr sig)+  mkHsExplicitListPV l xs _ = cmdFail l $+    brackets (pprWithCommas ppr xs)+  mkHsSplicePV (L l sp) = cmdFail l (pprUntypedSplice True Nothing sp)+  mkHsRecordPV _ l _ a (fbinds, ddLoc) _ = do+    let (fs, ps) = partitionEithers fbinds+    if not (null ps)+      then addFatalError $ mkPlainErrorMsgEnvelope l $ PsErrOverloadedRecordDotInvalid+      else cmdFail l $ ppr a <+> ppr (mk_rec_fields fs ddLoc)+  mkHsNegAppPV l a _ = cmdFail l (text "-" <> ppr a)+  mkHsSectionR_PV l op c = cmdFail l $+    let pp_op = fromMaybe (panic "cannot print infix operator")+                          (ppr_infix_expr (unLoc op))+    in pp_op <> ppr c+  mkHsViewPatPV l a b _ = cmdFail l $+    ppr a <+> text "->" <+> ppr b+  mkHsAsPatPV l v _ c = cmdFail l $+    pprPrefixOcc (unLoc v) <> text "@" <> ppr c+  mkHsLazyPatPV l c _ = cmdFail l $+    text "~" <> ppr c+  mkHsBangPatPV l c _ = cmdFail l $+    text "!" <> ppr c+  mkSumOrTuplePV l boxity a _ = cmdFail (locA l) (pprSumOrTuple boxity a)+  mkHsEmbTyPV l _ ty = cmdFail l (text "type" <+> ppr ty)+  rejectPragmaPV _ = return ()++cmdFail :: SrcSpan -> SDoc -> PV a+cmdFail loc e = addFatalError $ mkPlainErrorMsgEnvelope loc $ PsErrParseErrorInCmd e++checkLamMatchGroup :: SrcSpan -> HsLamVariant -> MatchGroup GhcPs (LHsExpr GhcPs) -> PV ()+checkLamMatchGroup l LamSingle (MG { mg_alts = (L _ (matches:_))}) = do+  when (null (hsLMatchPats matches)) $ addError $ mkPlainErrorMsgEnvelope l PsErrEmptyLambda+checkLamMatchGroup _ _ _ = return ()++instance DisambECP (HsExpr GhcPs) where+  type Body (HsExpr GhcPs) = HsExpr+  ecpFromCmd' (L l c) = do+    addError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrArrowCmdInExpr c+    return (L l (hsHoleExpr noAnn))+  ecpFromExp' = return+  mkHsProjUpdatePV l fields arg isPun anns = do+    !cs <- getCommentsFor l+    return $ mkRdrProjUpdate (EpAnn (spanAsAnchor l) noAnn cs) fields arg isPun anns+  mkHsLetPV l tkLet bs tkIn c = do+    !cs <- getCommentsFor l+    return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsLet (tkLet, tkIn) bs c)+  type InfixOp (HsExpr GhcPs) = HsExpr GhcPs+  superInfixOp m = m+  mkHsOpAppPV l e1 op e2 = do+    !cs <- getCommentsFor l+    return $ L (EpAnn (spanAsAnchor l) noAnn cs) $ OpApp [] e1 (reLoc op) e2+  mkHsCasePV l e (L lm m) anns = do+    !cs <- getCommentsFor l+    let mg = mkMatchGroup FromSource (L lm m)+    return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsCase anns e mg)+  mkHsLamPV l lam_variant (L lm m) anns = do+    !cs <- getCommentsFor l+    let mg = mkLamCaseMatchGroup FromSource lam_variant (L lm m)+    checkLamMatchGroup l lam_variant mg+    return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsLam anns lam_variant mg)+  type FunArg (HsExpr GhcPs) = HsExpr GhcPs+  superFunArg m = m+  mkHsAppPV l e1 e2 = do+    checkExpBlockArguments e1+    checkExpBlockArguments e2+    return $ L l (HsApp noExtField e1 e2)+  mkHsAppTypePV l e at t = do+    checkExpBlockArguments e+    return $ L l (HsAppType at e (mkHsWildCardBndrs t))+  mkHsIfPV l c semi1 a semi2 b anns = do+    checkDoAndIfThenElse PsErrSemiColonsInCondExpr c semi1 a semi2 b+    !cs <- getCommentsFor l+    return $ L (EpAnn (spanAsAnchor l) noAnn cs) (mkHsIf c a b anns)+  mkHsDoPV l mod stmts anns = do+    !cs <- getCommentsFor l+    return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsDo anns (DoExpr mod) stmts)+  mkHsParPV l lpar e rpar = do+    !cs <- getCommentsFor l+    return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsPar (lpar, rpar) e)+  mkHsVarPV v@(L l@(EpAnn anc _ _) _) = do+    !cs <- getCommentsFor (getHasLoc l)+    return $ L (EpAnn anc noAnn cs) (HsVar noExtField v)+  mkHsLitPV (L l a) = do+    !cs <- getCommentsFor l+    return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsLit noExtField a)+  mkHsOverLitPV (L (EpAnn l an csIn) a) = do+    !cs <- getCommentsFor (locA l)+    return $ L (EpAnn  l an (cs Semi.<> csIn)) (HsOverLit NoExtField a)+  mkHsWildCardPV l = return $ L (noAnnSrcSpan l) (hsHoleExpr noAnn)+  mkHsTySigPV l@(EpAnn anc an csIn) a sig anns = do+    !cs <- getCommentsFor (locA l)+    return $ L (EpAnn anc an (csIn Semi.<> cs)) (ExprWithTySig anns a (hsTypeToHsSigWcType sig))+  mkHsExplicitListPV l xs anns = do+    !cs <- getCommentsFor l+    return $ L (EpAnn (spanAsAnchor l) noAnn cs) (ExplicitList anns xs)+  mkHsSplicePV (L l a) = do+    !cs <- getCommentsFor l+    return $ fmap (HsUntypedSplice NoExtField) (L (EpAnn (spanAsAnchor l) noAnn cs) a)+  mkHsRecordPV opts l lrec a (fbinds, ddLoc) anns = do+    !cs <- getCommentsFor l+    r <- mkRecConstrOrUpdate opts a lrec (fbinds, ddLoc) anns+    checkRecordSyntax (L (EpAnn (spanAsAnchor l) noAnn cs) r)+  mkHsNegAppPV l a anns = do+    !cs <- getCommentsFor l+    return $ L (EpAnn (spanAsAnchor l) noAnn cs) (NegApp anns a noSyntaxExpr)+  mkHsSectionR_PV l op e = do+    !cs <- getCommentsFor l+    return $ L (EpAnn (spanAsAnchor l) noAnn cs) (SectionR noExtField op e)+  mkHsViewPatPV l a b _ = addError (mkPlainErrorMsgEnvelope l $ PsErrViewPatInExpr a b)+                          >> return (L (noAnnSrcSpan l) (hsHoleExpr noAnn))+  mkHsAsPatPV l v _ e   = addError (mkPlainErrorMsgEnvelope l $ PsErrTypeAppWithoutSpace (unLoc v) e)+                          >> return (L (noAnnSrcSpan l) (hsHoleExpr noAnn))+  mkHsLazyPatPV l e   _ = addError (mkPlainErrorMsgEnvelope l $ PsErrLazyPatWithoutSpace e)+                          >> return (L (noAnnSrcSpan l) (hsHoleExpr noAnn))+  mkHsBangPatPV l e   _ = addError (mkPlainErrorMsgEnvelope l $ PsErrBangPatWithoutSpace e)+                          >> return (L (noAnnSrcSpan l) (hsHoleExpr noAnn))+  mkSumOrTuplePV = mkSumOrTupleExpr+  mkHsEmbTyPV l toktype ty =+    return $ L (noAnnSrcSpan l) $+      HsEmbTy toktype (mkHsWildCardBndrs ty)+  rejectPragmaPV (L _ (OpApp _ _ _ e)) =+    -- assuming left-associative parsing of operators+    rejectPragmaPV e+  rejectPragmaPV (L l (HsPragE _ prag _)) = addError $ mkPlainErrorMsgEnvelope (locA l) $+                                                         (PsErrUnallowedPragma prag)+  rejectPragmaPV _                        = return ()++hsHoleExpr :: Maybe EpAnnUnboundVar -> HsExpr GhcPs+hsHoleExpr anns = HsUnboundVar anns (mkRdrUnqual (mkVarOccFS (fsLit "_")))++instance DisambECP (PatBuilder GhcPs) where+  type Body (PatBuilder GhcPs) = PatBuilder+  ecpFromCmd' (L l c)    = addFatalError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrArrowCmdInPat c+  ecpFromExp' (L l e)    = addFatalError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrArrowExprInPat e+  mkHsLetPV l _ _ _ _    = addFatalError $ mkPlainErrorMsgEnvelope l PsErrLetInPat+  mkHsProjUpdatePV l _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrOverloadedRecordDotInvalid+  type InfixOp (PatBuilder GhcPs) = RdrName+  superInfixOp m = m+  mkHsOpAppPV l p1 op p2 = do+    !cs <- getCommentsFor l+    return $ L (EpAnn (spanAsAnchor l) noAnn cs) $ PatBuilderOpApp p1 op p2 []++  mkHsLamPV l lam_variant _ _     = addFatalError $ mkPlainErrorMsgEnvelope l (PsErrLambdaInPat lam_variant)++  mkHsCasePV l _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrCaseInPat+  type FunArg (PatBuilder GhcPs) = PatBuilder GhcPs+  superFunArg m = m+  mkHsAppPV l p1 p2      = return $ L l (PatBuilderApp p1 p2)+  mkHsAppTypePV l p at t = do+    !cs <- getCommentsFor (locA l)+    return $ L (addCommentsToEpAnn l cs) (PatBuilderAppType p at (mkHsTyPat t))+  mkHsIfPV l _ _ _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrIfThenElseInPat+  mkHsDoPV l _ _ _       = addFatalError $ mkPlainErrorMsgEnvelope l PsErrDoNotationInPat+  mkHsParPV l lpar p rpar   = return $ L (noAnnSrcSpan l) (PatBuilderPar lpar p rpar)+  mkHsVarPV v@(getLoc -> l) = return $ L (l2l l) (PatBuilderVar v)+  mkHsLitPV lit@(L l a) = do+    checkUnboxedLitPat lit+    !cs <- getCommentsFor l+    return $ L (EpAnn (spanAsAnchor l) noAnn cs) (PatBuilderPat (LitPat noExtField a))+  mkHsOverLitPV (L l a) = return $ L l (PatBuilderOverLit a)+  mkHsWildCardPV l = return $ L (noAnnSrcSpan l) (PatBuilderPat (WildPat noExtField))+  mkHsTySigPV l b sig anns = do+    p <- checkLPat b+    return $ L l (PatBuilderPat (SigPat anns p (mkHsPatSigType noAnn sig)))+  mkHsExplicitListPV l xs anns = do+    ps <- traverse checkLPat xs+    !cs <- getCommentsFor l+    return (L (EpAnn (spanAsAnchor l) noAnn cs) (PatBuilderPat (ListPat anns ps)))+  mkHsSplicePV (L l sp) = do+    !cs <- getCommentsFor l+    return $ L (EpAnn (spanAsAnchor l) noAnn cs) (PatBuilderPat (SplicePat noExtField sp))+  mkHsRecordPV _ l _ a (fbinds, ddLoc) anns = do+    let (fs, ps) = partitionEithers fbinds+    if not (null ps)+     then addFatalError $ mkPlainErrorMsgEnvelope l PsErrOverloadedRecordDotInvalid+     else do+       !cs <- getCommentsFor l+       r <- mkPatRec a (mk_rec_fields fs ddLoc) anns+       checkRecordSyntax (L (EpAnn (spanAsAnchor l) noAnn cs) r)+  mkHsNegAppPV l (L lp p) anns = do+    lit <- case p of+      PatBuilderOverLit pos_lit -> return (L (l2l lp) pos_lit)+      _ -> patFail l $ PsErrInPat p PEIP_NegApp+    !cs <- getCommentsFor l+    return $ L (EpAnn (spanAsAnchor l) noAnn cs) (PatBuilderPat (mkNPat lit (Just noSyntaxExpr) anns))+  mkHsSectionR_PV l op p = patFail l (PsErrParseRightOpSectionInPat (unLoc op) (unLoc p))+  mkHsViewPatPV l a b anns = do+    p <- checkLPat b+    !cs <- getCommentsFor l+    return $ L (EpAnn (spanAsAnchor l) noAnn cs) (PatBuilderPat (ViewPat anns a p))+  mkHsAsPatPV l v at e = do+    p <- checkLPat e+    !cs <- getCommentsFor l+    return $ L (EpAnn (spanAsAnchor l) noAnn cs) (PatBuilderPat (AsPat at v p))+  mkHsLazyPatPV l e a = do+    p <- checkLPat e+    !cs <- getCommentsFor l+    return $ L (EpAnn (spanAsAnchor l) noAnn cs) (PatBuilderPat (LazyPat a p))+  mkHsBangPatPV l e an = do+    p <- checkLPat e+    !cs <- getCommentsFor l+    let pb = BangPat an p+    hintBangPat l pb+    return $ L (EpAnn (spanAsAnchor l) noAnn cs) (PatBuilderPat pb)+  mkSumOrTuplePV = mkSumOrTuplePat+  mkHsEmbTyPV l toktype ty =+    return $ L (noAnnSrcSpan l) $+      PatBuilderPat (EmbTyPat toktype (mkHsTyPat ty))+  rejectPragmaPV _ = return ()++-- | Ensure that a literal pattern isn't of type Addr#, Float#, Double#.+checkUnboxedLitPat :: Located (HsLit GhcPs) -> PV ()+checkUnboxedLitPat (L loc lit) =+  case lit of+    -- Don't allow primitive string literal patterns.+    -- See #13260.+    HsStringPrim {}+      -> addError $ mkPlainErrorMsgEnvelope loc $+                           (PsErrIllegalUnboxedStringInPat lit)++   -- Don't allow Float#/Double# literal patterns.+   -- See #9238 and Note [Rules for floating-point comparisons]+   -- in GHC.Core.Opt.ConstantFold.+    _ | is_floating_lit lit+      -> addError $ mkPlainErrorMsgEnvelope loc $+                           (PsErrIllegalUnboxedFloatingLitInPat lit)++      | otherwise+      -> return ()++  where+    is_floating_lit :: HsLit GhcPs -> Bool+    is_floating_lit (HsFloatPrim  {}) = True+    is_floating_lit (HsDoublePrim {}) = True+    is_floating_lit _                 = False++mkPatRec ::+  LocatedA (PatBuilder GhcPs) ->+  HsRecFields GhcPs (LocatedA (PatBuilder GhcPs)) ->+  [AddEpAnn] ->+  PV (PatBuilder GhcPs)+mkPatRec (unLoc -> PatBuilderVar c) (HsRecFields fs dd) anns+  | isRdrDataCon (unLoc c)+  = do fs <- mapM checkPatField fs+       return $ PatBuilderPat $ ConPat+         { pat_con_ext = anns+         , pat_con = c+         , pat_args = RecCon (HsRecFields fs dd)+         }+mkPatRec p _ _ =+  addFatalError $ mkPlainErrorMsgEnvelope (getLocA p) $+                    (PsErrInvalidRecordCon (unLoc p))++-- | Disambiguate constructs that may appear when we do not know+-- ahead of time whether we are parsing a type or a newtype/data constructor.+--+-- See Note [Ambiguous syntactic categories] for the general idea.+--+-- See Note [Parsing data constructors is hard] for the specific issue this+-- particular class is solving.+--+class DisambTD b where+  -- | Process the head of a type-level function/constructor application,+  -- i.e. the @H@ in @H a b c@.+  mkHsAppTyHeadPV :: LHsType GhcPs -> PV (LocatedA b)+  -- | Disambiguate @f x@ (function application or prefix data constructor).+  mkHsAppTyPV :: LocatedA b -> LHsType GhcPs -> PV (LocatedA b)+  -- | Disambiguate @f \@t@ (visible kind application)+  mkHsAppKindTyPV :: LocatedA b -> EpToken "@" -> LHsType GhcPs -> PV (LocatedA b)+  -- | Disambiguate @f \# x@ (infix operator)+  mkHsOpTyPV :: PromotionFlag -> LHsType GhcPs -> LocatedN RdrName -> LHsType GhcPs -> PV (LocatedA b)+  -- | Disambiguate @{-\# UNPACK \#-} t@ (unpack/nounpack pragma)+  mkUnpackednessPV :: Located UnpackednessPragma -> LocatedA b -> PV (LocatedA b)++instance DisambTD (HsType GhcPs) where+  mkHsAppTyHeadPV = return+  mkHsAppTyPV t1 t2 = return (mkHsAppTy t1 t2)+  mkHsAppKindTyPV t at ki = return (mkHsAppKindTy at t ki)+  mkHsOpTyPV prom t1 op t2 = do+    let (L l ty) = mkLHsOpTy prom t1 op t2+    !cs <- getCommentsFor (locA l)+    return (L (addCommentsToEpAnn l cs) ty)+  mkUnpackednessPV = addUnpackednessP++dataConBuilderCon :: LocatedA DataConBuilder -> LocatedN RdrName+dataConBuilderCon (L _ (PrefixDataConBuilder _ dc)) = dc+dataConBuilderCon (L _ (InfixDataConBuilder _ dc _)) = dc++dataConBuilderDetails :: LocatedA DataConBuilder -> HsConDeclH98Details GhcPs++-- Detect when the record syntax is used:+--   data T = MkT { ... }+dataConBuilderDetails (L _ (PrefixDataConBuilder flds _))+  | [L (EpAnn anc _ cs) (HsRecTy an fields)] <- toList flds+  = RecCon (L (EpAnn anc an cs) fields)++-- Normal prefix constructor, e.g.  data T = MkT A B C+dataConBuilderDetails (L _ (PrefixDataConBuilder flds _))+  = PrefixCon noTypeArgs (map hsLinear (toList flds))++-- Infix constructor, e.g. data T = Int :! Bool+dataConBuilderDetails (L (EpAnn _ _ csl) (InfixDataConBuilder (L (EpAnn anc ann csll) lhs) _ rhs))+  = InfixCon (hsLinear (L (EpAnn anc ann (csl Semi.<> csll)) lhs)) (hsLinear rhs)+++instance DisambTD DataConBuilder where+  mkHsAppTyHeadPV = tyToDataConBuilder++  mkHsAppTyPV (L l (PrefixDataConBuilder flds fn)) t =+    return $+      L (noAnnSrcSpan $ combineSrcSpans (locA l) (getLocA t))+        (PrefixDataConBuilder (flds `snocOL` t) fn)+  mkHsAppTyPV (L _ InfixDataConBuilder{}) _ =+    -- This case is impossible because of the way+    -- the grammar in Parser.y is written (see infixtype/ftype).+    panic "mkHsAppTyPV: InfixDataConBuilder"++  mkHsAppKindTyPV lhs at ki =+    addFatalError $ mkPlainErrorMsgEnvelope (getEpTokenSrcSpan at) $+                      (PsErrUnexpectedKindAppInDataCon (unLoc lhs) (unLoc ki))++  mkHsOpTyPV prom lhs tc rhs = do+      check_no_ops (unLoc rhs)  -- check the RHS because parsing type operators is right-associative+      data_con <- eitherToP $ tyConToDataCon tc+      !cs <- getCommentsFor (locA l)+      checkNotPromotedDataCon prom data_con+      return $ L (addCommentsToEpAnn l cs) (InfixDataConBuilder lhs data_con rhs)+    where+      l = combineLocsA lhs rhs+      check_no_ops (HsBangTy _ _ t) = check_no_ops (unLoc t)+      check_no_ops (HsOpTy{}) =+        addError $ mkPlainErrorMsgEnvelope (locA l) $+                     (PsErrInvalidInfixDataCon (unLoc lhs) (unLoc tc) (unLoc rhs))+      check_no_ops _ = return ()++  mkUnpackednessPV unpk constr_stuff+    | L _ (InfixDataConBuilder lhs data_con rhs) <- constr_stuff+    = -- When the user writes  data T = {-# UNPACK #-} Int :+ Bool+      --   we apply {-# UNPACK #-} to the LHS+      do lhs' <- addUnpackednessP unpk lhs+         let l = combineLocsA (reLoc unpk) constr_stuff+         return $ L l (InfixDataConBuilder lhs' data_con rhs)+    | otherwise =+      do addError $ mkPlainErrorMsgEnvelope (getLoc unpk) PsErrUnpackDataCon+         return constr_stuff++tyToDataConBuilder :: LHsType GhcPs -> PV (LocatedA DataConBuilder)+tyToDataConBuilder (L l (HsTyVar _ prom v)) = do+  data_con <- eitherToP $ tyConToDataCon v+  checkNotPromotedDataCon prom data_con+  return $ L l (PrefixDataConBuilder nilOL data_con)+tyToDataConBuilder (L l (HsTupleTy _ HsBoxedOrConstraintTuple ts)) = do+  let data_con = L (l2l l) (getRdrName (tupleDataCon Boxed (length ts)))+  return $ L l (PrefixDataConBuilder (toOL ts) data_con)+tyToDataConBuilder (L l (HsTupleTy _ HsUnboxedTuple ts)) = do+  let data_con = L (l2l l) (getRdrName (tupleDataCon Unboxed (length ts)))+  return $ L l (PrefixDataConBuilder (toOL ts) data_con)+tyToDataConBuilder t =+  addFatalError $ mkPlainErrorMsgEnvelope (getLocA t) $+                    (PsErrInvalidDataCon (unLoc t))++-- | Rejects declarations such as @data T = 'MkT@ (note the leading tick).+checkNotPromotedDataCon :: PromotionFlag -> LocatedN RdrName -> PV ()+checkNotPromotedDataCon NotPromoted _ = return ()+checkNotPromotedDataCon IsPromoted (L l name) =+  addError $ mkPlainErrorMsgEnvelope (locA l) $+    PsErrIllegalPromotionQuoteDataCon name++mkUnboxedSumCon :: LHsType GhcPs -> ConTag -> Arity -> (LocatedN RdrName, HsConDeclH98Details GhcPs)+mkUnboxedSumCon t tag arity =+  (noLocA (getRdrName (sumDataCon tag arity)), PrefixCon noTypeArgs [hsLinear t])++{- Note [Ambiguous syntactic categories]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+There are places in the grammar where we do not know whether we are parsing an+expression or a pattern without unlimited lookahead (which we do not have in+'happy'):++View patterns:++    f (Con a b     ) = ...  -- 'Con a b' is a pattern+    f (Con a b -> x) = ...  -- 'Con a b' is an expression++do-notation:++    do { Con a b <- x } -- 'Con a b' is a pattern+    do { Con a b }      -- 'Con a b' is an expression++Guards:++    x | True <- p && q = ...  -- 'True' is a pattern+    x | True           = ...  -- 'True' is an expression++Top-level value/function declarations (FunBind/PatBind):++    f ! a         -- TH splice+    f ! a = ...   -- function declaration++    Until we encounter the = sign, we don't know if it's a top-level+    TemplateHaskell splice where ! is used, or if it's a function declaration+    where ! is bound.++There are also places in the grammar where we do not know whether we are+parsing an expression or a command:++    proc x -> do { (stuff) -< x }   -- 'stuff' is an expression+    proc x -> do { (stuff) }        -- 'stuff' is a command++    Until we encounter arrow syntax (-<) we don't know whether to parse 'stuff'+    as an expression or a command.++In fact, do-notation is subject to both ambiguities:++    proc x -> do { (stuff) -< x }        -- 'stuff' is an expression+    proc x -> do { (stuff) <- f -< x }   -- 'stuff' is a pattern+    proc x -> do { (stuff) }             -- 'stuff' is a command++There are many possible solutions to this problem. For an overview of the ones+we decided against, see Note [Resolving parsing ambiguities: non-taken alternatives]++The solution that keeps basic definitions (such as HsExpr) clean, keeps the+concerns local to the parser, and does not require duplication of hsSyn types,+or an extra pass over the entire AST, is to parse into an overloaded+parser-validator (a so-called tagless final encoding):++    class DisambECP b where ...+    instance DisambECP (HsCmd GhcPs) where ...+    instance DisambECP (HsExp GhcPs) where ...+    instance DisambECP (PatBuilder GhcPs) where ...++The 'DisambECP' class contains functions to build and validate 'b'. For example,+to add parentheses we have:++  mkHsParPV :: DisambECP b => SrcSpan -> Located b -> PV (Located b)++'mkHsParPV' will wrap the inner value in HsCmdPar for commands, HsPar for+expressions, and 'PatBuilderPar' for patterns (later transformed into ParPat,+see Note [PatBuilder]).++Consider the 'alts' production used to parse case-of alternatives:++  alts :: { Located ([AddEpAnn],[LMatch GhcPs (LHsExpr GhcPs)]) }+    : alts1     { sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }+    | ';' alts  { sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) }++We abstract over LHsExpr GhcPs, and it becomes:++  alts :: { forall b. DisambECP b => PV (Located ([AddEpAnn],[LMatch GhcPs (Located b)])) }+    : alts1     { $1 >>= \ $1 ->+                  return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }+    | ';' alts  { $2 >>= \ $2 ->+                  return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) }++Compared to the initial definition, the added bits are:++    forall b. DisambECP b => PV ( ... ) -- in the type signature+    $1 >>= \ $1 -> return $             -- in one reduction rule+    $2 >>= \ $2 -> return $             -- in another reduction rule++The overhead is constant relative to the size of the rest of the reduction+rule, so this approach scales well to large parser productions.++Note that we write ($1 >>= \ $1 -> ...), so the second $1 is in a binding+position and shadows the previous $1. We can do this because internally+'happy' desugars $n to happy_var_n, and the rationale behind this idiom+is to be able to write (sLL $1 $>) later on. The alternative would be to+write this as ($1 >>= \ fresh_name -> ...), but then we couldn't refer+to the last fresh name as $>.++Finally, we instantiate the polymorphic type to a concrete one, and run the+parser-validator, for example:++    stmt   :: { forall b. DisambECP b => PV (LStmt GhcPs (Located b)) }+    e_stmt :: { LStmt GhcPs (LHsExpr GhcPs) }+            : stmt {% runPV $1 }++In e_stmt, three things happen:++  1. we instantiate: b ~ HsExpr GhcPs+  2. we embed the PV computation into P by using runPV+  3. we run validation by using a monadic production, {% ... }++At this point the ambiguity is resolved.+-}+++{- Note [Resolving parsing ambiguities: non-taken alternatives]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Alternative I, extra constructors in GHC.Hs.Expr+------------------------------------------------+We could add extra constructors to HsExpr to represent command-specific and+pattern-specific syntactic constructs. Under this scheme, we parse patterns+and commands as expressions and rejig later.  This is what GHC used to do, and+it polluted 'HsExpr' with irrelevant constructors:++  * for commands: 'HsArrForm', 'HsArrApp'+  * for patterns: 'EWildPat', 'EAsPat', 'EViewPat', 'ELazyPat'++(As of now, we still do that for patterns, but we plan to fix it).++There are several issues with this:++  * The implementation details of parsing are leaking into hsSyn definitions.++  * Code that uses HsExpr has to panic on these impossible-after-parsing cases.++  * HsExpr is arbitrarily selected as the extension basis. Why not extend+    HsCmd or HsPat with extra constructors instead?++Alternative II, extra constructors in GHC.Hs.Expr for GhcPs+-----------------------------------------------------------+We could address some of the problems with Alternative I by using Trees That+Grow and extending HsExpr only in the GhcPs pass. However, GhcPs corresponds to+the output of parsing, not to its intermediate results, so we wouldn't want+them there either.++Alternative III, extra constructors in GHC.Hs.Expr for GhcPrePs+---------------------------------------------------------------+We could introduce a new pass, GhcPrePs, to keep GhcPs pristine.+Unfortunately, creating a new pass would significantly bloat conversion code+and slow down the compiler by adding another linear-time pass over the entire+AST. For example, in order to build HsExpr GhcPrePs, we would need to build+HsLocalBinds GhcPrePs (as part of HsLet), and we never want HsLocalBinds+GhcPrePs.+++Alternative IV, sum type and bottom-up data flow+------------------------------------------------+Expressions and commands are disjoint. There are no user inputs that could be+interpreted as either an expression or a command depending on outer context:++  5        -- definitely an expression+  x -< y   -- definitely a command++Even though we have both 'HsLam' and 'HsCmdLam', we can look at+the body to disambiguate:++  \p -> 5        -- definitely an expression+  \p -> x -< y   -- definitely a command++This means we could use a bottom-up flow of information to determine+whether we are parsing an expression or a command, using a sum type+for intermediate results:++  Either (LHsExpr GhcPs) (LHsCmd GhcPs)++There are two problems with this:++  * We cannot handle the ambiguity between expressions and+    patterns, which are not disjoint.++  * Bottom-up flow of information leads to poor error messages. Consider++        if ... then 5 else (x -< y)++    Do we report that '5' is not a valid command or that (x -< y) is not a+    valid expression?  It depends on whether we want the entire node to be+    'HsIf' or 'HsCmdIf', and this information flows top-down, from the+    surrounding parsing context (are we in 'proc'?)++Alternative V, backtracking with parser combinators+---------------------------------------------------+One might think we could sidestep the issue entirely by using a backtracking+parser and doing something along the lines of (try pExpr <|> pPat).++Turns out, this wouldn't work very well, as there can be patterns inside+expressions (e.g. via 'case', 'let', 'do') and expressions inside patterns+(e.g. view patterns). To handle this, we would need to backtrack while+backtracking, and unbound levels of backtracking lead to very fragile+performance.++Alternative VI, an intermediate data type+-----------------------------------------+There are common syntactic elements of expressions, commands, and patterns+(e.g. all of them must have balanced parentheses), and we can capture this+common structure in an intermediate data type, Frame:++data Frame+  = FrameVar RdrName+    -- ^ Identifier: Just, map, BS.length+  | FrameTuple [LTupArgFrame] Boxity+    -- ^ Tuple (section): (a,b) (a,b,c) (a,,) (,a,)+  | FrameTySig LFrame (LHsSigWcType GhcPs)+    -- ^ Type signature: x :: ty+  | FramePar (SrcSpan, SrcSpan) LFrame+    -- ^ Parentheses+  | FrameIf LFrame LFrame LFrame+    -- ^ If-expression: if p then x else y+  | FrameCase LFrame [LFrameMatch]+    -- ^ Case-expression: case x of { p1 -> e1; p2 -> e2 }+  | FrameDo HsStmtContextRn [LFrameStmt]+    -- ^ Do-expression: do { s1; a <- s2; s3 }+  ...+  | FrameExpr (HsExpr GhcPs)   -- unambiguously an expression+  | FramePat (HsPat GhcPs)     -- unambiguously a pattern+  | FrameCommand (HsCmd GhcPs) -- unambiguously a command++To determine which constructors 'Frame' needs to have, we take the union of+intersections between HsExpr, HsCmd, and HsPat.++The intersection between HsPat and HsExpr:++  HsPat  =  VarPat   | TuplePat      | SigPat        | ParPat   | ...+  HsExpr =  HsVar    | ExplicitTuple | ExprWithTySig | HsPar    | ...+  -------------------------------------------------------------------+  Frame  =  FrameVar | FrameTuple    | FrameTySig    | FramePar | ...++The intersection between HsCmd and HsExpr:++  HsCmd  = HsCmdIf | HsCmdCase | HsCmdDo | HsCmdPar+  HsExpr = HsIf    | HsCase    | HsDo    | HsPar+  ------------------------------------------------+  Frame = FrameIf  | FrameCase | FrameDo | FramePar++The intersection between HsCmd and HsPat:++  HsPat  = ParPat   | ...+  HsCmd  = HsCmdPar | ...+  -----------------------+  Frame  = FramePar | ...++Take the union of each intersection and this yields the final 'Frame' data+type. The problem with this approach is that we end up duplicating a good+portion of hsSyn:++    Frame         for  HsExpr, HsPat, HsCmd+    TupArgFrame   for  HsTupArg+    FrameMatch    for  Match+    FrameStmt     for  StmtLR+    FrameGRHS     for  GRHS+    FrameGRHSs    for  GRHSs+    ...++Alternative VII, a product type+-------------------------------+We could avoid the intermediate representation of Alternative VI by parsing+into a product of interpretations directly:++    type ExpCmdPat = ( PV (LHsExpr GhcPs)+                     , PV (LHsCmd GhcPs)+                     , PV (LHsPat GhcPs) )++This means that in positions where we do not know whether to produce+expression, a pattern, or a command, we instead produce a parser-validator for+each possible option.++Then, as soon as we have parsed far enough to resolve the ambiguity, we pick+the appropriate component of the product, discarding the rest:++    checkExpOf3 (e, _, _) = e  -- interpret as an expression+    checkCmdOf3 (_, c, _) = c  -- interpret as a command+    checkPatOf3 (_, _, p) = p  -- interpret as a pattern++We can easily define ambiguities between arbitrary subsets of interpretations.+For example, when we know ahead of type that only an expression or a command is+possible, but not a pattern, we can use a smaller type:++    type ExpCmd = (PV (LHsExpr GhcPs), PV (LHsCmd GhcPs))++    checkExpOf2 (e, _) = e  -- interpret as an expression+    checkCmdOf2 (_, c) = c  -- interpret as a command++However, there is a slight problem with this approach, namely code duplication+in parser productions. Consider the 'alts' production used to parse case-of+alternatives:++  alts :: { Located ([AddEpAnn],[LMatch GhcPs (LHsExpr GhcPs)]) }+    : alts1     { sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }+    | ';' alts  { sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) }++Under the new scheme, we have to completely duplicate its type signature and+each reduction rule:++  alts :: { ( PV (Located ([AddEpAnn],[LMatch GhcPs (LHsExpr GhcPs)])) -- as an expression+            , PV (Located ([AddEpAnn],[LMatch GhcPs (LHsCmd GhcPs)]))  -- as a command+            ) }+    : alts1+        { ( checkExpOf2 $1 >>= \ $1 ->+            return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1)+          , checkCmdOf2 $1 >>= \ $1 ->+            return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1)+          ) }+    | ';' alts+        { ( checkExpOf2 $2 >>= \ $2 ->+            return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2)+          , checkCmdOf2 $2 >>= \ $2 ->+            return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2)+          ) }++And the same goes for other productions: 'altslist', 'alts1', 'alt', 'alt_rhs',+'ralt', 'gdpats', 'gdpat', 'exp', ... and so on. That is a lot of code!++Alternative VIII, a function from a GADT+----------------------------------------+We could avoid code duplication of the Alternative VII by representing the product+as a function from a GADT:++    data ExpCmdG b where+      ExpG :: ExpCmdG HsExpr+      CmdG :: ExpCmdG HsCmd++    type ExpCmd = forall b. ExpCmdG b -> PV (Located (b GhcPs))++    checkExp :: ExpCmd -> PV (LHsExpr GhcPs)+    checkCmd :: ExpCmd -> PV (LHsCmd GhcPs)+    checkExp f = f ExpG  -- interpret as an expression+    checkCmd f = f CmdG  -- interpret as a command++Consider the 'alts' production used to parse case-of alternatives:++  alts :: { Located ([AddEpAnn],[LMatch GhcPs (LHsExpr GhcPs)]) }+    : alts1     { sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }+    | ';' alts  { sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) }++We abstract over LHsExpr, and it becomes:++  alts :: { forall b. ExpCmdG b -> PV (Located ([AddEpAnn],[LMatch GhcPs (Located (b GhcPs))])) }+    : alts1+        { \tag -> $1 tag >>= \ $1 ->+                  return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }+    | ';' alts+        { \tag -> $2 tag >>= \ $2 ->+                  return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) }++Note that 'ExpCmdG' is a singleton type, the value is completely+determined by the type:++  when (b~HsExpr),  tag = ExpG+  when (b~HsCmd),   tag = CmdG++This is a clear indication that we can use a class to pass this value behind+the scenes:++  class    ExpCmdI b      where expCmdG :: ExpCmdG b+  instance ExpCmdI HsExpr where expCmdG = ExpG+  instance ExpCmdI HsCmd  where expCmdG = CmdG++And now the 'alts' production is simplified, as we no longer need to+thread 'tag' explicitly:++  alts :: { forall b. ExpCmdI b => PV (Located ([AddEpAnn],[LMatch GhcPs (Located (b GhcPs))])) }+    : alts1     { $1 >>= \ $1 ->+                  return $ sL1 $1 (fst $ unLoc $1,snd $ unLoc $1) }+    | ';' alts  { $2 >>= \ $2 ->+                  return $ sLL $1 $> ((mj AnnSemi $1:(fst $ unLoc $2)),snd $ unLoc $2) }++This encoding works well enough, but introduces an extra GADT unlike the+tagless final encoding, and there's no need for this complexity.++-}++{- Note [PatBuilder]+~~~~~~~~~~~~~~~~~~~~+Unlike HsExpr or HsCmd, the Pat type cannot accommodate all intermediate forms,+so we introduce the notion of a PatBuilder.++Consider a pattern like this:++  Con a b c++We parse arguments to "Con" one at a time in the  fexp aexp  parser production,+building the result with mkHsAppPV, so the intermediate forms are:++  1. Con+  2. Con a+  3. Con a b+  4. Con a b c++In 'HsExpr', we have 'HsApp', so the intermediate forms are represented like+this (pseudocode):++  1. "Con"+  2. HsApp "Con" "a"+  3. HsApp (HsApp "Con" "a") "b"+  3. HsApp (HsApp (HsApp "Con" "a") "b") "c"++Similarly, in 'HsCmd' we have 'HsCmdApp'. In 'Pat', however, what we have+instead is 'ConPatIn', which is very awkward to modify and thus unsuitable for+the intermediate forms.++We also need an intermediate representation to postpone disambiguation between+FunBind and PatBind. Consider:++  a `Con` b = ...+  a `fun` b = ...++How do we know that (a `Con` b) is a PatBind but (a `fun` b) is a FunBind? We+learn this by inspecting an intermediate representation in 'isFunLhs' and+seeing that 'Con' is a data constructor but 'f' is not. We need an intermediate+representation capable of representing both a FunBind and a PatBind, so Pat is+insufficient.++PatBuilder is an extension of Pat that is capable of representing intermediate+parsing results for patterns and function bindings:++  data PatBuilder p+    = PatBuilderPat (Pat p)+    | PatBuilderApp (LocatedA (PatBuilder p)) (LocatedA (PatBuilder p))+    | PatBuilderOpApp (LocatedA (PatBuilder p)) (LocatedA RdrName) (LocatedA (PatBuilder p))+    ...++It can represent any pattern via 'PatBuilderPat', but it also has a variety of+other constructors which were added by following a simple principle: we never+pattern match on the pattern stored inside 'PatBuilderPat'.+-}++---------------------------------------------------------------------------+-- Miscellaneous utilities++-- | Check if a fixity is valid. We support bypassing the usual bound checks+-- for some special operators.+checkPrecP+        :: Located (SourceText,Int)              -- ^ precedence+        -> Located (OrdList (LocatedN RdrName))  -- ^ operators+        -> P ()+checkPrecP (L l (_,i)) (L _ ol)+ | 0 <= i, i <= maxPrecedence = pure ()+ | all specialOp ol = pure ()+ | otherwise = addFatalError $ mkPlainErrorMsgEnvelope l (PsErrPrecedenceOutOfRange i)+  where+    -- If you change this, consider updating Note [Fixity of (->)] in GHC/Types.hs+    specialOp op = unLoc op == getRdrName unrestrictedFunTyCon++mkRecConstrOrUpdate+        :: Bool+        -> LHsExpr GhcPs+        -> SrcSpan+        -> ([Fbind (HsExpr GhcPs)], Maybe SrcSpan)+        -> [AddEpAnn]+        -> PV (HsExpr GhcPs)+mkRecConstrOrUpdate _ (L _ (HsVar _ (L l c))) _lrec (fbinds,dd) anns+  | isRdrDataCon c+  = do+      let (fs, ps) = partitionEithers fbinds+      case ps of+          p:_ -> addFatalError $ mkPlainErrorMsgEnvelope (getLocA p) $+              PsErrOverloadedRecordDotInvalid+          _ -> return (mkRdrRecordCon (L l c) (mk_rec_fields fs dd) anns)+mkRecConstrOrUpdate overloaded_update exp _ (fs,dd) anns+  | Just dd_loc <- dd = addFatalError $ mkPlainErrorMsgEnvelope dd_loc $+                                          PsErrDotsInRecordUpdate+  | otherwise = mkRdrRecordUpd overloaded_update exp fs anns++mkRdrRecordUpd :: Bool -> LHsExpr GhcPs -> [Fbind (HsExpr GhcPs)] -> [AddEpAnn] -> PV (HsExpr GhcPs)+mkRdrRecordUpd overloaded_on exp@(L loc _) fbinds anns = do+  -- We do not need to know if OverloadedRecordDot is in effect. We do+  -- however need to know if OverloadedRecordUpdate (passed in+  -- overloaded_on) is in effect because it affects the Left/Right nature+  -- of the RecordUpd value we calculate.+  let (fs, ps) = partitionEithers fbinds+      fs' :: [LHsRecUpdField GhcPs GhcPs]+      fs' = map (fmap mk_rec_upd_field) fs+  case overloaded_on of+    False | not $ null ps ->+      -- A '.' was found in an update and OverloadedRecordUpdate isn't on.+      addFatalError $ mkPlainErrorMsgEnvelope (locA loc) PsErrOverloadedRecordUpdateNotEnabled+    False ->+      -- This is just a regular record update.+      return RecordUpd {+        rupd_ext = anns+      , rupd_expr = exp+      , rupd_flds =+          RegularRecUpdFields+            { xRecUpdFields = noExtField+            , recUpdFields  = fs' } }+    -- This is a RecordDotSyntax update.+    True -> do+      let qualifiedFields =+            [ L l lbl | L _ (HsFieldBind _ (L l lbl) _ _) <- fs'+                      , isQual . ambiguousFieldOccRdrName $ lbl+            ]+      case qualifiedFields of+          qf:_ -> addFatalError $ mkPlainErrorMsgEnvelope (getLocA qf) $+                  PsErrOverloadedRecordUpdateNoQualifiedFields+          _ -> return $+               RecordUpd+                { rupd_ext = anns+                , rupd_expr = exp+                , rupd_flds =+                   OverloadedRecUpdFields+                     { xOLRecUpdFields = noExtField+                     , olRecUpdFields  = toProjUpdates fbinds } }+  where+    toProjUpdates :: [Fbind (HsExpr GhcPs)] -> [LHsRecUpdProj GhcPs]+    toProjUpdates = map (\case { Right p -> p; Left f -> recFieldToProjUpdate f })++    -- Convert a top-level field update like {foo=2} or {bar} (punned)+    -- to a projection update.+    recFieldToProjUpdate :: LHsRecField GhcPs  (LHsExpr GhcPs) -> LHsRecUpdProj GhcPs+    recFieldToProjUpdate (L l (HsFieldBind anns (L _ (FieldOcc _ (L loc rdr))) arg pun)) =+        -- The idea here is to convert the label to a singleton [FastString].+        let f = occNameFS . rdrNameOcc $ rdr+            fl = DotFieldOcc noAnn (L loc (FieldLabelString f))+            lf = locA loc+        in mkRdrProjUpdate l (L lf [L (l2l loc) fl]) (punnedVar f) pun anns+        where+          -- If punning, compute HsVar "f" otherwise just arg. This+          -- has the effect that sentinel HsVar "pun-rhs" is replaced+          -- by HsVar "f" here, before the update is written to a+          -- setField expressions.+          punnedVar :: FastString -> LHsExpr GhcPs+          punnedVar f  = if not pun then arg else noLocA . HsVar noExtField . noLocA . mkRdrUnqual . mkVarOccFS $ f++mkRdrRecordCon+  :: LocatedN RdrName -> HsRecordBinds GhcPs -> [AddEpAnn] -> HsExpr GhcPs+mkRdrRecordCon con flds anns+  = RecordCon { rcon_ext = anns, rcon_con = con, rcon_flds = flds }++mk_rec_fields :: [LocatedA (HsRecField (GhcPass p) arg)] -> Maybe SrcSpan -> HsRecFields (GhcPass p) arg+mk_rec_fields fs Nothing = HsRecFields { rec_flds = fs, rec_dotdot = Nothing }+mk_rec_fields fs (Just s)  = HsRecFields { rec_flds = fs+                                     , rec_dotdot = Just (L (l2l s) (RecFieldsDotDot $ length fs)) }++mk_rec_upd_field :: HsRecField GhcPs (LHsExpr GhcPs) -> HsRecUpdField GhcPs GhcPs+mk_rec_upd_field (HsFieldBind noAnn (L loc (FieldOcc _ rdr)) arg pun)+  = HsFieldBind noAnn (L loc (Unambiguous noExtField rdr)) arg pun++mkInlinePragma :: SourceText -> (InlineSpec, RuleMatchInfo) -> Maybe Activation+               -> InlinePragma+-- The (Maybe Activation) is because the user can omit+-- the activation spec (and usually does)+mkInlinePragma src (inl, match_info) mb_act+  = InlinePragma { inl_src = src -- Note [Pragma source text] in "GHC.Types.SourceText"+                 , inl_inline = inl+                 , inl_sat    = Nothing+                 , inl_act    = act+                 , inl_rule   = match_info }+  where+    act = case mb_act of+            Just act -> act+            Nothing  -> -- No phase specified+                        case inl of+                          NoInline _  -> NeverActive+                          Opaque _    -> NeverActive+                          _other      -> AlwaysActive++mkOpaquePragma :: SourceText -> InlinePragma+mkOpaquePragma src+  = InlinePragma { inl_src    = src+                 , inl_inline = Opaque src+                 , inl_sat    = Nothing+                 -- By marking the OPAQUE pragma NeverActive we stop+                 -- (constructor) specialisation on OPAQUE things.+                 --+                 -- See Note [OPAQUE pragma]+                 , inl_act    = NeverActive+                 , inl_rule   = FunLike+                 }++checkNewOrData :: SrcSpan -> RdrName -> Bool -> NewOrData -> [LConDecl GhcPs]+               -> P (DataDefnCons (LConDecl GhcPs))+checkNewOrData span name is_type_data = curry $ \ case+    (NewType, [a]) -> pure $ NewTypeCon a+    (DataType, as) -> pure $ DataTypeCons is_type_data (handle_type_data as)+    (NewType, as) -> addFatalError $ mkPlainErrorMsgEnvelope span $ PsErrMultipleConForNewtype name (length as)+  where+    -- In a "type data" declaration, the constructors are in the type/class+    -- namespace rather than the data constructor namespace.+    -- See Note [Type data declarations] in GHC.Rename.Module.+    handle_type_data+      | is_type_data = map (fmap promote_constructor)+      | otherwise = id++    promote_constructor (dc@ConDeclGADT { con_names = cons })+      = dc { con_names = fmap (fmap promote_name) cons }+    promote_constructor (dc@ConDeclH98 { con_name = con })+      = dc { con_name = fmap promote_name con }+    promote_constructor dc = dc++    promote_name name = fromMaybe name (promoteRdrName name)++-----------------------------------------------------------------------------+-- utilities for foreign declarations++-- construct a foreign import declaration+--+mkImport :: Located CCallConv+         -> Located Safety+         -> (Located StringLiteral, LocatedN RdrName, LHsSigType GhcPs)+         -> P ([AddEpAnn] -> HsDecl GhcPs)+mkImport cconv safety (L loc (StringLiteral esrc entity _), v, ty) =+    case unLoc cconv of+      CCallConv          -> returnSpec =<< mkCImport+      CApiConv           -> do+        imp <- mkCImport+        if isCWrapperImport imp+          then addFatalError $ mkPlainErrorMsgEnvelope loc PsErrInvalidCApiImport+          else returnSpec imp+      StdCallConv        -> returnSpec =<< mkCImport+      PrimCallConv       -> mkOtherImport+      JavaScriptCallConv -> mkOtherImport+  where+    -- Parse a C-like entity string of the following form:+    --   "[static] [chname] [&] [cid]" | "dynamic" | "wrapper"+    -- If 'cid' is missing, the function name 'v' is used instead as symbol+    -- name (cf section 8.5.1 in Haskell 2010 report).+    mkCImport = do+      let e = unpackFS entity+      case parseCImport (reLoc cconv) (reLoc safety) (mkExtName (unLoc v)) e (L loc esrc) of+        Nothing         -> addFatalError $ mkPlainErrorMsgEnvelope loc $+                             PsErrMalformedEntityString+        Just importSpec -> return importSpec++    isCWrapperImport (CImport _ _ _ _ CWrapper) = True+    isCWrapperImport _ = False++    -- currently, all the other import conventions only support a symbol name in+    -- the entity string. If it is missing, we use the function name instead.+    mkOtherImport = returnSpec importSpec+      where+        entity'    = if nullFS entity+                        then mkExtName (unLoc v)+                        else entity+        funcTarget = CFunction (StaticTarget esrc entity' Nothing True)+        importSpec = CImport (L (l2l loc) esrc) (reLoc cconv) (reLoc safety) Nothing funcTarget++    returnSpec spec = return $ \ann -> ForD noExtField $ ForeignImport+          { fd_i_ext  = ann+          , fd_name   = v+          , fd_sig_ty = ty+          , fd_fi     = spec+          }++++-- the string "foo" is ambiguous: either a header or a C identifier.  The+-- C identifier case comes first in the alternatives below, so we pick+-- that one.+parseCImport :: LocatedE CCallConv -> LocatedE Safety -> FastString -> String+             -> Located SourceText+             -> Maybe (ForeignImport (GhcPass p))+parseCImport cconv safety nm str sourceText =+ listToMaybe $ map fst $ filter (null.snd) $+     readP_to_S parse str+ where+   parse = do+       skipSpaces+       r <- choice [+          string "dynamic" >> return (mk Nothing (CFunction DynamicTarget)),+          string "wrapper" >> return (mk Nothing CWrapper),+          do optional (token "static" >> skipSpaces)+             ((mk Nothing <$> cimp nm) ++++              (do h <- munch1 hdr_char+                  skipSpaces+                  let src = mkFastString h+                  mk (Just (Header (SourceText src) src))+                      <$> cimp nm))+         ]+       skipSpaces+       return r++   token str = do _ <- string str+                  toks <- look+                  case toks of+                      c : _+                       | id_char c -> pfail+                      _            -> return ()++   mk h n = CImport (reLoc sourceText) (reLoc cconv) (reLoc safety) h n++   hdr_char c = not (isSpace c)+   -- header files are filenames, which can contain+   -- pretty much any char (depending on the platform),+   -- so just accept any non-space character+   id_first_char c = isAlpha    c || c == '_'+   id_char       c = isAlphaNum c || c == '_'++   cimp nm = (ReadP.char '&' >> skipSpaces >> CLabel <$> cid)+             +++ (do isFun <- case unLoc cconv of+                               CApiConv ->+                                  option True+                                         (do token "value"+                                             skipSpaces+                                             return False)+                               _ -> return True+                     cid' <- cid+                     return (CFunction (StaticTarget NoSourceText cid'+                                        Nothing isFun)))+          where+            cid = return nm ++++                  (do c  <- satisfy id_first_char+                      cs <-  many (satisfy id_char)+                      return (mkFastString (c:cs)))+++-- construct a foreign export declaration+--+mkExport :: Located CCallConv+         -> (Located StringLiteral, LocatedN RdrName, LHsSigType GhcPs)+         -> P ([AddEpAnn] -> HsDecl GhcPs)+mkExport (L lc cconv) (L le (StringLiteral esrc entity _), v, ty)+ = return $ \ann -> ForD noExtField $+   ForeignExport { fd_e_ext = ann, fd_name = v, fd_sig_ty = ty+                 , fd_fe = CExport (L (l2l le) esrc) (L (l2l lc) (CExportStatic esrc entity' cconv)) }+  where+    entity' | nullFS entity = mkExtName (unLoc v)+            | otherwise     = entity++-- Supplying the ext_name in a foreign decl is optional; if it+-- isn't there, the Haskell name is assumed. Note that no transformation+-- of the Haskell name is then performed, so if you foreign export (++),+-- it's external name will be "++". Too bad; it's important because we don't+-- want z-encoding (e.g. names with z's in them shouldn't be doubled)+--+mkExtName :: RdrName -> CLabelString+mkExtName rdrNm = occNameFS (rdrNameOcc rdrNm)++--------------------------------------------------------------------------------+-- Help with module system imports/exports++data ImpExpSubSpec = ImpExpAbs+                   | ImpExpAll+                   | ImpExpList [LocatedA ImpExpQcSpec]+                   | ImpExpAllWith [LocatedA ImpExpQcSpec]++data ImpExpQcSpec = ImpExpQcName (LocatedN RdrName)+                  | ImpExpQcType EpaLocation (LocatedN RdrName)+                  | ImpExpQcWildcard++mkModuleImpExp :: Maybe (LWarningTxt GhcPs) -> [AddEpAnn] -> LocatedA ImpExpQcSpec+               -> ImpExpSubSpec -> P (IE GhcPs)+mkModuleImpExp warning anns (L l specname) subs = do+  case subs of+    ImpExpAbs+      | isVarNameSpace (rdrNameSpace name)+                       -> return $ IEVar warning+                           (L l (ieNameFromSpec specname)) Nothing+      | otherwise      -> IEThingAbs (warning, anns) . L l <$> nameT <*> pure noExportDoc+    ImpExpAll          -> IEThingAll (warning, anns) . L l <$> nameT <*> pure noExportDoc+    ImpExpList xs      ->+      (\newName -> IEThingWith (warning, anns) (L l newName)+        NoIEWildcard (wrapped xs)) <$> nameT <*> pure noExportDoc+    ImpExpAllWith xs                       ->+      do allowed <- getBit PatternSynonymsBit+         if allowed+          then+            let withs = map unLoc xs+                pos   = maybe NoIEWildcard IEWildcard+                          (findIndex isImpExpQcWildcard withs)+                ies :: [LocatedA (IEWrappedName GhcPs)]+                ies   = wrapped $ filter (not . isImpExpQcWildcard . unLoc) xs+            in (\newName+                        -> IEThingWith (warning, anns) (L l newName) pos ies)+               <$> nameT <*> pure noExportDoc+          else addFatalError $ mkPlainErrorMsgEnvelope (locA l) $+                 PsErrIllegalPatSynExport+  where+    noExportDoc :: Maybe (LHsDoc GhcPs)+    noExportDoc = Nothing++    name = ieNameVal specname+    nameT =+      if isVarNameSpace (rdrNameSpace name)+        then addFatalError $ mkPlainErrorMsgEnvelope (locA l) $+               (PsErrVarForTyCon name)+        else return $ ieNameFromSpec specname++    ieNameVal (ImpExpQcName ln)   = unLoc ln+    ieNameVal (ImpExpQcType _ ln) = unLoc ln+    ieNameVal (ImpExpQcWildcard)  = panic "ieNameVal got wildcard"++    ieNameFromSpec :: ImpExpQcSpec -> IEWrappedName GhcPs+    ieNameFromSpec (ImpExpQcName   (L l n)) = IEName noExtField (L l n)+    ieNameFromSpec (ImpExpQcType r (L l n)) = IEType r (L l n)+    ieNameFromSpec (ImpExpQcWildcard)  = panic "ieName got wildcard"++    wrapped = map (fmap ieNameFromSpec)++mkTypeImpExp :: LocatedN RdrName   -- TcCls or Var name space+             -> P (LocatedN RdrName)+mkTypeImpExp name =+  do requireExplicitNamespaces (getLocA name)+     return (fmap (`setRdrNameSpace` tcClsName) name)++checkImportSpec :: LocatedL [LIE GhcPs] -> P (LocatedL [LIE GhcPs])+checkImportSpec ie@(L _ specs) =+    case [l | (L l (IEThingWith _ _ (IEWildcard _) _ _)) <- specs] of+      [] -> return ie+      (l:_) -> importSpecError (locA l)+  where+    importSpecError l =+      addFatalError $ mkPlainErrorMsgEnvelope l PsErrIllegalImportBundleForm++-- In the correct order+mkImpExpSubSpec :: [LocatedA ImpExpQcSpec] -> P ([AddEpAnn], ImpExpSubSpec)+mkImpExpSubSpec [] = return ([], ImpExpList [])+mkImpExpSubSpec [L la ImpExpQcWildcard] =+  return ([AddEpAnn AnnDotdot (entry la)], ImpExpAll)+mkImpExpSubSpec xs =+  if (any (isImpExpQcWildcard . unLoc) xs)+    then return $ ([], ImpExpAllWith xs)+    else return $ ([], ImpExpList xs)++isImpExpQcWildcard :: ImpExpQcSpec -> Bool+isImpExpQcWildcard ImpExpQcWildcard = True+isImpExpQcWildcard _                = False++-----------------------------------------------------------------------------+-- Warnings and failures++warnPrepositiveQualifiedModule :: SrcSpan -> P ()+warnPrepositiveQualifiedModule span =+  addPsMessage span PsWarnImportPreQualified++failNotEnabledImportQualifiedPost :: SrcSpan -> P ()+failNotEnabledImportQualifiedPost loc =+  addError $ mkPlainErrorMsgEnvelope loc $ PsErrImportPostQualified++failImportQualifiedTwice :: SrcSpan -> P ()+failImportQualifiedTwice loc =+  addError $ mkPlainErrorMsgEnvelope loc $ PsErrImportQualifiedTwice++warnStarIsType :: SrcSpan -> P ()+warnStarIsType span = addPsMessage span PsWarnStarIsType++failOpFewArgs :: MonadP m => LocatedN RdrName -> m a+failOpFewArgs (L loc op) =+  do { star_is_type <- getBit StarIsTypeBit+     ; let is_star_type = if star_is_type then StarIsType else StarIsNotType+     ; addFatalError $ mkPlainErrorMsgEnvelope (locA loc) $+         (PsErrOpFewArgs is_star_type op) }++requireExplicitNamespaces :: MonadP m => SrcSpan -> m ()+requireExplicitNamespaces l = do+  allowed <- getBit ExplicitNamespacesBit+  unless allowed $+    addError $ mkPlainErrorMsgEnvelope l PsErrIllegalExplicitNamespace++-----------------------------------------------------------------------------+-- Misc utils++data PV_Context =+  PV_Context+    { pv_options :: ParserOpts+    , pv_details :: ParseContext -- See Note [Parser-Validator Details]+    }++data PV_Accum =+  PV_Accum+    { pv_warnings        :: Messages PsMessage+    , pv_errors          :: Messages PsMessage+    , pv_header_comments :: Strict.Maybe [LEpaComment]+    , pv_comment_q       :: [LEpaComment]+    }++data PV_Result a = PV_Ok PV_Accum a | PV_Failed PV_Accum+  deriving (Foldable, Functor, Traversable)++-- During parsing, we make use of several monadic effects: reporting parse errors,+-- accumulating warnings, adding API annotations, and checking for extensions. These+-- effects are captured by the 'MonadP' type class.+--+-- Sometimes we need to postpone some of these effects to a later stage due to+-- ambiguities described in Note [Ambiguous syntactic categories].+-- We could use two layers of the P monad, one for each stage:+--+--   abParser :: forall x. DisambAB x => P (P x)+--+-- The outer layer of P consumes the input and builds the inner layer, which+-- validates the input. But this type is not particularly helpful, as it obscures+-- the fact that the inner layer of P never consumes any input.+--+-- For clarity, we introduce the notion of a parser-validator: a parser that does+-- not consume any input, but may fail or use other effects. Thus we have:+--+--   abParser :: forall x. DisambAB x => P (PV x)+--+newtype PV a = PV { unPV :: PV_Context -> PV_Accum -> PV_Result a }+  deriving (Functor)++instance Applicative PV where+  pure a = a `seq` PV (\_ acc -> PV_Ok acc a)+  (<*>) = ap++instance Monad PV where+  m >>= f = PV $ \ctx acc ->+    case unPV m ctx acc of+      PV_Ok acc' a -> unPV (f a) ctx acc'+      PV_Failed acc' -> PV_Failed acc'++runPV :: PV a -> P a+runPV = runPV_details noParseContext++askParseContext :: PV ParseContext+askParseContext = PV $ \(PV_Context _ details) acc -> PV_Ok acc details++runPV_details :: ParseContext -> PV a -> P a+runPV_details details m =+  P $ \s ->+    let+      pv_ctx = PV_Context+        { pv_options = options s+        , pv_details = details }+      pv_acc = PV_Accum+        { pv_warnings = warnings s+        , pv_errors   = errors s+        , pv_header_comments = header_comments s+        , pv_comment_q = comment_q s }+      mkPState acc' =+        s { warnings = pv_warnings acc'+          , errors   = pv_errors acc'+          , comment_q = pv_comment_q acc' }+    in+      case unPV m pv_ctx pv_acc of+        PV_Ok acc' a -> POk (mkPState acc') a+        PV_Failed acc' -> PFailed (mkPState acc')++instance MonadP PV where+  addError err =+    PV $ \_ctx acc -> PV_Ok acc{pv_errors = err `addMessage` pv_errors acc} ()+  addWarning w =+    PV $ \_ctx acc ->+      -- No need to check for the warning flag to be set, GHC will correctly discard suppressed+      -- diagnostics.+      PV_Ok acc{pv_warnings= w `addMessage` pv_warnings acc} ()+  addFatalError err =+    addError err >> PV (const PV_Failed)+  getBit ext =+    PV $ \ctx acc ->+      let b = ext `xtest` pExtsBitmap (pv_options ctx) in+      PV_Ok acc $! b+  allocateCommentsP ss = PV $ \_ s ->+    if null (pv_comment_q s) then PV_Ok s emptyComments else  -- fast path+    let (comment_q', newAnns) = allocateComments ss (pv_comment_q s) in+      PV_Ok s {+         pv_comment_q = comment_q'+       } (EpaComments newAnns)+  allocatePriorCommentsP ss = PV $ \_ s ->+    let (header_comments', comment_q', newAnns)+          = allocatePriorComments ss (pv_comment_q s) (pv_header_comments s) in+      PV_Ok s {+         pv_header_comments = header_comments',+         pv_comment_q = comment_q'+       } (EpaComments newAnns)+  allocateFinalCommentsP ss = PV $ \_ s ->+    let (header_comments', comment_q', newAnns)+          = allocateFinalComments ss (pv_comment_q s) (pv_header_comments s) in+      PV_Ok s {+         pv_header_comments = header_comments',+         pv_comment_q = comment_q'+       } (EpaCommentsBalanced (Strict.fromMaybe [] header_comments') newAnns)++{- Note [Parser-Validator Details]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+A PV computation is parameterized by some 'ParseContext' for diagnostic messages, which can be set+depending on validation context. We use this in checkPattern to fix #984.++Consider this example, where the user has forgotten a 'do':++  f _ = do+    x <- computation+    case () of+      _ ->+        result <- computation+        case () of () -> undefined++GHC parses it as follows:++  f _ = do+    x <- computation+    (case () of+      _ ->+        result) <- computation+        case () of () -> undefined++Note that this fragment is parsed as a pattern:++  case () of+    _ ->+      result++We attempt to detect such cases and add a hint to the diagnostic messages:++  T984.hs:6:9:+    Parse error in pattern: case () of { _ -> result }+    Possibly caused by a missing 'do'?++The "Possibly caused by a missing 'do'?" suggestion is the hint that is computed+out of the 'ParseContext', which are read by functions like 'patFail' when+constructing the 'PsParseErrorInPatDetails' data structure. When validating in a+context other than 'bindpat' (a pattern to the left of <-), we set the+details to 'noParseContext' and it has no effect on the diagnostic messages.++-}++-- | Hint about bang patterns, assuming @BangPatterns@ is off.+hintBangPat :: SrcSpan -> Pat GhcPs -> PV ()+hintBangPat span e = do+    bang_on <- getBit BangPatBit+    unless bang_on $+      addError $ mkPlainErrorMsgEnvelope span $ PsErrIllegalBangPattern e++mkSumOrTupleExpr :: SrcSpanAnnA -> Boxity -> SumOrTuple (HsExpr GhcPs)+                 -> [AddEpAnn]+                 -> PV (LHsExpr GhcPs)++-- Tuple+mkSumOrTupleExpr l@(EpAnn anc an csIn) boxity (Tuple es) anns = do+    !cs <- getCommentsFor (locA l)+    return $ L (EpAnn anc an (csIn Semi.<> cs)) (ExplicitTuple anns (map toTupArg es) boxity)+  where+    toTupArg :: Either (EpAnn Bool) (LHsExpr GhcPs) -> HsTupArg GhcPs+    toTupArg (Left ann) = missingTupArg ann+    toTupArg (Right a)  = Present noExtField a++-- Sum+-- mkSumOrTupleExpr l Unboxed (Sum alt arity e) =+--     return $ L l (ExplicitSum noExtField alt arity e)+mkSumOrTupleExpr l@(EpAnn anc anIn csIn) Unboxed (Sum alt arity e barsp barsa) anns = do+    let an = case anns of+               [AddEpAnn AnnOpenPH o, AddEpAnn AnnClosePH c] ->+                 AnnExplicitSum o barsp barsa c+               _ -> panic "mkSumOrTupleExpr"+    !cs <- getCommentsFor (locA l)+    return $ L (EpAnn anc anIn (csIn Semi.<> cs)) (ExplicitSum an alt arity e)+mkSumOrTupleExpr l Boxed a@Sum{} _ =+    addFatalError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrUnsupportedBoxedSumExpr a++mkSumOrTuplePat+  :: SrcSpanAnnA -> Boxity -> SumOrTuple (PatBuilder GhcPs) -> [AddEpAnn]+  -> PV (LocatedA (PatBuilder GhcPs))++-- Tuple+mkSumOrTuplePat l boxity (Tuple ps) anns = do+  ps' <- traverse toTupPat ps+  return $ L l (PatBuilderPat (TuplePat anns ps' boxity))+  where+    toTupPat :: Either (EpAnn Bool) (LocatedA (PatBuilder GhcPs)) -> PV (LPat GhcPs)+    -- Ignore the element location so that the error message refers to the+    -- entire tuple. See #19504 (and the discussion) for details.+    toTupPat p = case p of+      Left _ -> addFatalError $+                  mkPlainErrorMsgEnvelope (locA l) PsErrTupleSectionInPat+      Right p' -> checkLPat p'++-- Sum+mkSumOrTuplePat l Unboxed (Sum alt arity p barsb barsa) anns = do+   p' <- checkLPat p+   let an = EpAnnSumPat anns barsb barsa+   return $ L l (PatBuilderPat (SumPat an p' alt arity))+mkSumOrTuplePat l Boxed a@Sum{} _ =+    addFatalError $+      mkPlainErrorMsgEnvelope (locA l) $ PsErrUnsupportedBoxedSumPat a++mkLHsOpTy :: PromotionFlag -> LHsType GhcPs -> LocatedN RdrName -> LHsType GhcPs -> LHsType GhcPs+mkLHsOpTy prom x op y =+  let loc = locA x `combineSrcSpans` locA op `combineSrcSpans` locA y+  in L (noAnnSrcSpan loc) (mkHsOpTy prom x op y)++mkMultTy :: EpToken "%" -> LHsType GhcPs -> EpUniToken "->" "→" -> HsArrow GhcPs+mkMultTy pct t@(L _ (HsTyLit _ (HsNumTy (SourceText (unpackFS -> "1")) 1))) arr+  -- See #18888 for the use of (SourceText "1") above+  = HsLinearArrow (EpPct1 pct1 arr)+  where+    -- The location of "%" combined with the location of "1".+    pct1 :: EpToken "%1"+    pct1 = epTokenWidenR pct (locA (getLoc t))+mkMultTy pct t arr = HsExplicitMult (pct, arr) t++mkMultAnn :: EpToken "%" -> LHsType GhcPs -> HsMultAnn GhcPs+mkMultAnn pct t@(L _ (HsTyLit _ (HsNumTy (SourceText (unpackFS -> "1")) 1)))+  -- See #18888 for the use of (SourceText "1") above+  = HsPct1Ann pct1+  where+    -- The location of "%" combined with the location of "1".+    pct1 :: EpToken "%1"+    pct1 = epTokenWidenR pct (locA (getLoc t))+mkMultAnn pct t = HsMultAnn pct t++mkTokenLocation :: SrcSpan -> TokenLocation+mkTokenLocation (UnhelpfulSpan _) = NoTokenLoc+mkTokenLocation (RealSrcSpan r mb) = TokenLoc (EpaSpan (RealSrcSpan r mb))++-- Precondition: the EpToken has EpaSpan, never EpaDelta.+epTokenWidenR :: EpToken tok -> SrcSpan -> EpToken tok'+epTokenWidenR NoEpTok _ = NoEpTok+epTokenWidenR (EpTok l) (UnhelpfulSpan _) = EpTok l+epTokenWidenR (EpTok (EpaSpan s1)) s2 = EpTok (EpaSpan (combineSrcSpans s1 s2))+epTokenWidenR (EpTok (EpaDelta _ _)) _ =+  -- Never happens because the parser does not produce EpaDelta.+  panic "epTokenWidenR: EpaDelta"++-----------------------------------------------------------------------------+-- Token symbols++starSym :: Bool -> FastString+starSym True = fsLit "★"+starSym False = fsLit "*"++-----------------------------------------+-- Bits and pieces for RecordDotSyntax.++mkRdrGetField :: LHsExpr GhcPs -> LocatedAn NoEpAnns (DotFieldOcc GhcPs)+  -> HsExpr GhcPs+mkRdrGetField arg field =+  HsGetField {+      gf_ext = NoExtField+    , gf_expr = arg+    , gf_field = field+    }++mkRdrProjection :: NonEmpty (LocatedAn NoEpAnns (DotFieldOcc GhcPs)) -> AnnProjection -> HsExpr GhcPs+mkRdrProjection flds anns =+  HsProjection {+      proj_ext = anns+    , proj_flds = flds+    }++mkRdrProjUpdate :: SrcSpanAnnA -> Located [LocatedAn NoEpAnns (DotFieldOcc GhcPs)]+                -> LHsExpr GhcPs -> Bool -> [AddEpAnn]+                -> LHsRecProj GhcPs (LHsExpr GhcPs)+mkRdrProjUpdate _ (L _ []) _ _ _ = panic "mkRdrProjUpdate: The impossible has happened!"+mkRdrProjUpdate loc (L l flds) arg isPun anns =+  L loc HsFieldBind {+      hfbAnn = anns+    , hfbLHS = L (noAnnSrcSpan l) (FieldLabelStrings flds)+    , hfbRHS = arg+    , hfbPun = isPun+  }++-----------------------------------------------------------------------------+-- Tuple and list punning++punsAllowed :: P Bool+punsAllowed = getBit ListTuplePunsBit++-- | Check whether @ListTuplePuns@ is enabled and return the first arg if it is,+-- the second arg otherwise.+punsIfElse :: a -> a -> P a+punsIfElse enabled disabled = do+  allowed <- punsAllowed+  pure (if allowed then enabled else disabled)++-- | Emit an error of type 'PsErrInvalidPun' with a location from @start@ to+-- @end@ if the extension @ListTuplePuns@ is disabled.+--+-- This is used in Parser.y to guard rules that require punning.+requireLTPuns :: PsErrPunDetails -> Located a -> Located b -> P ()+requireLTPuns err start end =+  unlessM punsAllowed $ do+    addError (mkPlainErrorMsgEnvelope loc (PsErrInvalidPun err))+  where+    loc = (combineSrcSpans (getLoc start) (getLoc end))++-- | Call a parser with a span and its comments given by a start and end token.+withCombinedComments ::+  HasLoc l1 =>+  HasLoc l2 =>+  l1 ->+  l2 ->+  (SrcSpan -> P a) ->+  P (LocatedA a)+withCombinedComments start end use = do+  cs <- getCommentsFor fullSpan+  a <- use fullSpan+  pure (L (EpAnn (spanAsAnchor fullSpan) noAnn cs) a)+  where+    fullSpan = combineSrcSpans (getHasLoc start) (getHasLoc end)++-- | Decide whether to parse tuple syntax @(Int, Double)@ in a type as a+-- type or data constructor, based on the extension @ListTuplePuns@.+-- The case with an explicit promotion quote, @'(Int, Double)@, is handled+-- by 'mkExplicitTupleTy'.+mkTupleSyntaxTy :: EpaLocation+                -> [LocatedA (HsType GhcPs)]+                -> EpaLocation+                -> P (HsType GhcPs)+mkTupleSyntaxTy parOpen args parClose =+  punsIfElse enabled disabled+  where+    enabled =+      HsTupleTy annParen HsBoxedOrConstraintTuple args+    disabled =+      HsExplicitTupleTy annsKeyword args++    annParen = AnnParen AnnParens parOpen parClose+    annsKeyword = [AddEpAnn AnnOpenP parOpen, AddEpAnn AnnCloseP parClose]++-- | Decide whether to parse tuple con syntax @(,)@ in a type as a+-- type or data constructor, based on the extension @ListTuplePuns@.+-- The case with an explicit promotion quote, @'(,)@, is handled+-- by the rule @SIMPLEQUOTE sysdcon_nolist@ in @atype@.+mkTupleSyntaxTycon :: Boxity -> Int -> P RdrName+mkTupleSyntaxTycon boxity n =+  punsIfElse+    (getRdrName (tupleTyCon boxity n))+    (getRdrName (tupleDataCon boxity n))++-- | Decide whether to parse list tycon syntax @[]@ in a type as a type or data+-- constructor, based on the extension @ListTuplePuns@.+-- The case with an explicit promotion quote, @'[]@, is handled by+-- 'mkExplicitListTy'.+mkListSyntaxTy0 :: EpaLocation+                -> EpaLocation+                -> SrcSpan+                -> P (HsType GhcPs)+mkListSyntaxTy0 brkOpen brkClose span =+  punsIfElse enabled disabled+  where+    enabled = HsTyVar noAnn NotPromoted rn++    -- attach the comments only to the RdrName since it's the innermost AST node+    rn = L (EpAnn fullLoc rdrNameAnn emptyComments) listTyCon_RDR++    disabled =+      HsExplicitListTy annsKeyword NotPromoted []++    rdrNameAnn = NameAnnOnly NameSquare brkOpen brkClose []+    annsKeyword = [AddEpAnn AnnOpenS brkOpen, AddEpAnn AnnCloseS brkClose]+    fullLoc = EpaSpan span++-- | Decide whether to parse list type syntax @[Int]@ in a type as a+-- type or data constructor, based on the extension @ListTuplePuns@.+-- The case with an explicit promotion quote, @'[Int]@, is handled+-- by 'mkExplicitListTy'.+mkListSyntaxTy1 :: EpaLocation+                -> LocatedA (HsType GhcPs)+                -> EpaLocation+                -> P (HsType GhcPs)+mkListSyntaxTy1 brkOpen t brkClose =+  punsIfElse enabled disabled+  where+    enabled = HsListTy annParen t++    disabled =+      HsExplicitListTy annsKeyword NotPromoted [t]++    annsKeyword = [AddEpAnn AnnOpenS brkOpen, AddEpAnn AnnCloseS brkClose]+    annParen = AnnParen AnnParensSquare brkOpen brkClose
compiler/GHC/Parser/PostProcess/Haddock.hs view
@@ -53,27 +53,23 @@ import GHC.Hs  import GHC.Types.SrcLoc-import GHC.Utils.Panic import GHC.Data.Bag  import Data.Semigroup import Data.Foldable import Data.Traversable-import Data.Maybe-import Data.List.NonEmpty (nonEmpty) import qualified Data.List.NonEmpty as NE+import Control.Applicative import Control.Monad import Control.Monad.Trans.State.Strict import Control.Monad.Trans.Reader-import Control.Monad.Trans.Writer import Data.Functor.Identity-import qualified Data.Monoid  import {-# SOURCE #-} GHC.Parser (parseIdentifier) import GHC.Parser.Lexer import GHC.Parser.HaddockLex import GHC.Parser.Errors.Types-import GHC.Utils.Misc (mergeListsBy, filterOut, mapLastM, (<&&>))+import GHC.Utils.Misc (mergeListsBy, filterOut, (<&&>)) import qualified GHC.Data.Strict as Strict  {- Note [Adding Haddock comments to the syntax tree]@@ -289,8 +285,8 @@     --      data C = MkC  -- ^ Comment on MkC     --      -- ^ Comment on C     ---    let layout_info = hsmodLayout (hsmodExt mod)-    hsmodDecls' <- addHaddockInterleaveItems layout_info (mkDocHsDecl layout_info) (hsmodDecls mod)+    let layout = hsmodLayout (hsmodExt mod)+    hsmodDecls' <- addHaddockInterleaveItems layout (mkDocHsDecl layout) (hsmodDecls mod)      pure $ L l_mod $       mod { hsmodExports = hsmodExports'@@ -303,7 +299,7 @@ lexLHsDocString :: Located HsDocString -> LHsDoc GhcPs lexLHsDocString = fmap lexHsDocString --- Only for module exports, not module imports.+-- | Only for module exports, not module imports. -- --    module M (a, b, c) where   -- use on this [LIE GhcPs] --    import I (a, b, c)         -- do not use here!@@ -312,13 +308,25 @@ instance HasHaddock (LocatedL [LocatedA (IE GhcPs)]) where   addHaddock (L l_exports exports) =     extendHdkA (locA l_exports) $ do-      exports' <- addHaddockInterleaveItems NoLayoutInfo mkDocIE exports+      exports' <- addHaddockInterleaveItems EpNoLayout mkDocIE exports       registerLocHdkA (srcLocSpan (srcSpanEnd (locA l_exports))) -- Do not consume comments after the closing parenthesis       pure $ L l_exports exports'  -- Needed to use 'addHaddockInterleaveItems' in 'instance HasHaddock (Located [LIE GhcPs])'. instance HasHaddock (LocatedA (IE GhcPs)) where-  addHaddock a = a <$ registerHdkA a+  addHaddock (L l_export ie ) =+    extendHdkA (locA l_export) $ liftHdkA $ do+      docs <- inLocRange (locRangeFrom (getBufPos (srcSpanEnd (locA l_export)))) $+        takeHdkComments mkDocPrev+      mb_doc <- selectDocString docs+      let mb_ldoc = lexLHsDocString <$> mb_doc+      let ie' = case ie of+            IEVar ext nm _                 -> IEVar ext nm mb_ldoc+            IEThingAbs ext nm _            -> IEThingAbs ext nm mb_ldoc+            IEThingAll ext nm _            -> IEThingAll ext nm mb_ldoc+            IEThingWith ext nm wild subs _ -> IEThingWith ext nm wild subs mb_ldoc+            x                              -> x+      pure $ L l_export ie'  {- Add Haddock items to a list of non-Haddock items. Used to process export lists (with mkDocIE) and declarations (with mkDocHsDecl).@@ -340,10 +348,10 @@  The inputs to addHaddockInterleaveItems are: -  * layout_info :: LayoutInfo GhcPs+  * layout :: EpLayout      In the example above, note that the indentation level inside the module is-    2 spaces. It would be represented as layout_info = VirtualBraces 2.+    2 spaces. It would be represented as layout = EpVirtualBraces 2.      It is used to delimit the search space for comments when processing     declarations. Here, we restrict indentation levels to >=(2+1), so that when@@ -352,7 +360,7 @@   * get_doc_item :: PsLocated HdkComment -> Maybe a      This is the function used to look up documentation comments.-    In the above example, get_doc_item = mkDocHsDecl layout_info,+    In the above example, get_doc_item = mkDocHsDecl layout,     and it will produce the following parts of the output:        DocD (DocCommentNext "Comment on D")@@ -372,25 +380,25 @@ addHaddockInterleaveItems   :: forall a.      HasHaddock a-  => LayoutInfo GhcPs+  => EpLayout   -> (PsLocated HdkComment -> Maybe a) -- Get a documentation item   -> [a]           -- Unprocessed (non-documentation) items   -> HdkA [a]      -- Documentation items & processed non-documentation items-addHaddockInterleaveItems layout_info get_doc_item = go+addHaddockInterleaveItems layout get_doc_item = go   where     go :: [a] -> HdkA [a]     go [] = liftHdkA (takeHdkComments get_doc_item)     go (item : items) = do       docItems <- liftHdkA (takeHdkComments get_doc_item)-      item' <- with_layout_info (addHaddock item)+      item' <- with_layout (addHaddock item)       other_items <- go items       pure $ docItems ++ item':other_items -    with_layout_info :: HdkA a -> HdkA a-    with_layout_info = case layout_info of-      NoLayoutInfo -> id-      ExplicitBraces{} -> id-      VirtualBraces n ->+    with_layout :: HdkA a -> HdkA a+    with_layout = case layout of+      EpNoLayout -> id+      EpExplicitBraces{} -> id+      EpVirtualBraces n ->         let loc_range = mempty { loc_range_col = ColumnFrom (n+1) }         in hoistHdkA (inLocRange loc_range) @@ -498,18 +506,18 @@   --      -- ^ Comment on the second method   --   addHaddock (TyClD _ decl)-    | ClassDecl { tcdCExt = (x, NoAnnSortKey), tcdLayout,+    | ClassDecl { tcdCExt = (x, layout, NoAnnSortKey),                   tcdCtxt, tcdLName, tcdTyVars, tcdFixity, tcdFDs,                   tcdSigs, tcdMeths, tcdATs, tcdATDefs } <- decl     = do         registerHdkA tcdLName         -- todo: register keyword location of 'where', see Note [Register keyword location]         where_cls' <--          addHaddockInterleaveItems tcdLayout (mkDocHsDecl tcdLayout) $+          addHaddockInterleaveItems layout (mkDocHsDecl layout) $           flattenBindsAndSigs (tcdMeths, tcdSigs, tcdATs, tcdATDefs, [], [])         pure $           let (tcdMeths', tcdSigs', tcdATs', tcdATDefs', _, tcdDocs) = partitionBindsAndSigs where_cls'-              decl' = ClassDecl { tcdCExt = (x, NoAnnSortKey), tcdLayout+              decl' = ClassDecl { tcdCExt = (x, layout, NoAnnSortKey)                                 , tcdCtxt, tcdLName, tcdTyVars, tcdFixity, tcdFDs                                 , tcdSigs = tcdSigs'                                 , tcdMeths = tcdMeths'@@ -698,202 +706,114 @@   addHaddock (L l_con_decl con_decl) =     extendHdkA (locA l_con_decl) $     case con_decl of-      ConDeclGADT { con_g_ext, con_names, con_dcolon, con_bndrs, con_mb_cxt, con_g_args, con_res_ty } -> do-        -- discardHasInnerDocs is ok because we don't need this info for GADTs.-        con_doc' <- discardHasInnerDocs $ getConDoc (getLocA (NE.head con_names))+      ConDeclGADT { con_g_ext, con_names, con_bndrs, con_mb_cxt, con_g_args, con_res_ty } -> do+        con_doc' <- getConDoc (getLocA (NE.head con_names))         con_g_args' <-           case con_g_args of-            PrefixConGADT ts -> PrefixConGADT <$> addHaddock ts-            RecConGADT (L l_rec flds) arr -> do-              -- discardHasInnerDocs is ok because we don't need this info for GADTs.-              flds' <- traverse (discardHasInnerDocs . addHaddockConDeclField) flds-              pure $ RecConGADT (L l_rec flds') arr+            PrefixConGADT x ts -> PrefixConGADT x <$> addHaddock ts+            RecConGADT arr (L l_rec flds) -> do+              flds' <- traverse addHaddockConDeclField flds+              pure $ RecConGADT arr (L l_rec flds')         con_res_ty' <- addHaddock con_res_ty         pure $ L l_con_decl $-          ConDeclGADT { con_g_ext, con_names, con_dcolon, con_bndrs, con_mb_cxt,+          ConDeclGADT { con_g_ext, con_names, con_bndrs, con_mb_cxt,                         con_doc = lexLHsDocString <$> con_doc',                         con_g_args = con_g_args',                         con_res_ty = con_res_ty' }       ConDeclH98 { con_ext, con_name, con_forall, con_ex_tvs, con_mb_cxt, con_args } ->-        addConTrailingDoc (srcSpanEnd $ locA l_con_decl) $-        case con_args of-          PrefixCon _ ts -> do-            con_doc' <- getConDoc (getLocA con_name)-            ts' <- traverse addHaddockConDeclFieldTy ts-            pure $ L l_con_decl $-              ConDeclH98 { con_ext, con_name, con_forall, con_ex_tvs, con_mb_cxt,-                           con_doc = lexLHsDocString <$> con_doc',-                           con_args = PrefixCon noTypeArgs ts' }-          InfixCon t1 t2 -> do-            t1' <- addHaddockConDeclFieldTy t1-            con_doc' <- getConDoc (getLocA con_name)-            t2' <- addHaddockConDeclFieldTy t2-            pure $ L l_con_decl $-              ConDeclH98 { con_ext, con_name, con_forall, con_ex_tvs, con_mb_cxt,-                           con_doc = lexLHsDocString <$> con_doc',-                           con_args = InfixCon t1' t2' }-          RecCon (L l_rec flds) -> do-            con_doc' <- getConDoc (getLocA con_name)-            flds' <- traverse addHaddockConDeclField flds-            pure $ L l_con_decl $-              ConDeclH98 { con_ext, con_name, con_forall, con_ex_tvs, con_mb_cxt,-                           con_doc = lexLHsDocString <$> con_doc',-                           con_args = RecCon (L l_rec flds') }---- Keep track of documentation comments on the data constructor or any of its--- fields.------ See Note [Trailing comment on constructor declaration]-type ConHdkA = WriterT HasInnerDocs HdkA+        let+          -- See Note [Leading and trailing comments on H98 constructors]+          getTrailingLeading :: HdkM (LocatedA (ConDecl GhcPs))+          getTrailingLeading = do+            con_doc' <- getPrevNextDoc (locA l_con_decl)+            return $ L l_con_decl $+              ConDeclH98 { con_ext, con_name, con_forall, con_ex_tvs, con_mb_cxt, con_args+                         , con_doc = lexLHsDocString <$> con_doc' } --- Does the data constructor declaration have any inner (non-trailing)--- documentation comments?------ Example when HasInnerDocs is True:------   data X =---      MkX       -- ^ inner comment---        Field1  -- ^ inner comment---        Field2  -- ^ inner comment---        Field3  -- ^ trailing comment------ Example when HasInnerDocs is False:------   data Y = MkY Field1 Field2 Field3  -- ^ trailing comment------ See Note [Trailing comment on constructor declaration]-newtype HasInnerDocs = HasInnerDocs Bool-  deriving (Semigroup, Monoid) via Data.Monoid.Any+          -- See Note [Leading and trailing comments on H98 constructors]+          getMixed :: HdkA (LocatedA (ConDecl GhcPs))+          getMixed =+            case con_args of+              PrefixCon _ ts -> do+                con_doc' <- getConDoc (getLocA con_name)+                ts' <- traverse addHaddockConDeclFieldTy ts+                pure $ L l_con_decl $+                  ConDeclH98 { con_ext, con_name, con_forall, con_ex_tvs, con_mb_cxt,+                               con_doc = lexLHsDocString <$> con_doc',+                               con_args = PrefixCon noTypeArgs ts' }+              InfixCon t1 t2 -> do+                t1' <- addHaddockConDeclFieldTy t1+                con_doc' <- getConDoc (getLocA con_name)+                t2' <- addHaddockConDeclFieldTy t2+                pure $ L l_con_decl $+                  ConDeclH98 { con_ext, con_name, con_forall, con_ex_tvs, con_mb_cxt,+                               con_doc = lexLHsDocString <$> con_doc',+                               con_args = InfixCon t1' t2' }+              RecCon (L l_rec flds) -> do+                con_doc' <- getConDoc (getLocA con_name)+                flds' <- traverse addHaddockConDeclField flds+                pure $ L l_con_decl $+                  ConDeclH98 { con_ext, con_name, con_forall, con_ex_tvs, con_mb_cxt,+                               con_doc = lexLHsDocString <$> con_doc',+                               con_args = RecCon (L l_rec flds') }+        in+          hoistHdkA+            (\m -> do { a <- onlyTrailingOrLeading (locA l_con_decl)+                      ; if a then getTrailingLeading else m })+            getMixed --- Run ConHdkA by discarding the HasInnerDocs info when we have no use for it.------ We only do this when processing data declarations that use GADT syntax,--- because only the H98 syntax declarations have special treatment for the--- trailing documentation comment.------ See Note [Trailing comment on constructor declaration]-discardHasInnerDocs :: ConHdkA a -> HdkA a-discardHasInnerDocs = fmap fst . runWriterT+-- See Note [Leading and trailing comments on H98 constructors]+onlyTrailingOrLeading :: SrcSpan -> HdkM Bool+onlyTrailingOrLeading l = peekHdkM $ do+  leading <-+    inLocRange (locRangeTo (getBufPos (srcSpanStart l))) $+    takeHdkComments mkDocNext+  inner <-+    inLocRange (locRangeIn (getBufSpan l)) $+    takeHdkComments (\x -> mkDocNext x <|> mkDocPrev x)+  trailing <-+    inLocRange (locRangeFrom (getBufPos (srcSpanEnd l))) $+    takeHdkComments mkDocPrev+  return $ case (leading, inner, trailing) of+    (_:_, [], []) -> True  -- leading comment only+    ([], [], _:_) -> True  -- trailing comment only+    _             -> False  -- Get the documentation comment associated with the data constructor in a -- data/newtype declaration. getConDoc   :: SrcSpan  -- Location of the data constructor-  -> ConHdkA (Maybe (Located HsDocString))-getConDoc l =-  WriterT $ extendHdkA l $ liftHdkA $ do-    mDoc <- getPrevNextDoc l-    return (mDoc, HasInnerDocs (isJust mDoc))+  -> HdkA (Maybe (Located HsDocString))+getConDoc l = extendHdkA l $ liftHdkA $ getPrevNextDoc l  -- Add documentation comment to a data constructor field. -- Used for PrefixCon and InfixCon. addHaddockConDeclFieldTy   :: HsScaled GhcPs (LHsType GhcPs)-  -> ConHdkA (HsScaled GhcPs (LHsType GhcPs))+  -> HdkA (HsScaled GhcPs (LHsType GhcPs)) addHaddockConDeclFieldTy (HsScaled mult (L l t)) =-  WriterT $ extendHdkA (locA l) $ liftHdkA $ do+  extendHdkA (locA l) $ liftHdkA $ do     mDoc <- getPrevNextDoc (locA l)-    return (HsScaled mult (mkLHsDocTy (L l t) mDoc),-            HasInnerDocs (isJust mDoc))+    return (HsScaled mult (mkLHsDocTy (L l t) mDoc))  -- Add documentation comment to a data constructor field. -- Used for RecCon. addHaddockConDeclField   :: LConDeclField GhcPs-  -> ConHdkA (LConDeclField GhcPs)+  -> HdkA (LConDeclField GhcPs) addHaddockConDeclField (L l_fld fld) =-  WriterT $ extendHdkA (locA l_fld) $ liftHdkA $ do+  extendHdkA (locA l_fld) $ liftHdkA $ do     cd_fld_doc <- fmap lexLHsDocString <$> getPrevNextDoc (locA l_fld)-    return (L l_fld (fld { cd_fld_doc }),-            HasInnerDocs (isJust cd_fld_doc))---- 1. Process a H98-syntax data constructor declaration in a context with no---    access to the trailing documentation comment (by running the provided---    ConHdkA computation).------ 2. Then grab the trailing comment (if it exists) and attach it where---    appropriate: either to the data constructor itself or to its last field,---    depending on HasInnerDocs.------ See Note [Trailing comment on constructor declaration]-addConTrailingDoc-  :: SrcLoc  -- The end of a data constructor declaration.-             -- Any docprev comment past this point is considered trailing.-  -> ConHdkA (LConDecl GhcPs)-  -> HdkA (LConDecl GhcPs)-addConTrailingDoc l_sep =-    hoistHdkA add_trailing_doc . runWriterT-  where-    add_trailing_doc-      :: HdkM (LConDecl GhcPs, HasInnerDocs)-      -> HdkM (LConDecl GhcPs)-    add_trailing_doc m = do-      (L l con_decl, HasInnerDocs has_inner_docs) <--        inLocRange (locRangeTo (getBufPos l_sep)) m-          -- inLocRange delimits the context so that the inner computation-          -- will not consume the trailing documentation comment.-      case con_decl of-        ConDeclH98{} -> do-          trailingDocs <--            inLocRange (locRangeFrom (getBufPos l_sep)) $-            takeHdkComments mkDocPrev-          if null trailingDocs-          then return (L l con_decl)-          else do-            if has_inner_docs then do-              let mk_doc_ty ::       HsScaled GhcPs (LHsType GhcPs)-                            -> HdkM (HsScaled GhcPs (LHsType GhcPs))-                  mk_doc_ty x@(HsScaled _ (L _ HsDocTy{})) =-                    -- Happens in the following case:-                    ---                    --    data T =-                    --      MkT-                    --        -- | Comment on SomeField-                    --        SomeField-                    --        -- ^ Another comment on SomeField? (rejected)-                    ---                    -- See tests/.../haddockExtraDocs.hs-                    x <$ reportExtraDocs trailingDocs-                  mk_doc_ty (HsScaled mult (L l' t)) = do-                    doc <- selectDocString trailingDocs-                    return $ HsScaled mult (mkLHsDocTy (L l' t) doc)-              let mk_doc_fld ::       LConDeclField GhcPs-                             -> HdkM (LConDeclField GhcPs)-                  mk_doc_fld x@(L _ (ConDeclField { cd_fld_doc = Just _ })) =-                    -- Happens in the following case:-                    ---                    --    data T =-                    --      MkT {-                    --        -- | Comment on SomeField-                    --        someField :: SomeField-                    --      } -- ^ Another comment on SomeField? (rejected)-                    ---                    -- See tests/.../haddockExtraDocs.hs-                    x <$ reportExtraDocs trailingDocs-                  mk_doc_fld (L l' con_fld) = do-                    doc <- selectDocString trailingDocs-                    return $ L l' (con_fld { cd_fld_doc = fmap lexLHsDocString doc })-              con_args' <- case con_args con_decl of-                x@(PrefixCon _ ts) -> case nonEmpty ts of-                    Nothing -> x <$ reportExtraDocs trailingDocs-                    Just ts -> PrefixCon noTypeArgs . toList <$> mapLastM mk_doc_ty ts-                x@(RecCon (L l_rec flds)) -> case nonEmpty flds of-                    Nothing -> x <$ reportExtraDocs trailingDocs-                    Just flds -> RecCon . L l_rec . toList <$> mapLastM mk_doc_fld flds-                InfixCon t1 t2 -> InfixCon t1 <$> mk_doc_ty t2-              return $ L l (con_decl{ con_args = con_args' })-            else do-              con_doc' <- selectDoc (con_doc con_decl `mcons` (map lexLHsDocString trailingDocs))-              return $ L l (con_decl{ con_doc = con_doc' })-        _ -> panic "addConTrailingDoc: non-H98 ConDecl"+    return (L l_fld (fld { cd_fld_doc })) -{- Note [Trailing comment on constructor declaration]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+{- Note [Leading and trailing comments on H98 constructors]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The trailing comment after a constructor declaration is associated with the-constructor itself when there are no other comments inside the declaration:+constructor itself when it is the only comment:     data T = MkT A B        -- ^ Comment on MkT    data T = MkT { x :: A } -- ^ Comment on MkT+   data T = A `MkT` B      -- ^ Comment on MkT  When there are other comments, the trailing comment applies to the last field: @@ -906,7 +826,58 @@          , b :: B   -- ^ Comment on b          , c :: C } -- ^ Comment on c -This makes the trailing comment context-sensitive. Example:+   data T =+       A      -- ^ Comment on A+      `MkT`   -- ^ Comment on MkT+       B      -- ^ Comment on B++When it comes to the leading comment, there is no such ambiguity in /prefix/+constructor declarations (plain or record syntax):++   data T =+    -- | Comment on MkT+    MkT A B++   data T =+    -- | Comment on MkT+    MkT+      -- | Comment on A+      A+      -- | Comment on B+      B++   data T =+    -- | Comment on MkT+    MkT { x :: A }++   data T =+     -- | Comment on MkT+     MkT {+      -- | Comment on a+      a :: A,+      -- | Comment on b+      b :: B,+      -- | Comment on c+      c :: C+    }++However, in /infix/ constructor declarations the leading comment is associated+with the constructor itself if it is the only comment, and with the first+field if there are other comments:++   data T =+    -- | Comment on MkT+    A `MkT` B++   data T =+    -- | Comment on A+    A+    -- | Comment on MkT+    `MkT`+    -- | Comment on B+    B++This makes the leading and trailing comments context-sensitive. Example:       data T =         -- | comment 1         MkT Int Bool -- ^ comment 2@@ -920,17 +891,20 @@  We implement this in two steps: -  1. Process the data constructor declaration in a delimited context where the-     trailing documentation comment is not visible. Delimiting the context is done-     in addConTrailingDoc.+  1. Gather information about available comments using `onlyTrailingOrLeading`.+     It inspects available comments but does not consume them, and returns a+     boolean that tells us what algorithm we should use+        True  <=>  expect a single leading/trailing comment+        False <=>  expect inner comments or more than one comment -     When processing the declaration, track whether the constructor or any of-     its fields have a documentation comment associated with them.-     This is done using WriterT HasInnerDocs, see ConHdkA.+  2. Collect the comments using the algorithm determined in the previous step -  2. Depending on whether HasInnerDocs is True or False, attach the-     trailing documentation comment to the data constructor itself-     or to its last field.+     a) `getTrailingLeading`:+            a single leading/trailing comment is applied to the entire+            constructor declaration as a whole; see the `con_doc` field+     b) `getMixed`:+            comments apply to individual parts of a constructor declaration,+            including its field types -}  instance HasHaddock a => HasHaddock (HsScaled GhcPs a) where@@ -1155,7 +1129,7 @@ -- A small wrapper over registerLocHdkA. -- -- See Note [Adding Haddock comments to the syntax tree].-registerHdkA :: GenLocated (SrcSpanAnn' a) e -> HdkA ()+registerHdkA :: GenLocated (EpAnn a) e -> HdkA () registerHdkA a = registerLocHdkA (getLocA a)  -- Modify the action of a HdkA computation.@@ -1266,6 +1240,13 @@         Just item -> (item : items, other_hdk_comments)         Nothing -> (items, hdk_comment : other_hdk_comments) +-- Run a HdkM action and restore the original state.+peekHdkM :: HdkM a -> HdkM a+peekHdkM m =+  HdkM $ \r s ->+    case unHdkM m r s of+      (a, _) -> (a, s)+ -- Get the docnext or docprev comment for an AST node at the given source span. getPrevNextDoc :: SrcSpan -> HdkM (Maybe (Located HsDocString)) getPrevNextDoc l = do@@ -1290,15 +1271,6 @@       reportExtraDocs extra_docs       return (Just doc) -selectDoc :: forall a. [LHsDoc a] -> HdkM (Maybe (LHsDoc a))-selectDoc = select . filterOut (isEmptyDocString . hsDocString . unLoc)-  where-    select [] = return Nothing-    select [doc] = return (Just doc)-    select (doc : extra_docs) = do-      reportExtraDocs $ map (\(L l d) -> L l $ hsDocString d) extra_docs-      return (Just doc)- reportExtraDocs :: [Located HsDocString] -> HdkM () reportExtraDocs =   traverse_ (\extra_doc -> appendHdkWarning (HdkWarnExtraComment extra_doc))@@ -1309,11 +1281,11 @@ *                                                                      * ********************************************************************* -} -mkDocHsDecl :: LayoutInfo GhcPs -> PsLocated HdkComment -> Maybe (LHsDecl GhcPs)-mkDocHsDecl layout_info a = fmap (DocD noExtField) <$> mkDocDecl layout_info a+mkDocHsDecl :: EpLayout -> PsLocated HdkComment -> Maybe (LHsDecl GhcPs)+mkDocHsDecl layout a = fmap (DocD noExtField) <$> mkDocDecl layout a -mkDocDecl :: LayoutInfo GhcPs -> PsLocated HdkComment -> Maybe (LDocDecl GhcPs)-mkDocDecl layout_info (L l_comment hdk_comment)+mkDocDecl :: EpLayout -> PsLocated HdkComment -> Maybe (LDocDecl GhcPs)+mkDocDecl layout (L l_comment hdk_comment)   | indent_mismatch = Nothing   | otherwise =     Just $ L (noAnnSrcSpan span) $@@ -1344,10 +1316,10 @@     --         class C a where     --           f :: a -> a     --         -- ^ indent mismatch-    indent_mismatch = case layout_info of-      NoLayoutInfo -> False-      ExplicitBraces{} -> False-      VirtualBraces n -> n /= srcSpanStartCol (psRealSpan l_comment)+    indent_mismatch = case layout of+      EpNoLayout -> False+      EpExplicitBraces{} -> False+      EpVirtualBraces n -> n /= srcSpanStartCol (psRealSpan l_comment)  mkDocIE :: PsLocated HdkComment -> Maybe (LIE GhcPs) mkDocIE (L l_comment hdk_comment) =@@ -1355,7 +1327,7 @@     HdkCommentSection n doc -> Just $ L l (IEGroup noExtField n $ L span $ lexHsDocString doc)     HdkCommentNamed s _doc -> Just $ L l (IEDocNamed noExtField s)     HdkCommentNext doc -> Just $ L l (IEDoc noExtField $ L span $ lexHsDocString doc)-    _ -> Nothing+    HdkCommentPrev doc -> Just $ L l (IEDoc noExtField $ L span $ lexHsDocString doc)   where l = noAnnSrcSpan span         span = mkSrcSpanPs l_comment @@ -1398,6 +1370,13 @@ locRangeTo (Strict.Just l) = mempty { loc_range_to = EndLoc l } locRangeTo Strict.Nothing = mempty +-- The location range within the specified span.+locRangeIn :: Strict.Maybe BufSpan -> LocRange+locRangeIn (Strict.Just l) =+  mempty { loc_range_from = StartLoc (bufSpanStart l)+         , loc_range_to   = EndLoc (bufSpanEnd l) }+locRangeIn Strict.Nothing = mempty+ -- Represents a predicate on BufPos: -- --   LowerLocBound |   BufPos -> Bool@@ -1517,7 +1496,7 @@     mapLL (\d -> DocD noExtField d) all_docs   ] -cmpBufSpanA :: GenLocated (SrcSpanAnn' a1) a2 -> GenLocated (SrcSpanAnn' a3) a2 -> Ordering+cmpBufSpanA :: GenLocated (EpAnn a1) a2 -> GenLocated (EpAnn a3) a2 -> Ordering cmpBufSpanA (L la a) (L lb b) = cmpBufSpan (L (locA la) a) (L (locA lb) b)  {- *********************************************************************@@ -1525,10 +1504,6 @@ *                   General purpose utilities                          * *                                                                      * ********************************************************************* -}---- Cons an element to a list, if exists.-mcons :: Maybe a -> [a] -> [a]-mcons = maybe id (:)  -- Map a function over a list of located items. mapLL :: (a -> b) -> [GenLocated l a] -> [GenLocated l b]
compiler/GHC/Parser/Types.hs view
@@ -29,7 +29,7 @@ data SumOrTuple b   = Sum ConTag Arity (LocatedA b) [EpaLocation] [EpaLocation]   -- ^ Last two are the locations of the '|' before and after the payload-  | Tuple [Either (EpAnn EpaLocation) (LocatedA b)]+  | Tuple [Either (EpAnn Bool) (LocatedA b)]  pprSumOrTuple :: Outputable b => Boxity -> SumOrTuple b -> SDoc pprSumOrTuple boxity = \case@@ -53,16 +53,16 @@ -- | See Note [Ambiguous syntactic categories] and Note [PatBuilder] data PatBuilder p   = PatBuilderPat (Pat p)-  | PatBuilderPar (LHsToken "(" p) (LocatedA (PatBuilder p)) (LHsToken ")" p)+  | PatBuilderPar (EpToken "(") (LocatedA (PatBuilder p)) (EpToken ")")   | PatBuilderApp (LocatedA (PatBuilder p)) (LocatedA (PatBuilder p))-  | PatBuilderAppType (LocatedA (PatBuilder p)) (LHsToken "@" p) (HsPatSigType GhcPs)+  | PatBuilderAppType (LocatedA (PatBuilder p)) (EpToken "@") (HsTyPat GhcPs)   | PatBuilderOpApp (LocatedA (PatBuilder p)) (LocatedN RdrName)-                    (LocatedA (PatBuilder p)) (EpAnn [AddEpAnn])+                    (LocatedA (PatBuilder p)) [AddEpAnn]   | PatBuilderVar (LocatedN RdrName)   | PatBuilderOverLit (HsOverLit GhcPs)  -- These instances are here so that they are not orphans-type instance Anno (GRHS GhcPs (LocatedA (PatBuilder GhcPs)))             = SrcAnn NoEpAnns+type instance Anno (GRHS GhcPs (LocatedA (PatBuilder GhcPs)))             = EpAnnCO type instance Anno [LocatedA (Match GhcPs (LocatedA (PatBuilder GhcPs)))] = SrcSpanAnnL type instance Anno (Match GhcPs (LocatedA (PatBuilder GhcPs)))            = SrcSpanAnnA type instance Anno (StmtLR GhcPs GhcPs (LocatedA (PatBuilder GhcPs)))     = SrcSpanAnnA
compiler/GHC/Platform.hs view
@@ -180,45 +180,12 @@ platformOS platform = case platformArchOS platform of    ArchOS _ os -> os -isARM :: Arch -> Bool-isARM (ArchARM {}) = True-isARM ArchAArch64  = True-isARM _ = False- -- | This predicate tells us whether the platform is 32-bit. target32Bit :: Platform -> Bool target32Bit p =     case platformWordSize p of       PW4 -> True       PW8 -> False---- | This predicate tells us whether the OS supports ELF-like shared libraries.-osElfTarget :: OS -> Bool-osElfTarget OSLinux     = True-osElfTarget OSFreeBSD   = True-osElfTarget OSDragonFly = True-osElfTarget OSOpenBSD   = True-osElfTarget OSNetBSD    = True-osElfTarget OSSolaris2  = True-osElfTarget OSDarwin    = False-osElfTarget OSMinGW32   = False-osElfTarget OSKFreeBSD  = True-osElfTarget OSHaiku     = True-osElfTarget OSQNXNTO    = False-osElfTarget OSAIX       = False-osElfTarget OSHurd      = True-osElfTarget OSWasi      = False-osElfTarget OSGhcjs     = False-osElfTarget OSUnknown   = False- -- Defaulting to False is safe; it means don't rely on any- -- ELF-specific functionality.  It is important to have a default for- -- portability, otherwise we have to answer this question for every- -- new platform we compile on (even unreg).---- | This predicate tells us whether the OS support Mach-O shared libraries.-osMachOTarget :: OS -> Bool-osMachOTarget OSDarwin = True-osMachOTarget _ = False  osUsesFrameworks :: OS -> Bool osUsesFrameworks OSDarwin = True
compiler/GHC/Platform/Ways.hs view
@@ -31,6 +31,7 @@    , wayGeneralFlags    , wayUnsetGeneralFlags    , wayOptc+   , wayOptcxx    , wayOptl    , wayOptP    , wayDesc@@ -176,6 +177,9 @@ wayOptc _ WayDebug      = [] wayOptc _ WayDyn        = [] wayOptc _ WayProf       = ["-DPROFILING"]++wayOptcxx :: Platform -> Way -> [String]+wayOptcxx = wayOptc -- Use the same flags as C  -- | Pass these options to linker when enabling this way wayOptl :: Platform -> Way -> [String]
compiler/GHC/Prelude/Basic.hs view
@@ -13,7 +13,7 @@  -- Every module in GHC --   * Is compiled with -XNoImplicitPrelude---   * Explicitly imports GHC.BasicPrelude or GHC.Prelude+--   * Explicitly imports GHC.Prelude.Basic or GHC.Prelude --   * The later provides some functionality with within ghc itself --     like pprTrace. @@ -55,9 +55,9 @@ -}  import qualified Prelude-import Prelude as X hiding ((<>), Applicative(..), head, tail)+import Prelude as X hiding ((<>), Applicative(..), Foldable(..), head, tail) import Control.Applicative (Applicative(..))-import Data.Foldable as X (foldl')+import Data.Foldable as X (Foldable(elem, foldMap, foldr, foldl, foldl', foldr1, foldl1, maximum, minimum, product, sum, null, length)) import GHC.Stack.Types (HasCallStack)  #if MIN_VERSION_base(4,16,0)
compiler/GHC/Runtime/Interpreter/Types.hs view
@@ -51,9 +51,6 @@    , interpLoader   :: !Loader       -- ^ Interpreter loader--  , interpLookupSymbolCache :: !(MVar (UniqFM FastString (Ptr ())))-      -- ^ LookupSymbol cache   }  data InterpInstance@@ -110,6 +107,9 @@       -- ^ Values that need to be freed before the next command is sent.       -- Finalizers for ForeignRefs can append values to this list       -- asynchronously.++  , instLookupSymbolCache :: !(MVar (UniqFM FastString (Ptr ())))+      -- ^ LookupSymbol cache    , instExtra             :: !c       -- ^ Instance specific extra fields
compiler/GHC/Settings.hs view
@@ -19,7 +19,7 @@   , sGlobalPackageDatabasePath   , sLdSupportsCompactUnwind   , sLdSupportsFilelist-  , sLdSupportsResponseFiles+  , sMergeObjsSupportsResponseFiles   , sLdIsGnuLd   , sGccSupportsNoPie   , sUseInplaceMinGW@@ -29,11 +29,10 @@   , sPgm_F   , sPgm_c   , sPgm_cxx+  , sPgm_cpp   , sPgm_a   , sPgm_l   , sPgm_lm-  , sPgm_dll-  , sPgm_T   , sPgm_windres   , sPgm_ar   , sPgm_otool@@ -41,7 +40,7 @@   , sPgm_ranlib   , sPgm_lo   , sPgm_lc-  , sPgm_lcc+  , sPgm_las   , sPgm_i   , sOpt_L   , sOpt_P@@ -55,7 +54,6 @@   , sOpt_windres   , sOpt_lo   , sOpt_lc-  , sOpt_lcc   , sOpt_i   , sExtraGccViaCFlags   , sTargetPlatformString@@ -88,8 +86,8 @@ data ToolSettings = ToolSettings   { toolSettings_ldSupportsCompactUnwind :: Bool   , toolSettings_ldSupportsFilelist      :: Bool-  , toolSettings_ldSupportsResponseFiles :: Bool   , toolSettings_ldSupportsSingleModule  :: Bool+  , toolSettings_mergeObjsSupportsResponseFiles :: Bool   , toolSettings_ldIsGnuLd               :: Bool   , toolSettings_ccSupportsNoPie         :: Bool   , toolSettings_useInplaceMinGW         :: Bool@@ -97,18 +95,19 @@    -- commands for particular phases   , toolSettings_pgm_L       :: String-  , toolSettings_pgm_P       :: (String, [Option])+  , -- | The Haskell C preprocessor and default options (not added by -optP)+    toolSettings_pgm_P       :: (String, [Option])   , toolSettings_pgm_F       :: String   , toolSettings_pgm_c       :: String   , toolSettings_pgm_cxx     :: String+  , -- | The C preprocessor (distinct from the Haskell C preprocessor!)+    toolSettings_pgm_cpp     :: (String, [Option])   , toolSettings_pgm_a       :: (String, [Option])   , toolSettings_pgm_l       :: (String, [Option])   , toolSettings_pgm_lm      :: Maybe (String, [Option])     -- ^ N.B. On Windows we don't have a linker which supports object     -- merging, hence the 'Maybe'. See Note [Object merging] in     -- "GHC.Driver.Pipeline.Execute" for details.-  , toolSettings_pgm_dll     :: (String, [Option])-  , toolSettings_pgm_T       :: String   , toolSettings_pgm_windres :: String   , toolSettings_pgm_ar      :: String   , toolSettings_pgm_otool   :: String@@ -118,8 +117,8 @@     toolSettings_pgm_lo      :: (String, [Option])   , -- | LLVM: llc static compiler     toolSettings_pgm_lc      :: (String, [Option])-  , -- | LLVM: c compiler-    toolSettings_pgm_lcc     :: (String, [Option])+    -- | LLVM: assembler+  , toolSettings_pgm_las     :: (String, [Option])   , toolSettings_pgm_i       :: String    -- options for particular phases@@ -139,8 +138,7 @@     toolSettings_opt_lo            :: [String]   , -- | LLVM: llc static compiler     toolSettings_opt_lc            :: [String]-  , -- | LLVM: c compiler-    toolSettings_opt_lcc           :: [String]+  , toolSettings_opt_las           :: [String]   , -- | iserv options     toolSettings_opt_i             :: [String] @@ -192,8 +190,8 @@ sLdSupportsCompactUnwind = toolSettings_ldSupportsCompactUnwind . sToolSettings sLdSupportsFilelist :: Settings -> Bool sLdSupportsFilelist = toolSettings_ldSupportsFilelist . sToolSettings-sLdSupportsResponseFiles :: Settings -> Bool-sLdSupportsResponseFiles = toolSettings_ldSupportsResponseFiles . sToolSettings+sMergeObjsSupportsResponseFiles :: Settings -> Bool+sMergeObjsSupportsResponseFiles = toolSettings_mergeObjsSupportsResponseFiles . sToolSettings sLdIsGnuLd :: Settings -> Bool sLdIsGnuLd = toolSettings_ldIsGnuLd . sToolSettings sGccSupportsNoPie :: Settings -> Bool@@ -213,16 +211,14 @@ sPgm_c = toolSettings_pgm_c . sToolSettings sPgm_cxx :: Settings -> String sPgm_cxx = toolSettings_pgm_cxx . sToolSettings+sPgm_cpp :: Settings -> (String, [Option])+sPgm_cpp = toolSettings_pgm_cpp . sToolSettings sPgm_a :: Settings -> (String, [Option]) sPgm_a = toolSettings_pgm_a . sToolSettings sPgm_l :: Settings -> (String, [Option]) sPgm_l = toolSettings_pgm_l . sToolSettings sPgm_lm :: Settings -> Maybe (String, [Option]) sPgm_lm = toolSettings_pgm_lm . sToolSettings-sPgm_dll :: Settings -> (String, [Option])-sPgm_dll = toolSettings_pgm_dll . sToolSettings-sPgm_T :: Settings -> String-sPgm_T = toolSettings_pgm_T . sToolSettings sPgm_windres :: Settings -> String sPgm_windres = toolSettings_pgm_windres . sToolSettings sPgm_ar :: Settings -> String@@ -237,8 +233,8 @@ sPgm_lo = toolSettings_pgm_lo . sToolSettings sPgm_lc :: Settings -> (String, [Option]) sPgm_lc = toolSettings_pgm_lc . sToolSettings-sPgm_lcc :: Settings -> (String, [Option])-sPgm_lcc = toolSettings_pgm_lcc . sToolSettings+sPgm_las :: Settings -> (String, [Option])+sPgm_las = toolSettings_pgm_las . sToolSettings sPgm_i :: Settings -> String sPgm_i = toolSettings_pgm_i . sToolSettings sOpt_L :: Settings -> [String]@@ -265,8 +261,6 @@ sOpt_lo = toolSettings_opt_lo . sToolSettings sOpt_lc :: Settings -> [String] sOpt_lc = toolSettings_opt_lc . sToolSettings-sOpt_lcc :: Settings -> [String]-sOpt_lcc = toolSettings_opt_lcc . sToolSettings sOpt_i :: Settings -> [String] sOpt_i = toolSettings_opt_i . sToolSettings
compiler/GHC/Settings/Constants.hs view
@@ -30,7 +30,7 @@ mAX_SOLVER_ITERATIONS :: Int mAX_SOLVER_ITERATIONS = 4 --- | In case of loopy quantified costraints constraints,+-- | In case of loopy quantified constraints constraints, --   how many times should we allow superclass expansions --   Should be less than mAX_SOLVER_ITERATIONS --   See Note [Expanding Recursive Superclasses and ExpansionFuel]
compiler/GHC/Stg/InferTags/TagSig.hs view
@@ -5,7 +5,7 @@ -- We export this type from this module instead of GHC.Stg.InferTags.Types -- because it's used by more than the analysis itself. For example in interface -- files where we record a tag signature for bindings.--- By putting the sig into it's own module we can avoid module loops.+-- By putting the sig into its own module we can avoid module loops. module GHC.Stg.InferTags.TagSig  where
compiler/GHC/Stg/Lift/Types.hs view
@@ -4,7 +4,7 @@  -- This module declares some basic types used by GHC.Stg.Lift -- We can import this module into GHC.Stg.Syntax, where the--- type instance declartions for BinderP etc live+-- type instance declarations for BinderP etc live  module GHC.Stg.Lift.Types(    Skeleton(..),
compiler/GHC/Stg/Syntax.hs view
@@ -56,6 +56,11 @@         stgRhsArity, freeVarsOfRhs,         isDllConApp,         stgArgType,+        stgArgRep,+        stgArgRep1,+        stgArgRepU,+        stgArgRep_maybe,+         stgCaseBndrInScope,          -- ppr@@ -76,7 +81,7 @@  import GHC.Core     ( AltCon ) import GHC.Core.DataCon-import GHC.Core.TyCon    ( PrimRep(..), TyCon )+import GHC.Core.TyCon    ( PrimRep(..), PrimOrVoidRep(..), TyCon ) import GHC.Core.Type     ( Type ) import GHC.Core.Ppr( {- instances -} ) @@ -86,7 +91,7 @@ import GHC.Types.Tickish     ( StgTickish ) import GHC.Types.Var.Set import GHC.Types.Literal     ( Literal, literalType )-import GHC.Types.RepType ( typePrimRep1, typePrimRep )+import GHC.Types.RepType ( typePrimRep, typePrimRep1, typePrimRepU, typePrimRep_maybe )  import GHC.Unit.Module       ( Module ) import GHC.Utils.Outputable@@ -173,23 +178,44 @@ --    $WT1 = T1 Int (Coercion (Refl Int)) -- -- The coercion argument here gets VoidRep-isAddrRep :: PrimRep -> Bool-isAddrRep AddrRep      = True-isAddrRep (BoxedRep _) = True -- FIXME: not true for JavaScript-isAddrRep _            = False+isAddrRep :: PrimOrVoidRep -> Bool+isAddrRep (NVRep AddrRep)      = True+isAddrRep (NVRep (BoxedRep _)) = True -- FIXME: not true for JavaScript+isAddrRep _                    = False  -- | Type of an @StgArg@ -- -- Very half baked because we have lost the type arguments.+--+-- This function should be avoided: in STG we aren't supposed to+-- look at types, but only PrimReps.+-- Use 'stgArgRep', 'stgArgRep_maybe', 'stgArgRep1' instaed. stgArgType :: StgArg -> Type stgArgType (StgVarArg v)   = idType v stgArgType (StgLitArg lit) = literalType lit +stgArgRep :: StgArg -> [PrimRep]+stgArgRep ty = typePrimRep (stgArgType ty)++stgArgRep_maybe :: StgArg -> Maybe [PrimRep]+stgArgRep_maybe ty = typePrimRep_maybe (stgArgType ty)++-- | Assumes that the argument has at most one PrimRep, which holds after unarisation.+-- See Note [Post-unarisation invariants] in GHC.Stg.Unarise.+-- See Note [VoidRep] in GHC.Types.RepType.+stgArgRep1 :: StgArg -> PrimOrVoidRep+stgArgRep1 ty = typePrimRep1 (stgArgType ty)++-- | Assumes that the argument has exactly one PrimRep.+-- See Note [VoidRep] in GHC.Types.RepType.+stgArgRepU :: StgArg -> PrimRep+stgArgRepU ty = typePrimRepU (stgArgType ty)+ -- | Given an alt type and whether the program is unarised, return whether the -- case binder is in scope. -- -- Case binders of unboxed tuple or unboxed sum type always dead after the--- unariser has run. See Note [Post-unarisation invariants].+-- unariser has run. See Note [Post-unarisation invariants] in GHC.Stg.Unarise. stgCaseBndrInScope :: AltType -> Bool {- ^ unarised? -} -> Bool stgCaseBndrInScope alt_ty unarised =     case alt_ty of@@ -291,7 +317,7 @@   | StgConApp   DataCon                 ConstructorNumber                 [StgArg] -- Saturated. See Note [Constructor applications in STG]-                [Type]   -- See Note [Types in StgConApp] in GHC.Stg.Unarise+                [[PrimRep]]   -- See Note [Representations in StgConApp] in GHC.Stg.Unarise    | StgOpApp    StgOp    -- Primitive op or foreign call                 [StgArg] -- Saturated.@@ -880,10 +906,9 @@              , hang (text "} in ") 2 (pprStgExpr opts expr)              ] -   StgTick _tickish expr -> sdocOption sdocSuppressTicks $ \case+   StgTick tickish expr -> sdocOption sdocSuppressTicks $ \case       True  -> pprStgExpr opts expr-      False -> pprStgExpr opts expr-        -- XXX sep [ ppr tickish, pprStgExpr opts expr ]+      False -> sep [ ppr tickish, pprStgExpr opts expr ]     -- Don't indent for a single case alternative.    StgCase expr bndr alt_type [alt]
compiler/GHC/StgToCmm/Config.hs view
@@ -50,6 +50,7 @@   , stgToCmmFastPAPCalls   :: !Bool              -- ^   , stgToCmmSCCProfiling   :: !Bool              -- ^ Check if cost-centre profiling is enabled   , stgToCmmEagerBlackHole :: !Bool              -- ^+  , stgToCmmOrigThunkInfo  :: !Bool              -- ^ Push @stg_orig_thunk_info@ frames during thunk update.   , stgToCmmInfoTableMap   :: !Bool              -- ^ true means generate C Stub for IPE map, See Note [Mapping Info Tables to Source Positions]   , stgToCmmInfoTableMapWithFallback :: !Bool    -- ^ Include info tables with fallback source locations in the info table map   , stgToCmmInfoTableMapWithStack :: !Bool       -- ^ Include info tables for STACK closures in the info table map@@ -64,6 +65,7 @@   , stgToCmmDoTagCheck     :: !Bool              -- ^ Verify tag inference predictions.   ------------------------------ Backend Flags ----------------------------------   , stgToCmmAllowBigArith             :: !Bool   -- ^ Allowed to emit larger than native size arithmetic (only LLVM and C backends)+  , stgToCmmAllowBigQuot              :: !Bool   -- ^ Allowed to emit larger than native size division operations   , stgToCmmAllowQuotRemInstr         :: !Bool   -- ^ Allowed to generate QuotRem instructions   , stgToCmmAllowQuotRem2             :: !Bool   -- ^ Allowed to generate QuotRem   , stgToCmmAllowExtendedAddSubInstrs :: !Bool   -- ^ Allowed to generate AddWordC, SubWordC, Add2, etc.
compiler/GHC/StgToJS/Linker/Types.hs view
@@ -18,8 +18,6 @@  module GHC.StgToJS.Linker.Types   ( JSLinkConfig (..)-  , defaultJSLinkConfig-  , LinkedObj (..)   , LinkPlan (..)   ) where@@ -27,7 +25,7 @@ import GHC.StgToJS.Object  import GHC.Unit.Types-import GHC.Utils.Outputable (hsep,Outputable(..),text,ppr, hang, IsDoc (vcat), IsLine (hcat))+import GHC.Utils.Outputable (Outputable(..),text,ppr, hang, IsDoc (vcat), IsLine (hcat))  import Data.Map.Strict      (Map) import Data.Set             (Set)@@ -42,23 +40,18 @@ --------------------------------------------------------------------------------  data JSLinkConfig = JSLinkConfig-  { lcNoJSExecutables    :: !Bool -- ^ Dont' build JS executables-  , lcNoHsMain           :: !Bool -- ^ Don't generate Haskell main entry-  , lcNoRts              :: !Bool -- ^ Don't dump the generated RTS-  , lcNoStats            :: !Bool -- ^ Disable .stats file generation-  , lcForeignRefs        :: !Bool -- ^ Dump .frefs (foreign references) files-  , lcCombineAll         :: !Bool -- ^ Generate all.js (combined js) + wrappers-  }---- | Default linker configuration-defaultJSLinkConfig :: JSLinkConfig-defaultJSLinkConfig = JSLinkConfig-  { lcNoJSExecutables = False-  , lcNoHsMain        = False-  , lcNoRts           = False-  , lcNoStats         = False-  , lcCombineAll      = True-  , lcForeignRefs     = True+  { lcNoJSExecutables :: !Bool         -- ^ Dont' build JS executables+  , lcNoHsMain        :: !Bool         -- ^ Don't generate Haskell main entry+  , lcNoRts           :: !Bool         -- ^ Don't dump the generated RTS+  , lcNoStats         :: !Bool         -- ^ Disable .stats file generation+  , lcForeignRefs     :: !Bool         -- ^ Dump .frefs (foreign references) files+  , lcCombineAll      :: !Bool         -- ^ Generate all.js (combined js) + wrappers+  , lcForceEmccRts    :: !Bool+      -- ^ Force the link with the emcc rts. Use this if you plan to dynamically+      -- load wasm modules made from C files (e.g. in iserv).+  , lcLinkCsources    :: !Bool+      -- ^ Link C sources (compiled to JS/Wasm) with Haskell code compiled to+      -- JS. This implies the use of the Emscripten RTS to load this code.   }  data LinkPlan = LinkPlan@@ -68,11 +61,15 @@   , lkp_dep_blocks :: Set BlockRef       -- ^ Blocks to link -  , lkp_archives   :: Set FilePath-      -- ^ Archives to load JS sources from+  , lkp_archives   :: !(Set FilePath)+      -- ^ Archives to load JS and Cc sources from (JS code corresponding to+      -- Haskell code is handled with blocks above) -  , lkp_extra_js   :: Set FilePath-      -- ^ Extra JS files to link+  , lkp_objs_js   :: !(Set FilePath)+      -- ^ JS objects to link++  , lkp_objs_cc   :: !(Set FilePath)+      -- ^ Cc objects to link   }  instance Outputable LinkPlan where@@ -81,20 +78,7 @@             -- plan, just meta info used to retrieve actual block contents             -- [ hcat [ text "Block info: ", ppr (lkp_block_info s)]             [ hcat [ text "Blocks: ", ppr (S.size (lkp_dep_blocks s))]-            , hang (text "JS files from archives:") 2 (vcat (fmap text (S.toList (lkp_archives s))))-            , hang (text "Extra JS:") 2 (vcat (fmap text (S.toList (lkp_extra_js s))))+            , hang (text "Archives:") 2 (vcat (fmap text (S.toList (lkp_archives s))))+            , hang (text "Extra JS objects:") 2 (vcat (fmap text (S.toList (lkp_objs_js s))))+            , hang (text "Extra Cc objects:") 2 (vcat (fmap text (S.toList (lkp_objs_cc s))))             ]------------------------------------------------------------------------------------- Linker Environment------------------------------------------------------------------------------------- | An object file that's either already in memory (with name) or on disk-data LinkedObj-  = ObjFile   FilePath      -- ^ load from this file-  | ObjLoaded String Object -- ^ already loaded: description and payload--instance Outputable LinkedObj where-  ppr = \case-    ObjFile fp    -> hsep [text "ObjFile", text fp]-    ObjLoaded s o -> hsep [text "ObjLoaded", text s, ppr (objModuleName o)]
compiler/GHC/StgToJS/Object.hs view
@@ -3,6 +3,9 @@ {-# LANGUAGE OverloadedStrings          #-} {-# LANGUAGE Rank2Types                 #-} {-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE ViewPatterns               #-}+{-# LANGUAGE MagicHash                  #-}+{-# LANGUAGE MultiWayIf                 #-}  -- only for DB.Binary instances on Module {-# OPTIONS_GHC -fno-warn-orphans #-}@@ -20,28 +23,23 @@ -- Stability   :  experimental -- --  Serialization/deserialization of binary .o files for the JavaScript backend---  The .o files contain dependency information and generated code.---  All strings are mapped to a central string table, which helps reduce---  file size and gives us efficient hash consing on read -----  Binary intermediate JavaScript object files:---   serialized [Text] -> ([ClosureInfo], JStat) blocks------  file layout:---   - magic "GHCJSOBJ"---   - compiler version tag---   - module name---   - offsets of string table---   - dependencies---   - offset of the index---   - unit infos---   - index---   - string table--- -----------------------------------------------------------------------------  module GHC.StgToJS.Object-  ( putObject+  ( ObjectKind(..)+  , getObjectKind+  , getObjectKindBS+  -- * JS object+  , JSOptions(..)+  , defaultJSOptions+  , getOptionsFromJsFile+  , writeJSObject+  , readJSObject+  , parseJSObject+  , parseJSObjectBS+  -- * HS object+  , putObject   , getObjectHeader   , getObjectBody   , getObject@@ -50,7 +48,6 @@   , readObjectBlocks   , readObjectBlockInfo   , isGlobalBlock-  , isJsObjectFile   , Object(..)   , IndexEntry(..)   , LocatedBlockInfo (..)@@ -73,17 +70,19 @@ import           Data.IntSet (IntSet) import qualified Data.IntSet as IS import           Data.List (sortOn)+import qualified Data.List as List import           Data.Map (Map) import qualified Data.Map as M import           Data.Word-import           Data.Char-import Foreign.Storable-import Foreign.Marshal.Array+import           Data.Semigroup+import qualified Data.ByteString          as B+import qualified Data.ByteString.Unsafe   as B+import Data.Char (isSpace) import System.IO  import GHC.Settings.Constants (hiVersion) -import GHC.JS.Unsat.Syntax+import GHC.JS.Ident import qualified GHC.JS.Syntax as Sat import GHC.StgToJS.Types @@ -96,8 +95,76 @@ import GHC.Utils.Binary hiding (SymbolTable) import GHC.Utils.Outputable (ppr, Outputable, hcat, vcat, text, hsep) import GHC.Utils.Monad (mapMaybeM)+import GHC.Utils.Panic+import GHC.Utils.Misc (dropWhileEndLE)+import System.IO.Unsafe+import qualified Control.Exception as Exception --- | An object file+----------------------------------------------+-- The JS backend supports 3 kinds of objects:+--   1. HS objects: produced from Haskell sources+--   2. JS objects: produced from JS sources+--   3. Cc objects: produced by emcc (e.g. from C sources)+--+-- They all have a different header that allows them to be distinguished.+-- See ObjectKind type.+----------------------------------------------++-- | Different kinds of object (.o) supported by the JS backend+data ObjectKind+  = ObjJs -- ^ JavaScript source embedded in a .o+  | ObjHs -- ^ JS backend object for Haskell code+  | ObjCc -- ^ Wasm module object as produced by emcc+  deriving (Show,Eq,Ord)++-- | Get the kind of a file object, if any+getObjectKind :: FilePath -> IO (Maybe ObjectKind)+getObjectKind fp = withBinaryFile fp ReadMode $ \h -> do+  let !max_header_length = max (B.length jsHeader)+                           $ max (B.length wasmHeader)+                                 (B.length hsHeader)++  bs <- B.hGet h max_header_length+  pure $! getObjectKindBS bs++-- | Get the kind of an object stored in a bytestring, if any+getObjectKindBS :: B.ByteString -> Maybe ObjectKind+getObjectKindBS bs+  | jsHeader   `B.isPrefixOf` bs = Just ObjJs+  | hsHeader   `B.isPrefixOf` bs = Just ObjHs+  | wasmHeader `B.isPrefixOf` bs = Just ObjCc+  | otherwise                    = Nothing++-- Header added to JS sources to discriminate them from other object files.+-- They all have .o extension but JS sources have this header.+jsHeader :: B.ByteString+jsHeader = unsafePerformIO $ B.unsafePackAddressLen 8 "GHCJS_JS"#++hsHeader :: B.ByteString+hsHeader = unsafePerformIO $ B.unsafePackAddressLen 8 "GHCJS_HS"#++wasmHeader :: B.ByteString+wasmHeader = unsafePerformIO $ B.unsafePackAddressLen 4 "\0asm"#++++------------------------------------------------+-- HS objects+--+--  file layout:+--   - magic "GHCJS_HS"+--   - compiler version tag+--   - module name+--   - offsets of string table+--   - dependencies+--   - offset of the index+--   - unit infos+--   - index+--   - string table+--+------------------------------------------------++-- | A HS object file data Object = Object   { objModuleName    :: !ModuleName     -- ^ name of the module@@ -216,11 +283,6 @@       }  --- | A tag that determines the kind of payload in the .o file. See--- @StgToJS.Linker.Arhive.magic@ for another kind of magic-magic :: String-magic = "GHCJSOBJ"- -- | Serialized block indexes and their exported symbols -- (the first block is module-global) type Index = [IndexEntry]@@ -231,7 +293,7 @@   ----------------------------------------------------------------------------------- Essential oeprations on Objects+-- Essential operations on Objects --------------------------------------------------------------------------------  -- | Given a handle to a Binary payload, add the module, 'mod_name', its@@ -243,7 +305,7 @@   -> [ObjBlock] -- ^ linkable units and their symbols   -> IO () putObject bh mod_name deps os = do-  forM_ magic (putByte bh . fromIntegral . ord)+  putByteString bh hsHeader   put_ bh (show hiVersion)    -- we store the module name as a String because we don't want to have to@@ -266,37 +328,12 @@         pure (oiSymbols o,p)       pure idx --- | Test if the object file is a JS object-isJsObjectFile :: FilePath -> IO Bool-isJsObjectFile fp = do-  let !n = length magic-  withBinaryFile fp ReadMode $ \hdl -> do-    allocaArray n $ \ptr -> do-      n' <- hGetBuf hdl ptr n-      if (n' /= n)-        then pure False-        else checkMagic (peekElemOff ptr)---- | Check magic-checkMagic :: (Int -> IO Word8) -> IO Bool-checkMagic get_byte = do-  let go_magic !i = \case-        []     -> pure True-        (e:es) -> get_byte i >>= \case-          c | fromIntegral (ord e) == c -> go_magic (i+1) es-            | otherwise                 -> pure False-  go_magic 0 magic---- | Parse object magic-getCheckMagic :: BinHandle -> IO Bool-getCheckMagic bh = checkMagic (const (getByte bh))- -- | Parse object header getObjectHeader :: BinHandle -> IO (Either String ModuleName) getObjectHeader bh = do-  is_magic <- getCheckMagic bh-  case is_magic of-    False -> pure (Left "invalid magic header")+  magic <- getByteString bh (B.length hsHeader)+  case magic == hsHeader of+    False -> pure (Left "invalid magic header for HS object")     True  -> do       is_correct_version <- ((== hiVersion) . read) <$> get bh       case is_correct_version of@@ -306,7 +343,7 @@           pure (Right (mkModuleName (mod_name)))  --- | Parse object body. Must be called after a sucessful getObjectHeader+-- | Parse object body. Must be called after a successful getObjectHeader getObjectBody :: BinHandle -> ModuleName -> IO Object getObjectBody bh0 mod_name = do   -- Read the string table@@ -483,8 +520,9 @@   put_ bh (Sat.JInt i)      = putByte bh 4 >> put_ bh i   put_ bh (Sat.JStr xs)     = putByte bh 5 >> put_ bh xs   put_ bh (Sat.JRegEx xs)   = putByte bh 6 >> put_ bh xs-  put_ bh (Sat.JHash m)     = putByte bh 7 >> put_ bh (sortOn (LexicalFastString . fst) $ nonDetUniqMapToList m)-  put_ bh (Sat.JFunc is s)  = putByte bh 8 >> put_ bh is >> put_ bh s+  put_ bh (Sat.JBool b)     = putByte bh 7 >> put_ bh b+  put_ bh (Sat.JHash m)     = putByte bh 8 >> put_ bh (sortOn (LexicalFastString . fst) $ nonDetUniqMapToList m)+  put_ bh (Sat.JFunc is s)  = putByte bh 9 >> put_ bh is >> put_ bh s   get bh = getByte bh >>= \case     1 -> Sat.JVar    <$> get bh     2 -> Sat.JList   <$> get bh@@ -492,13 +530,14 @@     4 -> Sat.JInt    <$> get bh     5 -> Sat.JStr    <$> get bh     6 -> Sat.JRegEx  <$> get bh-    7 -> Sat.JHash . listToUniqMap <$> get bh-    8 -> Sat.JFunc   <$> get bh <*> get bh+    7 -> Sat.JBool   <$> get bh+    8 -> Sat.JHash . listToUniqMap <$> get bh+    9 -> Sat.JFunc   <$> get bh <*> get bh     n -> error ("Binary get bh Sat.JVal: invalid tag: " ++ show n)  instance Binary Ident where-  put_ bh (TxtI xs) = put_ bh xs-  get bh = TxtI <$> get bh+  put_ bh (identFS -> xs) = put_ bh xs+  get  bh                = global <$> get bh  instance Binary ClosureInfo where   put_ bh (ClosureInfo v regs name layo typ static) = do@@ -509,7 +548,7 @@   put_ bh = putEnum bh   get bh = getEnum bh -instance Binary VarType where+instance Binary JSRep where   put_ bh = putEnum bh   get bh = getEnum bh @@ -629,3 +668,134 @@     6 -> BinLit    <$> get bh     7 -> LabelLit  <$> get bh <*> get bh     n -> error ("Binary get bh StaticLit: invalid tag " ++ show n)+++------------------------------------------------+-- JS objects+------------------------------------------------++-- | Options obtained from pragmas in JS files+data JSOptions = JSOptions+  { enableCPP                  :: !Bool     -- ^ Enable CPP on the JS file+  , emccExtraOptions           :: ![String] -- ^ Pass additional options to emcc at link time+  , emccExportedFunctions      :: ![String] -- ^ Arguments for `-sEXPORTED_FUNCTIONS`+  , emccExportedRuntimeMethods :: ![String] -- ^ Arguments for `-sEXPORTED_RUNTIME_METHODS`+  }+  deriving (Eq, Ord)+++instance Binary JSOptions where+  put_ bh (JSOptions a b c d) = do+    put_ bh a+    put_ bh b+    put_ bh c+    put_ bh d+  get bh = JSOptions <$> get bh <*> get bh <*> get bh <*> get bh++instance Semigroup JSOptions where+  a <> b = JSOptions+    { enableCPP                  = enableCPP a || enableCPP b+    , emccExtraOptions           = emccExtraOptions a ++ emccExtraOptions b+    , emccExportedFunctions      = List.nub (List.sort (emccExportedFunctions a ++ emccExportedFunctions b))+    , emccExportedRuntimeMethods = List.nub (List.sort (emccExportedRuntimeMethods a ++ emccExportedRuntimeMethods b))+    }++defaultJSOptions :: JSOptions+defaultJSOptions = JSOptions+  { enableCPP                  = False+  , emccExtraOptions           = []+  , emccExportedRuntimeMethods = []+  , emccExportedFunctions      = []+  }++-- mimics `lines` implementation+splitOnComma :: String -> [String]+splitOnComma s = cons $ case break (== ',') s of+                                   (l, s') -> (l, case s' of+                                                    []      -> []+                                                    _:s''   -> splitOnComma s'')+  where+    cons ~(h, t)        =  h : t++++-- | Get the JS option pragmas from .js files+getJsOptions :: Handle -> IO JSOptions+getJsOptions handle = do+  hSetEncoding handle utf8+  let trim = dropWhileEndLE isSpace . dropWhile isSpace+  let go opts = do+        hIsEOF handle >>= \case+          True -> pure opts+          False -> do+            xs <- hGetLine handle+            if not ("//#OPTIONS:" `List.isPrefixOf` xs)+              then pure opts+              else do+                -- drop prefix and spaces+                let ys = trim (drop 11 xs)+                let opts' = if+                      | ys == "CPP"+                      -> opts {enableCPP = True}++                      | Just s <- List.stripPrefix "EMCC:EXPORTED_FUNCTIONS=" ys+                      , fns <- fmap trim (splitOnComma s)+                      -> opts { emccExportedFunctions = emccExportedFunctions opts ++ fns }++                      | Just s <- List.stripPrefix "EMCC:EXPORTED_RUNTIME_METHODS=" ys+                      , fns <- fmap trim (splitOnComma s)+                      -> opts { emccExportedRuntimeMethods = emccExportedRuntimeMethods opts ++ fns }++                      | Just s <- List.stripPrefix "EMCC:EXTRA=" ys+                      -> opts { emccExtraOptions = emccExtraOptions opts ++ [s] }++                      | otherwise+                      -> panic ("Unrecognized JS pragma: " ++ ys)++                go opts'+  go defaultJSOptions++-- | Parse option pragma in JS file+getOptionsFromJsFile :: FilePath     -- ^ Input file+                     -> IO JSOptions -- ^ Parsed options.+getOptionsFromJsFile filename+    = Exception.bracket+              (openBinaryFile filename ReadMode)+              hClose+              getJsOptions+++-- | Write a JS object (embed some handwritten JS code)+writeJSObject :: JSOptions -> B.ByteString -> FilePath -> IO ()+writeJSObject opts contents output_fn = do+  bh <- openBinMem (B.length contents + 1000)++  putByteString bh jsHeader+  put_ bh opts+  put_ bh contents++  writeBinMem bh output_fn+++-- | Read a JS object from BinHandle+parseJSObject :: BinHandle -> IO (JSOptions, B.ByteString)+parseJSObject bh = do+  magic <- getByteString bh (B.length jsHeader)+  case magic == jsHeader of+    False -> panic "invalid magic header for JS object"+    True  -> do+      opts     <- get bh+      contents <- get bh+      pure (opts,contents)++-- | Read a JS object from ByteString+parseJSObjectBS :: B.ByteString -> IO (JSOptions, B.ByteString)+parseJSObjectBS bs = do+  bh <- unsafeUnpackBinBuffer bs+  parseJSObject bh++-- | Read a JS object from file+readJSObject :: FilePath -> IO (JSOptions, B.ByteString)+readJSObject input_fn = do+  bh <- readBinMem input_fn+  parseJSObject bh
compiler/GHC/StgToJS/Types.hs view
@@ -22,13 +22,15 @@  import GHC.Prelude -import GHC.JS.Unsat.Syntax+import GHC.JS.JStg.Syntax+import GHC.JS.Ident import qualified GHC.JS.Syntax as Sat import GHC.JS.Make import GHC.JS.Ppr ()  import GHC.Stg.Syntax import GHC.Core.TyCon+import GHC.Linker.Config  import GHC.Types.Unique import GHC.Types.Unique.FM@@ -60,12 +62,12 @@   , gsIdents    :: !IdCache               -- ^ hash consing for identifiers from a Unique   , gsUnfloated :: !(UniqFM Id CgStgExpr) -- ^ unfloated arguments   , gsGroup     :: GenGroupState          -- ^ state for the current binding group-  , gsGlobal    :: [JStat]                -- ^ global (per module) statements (gets included when anything else from the module is used)+  , gsGlobal    :: [JStgStat]             -- ^ global (per module) statements (gets included when anything else from the module is used)   }  -- | The JS code generator state relevant for the current binding group data GenGroupState = GenGroupState-  { ggsToplevelStats :: [JStat]        -- ^ extra toplevel statements for the binding group+  { ggsToplevelStats :: [JStgStat]     -- ^ extra toplevel statements for the binding group   , ggsClosureInfo   :: [ClosureInfo]  -- ^ closure metadata (info tables) for the binding group   , ggsStatic        :: [StaticInfo]   -- ^ static (CAF) data in our binding group   , ggsStack         :: [StackSlot]    -- ^ stack info for the current expression@@ -93,6 +95,7 @@   , csRuntimeAssert   :: !Bool -- ^ Enable runtime assertions   -- settings   , csContext         :: !SDocContext+  , csLinkerConfig    :: !LinkerConfig -- ^ Emscripten linker   }  -- | Information relevenat to code generation for closures.@@ -110,7 +113,7 @@ data CIRegs   = CIRegsUnknown                     -- ^ A value witnessing a state of unknown registers   | CIRegs { ciRegsSkip  :: Int       -- ^ unused registers before actual args start-           , ciRegsTypes :: [VarType] -- ^ args+           , ciRegsTypes :: [JSRep]   -- ^ args            }   deriving stock (Eq, Ord, Show) @@ -122,7 +125,7 @@       }   | CILayoutFixed               -- ^ whole layout known       { layoutSize :: !Int      -- ^ closure size in array positions, including entry-      , layout     :: [VarType] -- ^ The set of sized Types to layout+      , layout     :: [JSRep]   -- ^ The list of JSReps to layout       }   deriving stock (Eq, Ord, Show) @@ -147,10 +150,10 @@ --   note: only works after all top-level objects have been created instance ToJExpr CIStatic where   toJExpr (CIStaticRefs [])  = null_ -- [je| null |]-  toJExpr (CIStaticRefs rs)  = toJExpr (map TxtI rs)+  toJExpr (CIStaticRefs rs)  = toJExpr (map global rs) --- | Free variable types-data VarType+-- | JS primitive representations+data JSRep   = PtrV     -- ^ pointer = reference to heap object (closure object), lifted or not.              -- Can also be some RTS object (e.g. TVar#, MVar#, MutVar#, Weak#)   | VoidV    -- ^ no fields@@ -162,21 +165,21 @@   | ArrV     -- ^ boxed array   deriving stock (Eq, Ord, Enum, Bounded, Show) -instance ToJExpr VarType where+instance ToJExpr JSRep where   toJExpr = toJExpr . fromEnum  -- | The type of identifiers. These determine the suffix of generated functions -- in JS Land. For example, the entry function for the 'Just' constructor is a -- 'IdConEntry' which compiles to: -- @--- function h$baseZCGHCziMaybeziJust_con_e() { return h$rs() };+-- function h$ghczminternalZCGHCziInternalziMaybeziJust_con_e() { return h$rs() }; -- @ -- which just returns whatever the stack point is pointing to. Whereas the entry -- function to 'Just' is an 'IdEntry' and does the work. It compiles to: -- @--- function h$baseZCGHCziMaybeziJust_e() {+-- function h$ghczminternalZCGHCziInternalziMaybeziJust_e() { --    var h$$baseZCGHCziMaybezieta_8KXnScrCjF5 = h$r2;---    h$r1 = h$c1(h$baseZCGHCziMaybeziJust_con_e, h$$baseZCGHCziMaybezieta_8KXnScrCjF5);+--    h$r1 = h$c1(h$ghczminternalZCGHCziInternalziMaybeziJust_con_e, h$$ghczminternalZCGHCziInternalziMaybezieta_8KXnScrCjF5); --    return h$rs(); --    }; -- @@@ -338,28 +341,26 @@ -- | Typed expression data TypedExpr = TypedExpr   { typex_typ  :: !PrimRep-  , typex_expr :: [JExpr]+  , typex_expr :: [JStgExpr]   } --- FIXME: temporarily removed until JStg replaces JStat--- instance Outputable TypedExpr where---   ppr x = text "TypedExpr: " <+> ppr (typex_expr x)---           $$  text "PrimReps: " <+> ppr (typex_typ x)+instance Outputable TypedExpr where+  ppr (TypedExpr typ x) = ppr (typ, x)  -- | A Primop result is either an inlining of some JS payload, or a primitive -- call to a JS function defined in Shim files in base. data PrimRes-  = PrimInline JStat  -- ^ primop is inline, result is assigned directly-  | PRPrimCall JStat  -- ^ primop is async call, primop returns the next-                      -- function to run. result returned to stack top in-                      -- registers+  = PrimInline JStgStat  -- ^ primop is inline, result is assigned directly+  | PRPrimCall JStgStat  -- ^ primop is async call, primop returns the next+                         -- function to run. result returned to stack top in+                         -- registers  data ExprResult   = ExprCont-  | ExprInline (Maybe [JExpr])+  | ExprInline   deriving (Eq) -newtype ExprValData = ExprValData [JExpr]+newtype ExprValData = ExprValData [JStgExpr]   deriving newtype (Eq)  -- | A Closure is one of six types
compiler/GHC/Tc/Errors/Ppr.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MonadComprehensions #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE DataKinds #-}@@ -23,6 +24,9 @@   , pprTyThingUsedWrong   , pprUntouchableVariable +  --+  , mismatchMsg_ExpectedActuals+   -- | Useful when overriding message printing.   , messageWithInfoDiagnosticMessage   , messageWithHsDocContext@@ -34,7 +38,7 @@ import qualified Language.Haskell.TH as TH  import GHC.Builtin.Names-import GHC.Builtin.Types ( boxedRepDataConTyCon, tYPETyCon, filterCTuple )+import GHC.Builtin.Types ( boxedRepDataConTyCon, tYPETyCon, filterCTuple, pretendNameIsInScope )  import GHC.Types.Name.Reader import GHC.Unit.Module.ModIface@@ -65,7 +69,7 @@ import GHC.Tc.Errors.Types import GHC.Tc.Types.BasicTypes import GHC.Tc.Types.Constraint-import GHC.Tc.Types.Origin+import GHC.Tc.Types.Origin hiding ( Position(..) ) import GHC.Tc.Types.Rank (Rank(..)) import GHC.Tc.Types.TH import GHC.Tc.Utils.TcType@@ -74,7 +78,7 @@ import GHC.Types.Hint import GHC.Types.Hint.Ppr () -- Outputable GhcHint import GHC.Types.Basic-import GHC.Types.Error.Codes ( constructorCode )+import GHC.Types.Error.Codes import GHC.Types.Id import GHC.Types.Id.Info ( RecSelParent(..) ) import GHC.Types.Name@@ -141,7 +145,7 @@                   (diagnosticMessage opts msg)     TcRnWithHsDocContext ctxt msg       -> messageWithHsDocContext opts ctxt (diagnosticMessage opts msg)-    TcRnSolverReport msg _ _+    TcRnSolverReport msg _       -> mkSimpleDecorated $ pprSolverReportWithCtxt msg     TcRnSolverDepthError ty depth -> mkSimpleDecorated msg       where@@ -273,6 +277,14 @@         sole_msg =           vcat [ text "except as the sole constraint"                , nest 2 (text "e.g., deriving instance _ => Eq (Foo a)") ]+    TcRnIllegalNamedWildcardInTypeArgument rdr+      -> mkSimpleDecorated $+           hang (text "Illegal named wildcard in a required type argument:")+                2 (quotes (ppr rdr))+    TcRnIllegalImplicitTyVarInTypeArgument rdr+      -> mkSimpleDecorated $+            hang (text "Illegal implicitly quantified type variable in a required type argument:")+                2 (quotes (ppr rdr))     TcRnDuplicateFieldName fld_part dups       -> mkSimpleDecorated $            hsep [ text "Duplicate field name"@@ -343,7 +355,7 @@                2 (vcat $ map pprLBind . bagToList $ binds)           where             pprLoc loc = parens (text "defined at" <+> ppr loc)-            pprLBind :: CollectPass GhcRn => GenLocated (SrcSpanAnn' a) (HsBindLR GhcRn idR) -> SDoc+            pprLBind :: CollectPass GhcRn => GenLocated (EpAnn a) (HsBindLR GhcRn idR) -> SDoc             pprLBind (L loc bind) = pprWithCommas ppr (collectHsBindBinders CollNoDictBinders bind)                                         <+> pprLoc (locA loc)     TcRnPartialTypeSigTyVarMismatch n1 n2 fn_name hs_ty@@ -435,11 +447,10 @@     TcRnIllegalInstance reason ->       mkSimpleDecorated $ pprIllegalInstance reason     TcRnVDQInTermType mb_ty-      -> mkSimpleDecorated $ vcat-           [ case mb_ty of+      -> mkSimpleDecorated $+             case mb_ty of                Nothing -> main_msg                Just ty -> hang (main_msg <> char ':') 2 (pprType ty)-           , text "(GHC does not yet support this)" ]       where         main_msg =           text "Illegal visible, dependent quantification" <+>@@ -778,11 +789,6 @@     TcRnArrowProcGADTPattern       -> mkSimpleDecorated $            text "Proc patterns cannot use existential or GADT data constructors"-    TcRnForallIdentifier rdr_name-      -> mkSimpleDecorated $-            fsep [ text "The use of" <+> quotes (ppr rdr_name)-                                     <+> text "as an identifier",-                   text "will become an error in a future GHC release." ]     TcRnTypeEqualityOutOfScope       -> mkDecorated            [ text "The" <+> quotes (text "~") <+> text "operator is out of scope." $$@@ -808,18 +814,12 @@             fsep [ text "Pattern matching on GADTs without MonoLocalBinds"                  , text "is fragile." ]     TcRnIncorrectNameSpace name _-      -> mkSimpleDecorated $ msg+      -> mkSimpleDecorated $+           text "The" <+> what <+> text "does not live in" <+> other_ns         where-          msg-            -- We are in a type-level namespace,-            -- and the name is incorrectly at the term-level.-            | isValNameSpace ns-            = text "The" <+> what <+> text "does not live in the type-level namespace"--            -- We are in a term-level namespace,-            -- and the name is incorrectly at the type-level.-            | otherwise-            = text "Illegal term-level use of the" <+> what+          -- the other (opposite) namespace+          other_ns | isValNameSpace ns = text "the type-level namespace"+                   | otherwise         = text "the term-level namespace"           ns = nameNameSpace name           what = pprNameSpace ns <+> quotes (ppr name)     TcRnNotInScope err name imp_errs _@@ -967,6 +967,7 @@     TcRnIllegalRecordSyntax either_ty_ty       -> mkSimpleDecorated $            text "Record syntax is illegal here:" <+> either ppr ppr either_ty_ty+     TcRnInvalidVisibleKindArgument arg ty       -> mkSimpleDecorated $            text "Cannot apply function of kind" <+> quotes (ppr ty)@@ -1027,7 +1028,6 @@                                        <+> quotes (pprTheta theta)                       FamDataConPE   -> text "it comes from a data family instance"-                     NoDataKindsDC  -> text "perhaps you intended to use DataKinds"                      PatSynPE       -> text "pattern synonyms cannot be promoted"                      RecDataConPE   -> same_rec_group_msg                      ClassPE        -> same_rec_group_msg@@ -1035,6 +1035,10 @@                      TermVariablePE -> text "term variables cannot be promoted"                      TypeVariablePE -> text "type variables bound in a kind signature cannot be used in the type"           same_rec_group_msg = text "it is defined and used in the same recursive group"+    TcRnIllegalTermLevelUse name err+      -> mkSimpleDecorated $+           text "Illegal term-level use of the" <+>+             text (teCategory err) <+> quotes (ppr name)     TcRnMatchesHaveDiffNumArgs argsContext (MatchArgMatches match1 bad_matches)       -> mkSimpleDecorated $            (vcat [ pprMatchContextNouns argsContext <+>@@ -1073,20 +1077,29 @@       -> mkSimpleDecorated $          text "You cannot SPECIALISE" <+> quotes (ppr name)            <+> text "because its definition is not visible in this module"-    TcRnPragmaWarning {pragma_warning_occ, pragma_warning_msg, pragma_warning_import_mod, pragma_warning_defined_mod}+    TcRnPragmaWarning+      { pragma_warning_info = PragmaWarningInstance{pwarn_dfunid, pwarn_ctorig}+      , pragma_warning_msg }       -> mkSimpleDecorated $+        sep [ hang (text "In the use of")+                 2 (pprDFunId pwarn_dfunid)+            , ppr pwarn_ctorig+            , pprWarningTxtForMsg pragma_warning_msg+         ]+    TcRnPragmaWarning {pragma_warning_info, pragma_warning_msg}+      -> mkSimpleDecorated $         sep [ sep [ text "In the use of"-                <+> pprNonVarNameSpace (occNameSpace pragma_warning_occ)-                <+> quotes (ppr pragma_warning_occ)-                , parens impMsg <> colon ]+                <+> pprNonVarNameSpace (occNameSpace occ_name)+                <+> quotes (ppr occ_name)+                , parens imp_msg <> colon ]           , pprWarningTxtForMsg pragma_warning_msg ]           where-            impMsg  = text "imported from" <+> ppr pragma_warning_import_mod <> extra-            extra = case pragma_warning_defined_mod of-                      Just def_mod-                        | def_mod /= pragma_warning_import_mod-                          -> text ", but defined in" <+> ppr def_mod-                      _ -> empty+            occ_name = pwarn_occname pragma_warning_info+            imp_mod = pwarn_impmod pragma_warning_info+            imp_msg  = text "imported from" <+> ppr imp_mod <> extra+            extra | PragmaWarningName {pwarn_declmod = decl_mod} <- pragma_warning_info+                  , imp_mod /= decl_mod = text ", but defined in" <+> ppr decl_mod+                  | otherwise = empty     TcRnDifferentExportWarnings name locs       -> mkSimpleDecorated $ vcat [quotes (ppr name) <+> text "exported with different error messages",                                    text "at" <+> vcat (map ppr $ sortBy leftmost_smallest $ NE.toList locs)]@@ -1236,13 +1249,28 @@       hang (text "Missing role annotation" <> colon)          2 (text "type role" <+> ppr name <+> hsep (map ppr roles)) +    TcRnIllformedTypePattern p+      -> mkSimpleDecorated $+          hang (text "Ill-formed type pattern:") 2 (ppr p)+    TcRnIllegalTypePattern+      -> mkSimpleDecorated $+          text "Illegal type pattern." $$+          text "A type pattern must be checked against a visible forall."+    TcRnIllformedTypeArgument e+      -> mkSimpleDecorated $+          hang (text "Ill-formed type argument:") 2 (ppr e)+    TcRnIllegalTypeExpr+      -> mkSimpleDecorated $+          text "Illegal type expression." $$+          text "A type expression must be used to instantiate a visible forall."+     TcRnCapturedTermName tv_name shadowed_term_names       -> mkSimpleDecorated $         text "The type variable" <+> quotes (ppr tv_name) <+>           text "is implicitly quantified," $+$           text "even though another variable of the same name is in scope:" $+$           nest 2 var_names $+$-          text "This is not forward-compatible with a planned GHC extension, RequiredTypeArguments."+          text "This is not compatible with the RequiredTypeArguments extension."         where           var_names = case shadowed_term_names of               Left gbl_names -> vcat (map (\name -> quotes (ppr $ greName name) <+> pprNameProvenance name) gbl_names)@@ -1274,17 +1302,17 @@     TcRnEmptyCase ctxt -> mkSimpleDecorated message       where         pp_ctxt = case ctxt of-          CaseAlt                                  -> text "case expression"-          LamCaseAlt LamCase                       -> text "\\case expression"-          ArrowMatchCtxt (ArrowLamCaseAlt LamCase) -> text "\\case command"-          ArrowMatchCtxt ArrowCaseAlt              -> text "case command"-          ArrowMatchCtxt KappaExpr                 -> text "kappa abstraction"-          _                                        -> text "(unexpected)"-                                                      <+> pprMatchContextNoun ctxt+          CaseAlt                                -> text "case expression"+          LamAlt LamCase                         -> text "\\case expression"+          ArrowMatchCtxt (ArrowLamAlt LamSingle) -> text "kappa abstraction"+          ArrowMatchCtxt (ArrowLamAlt LamCase)   -> text "\\case command"+          ArrowMatchCtxt ArrowCaseAlt            -> text "case command"+          _                                      -> text "(unexpected)"+                                                    <+> pprMatchContextNoun ctxt          message = case ctxt of-          LamCaseAlt LamCases -> lcases_msg <+> text "expression"-          ArrowMatchCtxt (ArrowLamCaseAlt LamCases) -> lcases_msg <+> text "command"+          LamAlt LamCases -> lcases_msg <+> text "expression"+          ArrowMatchCtxt (ArrowLamAlt LamCases) -> lcases_msg <+> text "command"           _ -> text "Empty list of alternatives in" <+> pp_ctxt          lcases_msg =@@ -1312,18 +1340,6 @@            , text "Combine alternative minimal complete definitions with `|'" ]       where         sigs = sig1 : sig2 : otherSigs-    TcRnLoopySuperclassSolve wtd_loc wtd_pty ->-      mkSimpleDecorated $ vcat [ header, warning, user_manual ]-      where-        header, warning, user_manual :: SDoc-        header-          = vcat [ text "I am solving the constraint" <+> quotes (ppr wtd_pty) <> comma-                 , nest 2 $ pprCtOrigin (ctLocOrigin wtd_loc) <> comma-                 , text "in a way that might turn out to loop at runtime." ]-        warning-          = vcat [ text "Starting from GHC 9.10, this warning will turn into an error." ]-        user_manual =-          vcat [ text "See the user manual, § Undecidable instances and loopy superclasses." ]     TcRnUnexpectedStandaloneDerivingDecl -> mkSimpleDecorated $       text "Illegal standalone deriving declaration"     TcRnUnusedVariableInRuleDecl name var -> mkSimpleDecorated $@@ -1395,6 +1411,11 @@          text "Stage error:" <+> pprStageCheckReason reason <+>          hsep [text "is bound at stage" <+> ppr bind_lvl,                text "but used at stage" <+> ppr use_lvl]+    TcRnBadlyStagedType name bind_lvl use_lvl+      -> mkSimpleDecorated $+         text "Badly staged type:" <+> ppr name <+>+         hsep [text "is bound at stage" <+> ppr bind_lvl,+               text "but used at stage" <+> ppr use_lvl]     TcRnStageRestriction reason       -> mkSimpleDecorated $          sep [ text "GHC stage restriction:"@@ -1466,6 +1487,9 @@     TcRnPartialFieldSelector fld -> mkSimpleDecorated $       sep [text "Use of partial record field selector" <> colon,            nest 2 $ quotes (ppr (occName fld))]+    TcRnHasFieldResolvedIncomplete name -> mkSimpleDecorated $+      text "The invocation of `getField` on the record field" <+> quotes (ppr name)+      <+> text "may produce an error since it is not defined for all data constructors"     TcRnBadFieldAnnotation n con reason -> mkSimpleDecorated $       hang (pprBadFieldAnnotationReason reason)          2 (text "on the" <+> speakNth n@@ -1584,20 +1608,6 @@     TcRnIncoherentRoles _ -> mkSimpleDecorated $       (text "Roles other than" <+> quotes (text "nominal") <+>       text "for class parameters can lead to incoherence.")-    TcRnBindVarAlreadyInScope tv_names_in_scope-      -> mkSimpleDecorated $-        vcat-          [ text "Type variable" <> plural tv_names_in_scope-            <+> hcat (punctuate (text ",") (map (quotes . ppr) tv_names_in_scope))-            <+> isOrAre tv_names_in_scope-            <+> text "already in scope."-          , text "Type applications in patterns must bind fresh variables, without shadowing."-          ]--    TcRnBindMultipleVariables ctx tv_name_w_loc-      -> mkSimpleDecorated $-        text "Variable" <+> text "`" <> ppr tv_name_w_loc <> text "'" <+> text "would be bound multiple times by" <+> pprHsDocContext ctx <> text "."-     TcRnUnexpectedKindVar tv_name       -> mkSimpleDecorated $ text "Unexpected kind variable" <+> quotes (ppr tv_name) @@ -1635,8 +1645,21 @@                 , inHsDocContext doc ]      TcRnDataKindsError typeOrKind thing-      -> mkSimpleDecorated $-           text "Illegal" <+> (text $ levelString typeOrKind) <> colon <+> quotes (ppr thing)+      -- See Note [Checking for DataKinds] (Wrinkle: Migration story for+      -- DataKinds typechecker errors) in GHC.Tc.Validity for why we give+      -- different diagnostic messages below.+      -> case thing of+           Left renamer_thing ->+             mkSimpleDecorated $+               text "Illegal" <+> ppr_level <> colon <+> quotes (ppr renamer_thing)+           Right typechecker_thing ->+             mkSimpleDecorated $ vcat+               [ text "An occurrence of" <+> quotes (ppr typechecker_thing) <+>+                 text "in a" <+> ppr_level <+> text "requires DataKinds."+               , text "Future versions of GHC will turn this warning into an error."+               ]+      where+        ppr_level = text $ levelString typeOrKind      TcRnTypeSynonymCycle decl_or_tcs       -> mkSimpleDecorated $@@ -1783,6 +1806,17 @@     TcRnNonCanonicalDefinition reason inst_ty       -> mkSimpleDecorated $          pprNonCanonicalDefinition inst_ty reason+    TcRnDefaultedExceptionContext ct_loc ->+      mkSimpleDecorated $ vcat [ header, warning, proposal ]+      where+        header, warning, proposal :: SDoc+        header+          = vcat [ text "Solving for an implicit ExceptionContext constraint"+                 , nest 2 $ pprCtOrigin (ctLocOrigin ct_loc) <> text "." ]+        warning+          = vcat [ text "Future versions of GHC will turn this warning into an error." ]+        proposal+          = vcat [ text "See GHC Proposal #330." ]     TcRnImplicitImportOfPrelude       -> mkSimpleDecorated $          text "Module" <+> quotes (text "Prelude") <+> text "implicitly imported."@@ -1833,7 +1867,7 @@     TcRnDeprecatedInvisTyArgInConPat ->       mkSimpleDecorated $         cat [ text "Type applications in constructor patterns will require"-            , text "the TypeAbstractions extension starting from GHC 9.12." ]+            , text "the TypeAbstractions extension starting from GHC 9.14." ]      TcRnInvisBndrWithoutSig _ hs_bndr ->       mkSimpleDecorated $@@ -1848,6 +1882,62 @@            , text "In the future GHC will no longer implicitly quantify over such variables"            ] +    TcRnInvalidDefaultedTyVar wanteds proposal bad_tvs ->+      mkSimpleDecorated $+      pprWithExplicitKindsWhen True $+      vcat [ text "Invalid defaulting proposal."+           , hang (text "The following type variable" <> plural (NE.toList bad_tvs) <+> text "cannot be defaulted, as" <+> why <> colon)+                2 (pprQuotedList (NE.toList bad_tvs))+           , hang (text "Defaulting proposal:")+                2 (ppr proposal)+           , hang (text "Wanted constraints:")+                2 (pprQuotedList (map ctPred wanteds))+           ]+        where+          why+            | _ :| [] <- bad_tvs+            = text "it is not an unfilled metavariable"+            | otherwise+            = text "they are not unfilled metavariables"++    TcRnNamespacedWarningPragmaWithoutFlag warning@(Warning (kw, _) _ txt) -> mkSimpleDecorated $+      vcat [ text "Illegal use of the" <+> quotes (ppr kw) <+> text "keyword:"+           , nest 2 (ppr warning)+           , text "in a" <+> pragma_type <+> text "pragma"+           ]+      where+        pragma_type = case txt of+          WarningTxt{} -> text "WARNING"+          DeprecatedTxt{} -> text "DEPRECATED"++    TcRnIllegalInvisibleTypePattern tp -> mkSimpleDecorated $+      text "Illegal invisible type pattern:" <+> ppr tp++    TcRnInvisPatWithNoForAll tp -> mkSimpleDecorated $+      text "Invisible type pattern" <+> ppr tp <+> text "has no associated forall"++    TcRnNamespacedFixitySigWithoutFlag sig@(FixitySig kw _ _) -> mkSimpleDecorated $+      vcat [ text "Illegal use of the" <+> quotes (ppr kw) <+> text "keyword:"+           , nest 2 (ppr sig)+           , text "in a fixity signature"+           ]++    TcRnOutOfArityTyVar ts_name tv_name -> mkDecorated+      [ vcat [ text "The arity of" <+> quotes (ppr ts_name) <+> text "is insufficiently high to accommodate"+             , text "an implicit binding for the" <+> quotes (ppr tv_name) <+> text "type variable." ]+      , suggestion ]+      where+        suggestion =+          text "Use" <+> quotes at_bndr     <+> text "on the LHS" <+>+          text "or"  <+> quotes forall_bndr <+> text "on the RHS" <+>+          text "to bring it into scope."+        at_bndr     = char '@' <> ppr tv_name+        forall_bndr = text "forall" <+> ppr tv_name <> text "."++    TcRnMisplacedInvisPat tp -> mkSimpleDecorated $+      text "Invisible type pattern" <+> ppr tp <+> text "is not allowed here"++  diagnosticReason :: TcRnMessage -> DiagnosticReason   diagnosticReason = \case     TcRnUnknownMessage m       -> diagnosticReason m@@ -1856,7 +1946,7 @@            TcRnMessageDetailed _ m -> diagnosticReason m     TcRnWithHsDocContext _ msg       -> diagnosticReason msg-    TcRnSolverReport _ reason _+    TcRnSolverReport _ reason       -> reason -- Error, or a Warning if we are deferring type errors     TcRnSolverDepthError {}       -> ErrorWithoutFlag@@ -1906,6 +1996,10 @@       -> ErrorWithoutFlag     TcRnIllegalWildcardInType{}       -> ErrorWithoutFlag+    TcRnIllegalNamedWildcardInTypeArgument{}+      -> ErrorWithoutFlag+    TcRnIllegalImplicitTyVarInTypeArgument{}+      -> ErrorWithoutFlag     TcRnDuplicateFieldName{}       -> ErrorWithoutFlag     TcRnIllegalViewPattern{}@@ -2081,8 +2175,6 @@       -> ErrorWithoutFlag     TcRnArrowProcGADTPattern       -> ErrorWithoutFlag-    TcRnForallIdentifier {}-      -> WarningWithFlag Opt_WarnForallIdentifier     TcRnTypeEqualityOutOfScope       -> WarningWithFlag Opt_WarnTypeEqualityOutOfScope     TcRnTypeEqualityRequiresOperators@@ -2149,6 +2241,8 @@       -> ErrorWithoutFlag     TcRnUnpromotableThing{}       -> ErrorWithoutFlag+    TcRnIllegalTermLevelUse{}+      -> ErrorWithoutFlag     TcRnMatchesHaveDiffNumArgs{}       -> ErrorWithoutFlag     TcRnCannotBindScopedTyVarInPatSig{}@@ -2245,8 +2339,6 @@       -> ErrorWithoutFlag     TcRnDuplicateMinimalSig{}       -> ErrorWithoutFlag-    TcRnLoopySuperclassSolve{}-      -> WarningWithFlag Opt_WarnLoopySuperclassSolve     TcRnUnexpectedStandaloneDerivingDecl{}       -> ErrorWithoutFlag     TcRnUnusedVariableInRuleDecl{}@@ -2275,6 +2367,8 @@       -> ErrorWithoutFlag     TcRnBadlyStaged{}       -> ErrorWithoutFlag+    TcRnBadlyStagedType{}+      -> WarningWithFlag Opt_WarnBadlyStagedTypes     TcRnStageRestriction{}       -> ErrorWithoutFlag     TcRnTyThingUsedWrong{}@@ -2299,6 +2393,8 @@       -> ErrorWithoutFlag     TcRnPartialFieldSelector{}       -> WarningWithFlag Opt_WarnPartialFields+    TcRnHasFieldResolvedIncomplete{}+      -> WarningWithFlag Opt_WarnIncompleteRecordSelectors     TcRnBadFieldAnnotation _ _ LazyFieldsDisabled       -> ErrorWithoutFlag     TcRnBadFieldAnnotation{}@@ -2345,10 +2441,6 @@       -> ErrorWithoutFlag     TcRnIncoherentRoles{}       -> ErrorWithoutFlag-    TcRnBindVarAlreadyInScope{}-      -> ErrorWithoutFlag-    TcRnBindMultipleVariables{}-      -> ErrorWithoutFlag     TcRnUnexpectedKindVar{}       -> ErrorWithoutFlag     TcRnNegativeNumTypeLiteral{}@@ -2365,8 +2457,17 @@       -> ErrorWithoutFlag     TcRnUnusedQuantifiedTypeVar{}       -> WarningWithFlag Opt_WarnUnusedForalls-    TcRnDataKindsError{}-      -> ErrorWithoutFlag+    TcRnDataKindsError _ thing+      -- DataKinds errors can arise from either the renamer (Left) or the+      -- typechecker (Right). The latter category of DataKinds errors are a+      -- fairly recent addition to GHC (introduced in GHC 9.10), and in order+      -- to prevent these new errors from breaking users' code, we temporarily+      -- downgrade these errors to warnings. See Note [Checking for DataKinds]+      -- (Wrinkle: Migration story for DataKinds typechecker errors)+      -- in GHC.Tc.Validity.+      -> case thing of+           Left  _ -> ErrorWithoutFlag+           Right _ -> WarningWithFlag Opt_WarnDataKindsTC     TcRnTypeSynonymCycle{}       -> ErrorWithoutFlag     TcRnZonkerMessage msg@@ -2428,6 +2529,8 @@       -> WarningWithFlag Opt_WarnNonCanonicalMonoidInstances     TcRnNonCanonicalDefinition (NonCanonicalMonad _) _       -> WarningWithFlag Opt_WarnNonCanonicalMonadInstances+    TcRnDefaultedExceptionContext{}+      -> WarningWithFlag Opt_WarnDefaultedExceptionContext     TcRnImplicitImportOfPrelude {}       -> WarningWithFlag Opt_WarnImplicitPrelude     TcRnMissingMain {}@@ -2441,7 +2544,7 @@     TcRnIllegalInvisTyVarBndr{}       -> ErrorWithoutFlag     TcRnDeprecatedInvisTyArgInConPat {}-      -> WarningWithoutFlag+      -> WarningWithFlag Opt_WarnDeprecatedTypeAbstractions     TcRnInvalidInvisTyVarBndr{}       -> ErrorWithoutFlag     TcRnInvisBndrWithoutSig{}@@ -2450,6 +2553,28 @@       -> WarningWithFlag Opt_WarnImplicitRhsQuantification     TcRnPatersonCondFailure{}       -> ErrorWithoutFlag+    TcRnIllformedTypePattern{}+      -> ErrorWithoutFlag+    TcRnIllegalTypePattern{}+      -> ErrorWithoutFlag+    TcRnIllformedTypeArgument{}+      -> ErrorWithoutFlag+    TcRnIllegalTypeExpr{}+      -> ErrorWithoutFlag+    TcRnInvalidDefaultedTyVar{}+      -> ErrorWithoutFlag+    TcRnNamespacedWarningPragmaWithoutFlag{}+      -> ErrorWithoutFlag+    TcRnIllegalInvisibleTypePattern{}+      -> ErrorWithoutFlag+    TcRnInvisPatWithNoForAll{}+      -> ErrorWithoutFlag+    TcRnNamespacedFixitySigWithoutFlag{}+      -> ErrorWithoutFlag+    TcRnOutOfArityTyVar{}+      -> ErrorWithoutFlag+    TcRnMisplacedInvisPat{}+      -> ErrorWithoutFlag    diagnosticHints = \case     TcRnUnknownMessage m@@ -2459,8 +2584,8 @@            TcRnMessageDetailed _ m -> diagnosticHints m     TcRnWithHsDocContext _ msg       -> diagnosticHints msg-    TcRnSolverReport _ _ hints-      -> hints+    TcRnSolverReport (SolverReportWithCtxt ctxt msg) _+      -> tcSolverReportMsgHints ctxt msg     TcRnSolverDepthError {}       -> [SuggestIncreaseReductionDepth]     TcRnRedundantConstraints{}@@ -2509,6 +2634,10 @@       -> [suggestExtension LangExt.RecordWildCards]     TcRnIllegalWildcardInType{}       -> noHints+    TcRnIllegalNamedWildcardInTypeArgument{}+      -> [SuggestAnonymousWildcard]+    TcRnIllegalImplicitTyVarInTypeArgument tv+      -> [SuggestExplicitQuantification tv]     TcRnDuplicateFieldName{}       -> noHints     TcRnIllegalViewPattern{}@@ -2569,8 +2698,9 @@       -> noHints     TcRnForAllEscapeError{}       -> noHints-    TcRnVDQInTermType{}-      -> noHints+    TcRnVDQInTermType mb_ty+      | isJust mb_ty -> [suggestExtension LangExt.RequiredTypeArguments]+      | otherwise    -> []     TcRnBadQuantPredHead{}       -> noHints     TcRnIllegalTupleConstraint{}@@ -2690,8 +2820,6 @@       -> noHints     TcRnArrowProcGADTPattern       -> noHints-    TcRnForallIdentifier {}-      -> [SuggestRenameForall]     TcRnTypeEqualityOutOfScope       -> noHints     TcRnTypeEqualityRequiresOperators@@ -2771,6 +2899,8 @@       -> noHints     TcRnUnpromotableThing{}       -> noHints+    TcRnIllegalTermLevelUse{}+      -> noHints     TcRnMatchesHaveDiffNumArgs{}       -> noHints     TcRnCannotBindScopedTyVarInPatSig{}@@ -2859,8 +2989,8 @@     TcRnOrphanCompletePragma{}       -> noHints     TcRnEmptyCase ctxt -> case ctxt of-      LamCaseAlt LamCases -> noHints -- cases syntax doesn't support empty case.-      ArrowMatchCtxt (ArrowLamCaseAlt LamCases) -> noHints+      LamAlt LamCases -> noHints -- cases syntax doesn't support empty case.+      ArrowMatchCtxt (ArrowLamAlt LamCases) -> noHints       _ -> [suggestExtension LangExt.EmptyCase]     TcRnNonStdGuards{}       -> [suggestExtension LangExt.PatternGuards]@@ -2872,13 +3002,6 @@       -> [suggestExtension LangExt.DefaultSignatures]     TcRnDuplicateMinimalSig{}       -> noHints-    TcRnLoopySuperclassSolve wtd_loc wtd_pty-      -> [LoopySuperclassSolveHint wtd_pty cls_or_qc]-      where-        cls_or_qc :: ClsInstOrQC-        cls_or_qc = case ctLocOrigin wtd_loc of-          ScOrigin c_or_q _ -> c_or_q-          _                 -> IsClsInst -- shouldn't happen     TcRnUnexpectedStandaloneDerivingDecl{}       -> [suggestExtension LangExt.StandaloneDeriving]     TcRnUnusedVariableInRuleDecl{}@@ -2909,6 +3032,8 @@       -> noHints     TcRnBadlyStaged{}       -> noHints+    TcRnBadlyStagedType{}+      -> noHints     TcRnStageRestriction{}       -> noHints     TcRnTyThingUsedWrong{}@@ -2935,6 +3060,8 @@       -> noHints     TcRnPartialFieldSelector{}       -> noHints+    TcRnHasFieldResolvedIncomplete{}+      -> noHints     TcRnBadFieldAnnotation _ _ LazyFieldsDisabled       -> [suggestExtension LangExt.StrictData]     TcRnBadFieldAnnotation{}@@ -2966,8 +3093,7 @@     TcRnGADTsDisabled{}       -> [suggestExtension LangExt.GADTs]     TcRnExistentialQuantificationDisabled{}-      -> [suggestExtension LangExt.ExistentialQuantification,-          suggestExtension LangExt.GADTs]+      -> [suggestAnyExtension [LangExt.ExistentialQuantification, LangExt.GADTs]]     TcRnGADTDataContext{}       -> noHints     TcRnMultipleConForNewtype{}@@ -2986,10 +3112,6 @@       -> [suggestExtension LangExt.RoleAnnotations]     TcRnIncoherentRoles{}       -> [suggestExtension LangExt.IncoherentInstances]-    TcRnBindVarAlreadyInScope{}-      -> noHints-    TcRnBindMultipleVariables{}-      -> noHints     TcRnUnexpectedKindVar{}       -> [suggestExtension LangExt.PolyKinds]     TcRnNegativeNumTypeLiteral{}@@ -3032,10 +3154,12 @@       let mod_name = moduleName $ is_mod is           occ = rdrNameOcc $ ieName ie       in case k of-        BadImportAvailVar         -> [ImportSuggestion occ $ CouldRemoveTypeKeyword mod_name]+        BadImportAvailVar          -> [ImportSuggestion occ $ CouldRemoveTypeKeyword mod_name]         BadImportNotExported suggs -> suggs-        BadImportAvailTyCon       -> [ImportSuggestion occ $ CouldAddTypeKeyword mod_name]-        BadImportAvailDataCon par -> [ImportSuggestion occ $ ImportDataCon (Just (mod_name, patsyns_enabled)) par]+        BadImportAvailTyCon ex_ns  ->+          [useExtensionInOrderTo empty LangExt.ExplicitNamespaces | not ex_ns]+          ++ [ImportSuggestion occ $ CouldAddTypeKeyword mod_name]+        BadImportAvailDataCon par  -> [ImportSuggestion occ $ ImportDataCon (Just (mod_name, patsyns_enabled)) par]         BadImportNotExportedSubordinates{} -> noHints     TcRnImportLookup{}       -> noHints@@ -3077,6 +3201,8 @@       -> noHints     TcRnNonCanonicalDefinition reason _       -> suggestNonCanonicalDefinition reason+    TcRnDefaultedExceptionContext _+      -> noHints     TcRnImplicitImportOfPrelude {}       -> noHints     TcRnMissingMain {}@@ -3099,8 +3225,29 @@       -> [SuggestBindTyVarOnLhs (unLoc kv)]     TcRnPatersonCondFailure{}       -> [suggestExtension LangExt.UndecidableInstances]+    TcRnIllformedTypePattern{}+      -> noHints+    TcRnIllegalTypePattern{}+      -> noHints+    TcRnIllformedTypeArgument{}+      -> noHints+    TcRnIllegalTypeExpr{}+      -> noHints+    TcRnInvalidDefaultedTyVar{}+      -> noHints+    TcRnNamespacedWarningPragmaWithoutFlag{}+      -> [suggestExtension LangExt.ExplicitNamespaces]+    TcRnIllegalInvisibleTypePattern{}+      -> [suggestExtension LangExt.TypeAbstractions]+    TcRnInvisPatWithNoForAll{}+      -> noHints+    TcRnNamespacedFixitySigWithoutFlag{}+      -> [suggestExtension LangExt.ExplicitNamespaces]+    TcRnOutOfArityTyVar{}+      -> noHints+    TcRnMisplacedInvisPat{}+      -> noHints -  diagnosticCode :: TcRnMessage -> Maybe DiagnosticCode   diagnosticCode = constructorCode  -- | Change [x] to "x", [x, y] to "x and y", [x, y, z] to "x, y, and z",@@ -3231,7 +3378,7 @@              , text "but it is not a type constructor or a class" ]  dodgy_msg_insert :: GlobalRdrElt -> IE GhcRn-dodgy_msg_insert tc_gre = IEThingAll (Nothing, noAnn) ii+dodgy_msg_insert tc_gre = IEThingAll (Nothing, noAnn) ii Nothing   where     ii = noLocA (IEName noExtField $ noLocA $ greName tc_gre) @@ -3644,7 +3791,7 @@     unsolved_concrete_eq_explanation tv not_conc =           text "Cannot unify" <+> quotes (ppr not_conc)       <+> text "with the type variable" <+> quotes (ppr tv)-      $$  text "because it is not a concrete" <+> what <> dot+      $$  text "because the former is not a concrete" <+> what <> dot       where         ki = tyVarKind tv         what :: SDoc@@ -4478,7 +4625,7 @@ **********************************************************************-}  pprHoleError :: SolverReportErrCtxt -> Hole -> HoleError -> SDoc-pprHoleError _ (Hole { hole_ty, hole_occ = rdr }) (OutOfScopeHole imp_errs)+pprHoleError _ (Hole { hole_ty, hole_occ = rdr }) (OutOfScopeHole imp_errs _hints)   = out_of_scope_msg $$ vcat (map ppr imp_errs)   where     herald | isDataOcc (rdrNameOcc rdr) = text "Data constructor not in scope:"@@ -4602,6 +4749,128 @@     UnknownSubordinate {}  -> noHints     NotInScopeTc _         -> noHints +tcSolverReportMsgHints :: SolverReportErrCtxt -> TcSolverReportMsg -> [GhcHint]+tcSolverReportMsgHints ctxt = \case+  BadTelescope {}+    -> noHints+  UserTypeError {}+    -> noHints+  UnsatisfiableError {}+    -> noHints+  ReportHoleError hole err+    -> holeErrorHints hole err+  CannotUnifyVariable mismatch_msg rea+    -> mismatchMsgHints ctxt mismatch_msg ++ cannotUnifyVariableHints rea+  Mismatch { mismatchMsg = mismatch_msg }+    -> mismatchMsgHints ctxt mismatch_msg+  FixedRuntimeRepError {}+    -> noHints+  BlockedEquality {}+    -> noHints+  ExpectingMoreArguments {}+    -> noHints+  UnboundImplicitParams {}+    -> noHints+  AmbiguityPreventsSolvingCt {}+    -> noHints+  CannotResolveInstance {}+    -> noHints+  OverlappingInstances {}+    -> noHints+  UnsafeOverlap {}+   -> noHints++mismatchMsgHints :: SolverReportErrCtxt -> MismatchMsg -> [GhcHint]+mismatchMsgHints ctxt msg =+  maybeToList [ hint | (exp,act) <- mismatchMsg_ExpectedActuals msg+                     , hint <- suggestAddSig ctxt exp act ]++mismatchMsg_ExpectedActuals :: MismatchMsg -> Maybe (Type, Type)+mismatchMsg_ExpectedActuals = \case+  BasicMismatch { mismatch_ty1 = exp, mismatch_ty2 = act } ->+    Just (exp, act)+  KindMismatch { kmismatch_expected = exp, kmismatch_actual = act } ->+    Just (exp, act)+  TypeEqMismatch { teq_mismatch_expected = exp, teq_mismatch_actual = act } ->+    Just (exp,act)+  CouldNotDeduce { cnd_extra = cnd_extra }+    | Just (CND_Extra _ exp act) <- cnd_extra+    -> Just (exp, act)+    | otherwise+    -> Nothing++holeErrorHints :: Hole -> HoleError -> [GhcHint]+holeErrorHints _hole = \case+  OutOfScopeHole _ hints+    -> hints+  HoleError {}+    -> noHints++cannotUnifyVariableHints :: CannotUnifyVariableReason -> [GhcHint]+cannotUnifyVariableHints = \case+  CannotUnifyWithPolytype {}+    -> noHints+  OccursCheck {}+    -> noHints+  SkolemEscape {}+    -> noHints+  DifferentTyVars {}+    -> noHints+  RepresentationalEq {}+    -> noHints++suggestAddSig :: SolverReportErrCtxt -> TcType -> TcType -> Maybe GhcHint+-- See Note [Suggest adding a type signature]+suggestAddSig ctxt ty1 _ty2+  | bndr : bndrs <- inferred_bndrs+  = Just $ SuggestAddTypeSignatures $ NamedBindings (bndr :| bndrs)+  | otherwise+  = Nothing+  where+    inferred_bndrs =+      case getTyVar_maybe ty1 of+        Just tv | isSkolemTyVar tv -> find (cec_encl ctxt) False tv+        _                          -> []++    -- 'find' returns the binders of an InferSkol for 'tv',+    -- provided there is an intervening implication with+    -- ic_given_eqs /= NoGivenEqs (i.e. a GADT match)+    find [] _ _ = []+    find (implic:implics) seen_eqs tv+       | tv `elem` ic_skols implic+       , InferSkol prs <- ic_info implic+       , seen_eqs+       = map fst prs+       | otherwise+       = find implics (seen_eqs || ic_given_eqs implic /= NoGivenEqs) tv++{- Note [Suggest adding a type signature]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The OutsideIn algorithm rejects GADT programs that don't have a principal+type, and indeed some that do.  Example:+   data T a where+     MkT :: Int -> T Int++   f (MkT n) = n++Does this have type f :: T a -> a, or f :: T a -> Int?+The error that shows up tends to be an attempt to unify an+untouchable type variable.  So suggestAddSig sees if the offending+type variable is bound by an *inferred* signature, and suggests+adding a declared signature instead.++More specifically, we suggest adding a type sig if we have p ~ ty, and+p is a skolem bound by an InferSkol.  Those skolems were created from+unification variables in simplifyInfer.  Why didn't we unify?  It must+have been because of an intervening GADT or existential, making it+untouchable. Either way, a type signature would help.  For GADTs, it+might make it typeable; for existentials the attempt to write a+signature will fail -- or at least will produce a better error message+next time++This initially came up in #8968, concerning pattern synonyms.+-}+ {- ********************************************************************* *                                                                      *                   Outputting ImportError messages@@ -4756,7 +5025,7 @@ {- Note ["Arising from" messages in generated code] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider code generated when we desugar code before typechecking;-see Note [Rebindable syntax and HsExpansion].+see Note [Rebindable syntax and XXExprGhcRn].  In this code, constraints may be generated, but we don't want to say "arising from a call of foo" if 'foo' doesn't appear in the@@ -4799,9 +5068,9 @@       where         (env', tv') = tidy_tv_bndr env tv -    tidy_ty env ty@(FunTy af w arg res) -- Look under  c => t-      | isInvisibleFunArg af-      = ty { ft_mult = tidy_ty env w+    tidy_ty env ty@(FunTy { ft_mult = w, ft_arg = arg, ft_res = res })+      = -- Look under  c => t and t1 -> t2+        ty { ft_mult = tidy_ty env w            , ft_arg  = tidyType env arg            , ft_res  = tidy_ty env res }
compiler/GHC/Tc/Errors/Types.hs view
@@ -75,6 +75,7 @@   , HoleFitDispConfig(..)   , RelevantBindings(..), pprRelevantBindings   , PromotionErr(..), pprPECategory, peCategory+  , TermLevelUseErr(..), teCategory   , NotInScopeError(..), mkTcRnNotInScope   , ImportError(..)   , HoleError(..)@@ -84,6 +85,7 @@   , ExpectedBackends   , ArgOrResult(..)   , MatchArgsContext(..), MatchArgBadMatches(..)+  , PragmaWarningInfo(..)   , EmptyStatementGroupErrReason(..)   , UnexpectedStatement(..)   , DeclSort(..)@@ -329,11 +331,7 @@   -}   TcRnSolverReport :: SolverReportWithCtxt                    -> DiagnosticReason-                   -> [GhcHint]                    -> TcRnMessage-    -- TODO: split up TcRnSolverReport into several components,-    -- so that we can compute the reason and hints, as opposed-    -- to having to pass them here.    {-| TcRnSolverDepthError is an error that occurs when the constraint solver       exceeds the maximum recursion depth.@@ -543,6 +541,8 @@                  rename/should_fail/T2723                  rename/should_compile/T3262                  driver/werror+                 rename/should_fail/T22478d+                 typecheck/should_fail/TyAppPat_ScopedTyVarConflict   -}   TcRnShadowedName :: OccName -> ShadowedNameProvenance -> TcRnMessage @@ -713,6 +713,37 @@     -> !BadAnonWildcardContext     -> TcRnMessage +  {-| TcRnIllegalNamedWildcardInTypeArgument is an error that occurs+      when a named wildcard is used in a required type argument.++      Example:++        vfun :: forall (a :: k) -> ()+        x = vfun _nwc+        --       ^^^^+        -- named wildcards not allowed in type arguments++      Test cases:+        T23738_fail_wild+  -}+  TcRnIllegalNamedWildcardInTypeArgument+    :: RdrName+    -> TcRnMessage++  {- TcRnIllegalImplicitTyVarInTypeArgument is an error raised+     when a type variable is implicitly quantified in a required type argument.++     Example:+       vfun :: forall (a :: k) -> ()+       x = vfun (Nothing :: Maybe a)+       --                        ^^^+       -- implicit quantification not allowed in type arguments++  -}+  TcRnIllegalImplicitTyVarInTypeArgument+    :: RdrName+    -> TcRnMessage+   {-| TcRnDuplicateFieldName is an error that occurs whenever       there are duplicate field names in a single record. @@ -756,7 +787,7 @@      Test cases: th/T8412                  typecheck/should_fail/T8306   -}-  TcRnNegativeNumTypeLiteral :: HsType GhcPs -> TcRnMessage+  TcRnNegativeNumTypeLiteral :: HsTyLit GhcPs -> TcRnMessage    {-| TcRnIllegalWildcardsInConstructor is an error that occurs whenever       the record wildcards '..' are used inside a constructor without labeled fields.@@ -1009,7 +1040,7 @@       Test cases: typecheck/should_compile/T11339   -}-  TcRnOverloadedSig :: TcIdSigInfo -> TcRnMessage+  TcRnOverloadedSig :: TcIdSig -> TcRnMessage    {-| TcRnTupleConstraintInst is an error that occurs whenever an instance       for a tuple constraint is specified.@@ -1868,17 +1899,6 @@   -}   TcRnArrowProcGADTPattern :: TcRnMessage -  {-| TcRnForallIdentifier is a warning (controlled with -Wforall-identifier) that occurs-     when a definition uses 'forall' as an identifier.--     Example:-       forall x = ()-       g forall = ()--     Test cases: T20609 T20609a T20609b T20609c T20609d-  -}-  TcRnForallIdentifier :: RdrName -> TcRnMessage-   {-| TcRnCapturedTermName is a warning (controlled by -Wterm-variable-capture) that occurs     when an implicitly quantified type variable's name is already used for a term.     Example:@@ -1889,25 +1909,6 @@  -}   TcRnCapturedTermName :: RdrName -> Either [GlobalRdrElt] Name -> TcRnMessage -  {-| TcRnTypeMultipleOccurenceOfBindVar is an error that occurs if a bound-      type variable's name is already in use.-    Example:-      f :: forall a. ...-      f (MkT @a ...) = ...--    Test cases: TyAppPat_ScopedTyVarConflict TyAppPat_NonlinearMultiPat TyAppPat_NonlinearMultiAppPat-  -}-  TcRnBindVarAlreadyInScope :: [LocatedN RdrName] -> TcRnMessage--  {-| TcRnBindMultipleVariables is an error that occurs in the case of-    multiple occurrences of a bound variable.-    Example:-      foo (MkFoo @(a,a) ...) = ...--    Test case: typecheck/should_fail/TyAppPat_NonlinearSinglePat-  -}-  TcRnBindMultipleVariables :: HsDocContext -> LocatedN RdrName -> TcRnMessage-   {-| TcRnTypeEqualityOutOfScope is a warning (controlled by -Wtype-equality-out-of-scope)       that occurs when the type equality (a ~ b) is not in scope. @@ -2043,9 +2044,11 @@        Example: -        f x = Int+        list2 = $( conE ''(:) `appE` litE (IntegerL 5) `appE` conE '[] )+        --              ^^^^^+        --              should use a single quotation tick, i.e. '(:) -      Test cases: T18740a, T20884.+      Test cases: T20884.   -}   TcRnIncorrectNameSpace :: Name                          -> Bool -- ^ whether the error is happening@@ -2202,6 +2205,7 @@      Test cases: parser/should_fail/unpack_inside_type                 typecheck/should_fail/T7210+                rename/should_fail/T22478b   -}   TcRnUnexpectedAnnotation :: !(HsType GhcRn) -> !HsSrcBang -> TcRnMessage @@ -2212,6 +2216,7 @@      Test cases: rename/should_fail/T7943                 rename/should_fail/T9077+                rename/should_fail/T22478b   -}   TcRnIllegalRecordSyntax :: Either (HsType GhcPs) (HsType GhcRn) -> TcRnMessage @@ -2267,6 +2272,8 @@       where the implicitly-bound type type variables can't be matched up unambiguously       with the ones from the signature. See Note [Disconnected type variables] in       GHC.Tc.Gen.HsType.++      Test cases: T24083   -}   TcRnDisconnectedTyVar :: !Name -> TcRnMessage @@ -2366,6 +2373,27 @@   -}   TcRnUnpromotableThing :: !Name -> !PromotionErr -> TcRnMessage +  {- | TcRnIllegalTermLevelUse is an error that occurs when the user attempts to+       use a type-level entity at the term-level.++       Examples:+          f x = Int                 -- illegal use of a type constructor+          g (Proxy :: Proxy a) = a  -- illegal use of a type variable++       Note that the namespace cannot be used to determine if a name refers to a+       type-level entity:++          {-# LANGUAGE RequiredTypeArguments #-}+          bad :: forall (a :: k) -> k+          bad t = t++      The name `t` is assigned the `varName` namespace but stands for a type+      variable that cannot be used at the term level.++      Test cases: T18740a, T18740b, T23739_fail_ret, T23739_fail_case+  -}+  TcRnIllegalTermLevelUse :: !Name -> !TermLevelUseErr -> TcRnMessage+   {-| TcRnMatchesHaveDiffNumArgs is an error occurring when something has matches      that have different numbers of arguments @@ -2377,7 +2405,7 @@                 typecheck/should_fail/T20768_fail   -}   TcRnMatchesHaveDiffNumArgs-    :: !(HsMatchContext GhcTc) -- ^ Pattern match specifics+    :: !HsMatchContextRn   -- ^ Pattern match specifics     -> !MatchArgBadMatches     -> TcRnMessage @@ -2391,7 +2419,7 @@   -}   TcRnUnexpectedPatSigType :: HsPatSigType GhcPs -> TcRnMessage -  {-| TcRnIllegalKindSignature is an error occuring when there is+  {-| TcRnIllegalKindSignature is an error occurring when there is       a kind signature without -XKindSignatures extension        Examples:@@ -2405,6 +2433,12 @@       an illegal type or kind, probably required -XDataKinds       and is used without the enabled extension. +      This error can occur in both the renamer and the typechecker. The field+      of type @'Either' ('HsType' 'GhcPs') 'Type'@ reflects this: this field+      will contain a 'Left' value if the error occurred in the renamer, and this+      field will contain a 'Right' value if the error occurred in the+      typechecker.+       Examples:          type Foo = [Nat, Char]@@ -2412,11 +2446,24 @@         type Bar = [Int, String]        Test cases: linear/should_fail/T18888+                  parser/should_fail/readFail001                   polykinds/T7151+                  polykinds/T7433+                  rename/should_fail/T13568+                  rename/should_fail/T22478e                   th/TH_Promoted1Tuple-                  typecheck/should_fail/tcfail094+                  typecheck/should_compile/tcfail094+                  typecheck/should_compile/T22141a+                  typecheck/should_compile/T22141b+                  typecheck/should_compile/T22141c+                  typecheck/should_compile/T22141d+                  typecheck/should_compile/T22141e+                  typecheck/should_compile/T22141f+                  typecheck/should_compile/T22141g+                  typecheck/should_fail/T20873c+                  typecheck/should_fail/T20873d   -}-  TcRnDataKindsError :: TypeOrKind -> HsType GhcPs -> TcRnMessage+  TcRnDataKindsError :: TypeOrKind -> Either (HsType GhcPs) Type -> TcRnMessage    {-| TcRnCannotBindScopedTyVarInPatSig is an error stating that scoped type      variables cannot be used in pattern bindings.@@ -2512,12 +2559,17 @@       rn050       rn066 (here is a warning, not deprecation)       T3303+      ExportWarnings1+      ExportWarnings2+      ExportWarnings3+      ExportWarnings4+      ExportWarnings5+      ExportWarnings6+      InstanceWarnings   -}   TcRnPragmaWarning :: {-    pragma_warning_occ :: OccName,-    pragma_warning_msg :: WarningTxt GhcRn,-    pragma_warning_import_mod :: ModuleName,-    pragma_warning_defined_mod :: Maybe ModuleName+    pragma_warning_info :: PragmaWarningInfo,+    pragma_warning_msg :: WarningTxt GhcRn   } -> TcRnMessage    {-| TcRnDifferentExportWarnings is an error that occurs when the@@ -2828,7 +2880,7 @@                  parser/should_fail/readFail028   -}   TcRnLastStmtNotExpr-    :: HsStmtContext GhcRn+    :: HsStmtContextRn     -> UnexpectedStatement     -> TcRnMessage @@ -2842,7 +2894,7 @@                  parser/should_fail/readFail043   -}   TcRnUnexpectedStatementInContext-    :: HsStmtContext GhcRn+    :: HsStmtContextRn     -> UnexpectedStatement     -> Maybe LangExt.Extension     -> TcRnMessage@@ -2959,7 +3011,7 @@       Test cases: rename/should_fail/RnEmptyCaseFail   -}-  TcRnEmptyCase :: HsMatchContext GhcRn -> TcRnMessage+  TcRnEmptyCase :: HsMatchContextRn -> TcRnMessage    {-| TcRnNonStdGuards is a warning thrown when a user uses       non-standard guards (e.g. patterns in guards) without@@ -3097,23 +3149,6 @@   TcRnDeprecatedInvisTyArgInConPat     :: TcRnMessage -  {-| TcRnLoopySuperclassSolve is a warning, controlled by @-Wloopy-superclass-solve@,-      that is triggered when GHC solves a constraint in a possibly-loopy way,-      violating the class instance termination rules described in the section-      "Undecidable instances and loopy superclasses" of the user's guide.--      Example:--        class Foo f-        class Foo f => Bar f g-        instance Bar f f => Bar f (h k)--      Test cases: T20666, T20666{a,b}, T22891, T22912.-  -}-  TcRnLoopySuperclassSolve :: CtLoc    -- ^ Wanted 'CtLoc'-                           -> PredType -- ^ Wanted 'PredType'-                           -> TcRnMessage-   {-| TcRnUnexpectedStandaloneDerivingDecl is an error thrown when a user uses       standalone deriving without enabling the StandaloneDeriving extension. @@ -3322,6 +3357,21 @@     :: !StageCheckReason -- ^ The binding being spliced.     -> TcRnMessage +  {-| TcRnBadlyStagedWarn is a warning that occurs when a TH type binding is+    used in an invalid stage.++    Controlled by flags:+       - Wbadly-staged-type++    Test cases:+      T23829_timely T23829_tardy T23829_hasty+  -}+  TcRnBadlyStagedType+    :: !Name  -- ^ The type binding being spliced.+    -> !Int -- ^ The binding stage.+    -> !Int -- ^ The stage at which the binding is used.+    -> TcRnMessage+   {-| TcRnTyThingUsedWrong is an error that occurs when a thing is used where another     thing was expected. @@ -3448,6 +3498,24 @@   TcRnPartialFieldSelector :: !FieldLabel -- ^ The selector                            -> TcRnMessage +  {-| TcRnHasFieldResolvedIncomplete is a warning triggered when a HasField constraint+      is resolved for a record field for which a `getField @"field"` application+      might not be successful. Currently, this means that the warning is triggered when+      the parent data type of that record field does not have that field in all+      its constructors.++      Example(s):+      data T = T1 | T2 {x :: Bool}+      f :: HasField t "x" Bool => t -> Bool+      f = getField @"x"+      g :: T -> Bool+      g = f++     Test cases:+       TcIncompleteRecSel+  -}+  TcRnHasFieldResolvedIncomplete :: !Name -> TcRnMessage+   {-| TcRnBadFieldAnnotation is an error/warning group indicating that a     strictness/unpack related data type field annotation is invalid.   -}@@ -3934,7 +4002,9 @@      Test cases:       dsrun006, mdofail002, mdofail003, mod23, mod24, qq006, rnfail001,-      rnfail004, SimpleFail6, T14114, T16110_Fail1, tcfail038, TH_spliceD1+      rnfail004, SimpleFail6, T14114, T16110_Fail1, tcfail038, TH_spliceD1,+      T22478b, TyAppPat_NonlinearMultiAppPat, TyAppPat_NonlinearMultiPat,+      TyAppPat_NonlinearSinglePat,   -}   TcRnBindingNameConflict :: !RdrName -- ^ The conflicting name                           -> !(NE.NonEmpty SrcSpan)@@ -4057,9 +4127,185 @@   -}   TcRnImplicitRhsQuantification :: LocatedN RdrName -> TcRnMessage -  deriving Generic+  {-| TcRnIllformedTypePattern is an error raised when the pattern+      corresponding to a required type argument (visible forall)+      does not have a form that can be interpreted as a type pattern. +      Example: +        vfun :: forall (a :: k) -> ()+        vfun !x = ()+        --   ^^+        -- bang-patterns not allowed as type patterns++      Test cases:+          T22326_fail_bang_pat+  -}+  TcRnIllformedTypePattern :: !(Pat GhcRn) -> TcRnMessage++  {-| TcRnIllegalTypePattern is an error raised when a pattern constructed+      with the @type@ keyword occurs in a position that does not correspond+      to a required type argument (visible forall).++      Example:++        case x of+          (type _) -> True     -- the (type _) pattern is illegal here+          _        -> False++      Test cases:+        T22326_fail_ado+        T22326_fail_caseof+  -}+  TcRnIllegalTypePattern :: TcRnMessage++  {-| TcRnIllformedTypeArgument is an error raised when an argument+      that specifies a required type argument (instantiates a visible forall)+      does not have a form that can be interpreted as a type argument.++      Example:++        vfun :: forall (a :: k) -> ()+        x = vfun (\_ -> _)+        --       ^^^^^^^^^+        -- lambdas not allowed in type arguments++      Test cases:+        T22326_fail_lam_arg+  -}+  TcRnIllformedTypeArgument :: !(LHsExpr GhcRn) -> TcRnMessage++  {-| TcRnIllegalTypeExpr is an error raised when an expression constructed+      with the @type@ keyword occurs in a position that does not correspond+      to a required type argument (visible forall).++      Example:++        xtop = type Int                  -- not a function argument+        xarg = length (type Int)         -- `length` does not expect a required type argument++      Test cases:+        T22326_fail_app+        T22326_fail_top+  -}+  TcRnIllegalTypeExpr :: TcRnMessage++  {-| TcRnInvalidDefaultedTyVar is an error raised when a+      defaulting plugin proposes to default a type variable that is+      not an unfilled metavariable++      Test cases:+        T23832_invalid+  -}+  TcRnInvalidDefaultedTyVar+      :: ![Ct]                -- ^ The constraints passed to the plugin+      -> [(TcTyVar, Type)]    -- ^ The plugin-proposed type variable defaults+      -> NE.NonEmpty TcTyVar  -- ^ The invalid type variables of the proposal+      -> TcRnMessage++  {-| TcRnNamespacedWarningPragmaWithoutFlag is an error that occurs when+      a namespace specifier is used in {-# WARNING ... #-} or {-# DEPRECATED ... #-}+      pragmas without the -XExplicitNamespaces extension enabled++      Example:++        {-# LANGUAGE NoExplicitNamespaces #-}+        f = id+        {-# WARNING data f "some warning message" #-}++      Test cases:+        T24396c+  -}+  TcRnNamespacedWarningPragmaWithoutFlag :: WarnDecl GhcPs -> TcRnMessage++  {-| TcRnInvisPatWithNoForAll is an error raised when invisible type pattern+      is used without associated `forall` in types++      Examples:++        f :: Int+        f @t = 5++        g :: [a -> a]+        g = [\ @t x -> x :: t]++      Test cases: T17694c T17594d+  -}+  TcRnInvisPatWithNoForAll :: HsTyPat GhcRn -> TcRnMessage++  {-| TcRnIllegalInvisibleTypePattern is an error raised when invisible type pattern+      is used without the TypeAbstractions extension enabled++      Example:++        {-# LANGUAGE NoTypeAbstractions #-}+        id :: a -> a+        id @t x = x++      Test cases: T17694b+  -}+  TcRnIllegalInvisibleTypePattern :: HsTyPat GhcPs -> TcRnMessage++  {-| TcRnNamespacedFixitySigWithoutFlag is an error that occurs when+      a namespace specifier is used in fixity signatures+      without the -XExplicitNamespaces extension enabled++      Example:++        {-# LANGUAGE NoExplicitNamespaces #-}+        f = const+        infixl 7 data `f`++      Test cases:+        T14032c+  -}+  TcRnNamespacedFixitySigWithoutFlag :: FixitySig GhcPs -> TcRnMessage++  {-| TcRnDefaultedExceptionContext is a warning that is triggered when the+      backward-compatibility logic solving for implicit ExceptionContext+      constraints fires.++      Test cases: DefaultExceptionContext+  -}+  TcRnDefaultedExceptionContext :: CtLoc -> TcRnMessage++  {-| TcRnOutOfArityTyVar is an error raised when the arity of a type synonym+      (as determined by the SAKS and the LHS) is insufficiently high to+      accommodate an implicit binding for a free variable that occurs in the+      outermost kind signature on the RHS of the said type synonym.++      Example:++        type SynBad :: forall k. k -> Type+        type SynBad = Proxy :: j -> Type++      Test cases:+        T24770a+  -}+  TcRnOutOfArityTyVar+    :: Name -- ^ Type synonym's name+    -> Name -- ^ Type variable's name+    -> TcRnMessage++  {- TcRnMisplacedInvisPat is an error raised when invisible @-pattern+     appears in invalid context (e.g. pattern in case of or in do-notation)+     or nested inside the pattern. Template Haskell seems to be the only+     source for this diagnostic.++     Examples:++        f (smth, $(invisP (varT (newName "blah")))) = ...++        g = do+          $(invisP (varT (newName "blah"))) <- aciton1+          ...++     Test cases:++  -}+  TcRnMisplacedInvisPat :: HsTyPat GhcPs -> TcRnMessage+  deriving Generic+ ----  data ZonkerMessage where@@ -4951,7 +5197,6 @@   = SolverReport   { sr_important_msg :: SolverReportWithCtxt   , sr_supplementary :: [SolverReportSupplementary]-  , sr_hints         :: [GhcHint]   }  -- | Additional information to print in a 'SolverReport', after the@@ -5426,7 +5671,9 @@   -- | Module does not export...   = BadImportNotExported [GhcHint] -- ^ suggestions for what might have been meant   -- | Missing @type@ keyword when importing a type.-  | BadImportAvailTyCon+  -- e.g.  `import TypeLits( (+) )`, where TypeLits exports a /type/ (+), not a /term/ (+)+  -- Then we want to suggest using `import TypeLits( type (+) )`+  | BadImportAvailTyCon Bool -- ^ is ExplicitNamespaces enabled?   -- | Trying to import a data constructor directly, e.g.   -- @import Data.Maybe (Just)@ instead of @import Data.Maybe (Maybe(Just))@   | BadImportAvailDataCon OccName@@ -5507,7 +5754,7 @@   -- See 'NotInScopeError' for other not-in-scope errors.   --   -- Test cases: T9177a.-  = OutOfScopeHole [ImportError]+  = OutOfScopeHole [ImportError] [GhcHint]   -- | Report a typed hole, or wildcard, with additional information.   | HoleError HoleSort               [TcTyVar]                     -- Other type variables which get computed on the way.@@ -5657,7 +5904,7 @@   = EquationArgs       !Name -- ^ Name of the function   | PatternArgs-      !(HsMatchContext GhcTc) -- ^ Pattern match specifics+      !HsMatchContextRn -- ^ Pattern match specifics  -- | The information necessary to report mismatched -- numbers of arguments in a match group.@@ -5666,6 +5913,16 @@     ::  { matchArgFirstMatch :: LocatedA (Match GhcRn body)         , matchArgBadMatches :: NE.NonEmpty (LocatedA (Match GhcRn body)) }     -> MatchArgBadMatches++data PragmaWarningInfo+  = PragmaWarningName { pwarn_occname :: OccName+                      , pwarn_impmod :: ModuleName+                      , pwarn_declmod :: ModuleName }+  | PragmaWarningExport { pwarn_occname :: OccName+                        , pwarn_impmod :: ModuleName }+  | PragmaWarningInstance { pwarn_dfunid :: DFunId+                          , pwarn_ctorig :: CtOrigin }+  -- | The context for an "empty statement group" error. data EmptyStatementGroupErrReason
compiler/GHC/Tc/Errors/Types/PromotionErr.hs view
@@ -2,6 +2,8 @@ module GHC.Tc.Errors.Types.PromotionErr ( PromotionErr(..)                                         , pprPECategory                                         , peCategory+                                        , TermLevelUseErr(..)+                                        , teCategory                                         ) where  import GHC.Prelude@@ -25,8 +27,7 @@    | RecDataConPE     -- Data constructor in a recursive loop                      -- See Note [Recursion and promoting data constructors] in GHC.Tc.TyCl-  | TermVariablePE   -- See Note [Promoted variables in types]-  | NoDataKindsDC    -- -XDataKinds not enabled (for a datacon)+  | TermVariablePE   -- See Note [Demotion of unqualified variables] in GHC.Rename.Env   | TypeVariablePE   -- See Note [Type variable scoping errors during typechecking]   deriving (Generic) @@ -37,7 +38,6 @@   ppr FamDataConPE         = text "FamDataConPE"   ppr (ConstrainedDataConPE theta) = text "ConstrainedDataConPE" <+> parens (ppr theta)   ppr RecDataConPE         = text "RecDataConPE"-  ppr NoDataKindsDC        = text "NoDataKindsDC"   ppr TermVariablePE       = text "TermVariablePE"   ppr TypeVariablePE       = text "TypeVariablePE" @@ -51,10 +51,20 @@ peCategory FamDataConPE         = "data constructor" peCategory ConstrainedDataConPE{} = "data constructor" peCategory RecDataConPE         = "data constructor"-peCategory NoDataKindsDC        = "data constructor" peCategory TermVariablePE       = "term variable" peCategory TypeVariablePE       = "type variable" +-- The opposite of a promotion error (a demotion error, in a sense).+data TermLevelUseErr+  = TyConTE   -- Type constructor used at the term level, e.g. x = Int+  | ClassTE   -- Class used at the term level,            e.g. x = Functor+  | TyVarTE   -- Type variable used at the term level,    e.g. f (Proxy :: Proxy a) = a+  deriving (Generic)++teCategory :: TermLevelUseErr -> String+teCategory ClassTE = "class"+teCategory TyConTE = "type constructor"+teCategory TyVarTE = "type variable"  {- Note [Type variable scoping errors during typechecking] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
compiler/GHC/Tc/Solver/InertSet.hs view
@@ -76,7 +76,6 @@ import GHC.Utils.Misc       ( partitionWith ) import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Utils.Panic.Plain import GHC.Data.Maybe import GHC.Data.Bag @@ -1732,7 +1731,7 @@           _  -> False  -- | Returns True iff there are no Given constraints that might,--- potentially, match the given class consraint. This is used when checking to see if a+-- potentially, match the given class constraint. This is used when checking to see if a -- Given might overlap with an instance. See Note [Instance and Given overlap] -- in GHC.Tc.Solver.Dict noMatchableGivenDicts :: InertSet -> CtLoc -> Class -> [TcType] -> Bool
compiler/GHC/Tc/Solver/Types.hs view
@@ -41,7 +41,6 @@ import GHC.Utils.Constants import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Utils.Panic.Plain  {- ********************************************************************* *                                                                      *
compiler/GHC/Tc/Types.hs view
@@ -67,9 +67,12 @@         ArrowCtxt(..),          -- TcSigInfo-        TcSigFun, TcSigInfo(..), TcIdSigInfo(..),-        TcIdSigInst(..), TcPatSynInfo(..),-        isPartialSig, hasCompleteSig,+        TcSigFun,+        TcSigInfo(..), TcIdSig(..),+        TcCompleteSig(..), TcPartialSig(..), TcPatSynSig(..),+        TcIdSigInst(..),+        isPartialSig, hasCompleteSig, tcSigInfoName, tcIdSigLoc,+        completeSigPolyId_maybe,          -- Misc other types         TcId,@@ -86,7 +89,7 @@          -- Defaulting plugin         DefaultingPlugin(..), DefaultingProposal(..),-        FillDefaulting, DefaultingPluginResult,+        FillDefaulting,          -- Role annotations         RoleAnnotEnv, emptyRoleAnnotEnv, mkRoleAnnotEnv,@@ -602,7 +605,9 @@         tcg_fords     :: [LForeignDecl GhcTc], -- ...Foreign import & exports         tcg_patsyns   :: [PatSyn],            -- ...Pattern synonyms -        tcg_doc_hdr   :: Maybe (LHsDoc GhcRn), -- ^ Maybe Haddock header docs+        tcg_hdr_info   :: (Maybe (LHsDoc GhcRn), Maybe (XRec GhcRn ModuleName)),+        -- ^ Maybe Haddock header docs and Maybe located module name+         tcg_hpc       :: !AnyHpcUsage,       -- ^ @True@ if any part of the                                              --  prog uses hpc instrumentation.            -- NB. BangPattern is to fix a leak, see #15111@@ -1052,30 +1057,26 @@     , tcRewriterNewWanteds :: [Ct]     } --- | A collection of candidate default types for a type variable.+-- | A collection of candidate default types for sets of type variables. data DefaultingProposal   = DefaultingProposal-    { deProposalTyVar :: TcTyVar-      -- ^ The type variable to default.-    , deProposalCandidates :: [Type]-      -- ^ Candidate types to default the type variable to.+    { deProposals :: [[(TcTyVar, Type)]]+      -- ^ The type variable assignments to try.     , deProposalCts :: [Ct]       -- ^ The constraints against which defaults are checked.     }  instance Outputable DefaultingProposal where   ppr p = text "DefaultingProposal"-          <+> ppr (deProposalTyVar p)-          <+> ppr (deProposalCandidates p)+          <+> ppr (deProposals p)           <+> ppr (deProposalCts p) -type DefaultingPluginResult = [DefaultingProposal] type FillDefaulting   = WantedConstraints       -- Zonked constraints containing the unfilled metavariables that       -- can be defaulted. See wrinkle (DP1) of Note [Defaulting plugins]       -- in GHC.Tc.Solver-  -> TcPluginM DefaultingPluginResult+  -> TcPluginM [DefaultingProposal]  -- | A plugin for controlling defaulting. data DefaultingPlugin = forall s. DefaultingPlugin
compiler/GHC/Tc/Types/BasicTypes.hs view
@@ -5,13 +5,11 @@   , TcBinder(..)    -- * Signatures-  , TcSigFun-  , TcIdSigInfo(..)-  , TcSigInfo(..)-  , TcPatSynInfo(..)+  , TcSigFun, TcSigInfo(..), TcIdSig(..)+  , TcCompleteSig(..), TcPartialSig(..), TcPatSynSig(..)   , TcIdSigInst(..)-  , isPartialSig-  , hasCompleteSig+  , isPartialSig, hasCompleteSig+  , tcSigInfoName, tcIdSigLoc, completeSigPolyId_maybe    -- * TcTyThing   , TcTyThing(..)@@ -101,33 +99,50 @@  type TcSigFun  = Name -> Maybe TcSigInfo -data TcSigInfo = TcIdSig     TcIdSigInfo-               | TcPatSynSig TcPatSynInfo+-- TcSigInfo is simply the range of TcSigFun+data TcSigInfo = TcIdSig     TcIdSig+               | TcPatSynSig TcPatSynSig    -- For a pattern synonym -data TcIdSigInfo   -- See Note [Complete and partial type signatures]-  = CompleteSig    -- A complete signature with no wildcards,-                   -- so the complete polymorphic type is known.-      { sig_bndr :: TcId          -- The polymorphic Id with that type+-- See Note [Complete and partial type signatures]+data TcIdSig  -- For an Id+  = TcCompleteSig TcCompleteSig+  | TcPartialSig  TcPartialSig -      , sig_ctxt :: UserTypeCtxt  -- In the case of type-class default methods,-                                  -- the Name in the FunSigCtxt is not the same-                                  -- as the TcId; the former is 'op', while the-                                  -- latter is '$dmop' or some such+data TcCompleteSig  -- A complete signature with no wildcards,+                    -- so the complete polymorphic type is known.+  = CSig { sig_bndr :: TcId          -- The polymorphic Id with that type -      , sig_loc  :: SrcSpan       -- Location of the type signature-      }+         , sig_ctxt :: UserTypeCtxt  -- In the case of type-class default methods,+                                     -- the Name in the FunSigCtxt is not the same+                                     -- as the TcId; the former is 'op', while the+                                     -- latter is '$dmop' or some such -  | PartialSig     -- A partial type signature (i.e. includes one or more+         , sig_loc  :: SrcSpan       -- Location of the type signature+         }++data TcPartialSig  -- A partial type signature (i.e. includes one or more                    -- wildcards). In this case it doesn't make sense to give                    -- the polymorphic Id, because we are going to /infer/ its                    -- type, so we can't make the polymorphic Id ab-initio-      { psig_name  :: Name   -- Name of the function; used when report wildcards-      , psig_hs_ty :: LHsSigWcType GhcRn  -- The original partial signature in-                                          -- HsSyn form-      , sig_ctxt   :: UserTypeCtxt-      , sig_loc    :: SrcSpan            -- Location of the type signature-      }+  = PSig { psig_name  :: Name   -- Name of the function; used when report wildcards+         , psig_hs_ty :: LHsSigWcType GhcRn  -- The original partial signature in+                                             -- HsSyn form+         , psig_ctxt  :: UserTypeCtxt+         , psig_loc   :: SrcSpan            -- Location of the type signature+         } +data TcPatSynSig+  = PatSig {+        patsig_name           :: Name,+        patsig_implicit_bndrs :: [InvisTVBinder], -- Implicitly-bound kind vars (Inferred) and+                                                  -- implicitly-bound type vars (Specified)+          -- See Note [The pattern-synonym signature splitting rule] in GHC.Tc.TyCl.PatSyn+        patsig_univ_bndrs     :: [InvisTVBinder], -- Bound by explicit user forall+        patsig_req            :: TcThetaType,+        patsig_ex_bndrs       :: [InvisTVBinder], -- Bound by explicit user forall+        patsig_prov           :: TcThetaType,+        patsig_body_ty        :: TcSigmaType+    }  {- Note [Complete and partial type signatures] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -146,7 +161,7 @@ -}  data TcIdSigInst-  = TISI { sig_inst_sig :: TcIdSigInfo+  = TISI { sig_inst_sig :: TcIdSig           , sig_inst_skols :: [(Name, InvisTVBinder)]                -- Instantiated type and kind variables, TyVarTvs@@ -187,7 +202,7 @@ Note that "sig_inst_tau" might actually be a polymorphic type, if the original function had a signature like    forall a. Eq a => forall b. Ord b => ....-But that's ok: tcMatchesFun (called by tcRhs) can deal with that+But that's ok: tcFunBindMatches (called by tcRhs) can deal with that It happens, too!  See Note [Polymorphic methods] in GHC.Tc.TyCl.Class.  Note [Quantified variables in partial type signatures]@@ -231,51 +246,59 @@    sig_inst_wcs   = [ _22::k ] -} -data TcPatSynInfo-  = TPSI {-        patsig_name           :: Name,-        patsig_implicit_bndrs :: [InvisTVBinder], -- Implicitly-bound kind vars (Inferred) and-                                                  -- implicitly-bound type vars (Specified)-          -- See Note [The pattern-synonym signature splitting rule] in GHC.Tc.TyCl.PatSyn-        patsig_univ_bndrs     :: [InvisTVBinder], -- Bound by explicit user forall-        patsig_req            :: TcThetaType,-        patsig_ex_bndrs       :: [InvisTVBinder], -- Bound by explicit user forall-        patsig_prov           :: TcThetaType,-        patsig_body_ty        :: TcSigmaType-    }- instance Outputable TcSigInfo where-  ppr (TcIdSig     idsi) = ppr idsi-  ppr (TcPatSynSig tpsi) = text "TcPatSynInfo" <+> ppr tpsi+  ppr (TcIdSig sig)     = ppr sig+  ppr (TcPatSynSig sig) = ppr sig -instance Outputable TcIdSigInfo where-    ppr (CompleteSig { sig_bndr = bndr })-        = ppr bndr <+> dcolon <+> ppr (idType bndr)-    ppr (PartialSig { psig_name = name, psig_hs_ty = hs_ty })-        = text "[partial signature]" <+> ppr name <+> dcolon <+> ppr hs_ty+instance Outputable TcIdSig where+  ppr (TcCompleteSig sig) = ppr sig+  ppr (TcPartialSig sig)  = ppr sig -instance Outputable TcIdSigInst where-    ppr (TISI { sig_inst_sig = sig, sig_inst_skols = skols-              , sig_inst_theta = theta, sig_inst_tau = tau })-        = hang (ppr sig) 2 (vcat [ ppr skols, ppr theta <+> darrow <+> ppr tau ])+instance Outputable TcCompleteSig where+  ppr (CSig { sig_bndr = bndr })+      = ppr bndr <+> dcolon <+> ppr (idType bndr) -instance Outputable TcPatSynInfo where-    ppr (TPSI{ patsig_name = name}) = ppr name+instance Outputable TcPartialSig where+  ppr (PSig { psig_name = name, psig_hs_ty = hs_ty })+      = text "[partial signature]" <+> ppr name <+> dcolon <+> ppr hs_ty +instance Outputable TcPatSynSig where+  ppr (PatSig { patsig_name = name}) = ppr name++instance Outputable TcIdSigInst where+  ppr (TISI { sig_inst_sig = sig, sig_inst_skols = skols+            , sig_inst_theta = theta, sig_inst_tau = tau })+      = hang (ppr sig) 2 (vcat [ ppr skols, ppr theta <+> darrow <+> ppr tau ])+ isPartialSig :: TcIdSigInst -> Bool-isPartialSig (TISI { sig_inst_sig = PartialSig {} }) = True-isPartialSig _                                       = False+isPartialSig (TISI { sig_inst_sig = TcPartialSig {} }) = True+isPartialSig _                                         = False  -- | No signature or a partial signature hasCompleteSig :: TcSigFun -> Name -> Bool hasCompleteSig sig_fn name   = case sig_fn name of-      Just (TcIdSig (CompleteSig {})) -> True-      _                               -> False+      Just (TcIdSig (TcCompleteSig {})) -> True+      _                                 -> False ------------------------------- TcTyThing----------------------------+tcSigInfoName :: TcSigInfo -> Name+tcSigInfoName (TcIdSig (TcCompleteSig sig)) = idName (sig_bndr sig)+tcSigInfoName (TcIdSig (TcPartialSig  sig)) = psig_name sig+tcSigInfoName (TcPatSynSig sig)             = patsig_name sig++tcIdSigLoc :: TcIdSig -> SrcSpan+tcIdSigLoc (TcCompleteSig sig) = sig_loc sig+tcIdSigLoc (TcPartialSig  sig) = psig_loc sig++completeSigPolyId_maybe :: TcSigInfo -> Maybe TcId+completeSigPolyId_maybe (TcIdSig (TcCompleteSig sig)) = Just (sig_bndr sig)+completeSigPolyId_maybe _                             = Nothing++{- *********************************************************************+*                                                                      *+             TcTyThing+*                                                                      *+********************************************************************* -}  -- | A typecheckable thing available in a local context.  Could be -- 'AGlobal' 'TyThing', but also lexically scoped variables, etc.
compiler/GHC/Tc/Types/Constraint.hs view
@@ -83,7 +83,7 @@         ctEvExpr, ctEvTerm, ctEvCoercion, ctEvEvId,         ctEvRewriters, ctEvUnique, tcEvDestUnique,         mkKindEqLoc, toKindLoc, toInvisibleLoc, mkGivenLoc,-        ctEvRole, setCtEvPredType, setCtEvLoc,+        ctEvRole, setCtEvPredType, setCtEvLoc, arisesFromGivens,         tyCoVarsOfCtEvList, tyCoVarsOfCtEv, tyCoVarsOfCtEvsList,          -- RewriterSet@@ -1312,51 +1312,25 @@ insolubleWC :: WantedConstraints -> Bool insolubleWC (WC { wc_impl = implics, wc_simple = simples, wc_errors = errors })   =  anyBag insolubleWantedCt simples-       -- insolubleWantedCt: wanteds only: see Note [Given insolubles]   || anyBag insolubleImplic implics   || anyBag is_insoluble errors-  where++    where       is_insoluble (DE_Hole hole) = isOutOfScopeHole hole -- See Note [Insoluble holes]       is_insoluble (DE_NotConcrete {}) = True  insolubleWantedCt :: Ct -> Bool -- Definitely insoluble, in particular /excluding/ type-hole constraints -- Namely:---   a) an insoluble constraint as per 'insolubleIrredCt', i.e. either+--   a) an insoluble constraint as per 'insolubleCt', i.e. either --        - an insoluble equality constraint (e.g. Int ~ Bool), or --        - a custom type error constraint, TypeError msg :: Constraint --   b) that does not arise from a Given or a Wanted/Wanted fundep interaction--- See Note [Insoluble Wanteds]-insolubleWantedCt ct-  | CIrredCan ir_ct <- ct-      -- CIrredCan: see (IW1) in Note [Insoluble Wanteds]-  , IrredCt { ir_ev = ev } <- ir_ct-  , CtWanted { ctev_loc = loc, ctev_rewriters = rewriters }  <- ev-      -- It's a Wanted-  , insolubleIrredCt ir_ct-      -- It's insoluble-  , isEmptyRewriterSet rewriters-      -- It has no rewriters; see (IW2) in Note [Insoluble Wanteds]-  , not (isGivenLoc loc)-      -- isGivenLoc: see (IW3) in Note [Insoluble Wanteds]-  , not (isWantedWantedFunDepOrigin (ctLocOrigin loc))-      -- origin check: see (IW4) in Note [Insoluble Wanteds]-  = True--  | otherwise-  = False---- | Returns True of constraints that are definitely insoluble,---   as well as TypeError constraints.--- Can return 'True' for Given constraints, unlike 'insolubleWantedCt'. ----- The function is tuned for application /after/ constraint solving---       i.e. assuming canonicalisation has been done--- That's why it looks only for IrredCt; all insoluble constraints--- are put into CIrredCan-insolubleCt :: Ct -> Bool-insolubleCt (CIrredCan ir_ct) = insolubleIrredCt ir_ct-insolubleCt _                 = False+-- See Note [Given insolubles].+insolubleWantedCt ct = insolubleCt ct &&+                       not (arisesFromGivens ct) &&+                       not (isWantedWantedFunDepOrigin (ctOrigin ct))  insolubleIrredCt :: IrredCt -> Bool -- Returns True of Irred constraints that are /definitely/ insoluble@@ -1386,6 +1360,18 @@   -- >   Assert 'True  _errMsg = ()   -- >   Assert _check errMsg  = errMsg +-- | Returns True of constraints that are definitely insoluble,+--   as well as TypeError constraints.+-- Can return 'True' for Given constraints, unlike 'insolubleWantedCt'.+--+-- The function is tuned for application /after/ constraint solving+--       i.e. assuming canonicalisation has been done+-- That's why it looks only for IrredCt; all insoluble constraints+-- are put into CIrredCan+insolubleCt :: Ct -> Bool+insolubleCt (CIrredCan ir_ct) = insolubleIrredCt ir_ct+insolubleCt _                 = False+ -- | Does this hole represent an "out of scope" error? -- See Note [Insoluble holes] isOutOfScopeHole :: Hole -> Bool@@ -1429,31 +1415,6 @@ Bottom line: insolubleWC (called in GHC.Tc.Solver.setImplicationStatus)              should ignore givens even if they are insoluble. -Note [Insoluble Wanteds]-~~~~~~~~~~~~~~~~~~~~~~~~-insolubleWantedCt returns True of a Wanted constraint that definitely-can't be solved.  But not quite all such constraints; see wrinkles.--(IW1) insolubleWantedCt is tuned for application /after/ constraint-   solving i.e. assuming canonicalisation has been done.  That's why-   it looks only for IrredCt; all insoluble constraints are put into-   CIrredCan--(IW2) We only treat it as insoluble if it has an empty rewriter set.  (See Note-   [Wanteds rewrite Wanteds].)  Otherwise #25325 happens: a Wanted constraint A-   that is /not/ insoluble rewrites some other Wanted constraint B, so B has A-   in its rewriter set.  Now B looks insoluble.  The danger is that we'll-   suppress reporting B because of its empty rewriter set; and suppress-   reporting A because there is an insoluble B lying around.  (This suppression-   happens in GHC.Tc.Errors.mkErrorItem.)  Solution: don't treat B as insoluble.--(IW3) If the Wanted arises from a Given (how can that happen?), don't-   treat it as a Wanted insoluble (obviously).--(IW4) If the Wanted came from a  Wanted/Wanted fundep interaction, don't-   treat the constraint as insoluble. See Note [Suppressing confusing errors]-   in GHC.Tc.Errors- Note [Insoluble holes] ~~~~~~~~~~~~~~~~~~~~~~ Hole constraints that ARE NOT treated as truly insoluble:@@ -2094,6 +2055,9 @@  setCtEvLoc :: CtEvidence -> CtLoc -> CtEvidence setCtEvLoc ctev loc = ctev { ctev_loc = loc }++arisesFromGivens :: Ct -> Bool+arisesFromGivens ct = isGivenCt ct || isGivenLoc (ctLoc ct)  -- | Set the type of CtEvidence. --
compiler/GHC/Tc/Types/ErrCtxt.hs view
compiler/GHC/Tc/Types/Evidence.hs view
@@ -7,7 +7,7 @@    -- * HsWrapper   HsWrapper(..),-  (<.>), mkWpTyApps, mkWpEvApps, mkWpEvVarApps, mkWpTyLams,+  (<.>), mkWpTyApps, mkWpEvApps, mkWpEvVarApps, mkWpTyLams, mkWpVisTyLam,   mkWpEvLams, mkWpLet, mkWpFun, mkWpCastN, mkWpCastR, mkWpEta,   collectHsWrapBinders,   idHsWrapper, isIdHsWrapper,@@ -257,6 +257,21 @@  mkWpTyLams :: [TyVar] -> HsWrapper mkWpTyLams ids = mk_co_lam_fn WpTyLam ids++-- Construct a type lambda and cast its type+-- from `forall tv. res` to `forall tv -> res`.+--+-- (\ @tv -> e )+--    `cast` (forall (tv[spec]~[req] :: <*>_N). <res>_R       -- ForAllCo is the evidence that...+--              :: (forall tv. res) ~R# (forall tv -> res))   -- invisible and visible foralls are representationally equal+--+mkWpVisTyLam :: TyVar -> Type -> HsWrapper+mkWpVisTyLam tv res =+  WpCast (mkForAllCo tv coreTyLamForAllTyFlag Required kind_co body_co)+  <.> WpTyLam tv+  where+    kind_co = mkNomReflCo (varType tv)+    body_co = mkRepReflCo res  mkWpEvLams :: [Var] -> HsWrapper mkWpEvLams ids = mk_co_lam_fn WpEvLam ids
compiler/GHC/Tc/Types/LclEnv.hs view
@@ -90,7 +90,7 @@   = TcLclCtxt {         tcl_loc        :: RealSrcSpan,     -- Source span         tcl_ctxt       :: [ErrCtxt],       -- Error context, innermost on top-        tcl_in_gen_code :: Bool,           -- See Note [Rebindable syntax and HsExpansion]+        tcl_in_gen_code :: Bool,           -- See Note [Rebindable syntax and XXExprGhcRn]         tcl_tclvl      :: TcLevel,         tcl_bndrs      :: TcBinderStack,   -- Used for reporting relevant bindings,                                            -- and for tidying type
compiler/GHC/Tc/Types/Origin.hs view
@@ -2,6 +2,8 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE PolyKinds #-}+{-# LANGUAGE StandaloneKindSignatures #-}+{-# LANGUAGE TypeFamilies #-}  -- | Describes the provenance of types as they flow through the type-checker. -- The datatypes here are mainly used for error message generation.@@ -20,23 +22,30 @@   isVisibleOrigin, toInvisibleOrigin,   pprCtOrigin, isGivenOrigin, isWantedWantedFunDepOrigin,   isWantedSuperclassOrigin,+  ClsInstOrQC(..), NakedScFlag(..), NonLinearPatternReason(..),    TypedThing(..), TyVarBndrs(..), -  -- * CtOrigin and CallStack+  -- * CallStack   isPushCallStackOrigin, callStackOriginFS,-  ClsInstOrQC(..), NakedScFlag(..),    -- * FixedRuntimeRep origin-  FixedRuntimeRepOrigin(..), FixedRuntimeRepContext(..),+  FixedRuntimeRepOrigin(..),+  FixedRuntimeRepContext(..),   pprFixedRuntimeRepContext,-  StmtOrigin(..), RepPolyFun(..), ArgPos(..),+  StmtOrigin(..), ArgPos(..),+  mkFRRUnboxedTuple, mkFRRUnboxedSum, -  -- * Arrow command origin+  -- ** FixedRuntimeRep origin for rep-poly 'Id's+  RepPolyId(..), Polarity(..), Position(..),++  -- ** Arrow command FixedRuntimeRep origin   FRRArrowContext(..), pprFRRArrowContext,++  -- ** ExpectedFunTy FixedRuntimeRepOrigin   ExpectedFunTyOrigin(..), pprExpectedFunTyOrigin, pprExpectedFunTyHerald, -  -- InstanceWhat+  -- * InstanceWhat   InstanceWhat(..), SafeOverlapping   ) where @@ -55,6 +64,7 @@ import GHC.Core.Multiplicity ( scaledThing )  import GHC.Unit.Module+import GHC.Unit.Module.Warnings import GHC.Types.Id import GHC.Types.Name import GHC.Types.Name.Reader@@ -67,12 +77,13 @@ import GHC.Utils.Panic import GHC.Stack import GHC.Utils.Monad-import GHC.Utils.Misc( HasDebugCallStack ) import GHC.Types.Unique import GHC.Types.Unique.Supply  import Language.Haskell.Syntax.Basic (FieldLabelString(..)) +import qualified Data.Kind as Hs+ {- ********************************************************************* *                                                                      *           UserTypeCtxt@@ -149,10 +160,14 @@ -- | Report Redundant Constraints. data ReportRedundantConstraints   = NoRRC            -- ^ Don't report redundant constraints-  | WantRRC SrcSpan  -- ^ Report redundant constraints, and here-                     -- is the SrcSpan for the constraints-                     -- E.g. f :: (Eq a, Ord b) => blah-                     -- The span is for the (Eq a, Ord b)++  | WantRRC SrcSpan  -- ^ Report redundant constraints+      -- The SrcSpan is for the constraints+      -- E.g. f :: (Eq a, Ord b) => blah+      --      The span is for the (Eq a, Ord b)+      -- We need to record the span here because we have+      -- long since discarded the HsType in favour of a Type+   deriving( Eq )  -- Just for checkSkolInfoAnon  reportRedundantConstraints :: ReportRedundantConstraints -> Bool@@ -273,7 +288,7 @@   | FamInstSkol         -- Bound at a family instance decl   | PatSkol             -- An existential type variable bound by a pattern for       ConLike           -- a data constructor with an existential type.-      (HsMatchContext GhcTc)+      HsMatchContextRn              -- e.g.   data T = forall a. Eq a => MkT a              --        f (MkT x) = ...              -- The pattern MkT x will allocate an existential type@@ -312,10 +327,10 @@ -- -- We're hoping to be able to get rid of this entirely, but for the moment -- it's still needed.-unkSkol :: HasDebugCallStack => SkolemInfo+unkSkol :: HasCallStack => SkolemInfo unkSkol = SkolemInfo (mkUniqueGrimily 0) unkSkolAnon -unkSkolAnon :: HasDebugCallStack => SkolemInfoAnon+unkSkolAnon :: HasCallStack => SkolemInfoAnon unkSkolAnon = UnkSkol callStack  -- | Wrap up the origin of a skolem type variable with a new 'Unique',@@ -425,7 +440,7 @@   whatever it tidies to, say a''; and then we walk over the type   replacing the binder a by the tidied version a'', to give        forall a''. Eq a'' => forall b''. b'' -> a''-  We need to do this under (=>) arrows, to match what topSkolemise+  We need to do this under (=>) arrows and (->), to match what skolemisation   does.  * Typically a'' will have a nice pretty name like "a", but the point is@@ -448,6 +463,7 @@   = HsTypeRnThing (HsType GhcRn)   | TypeThing Type   | HsExprRnThing (HsExpr GhcRn)+  | HsExprTcThing (HsExpr GhcTc)   | NameThing Name  -- | Some kind of type variable binder.@@ -461,6 +477,7 @@   ppr (HsTypeRnThing ty) = ppr ty   ppr (TypeThing ty) = ppr ty   ppr (HsExprRnThing expr) = ppr expr+  ppr (HsExprTcThing expr) = ppr expr   ppr (NameThing name) = ppr name  instance Outputable TyVarBndrs where@@ -604,7 +621,7 @@       Module  -- ^ Module in which the instance was declared       ClsInst -- ^ The declared typeclass instance -  | NonLinearPatternOrigin+  | NonLinearPatternOrigin NonLinearPatternReason (LPat GhcRn)   | UsageEnvironmentOf Name    | CycleBreakerOrigin@@ -625,6 +642,12 @@       Type   -- the instantiated type of the method   | AmbiguityCheckOrigin UserTypeCtxt +data NonLinearPatternReason+  = LazyPatternReason+  | GeneralisedPatternReason+  | PatternSynonymReason+  | ViewPatternReason+  | OtherPatternReason  -- | The number of superclass selections needed to get this Given. -- If @d :: C ty@   has @ScDepth=2@, then the evidence @d@ will look@@ -699,13 +722,12 @@ exprCtOrigin (HsIPVar _ ip)       = IPOccOrigin ip exprCtOrigin (HsOverLit _ lit)    = LiteralOrigin lit exprCtOrigin (HsLit {})           = Shouldn'tHappenOrigin "concrete literal"-exprCtOrigin (HsLam _ matches)    = matchesCtOrigin matches-exprCtOrigin (HsLamCase _ _ ms)   = matchesCtOrigin ms+exprCtOrigin (HsLam _ _ ms)       = matchesCtOrigin ms exprCtOrigin (HsApp _ e1 _)       = lexprCtOrigin e1-exprCtOrigin (HsAppType _ e1 _ _) = lexprCtOrigin e1+exprCtOrigin (HsAppType _ e1 _)   = lexprCtOrigin e1 exprCtOrigin (OpApp _ _ op _)     = lexprCtOrigin op exprCtOrigin (NegApp _ e _)       = lexprCtOrigin e-exprCtOrigin (HsPar _ _ e _)      = lexprCtOrigin e+exprCtOrigin (HsPar _ e)          = lexprCtOrigin e exprCtOrigin (HsProjection _ _)   = SectionOrigin exprCtOrigin (SectionL _ _ _)     = SectionOrigin exprCtOrigin (SectionR _ _ _)     = SectionOrigin@@ -714,7 +736,7 @@ exprCtOrigin (HsCase _ _ matches) = matchesCtOrigin matches exprCtOrigin (HsIf {})           = IfThenElseOrigin exprCtOrigin (HsMultiIf _ rhs)   = lGRHSCtOrigin rhs-exprCtOrigin (HsLet _ _ _ _ e)   = lexprCtOrigin e+exprCtOrigin (HsLet _ _ e)       = lexprCtOrigin e exprCtOrigin (HsDo {})           = DoOrigin exprCtOrigin (RecordCon {})      = Shouldn'tHappenOrigin "record construction" exprCtOrigin (RecordUpd {})      = RecordUpdOrigin@@ -727,7 +749,11 @@ exprCtOrigin (HsUntypedSplice {})  = Shouldn'tHappenOrigin "TH untyped splice" exprCtOrigin (HsProc {})         = Shouldn'tHappenOrigin "proc" exprCtOrigin (HsStatic {})       = Shouldn'tHappenOrigin "static expression"-exprCtOrigin (XExpr (HsExpanded a _)) = exprCtOrigin a+exprCtOrigin (HsEmbTy {})        = Shouldn'tHappenOrigin "type expression"+exprCtOrigin (XExpr (ExpandedThingRn thing _)) | OrigExpr a <- thing = exprCtOrigin a+                                               | OrigStmt _ <- thing = DoOrigin+                                               | OrigPat p  <- thing = DoPatOrigin p+exprCtOrigin (XExpr (PopErrCtxt {})) = Shouldn'tHappenOrigin "PopErrCtxt"  -- | Extract a suitable CtOrigin from a MatchGroup matchesCtOrigin :: MatchGroup GhcRn (LHsExpr GhcRn) -> CtOrigin@@ -861,11 +887,15 @@          , whenPprDebug (braces (text "sc-origin:" <> ppr nkd))          , pprCtOrigin orig ] +pprCtOrigin (NonLinearPatternOrigin reason pat)+  = 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 :: HasCallStack => CtOrigin -> SDoc pprCtO (OccurrenceOf name)   = hsep [text "a use of", quotes (ppr name)] pprCtO (OccurrenceOfRecSel name) = hsep [text "a use of", quotes (ppr name)] pprCtO AppOrigin             = text "an application"@@ -901,7 +931,6 @@ pprCtO ListOrigin            = text "an overloaded list" pprCtO IfThenElseOrigin      = text "an if-then-else expression" pprCtO StaticOrigin          = text "a static form"-pprCtO NonLinearPatternOrigin = text "a non-linear pattern" pprCtO (UsageEnvironmentOf x) = hsep [text "multiplicity of", quotes (ppr x)] pprCtO BracketOrigin         = text "a quotation bracket" @@ -929,7 +958,14 @@ pprCtO (InstanceSigOrigin {})       = text "a type signature in an instance" 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 :: HasCallStack => NonLinearPatternReason -> SDoc+pprNonLinearPatternReason LazyPatternReason = parens (text "non-variable lazy pattern aren't linear")+pprNonLinearPatternReason GeneralisedPatternReason = parens (text "non-variable pattern bindings that have been generalised aren't linear")+pprNonLinearPatternReason PatternSynonymReason = parens (text "pattern synonyms aren't linear")+pprNonLinearPatternReason ViewPatternReason = parens (text "view patterns aren't linear")+pprNonLinearPatternReason OtherPatternReason = empty  {- ********************************************************************* *                                                                      *@@ -1003,7 +1039,7 @@   = FixedRuntimeRepOrigin     { frr_type    :: Type        -- ^ What type are we checking?-       -- For example, `a[tau]` in `a[tau] :: TYPE rr[tau]`.+       -- For example, @a[tau]@ in @a[tau] :: TYPE rr[tau]@.      , frr_context :: FixedRuntimeRepContext       -- ^ What context requires a fixed runtime representation?@@ -1034,6 +1070,32 @@   -- Test cases: LevPolyLet, RepPolyPatBind.   | FRRBinder !Name +  -- | Types appearing in negative position in the type of a+  -- representation-polymorphic 'Id' must have a fixed runtime representation.+  --+  -- This includes:+  --+  --  - arguments,+  --+  --    Test cases: RepPolyMagic, RepPolyRightSection, RepPolyWrappedVar,+  --                T14561b, T17817.+  --+  --  - continuation result types, such as in 'catch#', 'keepAlive#'+  --    and 'control0#'.+  --+  --    Test case: T21906.+  | FRRRepPolyId+      !Name+      !RepPolyId+      !(Position Neg)++  -- | A partial application of the constructor of a representation-polymorphic+  -- unlifted newtype in which the argument type does not have a fixed+  -- runtime representation.+  --+  -- Test cases: UnliftedNewtypesLevityBinder, UnliftedNewtypesCoerceFail.+  | FRRRepPolyUnliftedNewtype !DataCon+   -- | Pattern binds must have a fixed runtime representation.   --   -- Test case: RepPolyInferPatBind.@@ -1056,26 +1118,20 @@   -- Test case: T20363.   | FRRDataConPatArg !DataCon !Int -  -- | An instantiation of a function with no binding (e.g. `coerce`, `unsafeCoerce#`, an unboxed tuple 'DataCon')-  -- in which one of the remaining arguments types does not have a fixed runtime representation.-  ---  -- Test cases: RepPolyWrappedVar, T14561, UnliftedNewtypesLevityBinder, UnliftedNewtypesCoerceFail.-  | FRRNoBindingResArg !RepPolyFun !ArgPos--  -- | Arguments to unboxed tuples must have fixed runtime representations.+  -- | The 'RuntimeRep' arguments to unboxed tuples must be concrete 'RuntimeRep's.   --   -- Test case: RepPolyTuple.-  | FRRTupleArg !Int+  | FRRUnboxedTuple !Int    -- | Tuple sections must have a fixed runtime representation.   --   -- Test case: RepPolyTupleSection.-  | FRRTupleSection !Int+  | FRRUnboxedTupleSection !Int -  -- | Unboxed sums must have a fixed runtime representation.+  -- | The 'RuntimeRep' arguments to unboxed sums must be concrete 'RuntimeRep's.   --   -- Test cases: RepPolySum.-  | FRRUnboxedSum+  | FRRUnboxedSum !(Maybe Int)    -- | The body of a @do@ expression or a monad comprehension must   -- have a fixed runtime representation.@@ -1106,7 +1162,7 @@   | FRRArrow !FRRArrowContext    -- | A representation-polymorphic check arising from a call-  -- to 'matchExpectedFunTys' or 'matchActualFunTySigma'.+  -- to 'matchExpectedFunTys' or 'matchActualFunTy'.   --   -- See 'ExpectedFunTyOrigin' for more details.   | FRRExpectedFunTy@@ -1114,6 +1170,28 @@       !Int         -- ^ argument position (1-indexed) +-- | The description of a representation-polymorphic 'Id'.+data RepPolyId+  -- | A representation-polymorphic 'PrimOp'.+  = RepPolyPrimOp+  -- | An unboxed tuple constructor.+  | RepPolyTuple+  -- | An unboxed sum constructor.+  | RepPolySum+  -- | An unspecified representation-polymorphic function,+  -- e.g. a pseudo-op such as 'coerce'.+  | RepPolyFunction++-- | A synonym for 'FRRUnboxedTuple' exposed in the hs-boot file+-- for "GHC.Tc.Types.Origin".+mkFRRUnboxedTuple :: Int -> FixedRuntimeRepContext+mkFRRUnboxedTuple = FRRUnboxedTuple++-- | A synonym for 'FRRUnboxedSum' exposed in the hs-boot file+-- for "GHC.Tc.Types.Origin".+mkFRRUnboxedSum :: Maybe Int -> FixedRuntimeRepContext+mkFRRUnboxedSum = FRRUnboxedSum+ -- | Print the context for a @FixedRuntimeRep@ representation-polymorphism check. -- -- Note that this function does not include the specific 'RuntimeRep'@@ -1129,6 +1207,8 @@ pprFixedRuntimeRepContext (FRRBinder binder)   = sep [ text "The binder"         , quotes (ppr binder) ]+pprFixedRuntimeRepContext (FRRRepPolyId nm id what)+  = pprFRRRepPolyId id nm what pprFixedRuntimeRepContext FRRPatBind   = text "The pattern binding" pprFixedRuntimeRepContext FRRPatSynArg@@ -1144,30 +1224,17 @@       = text "newtype constructor pattern"       | otherwise       = text "data constructor pattern in" <+> speakNth i <+> text "position"-pprFixedRuntimeRepContext (FRRNoBindingResArg fn arg_pos)-  = vcat [ text "Unsaturated use of a representation-polymorphic" <+> what_fun <> dot-         , what_arg <+> text "argument of" <+> quotes (ppr fn) ]-  where-    what_fun, what_arg :: SDoc-    what_fun = case fn of-      RepPolyWiredIn {} -> text "primitive function"-      RepPolyDataCon dc -> what_con <+> text "constructor"-        where-          what_con :: SDoc-          what_con-            | isNewDataCon dc-            = text "newtype"-            | otherwise-            = text "data"-    what_arg = case arg_pos of-      ArgPosInvis -> text "An invisible"-      ArgPosVis i -> text "The" <+> speakNth i-pprFixedRuntimeRepContext (FRRTupleArg i)-  = text "The tuple argument in" <+> speakNth i <+> text "position"-pprFixedRuntimeRepContext (FRRTupleSection i)-  = text "The" <+> speakNth i <+> text "component of the tuple section"-pprFixedRuntimeRepContext FRRUnboxedSum+pprFixedRuntimeRepContext (FRRRepPolyUnliftedNewtype dc)+  = vcat [ text "Unsaturated use of a representation-polymorphic unlifted newtype."+         , text "The argument of the newtype constructor" <+> quotes (ppr dc) ]+pprFixedRuntimeRepContext (FRRUnboxedTuple i)+  = text "The" <+> speakNth i <+> text "component of the unboxed tuple"+pprFixedRuntimeRepContext (FRRUnboxedTupleSection i)+  = text "The" <+> speakNth i <+> text "component of the unboxed tuple section"+pprFixedRuntimeRepContext (FRRUnboxedSum Nothing)   = text "The unboxed sum"+pprFixedRuntimeRepContext (FRRUnboxedSum (Just i))+  = text "The" <+> speakNth i <+> text "component of the unboxed sum" pprFixedRuntimeRepContext (FRRBodyStmt stmtOrig i)   = vcat [ text "The" <+> speakNth i <+> text "argument to (>>)" <> comma          , text "arising from the" <+> ppr stmtOrig <> comma ]@@ -1198,23 +1265,6 @@   ppr MonadComprehension = text "monad comprehension"   ppr DoNotation         = quotes ( text "do" ) <+> text "statement" --- | A function with representation-polymorphic arguments,--- such as @coerce@ or @(#, #)@.------ Used for reporting partial applications of representation-polymorphic--- functions in error messages.-data RepPolyFun-  = RepPolyWiredIn !Id-    -- ^ A wired-in function with representation-polymorphic-    -- arguments, such as 'coerce'.-  | RepPolyDataCon !DataCon-    -- ^ A data constructor with representation-polymorphic arguments,-    -- such as an unboxed tuple or a newtype constructor with @-XUnliftedNewtypes@.--instance Outputable RepPolyFun where-  ppr (RepPolyWiredIn id) = ppr id-  ppr (RepPolyDataCon dc) = ppr dc- -- | The position of an argument (to be reported in an error message). data ArgPos   = ArgPosInvis@@ -1224,6 +1274,50 @@  {- ********************************************************************* *                                                                      *+            FixedRuntimeRep: representation-polymorphic Ids+*                                                                      *+********************************************************************* -}++data Polarity = Pos | Neg++type FlipPolarity :: Polarity -> Polarity+type family FlipPolarity p where+  FlipPolarity Pos = Neg+  FlipPolarity Neg = Pos++-- | A position in which a type variable appears in a type;+-- in particular, whether it appears in a positive or a negative position.+type Position :: Polarity -> Hs.Type+data Position p where+  -- | In the @i@-th argument of a function arrow+  Argument :: Int -> Position (FlipPolarity p) -> Position p+  -- | In the result of a function arrow+  Result   :: Position p -> Position p+  -- | At the top level of a type+  Top      :: Position Pos++pprFRRRepPolyId :: RepPolyId -> Name -> Position Neg -> SDoc+pprFRRRepPolyId id nm (Argument i pos) =+  text "The" <+> what <+> speakNth i <+> text "argument of" <+> pprRepPolyId id nm+  where+    what = case pos of+      Top       -> empty+      Result {} -> text "return type of the"+      _         -> text "nested return type inside the"+pprFRRRepPolyId id nm (Result {}) =+  text "The result of" <+> pprRepPolyId id nm++pprRepPolyId :: RepPolyId -> Name -> SDoc+pprRepPolyId id nm = id_desc <+> quotes (ppr nm)+  where+    id_desc = case id of+      RepPolyPrimOp   {} -> text "the primop"+      RepPolySum      {} -> text "the unboxed sum constructor"+      RepPolyTuple    {} -> text "the unboxed tuple constructor"+      RepPolyFunction {} -> empty++{- *********************************************************************+*                                                                      *                        FixedRuntimeRep: arrows *                                                                      * ********************************************************************* -}@@ -1293,7 +1387,7 @@ ********************************************************************* -}  -- | In what context are we calling 'matchExpectedFunTys'--- or 'matchActualFunTySigma'?+-- or 'matchActualFunTy'? -- -- Used for two things: --@@ -1314,9 +1408,9 @@   --   -- Test cases for representation-polymorphism checks:   --   RepPolyDoBind, RepPolyDoBody{1,2}, RepPolyMc{Bind,Body,Guard}, RepPolyNPlusK-  = ExpectedFunTySyntaxOp-    !CtOrigin-    !(HsExpr GhcRn)+  = forall (p :: Pass)+     . (OutputableBndrId p)+    => ExpectedFunTySyntaxOp !CtOrigin !(HsExpr (GhcPass p))       -- ^ rebindable syntax operator    -- | A view pattern must have a function type.@@ -1332,8 +1426,7 @@   -- Test cases for representation-polymorphism checks:   --   RepPolyApp   | forall (p :: Pass)-      . (OutputableBndrId p)-      => ExpectedFunTyArg+     . Outputable (HsExpr (GhcPass p)) => ExpectedFunTyArg           !TypedThing             -- ^ function           !(HsExpr (GhcPass p))@@ -1353,16 +1446,8 @@   -- | Ensure that a lambda abstraction has a function type.   --   -- Test cases for representation-polymorphism checks:-  --   RepPolyLambda-  | ExpectedFunTyLam-      !(MatchGroup GhcRn (LHsExpr GhcRn))--  -- | Ensure that a lambda case expression has a function type.-  ---  -- Test cases for representation-polymorphism checks:-  --   RepPolyMatch-  | ExpectedFunTyLamCase-      LamCaseVariant+  --   RepPolyLambda, RepPolyMatch+  | ExpectedFunTyLam HsLamVariant       !(HsExpr GhcRn)        -- ^ the entire lambda-case expression @@ -1390,8 +1475,7 @@       | otherwise       -> text "The" <+> speakNth i <+> text "pattern in the equation" <> plural alts      <+> text "for" <+> quotes (ppr fun)-    ExpectedFunTyLam {} -> binder_of $ text "lambda"-    ExpectedFunTyLamCase lc_variant _ -> binder_of $ lamCaseKeyword lc_variant+    ExpectedFunTyLam lam_variant _ -> binder_of $ lamCaseKeyword lam_variant   where     the_arg_of :: SDoc     the_arg_of = text "The" <+> speakNth i <+> text "argument of"@@ -1409,15 +1493,11 @@         , text "is applied to" ] pprExpectedFunTyHerald (ExpectedFunTyMatches fun (MG { mg_alts = L _ alts }))   = text "The equation" <> plural alts <+> text "for" <+> quotes (ppr fun) <+> hasOrHave alts-pprExpectedFunTyHerald (ExpectedFunTyLam match)-  = sep [ text "The lambda expression" <+>-                   quotes (pprSetDepth (PartWay 1) $-                           pprMatches match)-        -- The pprSetDepth makes the lambda abstraction print briefly+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" ]-pprExpectedFunTyHerald (ExpectedFunTyLamCase _ expr)-  = sep [ text "The function" <+> quotes (ppr expr)-        , text "requires" ]  {- ******************************************************************* *                                                                    *@@ -1447,7 +1527,10 @@    | TopLevInstance       -- Solved by a top-level instance decl       { iw_dfun_id   :: DFunId-      , iw_safe_over :: SafeOverlapping }+      , iw_safe_over :: SafeOverlapping+      , iw_warn      :: Maybe (WarningTxt GhcRn) }+            -- See Note [Implementation of deprecated instances]+            -- in GHC.Tc.Solver.Dict  instance Outputable InstanceWhat where   ppr BuiltinInstance   = text "a built-in instance"
compiler/GHC/Tc/Types/Origin.hs-boot view
@@ -1,14 +1,19 @@ module GHC.Tc.Types.Origin where -import GHC.Utils.Misc ( HasDebugCallStack )+import GHC.Prelude.Basic ( Int, Maybe )+import GHC.Stack ( HasCallStack )+import {-# SOURCE #-} GHC.Core.TyCo.Rep ( Type )  data SkolemInfoAnon data SkolemInfo data FixedRuntimeRepContext data FixedRuntimeRepOrigin+  = FixedRuntimeRepOrigin+    { frr_type    :: Type+    , frr_context :: FixedRuntimeRepContext+    } -data CtOrigin-data ClsInstOrQC = IsClsInst-                 | IsQC CtOrigin+mkFRRUnboxedTuple :: Int -> FixedRuntimeRepContext+mkFRRUnboxedSum :: Maybe Int -> FixedRuntimeRepContext -unkSkol :: HasDebugCallStack => SkolemInfo+unkSkol :: HasCallStack => SkolemInfo
compiler/GHC/Tc/Types/TH.hs view
@@ -17,7 +17,6 @@ import GHC.Tc.Types.Evidence import GHC.Utils.Outputable import GHC.Prelude-import GHC.Utils.Panic import GHC.Tc.Types.TcRef import GHC.Tc.Types.Constraint import GHC.Hs.Expr ( PendingTcSplice, PendingRnSplice )@@ -105,13 +104,19 @@ thLevel (Splice _)    = 0 thLevel Comp          = 1 thLevel (Brack s _)   = thLevel s + 1-thLevel (RunSplice _) = panic "thLevel: called when running a splice"+thLevel (RunSplice _) = 0 -- previously: panic "thLevel: called when running a splice"                         -- See Note [RunSplice ThLevel].  {- Note [RunSplice ThLevel] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ The 'RunSplice' stage is set when executing a splice, and only when running a splice. In particular it is not set when the splice is renamed or typechecked.++However, this is not true. `reifyInstances` for example does rename the given type,+and these types may contain variables (#9262 allow free variables in reifyInstances).+Therefore here we assume that thLevel (RunSplice _) = 0.+Proper fix would probably require renaming argument `reifyInstances` separately prior+to evaluation of the overall splice.  'RunSplice' is needed to provide a reference where 'addModFinalizer' can insert the finalizer (see Note [Delaying modFinalizers in untyped splices]), and
compiler/GHC/Tc/Utils/TcType.hs view
@@ -33,6 +33,9 @@   mkCheckExpType,   checkingExpType_maybe, checkingExpType, +  ExpPatType(..), mkCheckExpFunPatTy, mkInvisExpPatType,+  isVisibleExpPatType, isExpFunPatType,+   SyntaxOpType(..), synKnownType, mkSynFunTys,    --------------------------------@@ -49,6 +52,7 @@   tcIsTcTyVar, isTyVarTyVar, isOverlappableTyVar,  isTyConableTyVar,   ConcreteTvOrigin(..), isConcreteTyVar_maybe, isConcreteTyVar,   isConcreteTyVarTy, isConcreteTyVarTy_maybe, isConcreteInfo,+  ConcreteTyVars, noConcreteTyVars,   isAmbiguousTyVar, isCycleBreakerTyVar, metaTyVarRef, metaTyVarInfo,   isFlexi, isIndirect, isRuntimeUnkSkol,   metaTyVarTcLevel, setMetaTyVarTcLevel, metaTyVarTcLevel_maybe,@@ -73,7 +77,7 @@   tcSplitTyConApp, tcSplitTyConApp_maybe,   tcTyConAppTyCon, tcTyConAppTyCon_maybe, tcTyConAppArgs,   tcSplitAppTy_maybe, tcSplitAppTy, tcSplitAppTys, tcSplitAppTyNoView_maybe,-  tcSplitSigmaTy, tcSplitNestedSigmaTys, tcSplitIOType_maybe,+  tcSplitSigmaTy, tcSplitSigmaTyBndrs, tcSplitNestedSigmaTys, tcSplitIOType_maybe,    ---------------------------------   -- Predicates.@@ -163,7 +167,7 @@   extendSubstInScopeList, extendSubstInScopeSet, extendTvSubstAndInScope,   Type.lookupTyVar, Type.extendTCvSubst, Type.substTyVarBndr,   Type.extendTvSubst,-  isInScope, mkSubst, mkTvSubst, zipTyEnv, zipCoEnv,+  isInScope, mkTCvSubst, mkTvSubst, zipTyEnv, zipCoEnv,   Type.substTy, substTys, substScaledTys, substTyWith, substTyWithCoVars,   substTyAddInScope,   substTyUnchecked, substTysUnchecked, substScaledTyUnchecked,@@ -220,6 +224,7 @@ import GHC.Types.Name as Name             -- We use this to make dictionaries for type literals.             -- Perhaps there's a better way to do this?+import GHC.Types.Name.Env import GHC.Types.Name.Set import GHC.Builtin.Names import GHC.Builtin.Types ( coercibleClass, eqClass, heqClass, unitTyConKey@@ -230,13 +235,11 @@ import GHC.Data.List.SetOps ( getNth, findDupsEq ) import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Utils.Panic.Plain  import Data.IORef ( IORef ) import Data.List.NonEmpty( NonEmpty(..) ) import Data.List ( partition, nub, (\\) ) - {- ************************************************************************ *                                                                      *@@ -451,12 +454,35 @@ checkingExpType_maybe (Check ty) = Just ty checkingExpType_maybe (Infer {}) = Nothing --- | Returns the expected type when in checking mode. Panics if in inference--- mode.-checkingExpType :: String -> ExpType -> TcType-checkingExpType _   (Check ty) = ty-checkingExpType err et         = pprPanic "checkingExpType" (text err $$ ppr et)+-- | Returns the expected type when in checking mode.+--   Panics if in inference mode.+checkingExpType :: ExpType -> TcType+checkingExpType (Check ty)    = ty+checkingExpType et@(Infer {}) = pprPanic "checkingExpType" (ppr et) +-- Expected type of a pattern in a lambda or a function left-hand side.+data ExpPatType =+    ExpFunPatTy    (Scaled ExpSigmaTypeFRR)   -- the type A of a function A -> B+  | ExpForAllPatTy ForAllTyBinder             -- the binder (a::A) of  forall (a::A) -> B or forall (a :: A). B++mkCheckExpFunPatTy :: Scaled TcType -> ExpPatType+mkCheckExpFunPatTy (Scaled mult ty) = ExpFunPatTy (Scaled mult (mkCheckExpType ty))++mkInvisExpPatType :: InvisTyBinder -> ExpPatType+mkInvisExpPatType (Bndr tv spec) = ExpForAllPatTy (Bndr tv (Invisible spec))++isVisibleExpPatType :: ExpPatType -> Bool+isVisibleExpPatType (ExpForAllPatTy (Bndr _ vis)) = isVisibleForAllTyFlag vis+isVisibleExpPatType (ExpFunPatTy {})              = True++isExpFunPatType :: ExpPatType -> Bool+isExpFunPatType ExpFunPatTy{}    = True+isExpFunPatType ExpForAllPatTy{} = False++instance Outputable ExpPatType where+  ppr (ExpFunPatTy t) = ppr t+  ppr (ExpForAllPatTy tv) = text "forall" <+> ppr tv+ {- ********************************************************************* *                                                                      *           SyntaxOpType@@ -548,7 +574,7 @@ a bit awkward for the /producer/.  Why? Because sometimes we can't produce the SkolemInfo until we have the TcTyVars! -Example: in `GHC.Tc.Utils.Unify.tcTopSkolemise` we create SkolemTvs whose+Example: in `GHC.Tc.Utils.Unify.tcSkolemise` we create SkolemTvs whose `SkolemInfo` is `SigSkol`, whose arguments in turn mention the newly-created SkolemTvs.  So we a RecrusiveDo idiom, like this: @@ -580,7 +606,7 @@            , mtv_ref   :: IORef MetaDetails            , mtv_tclvl :: TcLevel }  -- See Note [TcLevel invariants] -vanillaSkolemTvUnk :: HasDebugCallStack => TcTyVarDetails+vanillaSkolemTvUnk :: HasCallStack => TcTyVarDetails vanillaSkolemTvUnk = SkolemTv unkSkol topTcLevel False  instance Outputable TcTyVarDetails where@@ -644,6 +670,16 @@    -- See 'FixedRuntimeRepOrigin' for more information.   = ConcreteFRR FixedRuntimeRepOrigin +-- | A mapping from skolem type variable 'Name' to concreteness information,+--+-- See Note [Representation-polymorphism checking built-ins] in GHC.Tc.Gen.Head.+type ConcreteTyVars = NameEnv ConcreteTvOrigin++-- | The 'Id' has no outer forall'd type variables which must be instantiated+-- to concrete types.+noConcreteTyVars :: ConcreteTyVars+noConcreteTyVars = emptyNameEnv+ {- ********************************************************************* *                                                                      *                 Untouchable type variables@@ -1414,6 +1450,11 @@                         (tvs, rho) -> case tcSplitPhiTy rho of                                         (theta, tau) -> (tvs, theta, tau) +tcSplitSigmaTyBndrs :: Type -> ([TcInvisTVBinder], ThetaType, Type)+tcSplitSigmaTyBndrs ty = case tcSplitForAllInvisTVBinders ty of+                        (tvs, rho) -> case tcSplitPhiTy rho of+                                        (theta, tau) -> (tvs, theta, tau)+ -- | Split a sigma type into its parts, going underneath as many arrows -- and foralls as possible. See Note [tcSplitNestedSigmaTys] tcSplitNestedSigmaTys :: Type -> ([TyVar], ThetaType, Type)@@ -1841,18 +1882,22 @@ -}  isSigmaTy :: TcType -> Bool--- isSigmaTy returns true of any qualified type.  It doesn't--- *necessarily* have any foralls.  E.g---        f :: (?x::Int) => Int -> Int-isSigmaTy ty | Just ty' <- coreView ty = isSigmaTy ty'-isSigmaTy (ForAllTy {})                = True+-- isSigmaTy returns true of any type with /invisible/ quantifiers at the top:+--     forall a. blah+--     Eq a => blah+--     ?x::Int => blah+-- But not+--     forall a -> blah+isSigmaTy (ForAllTy (Bndr _ af) _)     = isInvisibleForAllTyFlag af isSigmaTy (FunTy { ft_af = af })       = isInvisibleFunArg af+isSigmaTy ty | Just ty' <- coreView ty = isSigmaTy ty' isSigmaTy _                            = False + isRhoTy :: TcType -> Bool   -- True of TcRhoTypes; see Note [TcRhoType]-isRhoTy ty | Just ty' <- coreView ty = isRhoTy ty'-isRhoTy (ForAllTy {})                = False+isRhoTy (ForAllTy (Bndr _ af) _)     = isVisibleForAllTyFlag af isRhoTy (FunTy { ft_af = af })       = isVisibleFunArg af+isRhoTy ty | Just ty' <- coreView ty = isRhoTy ty' isRhoTy _                            = True  -- | Like 'isRhoTy', but also says 'True' for 'Infer' types@@ -1862,7 +1907,7 @@  isOverloadedTy :: Type -> Bool -- Yes for a type of a function that might require evidence-passing--- Used only by bindLocalMethods+-- Used by bindLocalMethods and for -fprof-late-overloaded isOverloadedTy ty | Just ty' <- coreView ty = isOverloadedTy ty' isOverloadedTy (ForAllTy _  ty)             = isOverloadedTy ty isOverloadedTy (FunTy { ft_af = af })       = isInvisibleFunArg af@@ -1990,8 +2035,8 @@ -}  tcSplitIOType_maybe :: Type -> Maybe (TyCon, Type)--- (tcSplitIOType_maybe t) returns Just (IO,t',co)---              if co : t ~ IO t'+-- (tcSplitIOType_maybe t) returns Just (IO,t')+--              if t = IO t' --              returns Nothing otherwise tcSplitIOType_maybe ty   = case tcSplitTyConApp_maybe ty of
compiler/GHC/Tc/Utils/TcType.hs-boot view
@@ -2,14 +2,21 @@ import GHC.Utils.Outputable( SDoc ) import GHC.Prelude ( Bool ) import {-# SOURCE #-} GHC.Types.Var ( TcTyVar )-import GHC.Utils.Misc( HasDebugCallStack )+import {-# SOURCE #-} GHC.Tc.Types.Origin ( FixedRuntimeRepOrigin )+import GHC.Types.Name.Env ( NameEnv )+import GHC.Stack  data MetaDetails  data TcTyVarDetails pprTcTyVarDetails :: TcTyVarDetails -> SDoc-vanillaSkolemTvUnk :: HasDebugCallStack => TcTyVarDetails+vanillaSkolemTvUnk :: HasCallStack => TcTyVarDetails isMetaTyVar :: TcTyVar -> Bool isTyConableTyVar :: TcTyVar -> Bool-isConcreteTyVar :: TcTyVar -> Bool +type ConcreteTyVars = NameEnv ConcreteTvOrigin+data ConcreteTvOrigin+  = ConcreteFRR FixedRuntimeRepOrigin++isConcreteTyVar :: TcTyVar -> Bool+noConcreteTyVars :: ConcreteTyVars
compiler/GHC/Types/Basic.hs view
@@ -28,7 +28,8 @@          ConTag, ConTagZ, fIRST_TAG, -        Arity, RepArity, JoinArity, FullArgCount,+        Arity, VisArity, RepArity, JoinArity, FullArgCount,+        JoinPointHood(..), isJoinPoint,          Alignment, mkAlignment, alignmentOf, alignmentBytes, @@ -37,6 +38,8 @@          RecFlag(..), isRec, isNonRec, boolToRecFlag,         Origin(..), isGenerated, DoPmc(..), requiresPMC,+        GenReason(..), isDoExpansionGenerated, doExpansionFlavour,+        doExpansionOrigin,          RuleName, pprRuleName, @@ -130,6 +133,7 @@ import qualified GHC.LanguageExtensions as LangExt import {-# SOURCE #-} Language.Haskell.Syntax.Type (PromotionFlag(..), isPromoted) import Language.Haskell.Syntax.Basic (Boxity(..), isBoxed, ConTag)+import {-# SOURCE #-} Language.Haskell.Syntax.Expr (HsDoFlavour)  import Control.DeepSeq ( NFData(..) ) import Data.Data@@ -179,6 +183,10 @@ -- See also Note [Definition of arity] in "GHC.Core.Opt.Arity" type Arity = Int +-- | Syntactic (visibility) arity, i.e. the number of visible arguments.+-- See Note [Visibility and arity]+type VisArity = Int+ -- | Representation Arity -- -- The number of represented arguments that can be applied to a value before it does@@ -199,6 +207,71 @@ -- both type and value arguments! type FullArgCount = Int +{- Note [Visibility and arity]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Arity is the number of arguments that a function expects. In a curried language+like Haskell, there is more than one way to count those arguments.++* `Arity` is the classic notion of arity, concerned with evalution, so it counts+  the number of /value/ arguments that need to be supplied before evaluation can+  take place, as described in notes+    Note [Definition of arity]      in GHC.Core.Opt.Arity+    Note [Arity and function types] in GHC.Types.Id.Info++  Examples:+    Int                       has arity == 0+    Int -> Int                has arity <= 1+    Int -> Bool -> Int        has arity <= 2+  We write (<=) rather than (==) as sometimes evaluation can occur before all+  value arguments are supplied, depending on the actual function definition.++  This evaluation-focused notion of arity ignores type arguments, so:+    forall a.   a             has arity == 0+    forall a.   a -> a        has arity <= 1+    forall a b. a -> b -> a   has arity <= 2+  This is true regardless of ForAllTyFlag, so the arity is also unaffected by+  (forall {a}. ty) or (forall a -> ty).++  Class dictionaries count towards the arity, as they are passed at runtime+    forall a.   (Num a)        => a            has arity <= 1+    forall a.   (Num a)        => a -> a       has arity <= 2+    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/+  arguments, i.e. arguments that occur visibly in the source code.++  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 (==)+  as this could be a partial application.++  At definition sites, we can acquire an underapproximation of vis-arity by+  counting the patterns on the LHS, e.g. `f a b = rhs` has vis-arity >= 2.+  The actual vis-arity can be higher if there is a lambda on the RHS,+  e.g. `f a b = \c -> rhs`.++  If we look at the types, we can observe the following+    * function arrows   (a -> b)        add to the vis-arity+    * visible foralls   (forall a -> b) add to the vis-arity+    * constraint arrows (a => b)        do not affect the vis-arity+    * invisible foralls (forall a. b)   do not affect the vis-arity++  This means that ForAllTyFlag matters for VisArity (in contrast to Arity),+  while the type/value distinction is unimportant (again in contrast to Arity).++  Examples:+    Int                         -- vis-arity == 0   (no args)+    Int -> Int                  -- vis-arity == 1   (1 funarg)+    forall a. a -> a            -- vis-arity == 1   (1 funarg)+    forall a. Num a => a -> a   -- vis-arity == 1   (1 funarg)+    forall a -> Num a => a      -- vis-arity == 1   (1 req tyarg, 0 funargs)+    forall a -> a -> a          -- vis-arity == 2   (1 req tyarg, 1 funarg)+    Int -> forall a -> Int      -- vis-arity == 2   (1 funarg, 1 req tyarg)++  Wrinkle: with TypeApplications and TypeAbstractions, it is possible to visibly+  bind and pass invisible arguments, e.g. `f @a x = ...` or `f @Int 42`. Those+  @-prefixed arguments are ignored for the purposes of vis-arity.+-}+ {- ************************************************************************ *                                                                      *@@ -587,16 +660,43 @@ -- -- See Note [Generated code and pattern-match checking]. data Origin = FromSource-            | Generated DoPmc+            | Generated GenReason DoPmc             deriving( Eq, Data )  isGenerated :: Origin -> Bool-isGenerated Generated {} = True+isGenerated Generated{}  = True isGenerated FromSource   = False +-- | This metadata stores the information as to why was the piece of code generated+--   It is useful for generating the right error context+-- See Part 3 in Note [Expanding HsDo with XXExprGhcRn] in `GHC.Tc.Gen.Do`+data GenReason = DoExpansion HsDoFlavour+               | OtherExpansion+               deriving (Eq, Data)++instance Outputable GenReason where+  ppr DoExpansion{}  = text "DoExpansion"+  ppr OtherExpansion = text "OtherExpansion"++doExpansionFlavour :: Origin -> Maybe HsDoFlavour+doExpansionFlavour (Generated (DoExpansion f) _) = Just f+doExpansionFlavour _ = Nothing++-- See Part 3 in Note [Expanding HsDo with XXExprGhcRn] in `GHC.Tc.Gen.Do`+isDoExpansionGenerated :: Origin -> Bool+isDoExpansionGenerated = isJust . doExpansionFlavour++-- See Part 3 in Note [Expanding HsDo with XXExprGhcRn] in `GHC.Tc.Gen.Do`+doExpansionOrigin :: HsDoFlavour -> Origin+doExpansionOrigin f = Generated (DoExpansion f) DoPmc+                    -- It is important that we perfrom PMC+                    -- on the expressions generated by do statements+                    -- to get the right pattern match checker warnings+                    -- See `GHC.HsToCore.Pmc.pmcMatches`+ instance Outputable Origin where-  ppr FromSource      = text "FromSource"-  ppr (Generated pmc) = text "Generated" <+> ppr pmc+  ppr FromSource             = text "FromSource"+  ppr (Generated reason pmc) = text "Generated" <+> ppr reason <+> ppr pmc  -- | Whether to run pattern-match checks in generated code. --@@ -614,14 +714,14 @@ -- -- See Note [Generated code and pattern-match checking]. requiresPMC :: Origin -> Bool-requiresPMC (Generated SkipPmc) = False+requiresPMC (Generated _ SkipPmc) = False requiresPMC _ = True  {- Note [Generated code and pattern-match checking] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Some parts of the compiler generate code that is then typechecked. For example: -  - the HsExpansion mechanism described in Note [Rebindable syntax and HsExpansion]+  - the XXExprGhcRn mechanism described in Note [Rebindable syntax and XXExprGhcRn]     in GHC.Hs.Expr,   - the deriving mechanism. @@ -1029,14 +1129,23 @@ *                                                                      * ************************************************************************ -This data type is used exclusively by the simplifier, but it appears in a+Note [OccInfo]+~~~~~~~~~~~~~+The OccInfo data type is used exclusively by the simplifier, but it appears in a SubstResult, which is currently defined in GHC.Types.Var.Env, which is pretty near the base of the module hierarchy.  So it seemed simpler to put the defn of-OccInfo here, safely at the bottom+OccInfo here, safely at the bottom.++Note that `OneOcc` doesn't meant that it occurs /syntactially/ only once; it+means that it is /used/ only once. It might occur syntactically many times.+For example, in (case x of A -> y; B -> y; C -> True),+* `y` is used only once+* but it occurs syntactically twice+ -}  -- | identifier Occurrence Information-data OccInfo+data OccInfo -- See Note [OccInfo]   = ManyOccs        { occ_tail    :: !TailCallInfo }                         -- ^ There are many occurrences, or unknown occurrences @@ -1134,8 +1243,9 @@   mappend = (Semi.<>)  ------------------data TailCallInfo = AlwaysTailCalled JoinArity -- See Note [TailCallInfo]-                  | NoTailCallInfo+data TailCallInfo+  = AlwaysTailCalled {-# UNPACK #-} !JoinArity -- See Note [TailCallInfo]+  | NoTailCallInfo   deriving (Eq)  tailCallInfo :: OccInfo -> TailCallInfo@@ -1216,7 +1326,7 @@ function is always tail-called. See Note [Invariants on join points].  This info is quite fragile and should not be relied upon unless the occurrence-analyser has *just* run. Use 'Id.isJoinId_maybe' for the permanent state of+analyser has *just* run. Use 'Id.idJoinPointHood' for the permanent state of the join-point-hood of a binder; a join id itself will not be marked AlwaysTailCalled. @@ -2200,7 +2310,7 @@ GHC.Iface.Type.defaultIfaceTyVarsOfKind    This is a built-in defaulting mechanism that only applies when pretty-printing.-  It defaults 'RuntimeRep'/'Levity' variables unless -fprint-explicit-kinds is enabled,+  It defaults 'RuntimeRep'/'Levity' variables unless -fprint-explicit-runtime-reps is enabled,   and 'Multiplicity' variables unless -XLinearTypes is enabled.  -}
compiler/GHC/Types/CompleteMatch.hs view
@@ -35,6 +35,11 @@     ty_matches sig_tc       | Just (tc, _arg_tys) <- splitTyConApp_maybe ty       , tc == sig_tc+      || sig_tc `is_family_ty_con_of` tc+         -- #24326: sig_tc might be the data Family TyCon of the representation+         --         TyCon tc -- this CompleteMatch still applies       = True       | otherwise       = False+    fam_tc `is_family_ty_con_of` repr_tc =+      (fst <$> tyConFamInst_maybe repr_tc) == Just fam_tc
compiler/GHC/Types/Demand.hs view
@@ -22,13 +22,15 @@     absDmd, topDmd, botDmd, seqDmd, topSubDmd,     -- *** Least upper bound     lubCard, lubDmd, lubSubDmd,+    -- *** Greatest lower bound+    glbCard,     -- *** Plus     plusCard, plusDmd, plusSubDmd,     -- *** Multiply     multCard, multDmd, multSubDmd,     -- ** Predicates on @Card@inalities and @Demand@s-    isAbs, isUsedOnce, isStrict,-    isAbsDmd, isUsedOnceDmd, isStrUsedDmd, isStrictDmd,+    isAbs, isAtMostOnce, isStrict,+    isAbsDmd, isAtMostOnceDmd, isStrUsedDmd, isStrictDmd,     isTopDmd, isWeakDmd, onlyBoxedArguments,     -- ** Special demands     evalDmd,@@ -39,7 +41,7 @@     peelCallDmd, peelManyCalls, mkCalledOnceDmd, mkCalledOnceDmds,     mkWorkerDemand, subDemandIfEvaluated,     -- ** Extracting one-shot information-    argOneShots, argsOneShots, saturatedByOneShots,+    callCards, argOneShots, argsOneShots, saturatedByOneShots,     -- ** Manipulating Boxity of a Demand     unboxDeeplyDmd, @@ -96,7 +98,6 @@ import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Utils.Panic.Plain  import Data.Coerce (coerce) import Data.Function@@ -541,9 +542,9 @@ isAbs (Card c) = c .&. 0b110 == 0 -- simply check 1 and n bit are not set  -- | True <=> upper bound is 1.-isUsedOnce :: Card -> Bool+isAtMostOnce :: Card -> Bool -- See Note [Bit vector representation for Card]-isUsedOnce (Card c) = c .&. 0b100 == 0 -- simply check n bit is not set+isAtMostOnce (Card c) = c .&. 0b100 == 0 -- simply check n bit is not set  -- | Is this a 'CardNonAbs'? isCardNonAbs :: Card -> Bool@@ -551,7 +552,7 @@  -- | Is this a 'CardNonOnce'? isCardNonOnce :: Card -> Bool-isCardNonOnce n = isAbs n || not (isUsedOnce n)+isCardNonOnce n = isAbs n || not (isAtMostOnce n)  -- | Intersect with [0,1]. oneifyCard :: Card -> Card@@ -928,8 +929,8 @@ isStrUsedDmd (n :* _) = isStrict n && not (isAbs n)  -- | Is the value used at most once?-isUsedOnceDmd :: Demand -> Bool-isUsedOnceDmd (n :* _) = isUsedOnce n+isAtMostOnceDmd :: Demand -> Bool+isAtMostOnceDmd (n :* _) = isAtMostOnce n  -- | We try to avoid tracking weak free variable demands in strictness -- signatures for analysis performance reasons.@@ -1069,13 +1070,17 @@ argOneShots AbsDmd    = [] -- This defn conflicts with 'saturatedByOneShots', argOneShots BotDmd    = [] -- according to which we should return                            -- @repeat OneShotLam@ here...-argOneShots (_ :* sd) = go sd+argOneShots (_ :* sd) = map go (callCards sd)   where-    go (Call n sd)-      | isUsedOnce n = OneShotLam    : go sd-      | otherwise    = NoOneShotInfo : go sd-    go _    = []+    go n | isAtMostOnce n = OneShotLam+         | otherwise      = NoOneShotInfo +-- | See Note [Computing one-shot info]+callCards :: SubDemand -> [Card]+callCards (Call n sd) = n : callCards sd+callCards (Poly _ _n) = [] -- n is never C_01 or C_11 so we may as well stop here+callCards Prod{}      = []+ -- | -- @saturatedByOneShots n C(M,C(M,...)) = True@ --   <=>@@ -1084,7 +1089,7 @@ saturatedByOneShots :: Int -> Demand -> Bool saturatedByOneShots _ AbsDmd    = True saturatedByOneShots _ BotDmd    = True-saturatedByOneShots n (_ :* sd) = isUsedOnce $ fst $ peelManyCalls n sd+saturatedByOneShots n (_ :* sd) = isAtMostOnce $ fst $ peelManyCalls n sd  {- Note [Strict demands] ~~~~~~~~~~~~~~~~~~~~~~~~@@ -1427,7 +1432,7 @@ -- -- [n] nontermination (e.g. loops) -- [i] throws imprecise exception--- [p] throws precise exceTtion+-- [p] throws precise exception -- [c] converges (reduces to WHNF). -- -- The different lattice elements correspond to different subsets, indicated by@@ -1735,7 +1740,7 @@ -- Subject to Note [Default demand on free variables and arguments] -- | Captures the result of an evaluation of an expression, by -----   * Listing how the free variables of that expression have been evaluted+--   * Listing how the free variables of that expression have been evaluated --     ('de_fvs') --   * Saying whether or not evaluation would surely diverge ('de_div') --
compiler/GHC/Types/Error.hs view
@@ -21,6 +21,7 @@    , addMessage    , unionMessages    , unionManyMessages+   , filterMessages    , MsgEnvelope (..)     -- * Classifying Messages@@ -102,20 +103,19 @@ import GHC.Utils.Json import GHC.Utils.Panic import GHC.Unit.Module.Warnings (WarningCategory)- import Data.Bifunctor-import Data.Foldable    ( fold )+import Data.Foldable    ( fold, toList ) import Data.List.NonEmpty ( NonEmpty (..) ) import qualified Data.List.NonEmpty as NE import Data.List ( intercalate ) import Data.Typeable ( Typeable ) import Numeric.Natural ( Natural ) import Text.Printf ( printf )--{--Note [Messages]-~~~~~~~~~~~~~~~+import GHC.Version (cProjectVersion)+import GHC.Types.Hint.Ppr () -- Outputtable instance +{- Note [Messages]+~~~~~~~~~~~~~~~~~~ We represent the 'Messages' as a single bag of warnings and errors.  The reason behind that is that there is a fluid relationship between errors@@ -167,6 +167,9 @@                pprDiagnostic (errMsgDiagnostic envelope)              ] +instance Diagnostic e => ToJson (Messages e) where+  json msgs =  JSArray . toList $ json <$> getMessages msgs+ {- Note [Discarding Messages] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -194,6 +197,10 @@ unionManyMessages :: Foldable f => f (Messages e) -> Messages e unionManyMessages = fold +filterMessages :: (MsgEnvelope e -> Bool) -> Messages e -> Messages e+filterMessages f (Messages msgs) =+  Messages (filterBag f msgs)+ -- | A 'DecoratedSDoc' is isomorphic to a '[SDoc]' but it carries the -- invariant that the input '[SDoc]' needs to be rendered /decorated/ into its -- final form, where the typical case would be adding bullets between each@@ -318,7 +325,7 @@  -- | A generic 'Diagnostic' message, without any further classification or -- provenance: By looking at a 'DiagnosticMessage' we don't know neither--- /where/ it was generated nor how to intepret its payload (as it's just a+-- /where/ it was generated nor how to interpret its payload (as it's just a -- structured document). All we can do is to print it out and look at its -- 'DiagnosticReason'. data DiagnosticMessage = DiagnosticMessage@@ -537,7 +544,9 @@     SevError   -> text "SevError"  instance ToJson Severity where-  json s = JSString (show s)+  json SevIgnore = JSString "Ignore"+  json SevWarning = JSString "Warning"+  json SevError = JSString "Error"  instance ToJson MessageClass where   json MCOutput = JSString "MCOutput"@@ -548,6 +557,45 @@   json (MCDiagnostic sev reason code) =     JSString $ renderWithContext defaultSDocContext (ppr $ text "MCDiagnostic" <+> ppr sev <+> ppr reason <+> ppr code) +instance ToJson DiagnosticCode where+  json c = JSInt (fromIntegral (diagnosticCodeNumber c))++{- Note [Diagnostic Message JSON Schema]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The below instance of ToJson must conform to the JSON schema+specified in docs/users_guide/diagnostics-as-json-schema-1_0.json.+When the schema is altered, please bump the version.+If the content is altered in a backwards compatible way,+update the minor version (e.g. 1.3 ~> 1.4).+If the content is breaking, update the major version (e.g. 1.3 ~> 2.3).+When updating the schema, replace the above file and name it appropriately with+the version appended, and change the documentation of the -fdiagnostics-as-json+flag to reflect the new schema.+To learn more about JSON schemas, check out the below link:+https://json-schema.org+-}++schemaVersion :: String+schemaVersion = "1.0"+-- See Note [Diagnostic Message JSON Schema] before editing!+instance Diagnostic e => ToJson (MsgEnvelope e) where+  json m = JSObject [+    ("version", JSString schemaVersion),+    ("ghcVersion", JSString $ "ghc-" ++ cProjectVersion),+    ("span", json $ errMsgSpan m),+    ("severity", json $ errMsgSeverity m),+    ("code", maybe JSNull json (diagnosticCode diag)),+    ("message", JSArray $ map renderToJSString diagMsg),+    ("hints", JSArray $ map (renderToJSString . ppr) (diagnosticHints diag) )+    ]+    where diag = errMsgDiagnostic m+          opts = defaultDiagnosticOpts @e+          style = mkErrStyle (errMsgContext m)+          ctx = defaultSDocContext {sdocStyle = style }+          diagMsg = filter (not . isEmpty ctx) (unDecorated (diagnosticMessage (opts) diag))+          renderToJSString :: SDoc -> JsonDoc+          renderToJSString = JSString . (renderWithContext ctx)+ instance Show (MsgEnvelope DiagnosticMessage) where     show = showMsgEnvelope @@ -600,9 +648,18 @@                   -> brackets msg               _   -> empty +          ppr_with_hyperlink code =+            -- this is a bit hacky, but we assume that if the terminal supports colors+            -- then it should also support links+            sdocOption (\ ctx -> sdocPrintErrIndexLinks ctx) $+              \ use_hyperlinks ->+                 if use_hyperlinks+                 then ppr $ LinkedDiagCode code+                 else ppr code+           code_doc =             case msg_class of-              MCDiagnostic _ _ (Just code) -> brackets (coloured msg_colour $ ppr code)+              MCDiagnostic _ _ (Just code) -> brackets (ppr_with_hyperlink code)               _                            -> empty            flag_msg :: Severity -> DiagnosticReason -> Maybe SDoc@@ -804,8 +861,29 @@     , diagnosticCodeNumber    :: Natural         -- ^ the actual diagnostic code     }+  deriving ( Eq, Ord ) -instance Outputable DiagnosticCode where-  ppr (DiagnosticCode prefix c) =-    text prefix <> text "-" <> text (printf "%05d" c)+instance Show DiagnosticCode where+  show (DiagnosticCode prefix c) =+    prefix ++ "-" ++ printf "%05d" c       -- pad the numeric code to have at least 5 digits++instance Outputable DiagnosticCode where+  ppr code = text (show code)++-- | A newtype that is a witness to the `-fprint-error-index-links` flag. It+-- alters the @Outputable@ instance to emit @DiagnosticCode@ as ANSI hyperlinks+-- to the HF error index+newtype LinkedDiagCode = LinkedDiagCode DiagnosticCode++instance Outputable LinkedDiagCode where+  ppr (LinkedDiagCode d@DiagnosticCode{}) = linkEscapeCode d++-- | Wrap the link in terminal escape codes specified by OSC 8.+linkEscapeCode :: DiagnosticCode -> SDoc+linkEscapeCode d = text "\ESC]8;;" <> hfErrorLink d -- make the actual link+                   <> text "\ESC\\" <> ppr d <> text "\ESC]8;;\ESC\\" -- the rest is the visible text++-- | create a link to the HF error index given an error code.+hfErrorLink :: DiagnosticCode -> SDoc+hfErrorLink errorCode = text "https://errors.haskell.org/messages/" <> ppr errorCode
compiler/GHC/Types/Error/Codes.hs view
@@ -16,7 +16,7 @@ -- A diagnostic code is a numeric unique identifier for a diagnostic. -- See Note [Diagnostic codes]. module GHC.Types.Error.Codes-  ( constructorCode )+  ( GhcDiagnosticCode, constructorCode, constructorCodes )   where  import GHC.Prelude@@ -36,10 +36,14 @@ import Data.Kind    ( Type, Constraint ) import GHC.Exts     ( proxy# ) import GHC.Generics-import GHC.TypeLits ( Symbol, TypeError, ErrorMessage(..) )+import GHC.TypeLits ( Symbol, KnownSymbol, symbolVal'+                    , TypeError, ErrorMessage(..) ) import GHC.TypeNats ( Nat, KnownNat, natVal' ) +import Data.Map.Strict ( Map )+import qualified Data.Map.Strict as Map + {- Note [Diagnostic codes] ~~~~~~~~~~~~~~~~~~~~~~~~~~ Every time a new diagnostic (error or warning) is introduced to GHC,@@ -67,7 +71,7 @@          GhcDiagnosticCode "MyNewErrorConstructor" = 12345         You can obtain new randomly-generated error codes by using-       https://www.random.org/integers/?num=10&min=1&max=99999&col=1&base=10&format=plain.+       https://www.random.org/integers/?num=10&min=1&max=99999&col=1&base=10&format=plain         You will get a type error if you try to use an error code that is already        used by another constructor.@@ -110,6 +114,18 @@                 => diag -> Maybe DiagnosticCode constructorCode diag = gdiagnosticCode (from diag) +-- | This function computes all diagnostic codes that occur inside a given+-- type using generics and the 'GhcDiagnosticCode' type family.+--+-- For example, if @T = MkT1 | MkT2@, @GhcDiagnosticCode \"MkT1\" = 123@ and+-- @GhcDiagnosticCode \"MkT2\" = 456@, then we will get+-- > constructorCodes @T = fromList [ (123, \"MkT1\"), (456, \"MkT2\") ]+constructorCodes :: forall diag. (Generic diag, GDiagnosticCodes '[diag] (Rep diag))+                 => Map DiagnosticCode String+constructorCodes = gdiagnosticCodes @'[diag] @(Rep diag)+  -- See Note [diagnosticCodes: don't recur into already-seen types]+  -- for the @'[diag] type argument.+ -- | Type family computing the numeric diagnostic code for a given error message constructor. -- -- Its injectivity annotation ensures uniqueness of error codes.@@ -148,6 +164,7 @@   GhcDiagnosticCode "DsRecBindsNotAllowedForUnliftedTys"            = 20185   GhcDiagnosticCode "DsRuleMightInlineFirst"                        = 95396   GhcDiagnosticCode "DsAnotherRuleMightFireFirst"                   = 87502+  GhcDiagnosticCode "DsIncompleteRecordSelector"                    = 17335     -- Parser diagnostic codes@@ -222,7 +239,7 @@   GhcDiagnosticCode "PsErrIllegalUnboxedFloatingLitInPat"           = 76595   GhcDiagnosticCode "PsErrDoNotationInPat"                          = 06446   GhcDiagnosticCode "PsErrIfThenElseInPat"                          = 45696-  GhcDiagnosticCode "PsErrLambdaCaseInPat"                          = 07636+  GhcDiagnosticCode "PsErrLambdaCaseInPat"                          = Outdated 07636   GhcDiagnosticCode "PsErrCaseInPat"                                = 53786   GhcDiagnosticCode "PsErrLetInPat"                                 = 78892   GhcDiagnosticCode "PsErrLambdaInPat"                              = 00482@@ -232,7 +249,7 @@   GhcDiagnosticCode "PsErrViewPatInExpr"                            = 66228   GhcDiagnosticCode "PsErrLambdaCmdInFunAppCmd"                     = 12178   GhcDiagnosticCode "PsErrCaseCmdInFunAppCmd"                       = 92971-  GhcDiagnosticCode "PsErrLambdaCaseCmdInFunAppCmd"                 = 47171+  GhcDiagnosticCode "PsErrLambdaCaseCmdInFunAppCmd"                 = Outdated 47171   GhcDiagnosticCode "PsErrIfCmdInFunAppCmd"                         = 97005   GhcDiagnosticCode "PsErrLetCmdInFunAppCmd"                        = 70526   GhcDiagnosticCode "PsErrDoCmdInFunAppCmd"                         = 77808@@ -240,7 +257,7 @@   GhcDiagnosticCode "PsErrMDoInFunAppExpr"                          = 67630   GhcDiagnosticCode "PsErrLambdaInFunAppExpr"                       = 06074   GhcDiagnosticCode "PsErrCaseInFunAppExpr"                         = 25037-  GhcDiagnosticCode "PsErrLambdaCaseInFunAppExpr"                   = 77182+  GhcDiagnosticCode "PsErrLambdaCaseInFunAppExpr"                   = Outdated 77182   GhcDiagnosticCode "PsErrLetInFunAppExpr"                          = 90355   GhcDiagnosticCode "PsErrIfInFunAppExpr"                           = 01239   GhcDiagnosticCode "PsErrProcInFunAppExpr"                         = 04807@@ -269,6 +286,7 @@   GhcDiagnosticCode "PsErrInvalidCApiImport"                        = 72744   GhcDiagnosticCode "PsErrMultipleConForNewtype"                    = 05380   GhcDiagnosticCode "PsErrUnicodeCharLooksLike"                     = 31623+  GhcDiagnosticCode "PsErrInvalidPun"                               = 52943    -- Driver diagnostic codes   GhcDiagnosticCode "DriverMissingHomeModules"                      = 32850@@ -352,6 +370,8 @@   GhcDiagnosticCode "TcRnIllegalFieldPunning"                       = 44287   GhcDiagnosticCode "TcRnIllegalWildcardsInRecord"                  = 37132   GhcDiagnosticCode "TcRnIllegalWildcardInType"                     = 65507+  GhcDiagnosticCode "TcRnIllegalNamedWildcardInTypeArgument"        = 93411+  GhcDiagnosticCode "TcRnIllegalImplicitTyVarInTypeArgument"        = 80557   GhcDiagnosticCode "TcRnDuplicateFieldName"                        = 85524   GhcDiagnosticCode "TcRnIllegalViewPattern"                        = 22406   GhcDiagnosticCode "TcRnCharLiteralOutOfRange"                     = 17268@@ -419,7 +439,6 @@   GhcDiagnosticCode "TcRnPartialTypeSignatures"                     = 60661   GhcDiagnosticCode "TcRnLazyGADTPattern"                           = 87005   GhcDiagnosticCode "TcRnArrowProcGADTPattern"                      = 64525-  GhcDiagnosticCode "TcRnForallIdentifier"                          = 64088   GhcDiagnosticCode "TcRnTypeEqualityOutOfScope"                    = 12003   GhcDiagnosticCode "TcRnTypeEqualityRequiresOperators"             = 58520   GhcDiagnosticCode "TcRnIllegalTypeOperator"                       = 62547@@ -472,8 +491,6 @@   GhcDiagnosticCode "TcRnDifferentExportWarnings"                   = 92878   GhcDiagnosticCode "TcRnIncompleteExportWarnings"                  = 94721   GhcDiagnosticCode "TcRnIllegalTypeOperatorDecl"                   = 50649-  GhcDiagnosticCode "TcRnBindVarAlreadyInScope"                     = 69710-  GhcDiagnosticCode "TcRnBindMultipleVariables"                     = 92957   GhcDiagnosticCode "TcRnIllegalKind"                               = 64861   GhcDiagnosticCode "TcRnUnexpectedPatSigType"                      = 74097   GhcDiagnosticCode "TcRnIllegalKindSignature"                      = 91382@@ -481,7 +498,6 @@    GhcDiagnosticCode "TcRnIllegalHsigDefaultMethods"                 = 93006   GhcDiagnosticCode "TcRnHsigFixityMismatch"                        = 93007-  GhcDiagnosticCode "TcRnHsigNoIface"                               = 93010   GhcDiagnosticCode "TcRnHsigMissingModuleExport"                   = 93011   GhcDiagnosticCode "TcRnBadGenericMethod"                          = 59794   GhcDiagnosticCode "TcRnWarningMinimalDefIncomplete"               = 13511@@ -490,7 +506,6 @@   GhcDiagnosticCode "TcRnBadMethodErr"                              = 46284   GhcDiagnosticCode "TcRnIllegalTypeData"                           = 15013   GhcDiagnosticCode "TcRnTypeDataForbids"                           = 67297-  GhcDiagnosticCode "TcRnInterfaceLookupError"                      = 52243   GhcDiagnosticCode "TcRnUnsatisfiedMinimalDef"                     = 06201   GhcDiagnosticCode "TcRnMisplacedInstSig"                          = 06202   GhcDiagnosticCode "TcRnCapturedTermName"                          = 54201@@ -505,7 +520,7 @@   GhcDiagnosticCode "TcRnMisplacedSigDecl"                          = 87866   GhcDiagnosticCode "TcRnUnexpectedDefaultSig"                      = 40700   GhcDiagnosticCode "TcRnDuplicateMinimalSig"                       = 85346-  GhcDiagnosticCode "TcRnLoopySuperclassSolve"                      = 36038+  GhcDiagnosticCode "TcRnLoopySuperclassSolve"                      = Outdated 36038   GhcDiagnosticCode "TcRnUnexpectedStandaloneDerivingDecl"          = 95159   GhcDiagnosticCode "TcRnUnusedVariableInRuleDecl"                  = 65669   GhcDiagnosticCode "TcRnUnexpectedStandaloneKindSig"               = 45906@@ -520,6 +535,7 @@   GhcDiagnosticCode "TcRnIncorrectTyVarOnLhsOfInjCond"              = 88333   GhcDiagnosticCode "TcRnUnknownTyVarsOnRhsOfInjCond"               = 48254   GhcDiagnosticCode "TcRnBadlyStaged"                               = 28914+  GhcDiagnosticCode "TcRnBadlyStagedType"                           = 86357   GhcDiagnosticCode "TcRnStageRestriction"                          = 18157   GhcDiagnosticCode "TcRnTyThingUsedWrong"                          = 10969   GhcDiagnosticCode "TcRnCannotDefaultKindVar"                      = 79924@@ -531,6 +547,7 @@   GhcDiagnosticCode "TcRnTyFamDepsDisabled"                         = 43991   GhcDiagnosticCode "TcRnAbstractClosedTyFamDecl"                   = 60012   GhcDiagnosticCode "TcRnPartialFieldSelector"                      = 82712+  GhcDiagnosticCode "TcRnHasFieldResolvedIncomplete"                = 86894   GhcDiagnosticCode "TcRnSuperclassCycle"                           = 29210   GhcDiagnosticCode "TcRnDefaultSigMismatch"                        = 72771   GhcDiagnosticCode "TcRnTyFamResultDisabled"                       = 44012@@ -571,6 +588,7 @@   GhcDiagnosticCode "TcRnBindingNameConflict"                       = 10498   GhcDiagnosticCode "NonCanonicalMonoid"                            = 50928   GhcDiagnosticCode "NonCanonicalMonad"                             = 22705+  GhcDiagnosticCode "TcRnDefaultedExceptionContext"                 = 46235   GhcDiagnosticCode "TcRnImplicitImportOfPrelude"                   = 20540   GhcDiagnosticCode "TcRnMissingMain"                               = 67120   GhcDiagnosticCode "TcRnGhciUnliftedBind"                          = 17999@@ -582,6 +600,14 @@   GhcDiagnosticCode "TcRnBadTyConTelescope"                         = 87279   GhcDiagnosticCode "TcRnPatersonCondFailure"                       = 22979   GhcDiagnosticCode "TcRnDeprecatedInvisTyArgInConPat"              = 69797+  GhcDiagnosticCode "TcRnInvalidDefaultedTyVar"                     = 45625+  GhcDiagnosticCode "TcRnIllegalTermLevelUse"                       = 01928+  GhcDiagnosticCode "TcRnNamespacedWarningPragmaWithoutFlag"        = 14995+  GhcDiagnosticCode "TcRnInvisPatWithNoForAll"                      = 14964+  GhcDiagnosticCode "TcRnIllegalInvisibleTypePattern"               = 78249+  GhcDiagnosticCode "TcRnNamespacedFixitySigWithoutFlag"            = 78534+  GhcDiagnosticCode "TcRnOutOfArityTyVar"                           = 84925+  GhcDiagnosticCode "TcRnMisplacedInvisPat"                         = 11983    -- TcRnTypeApplicationsDisabled   GhcDiagnosticCode "TypeApplication"                               = 23482@@ -628,6 +654,10 @@   GhcDiagnosticCode "HasConstructorContext"                         = 17440   GhcDiagnosticCode "HasExistentialTyVar"                           = 07525   GhcDiagnosticCode "HasStrictnessAnnotation"                       = 04049+  GhcDiagnosticCode "TcRnIllformedTypePattern"                      = 88754+  GhcDiagnosticCode "TcRnIllegalTypePattern"                        = 70206+  GhcDiagnosticCode "TcRnIllformedTypeArgument"                     = 29092+  GhcDiagnosticCode "TcRnIllegalTypeExpr"                           = 35499    -- TcRnBadRecordUpdate   GhcDiagnosticCode "NoConstructorHasAllFields"                     = 14392@@ -850,7 +880,6 @@   GhcDiagnosticCode "FamDataConPE"                                  = 64578   GhcDiagnosticCode "ConstrainedDataConPE"                          = 28374   GhcDiagnosticCode "RecDataConPE"                                  = 56753-  GhcDiagnosticCode "NoDataKindsDC"                                 = 71015   GhcDiagnosticCode "TermVariablePE"                                = 45510   GhcDiagnosticCode "TypeVariablePE"                                = 47557 @@ -862,20 +891,31 @@   -- and this includes outdated diagnostic codes for errors that GHC   -- no longer reports. These are collected below. -  GhcDiagnosticCode "TcRnIllegalInstanceHeadDecl"                   = 12222-  GhcDiagnosticCode "TcRnNoClassInstHead"                           = 56538+  GhcDiagnosticCode "TcRnIllegalInstanceHeadDecl"                   = Outdated 12222+  GhcDiagnosticCode "TcRnNoClassInstHead"                           = Outdated 56538     -- The above two are subsumed by InstHeadNonClass [GHC-53946] -  GhcDiagnosticCode "TcRnNameByTemplateHaskellQuote"                = 40027-  GhcDiagnosticCode "TcRnIllegalBindingOfBuiltIn"                   = 69639-  GhcDiagnosticCode "TcRnMixedSelectors"                            = 40887-  GhcDiagnosticCode "TcRnBadBootFamInstDecl"                        = 06203-  GhcDiagnosticCode "TcRnBindInBootFile"                            = 11247-  GhcDiagnosticCode "TcRnUnexpectedTypeSplice"                      = 39180-  GhcDiagnosticCode "PsErrUnexpectedTypeAppInDecl"                  = 45054-  GhcDiagnosticCode "TcRnUnpromotableThing"                         = 88634-  GhcDiagnosticCode "UntouchableVariable"                           = 34699+  GhcDiagnosticCode "TcRnNameByTemplateHaskellQuote"                = Outdated 40027+  GhcDiagnosticCode "TcRnIllegalBindingOfBuiltIn"                   = Outdated 69639+  GhcDiagnosticCode "TcRnMixedSelectors"                            = Outdated 40887+  GhcDiagnosticCode "TcRnBadBootFamInstDecl"                        = Outdated 06203+  GhcDiagnosticCode "TcRnBindInBootFile"                            = Outdated 11247+  GhcDiagnosticCode "TcRnUnexpectedTypeSplice"                      = Outdated 39180+  GhcDiagnosticCode "PsErrUnexpectedTypeAppInDecl"                  = Outdated 45054+  GhcDiagnosticCode "TcRnUnpromotableThing"                         = Outdated 88634+  GhcDiagnosticCode "UntouchableVariable"                           = Outdated 34699+  GhcDiagnosticCode "TcRnBindVarAlreadyInScope"                     = Outdated 69710+  GhcDiagnosticCode "TcRnBindMultipleVariables"                     = Outdated 92957+  GhcDiagnosticCode "TcRnHsigNoIface"                               = Outdated 93010+  GhcDiagnosticCode "TcRnInterfaceLookupError"                      = Outdated 52243+  GhcDiagnosticCode "TcRnForallIdentifier"                          = Outdated 64088 +-- | Use this type synonym to mark a diagnostic code as outdated.+--+-- The presence of this type synonym is used by the 'codes' test to determine+-- which diagnostic codes to check for testsuite coverage.+type Outdated a = a+ {- ********************************************************************* *                                                                      *                  Recurring into an argument@@ -1102,12 +1142,26 @@ type GDiagnosticCode :: (Type -> Type) -> Constraint class GDiagnosticCode f where   gdiagnosticCode :: f a -> Maybe DiagnosticCode+-- | Use the generic representation of a type to retrieve the collection+-- of all diagnostic codes it can give rise to.+type GDiagnosticCodes :: [Type] -> (Type -> Type) -> Constraint+class GDiagnosticCodes seen f where+  gdiagnosticCodes :: Map DiagnosticCode String -type ConstructorCode :: Symbol -> (Type -> Type) -> Maybe Type -> Constraint+type ConstructorCode :: Symbol -> (Type -> Type)  -> Maybe Type -> Constraint class ConstructorCode con f recur where   gconstructorCode :: f a -> Maybe DiagnosticCode-instance KnownConstructor con => ConstructorCode con f 'Nothing where+type ConstructorCodes :: Symbol -> (Type -> Type) -> [Type] -> Maybe Type -> Constraint+class ConstructorCodes con f seen recur where+  gconstructorCodes :: Map DiagnosticCode String++instance (KnownConstructor con, KnownSymbol con) => ConstructorCode con f 'Nothing where   gconstructorCode _ = Just $ DiagnosticCode "GHC" $ natVal' @(GhcDiagnosticCode con) proxy#+instance (KnownConstructor con, KnownSymbol con) => ConstructorCodes con f seen 'Nothing where+  gconstructorCodes =+    Map.singleton+      (DiagnosticCode "GHC" $ natVal' @(GhcDiagnosticCode con) proxy#)+      (symbolVal' @con proxy#)  -- If we recur into the 'UnknownDiagnostic' existential datatype, -- unwrap the existential and obtain the error code.@@ -1117,30 +1171,51 @@       => ConstructorCode con f ('Just (UnknownDiagnostic opts)) where   gconstructorCode diag = case getType @(UnknownDiagnostic opts) @con @f diag of     UnknownDiagnostic _ diag -> diagnosticCode diag+instance {-# OVERLAPPING #-}+         ( ConRecursInto con ~ 'Just (UnknownDiagnostic opts) )+      => ConstructorCodes con f seen ('Just (UnknownDiagnostic opts)) where+  gconstructorCodes = Map.empty  -- (*) Recursive instance: Recur into the given type. instance ( ConRecursInto con ~ 'Just ty, HasType ty con f          , Generic ty, GDiagnosticCode (Rep ty) )       => ConstructorCode con f ('Just ty) where-  gconstructorCode diag = constructorCode (getType @ty @con @f diag)+  gconstructorCode diag = gdiagnosticCode (from $ getType @ty @con @f diag)+instance ( ConRecursInto con ~ 'Just ty, HasType ty con f+         , Generic ty, GDiagnosticCodes (Insert ty seen) (Rep ty)+         , Seen seen ty )+      => ConstructorCodes con f seen ('Just ty) where+  gconstructorCodes =+    -- See Note [diagnosticCodes: don't recur into already-seen types]+    if wasSeen @seen @ty+    then Map.empty+    else gdiagnosticCodes @(Insert ty seen) @(Rep ty)  -- (**) Constructor instance: handle constructors directly. -- -- Obtain the code from the 'GhcDiagnosticCode' -- type family, applied to the name of the constructor.-instance (ConstructorCode con f recur, recur ~ ConRecursInto con)+instance (ConstructorCode con f recur, recur ~ ConRecursInto con, KnownSymbol con)       => GDiagnosticCode (M1 i ('MetaCons con x y) f) where   gdiagnosticCode (M1 x) = gconstructorCode @con @f @recur x+instance (ConstructorCodes con f seen recur, recur ~ ConRecursInto con, KnownSymbol con)+      => GDiagnosticCodes seen (M1 i ('MetaCons con x y) f) where+  gdiagnosticCodes = gconstructorCodes @con @f @seen @recur  -- Handle sum types (the diagnostic types are sums of constructors). instance (GDiagnosticCode f, GDiagnosticCode g) => GDiagnosticCode (f :+: g) where   gdiagnosticCode (L1 x) = gdiagnosticCode @f x   gdiagnosticCode (R1 y) = gdiagnosticCode @g y+instance (GDiagnosticCodes seen f, GDiagnosticCodes seen g) => GDiagnosticCodes seen (f :+: g) where+  gdiagnosticCodes = Map.union (gdiagnosticCodes @seen @f) (gdiagnosticCodes @seen @g)  -- Discard metadata we don't need. instance GDiagnosticCode f       => GDiagnosticCode (M1 i ('MetaData nm mod pkg nt) f) where   gdiagnosticCode (M1 x) = gdiagnosticCode @f x+instance GDiagnosticCodes seen f+      => GDiagnosticCodes seen (M1 i ('MetaData nm mod pkg nt) f) where+  gdiagnosticCodes = gdiagnosticCodes @seen @f  -- | Decide whether to pick the left or right branch -- when deciding how to recurse into a product.@@ -1191,6 +1266,50 @@ -- Pick the right branch. instance HasType ty orig g => HasTypeProd ty 'Nothing orig f g where   getTypeProd (_ :*: y) = getType @ty @orig @g y++{- Note [diagnosticCodes: don't recur into already-seen types]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+When traversing through the Generic representation of a datatype to compute all+of the corresponding error codes, we need to keep track of types we have already+seen in order to avoid a runtime loop.++For example, TcRnMessage is defined recursively in terms of itself:++  data TcRnMessage where+    ...+    TcRnMessageWithInfo :: !UnitState+                        -> !TcRnMessageDetailed -- contains a TcRnMessage+                        -> TcRnMessage++If we naively computed the collection of error codes, we would get a computation+of the form++  diagnosticCodes @TcRnMessage = ... `Map.union` constructorCodes "TcRnMessageWithInfo"+  constructorCodes "TcRnMessageWithInfo" = diagnosticCodes @TcRnMessage++This would cause an infinite loop. We thus keep track of a list of types we+have already encountered, and when we recur into a type we have already+encountered, we simply skip taking that union (see (*)).++Note that 'constructorCodes' starts by marking the initial type itself as "seen",+which precisely avoids the loop above when calling 'constructorCodes @TcRnMessage'.+-}++type Seen :: [Type] -> Type -> Constraint+class Seen seen ty where+  wasSeen :: Bool+instance Seen '[] ty where+  wasSeen = False+instance {-# OVERLAPPING #-} Seen (ty ': tys) ty where+  wasSeen = True+instance Seen tys ty => Seen (ty' ': tys) ty where+  wasSeen = wasSeen @tys @ty++type Insert :: Type -> [Type] -> [Type]+type family Insert ty tys where+  Insert ty '[] = '[ty]+  Insert ty (ty ': tys) = ty ': tys+  Insert ty (ty' ': tys) = ty' ': Insert ty tys  {- ********************************************************************* *                                                                      *
compiler/GHC/Types/ForeignCall.hs view
@@ -189,7 +189,7 @@ ccallConvAttribute CCallConv         = empty ccallConvAttribute CApiConv          = empty ccallConvAttribute (PrimCallConv {}) = panic "ccallConvAttribute PrimCallConv"-ccallConvAttribute JavaScriptCallConv = panic "ccallConvAttribute JavaScriptCallConv"+ccallConvAttribute JavaScriptCallConv = empty  type CLabelString = FastString          -- A C label, completely unencoded 
compiler/GHC/Types/GREInfo.hs view
@@ -186,7 +186,7 @@   - We can fill in the dots if you say `T1 {..}` in construction or pattern matching     See GHC.Rename.Pat.rnHsRecFields.rn_dotdot -* Whether the contructor is nullary.+* Whether the constructor is nullary.   We need to know this to accept `T2 {..}`, and `T3 {..}`, but reject `T4 {..}`,   in both construction and pattern matching.   See GHC.Rename.Pat.rnHsRecFields.rn_dotdot
compiler/GHC/Types/Hint.hs view
@@ -35,13 +35,12 @@ import GHC.Core.Coercion import GHC.Core.FamInstEnv (FamFlavor) import GHC.Core.TyCon (TyCon)-import GHC.Core.Type (PredType, Type)+import GHC.Core.Type (Type) import GHC.Types.Fixity (LexicalFixity(..)) import GHC.Types.Name (Name, NameSpace, OccName (occNameFS), isSymOcc, nameOccName) import GHC.Types.Name.Reader (RdrName (Unqual), ImpDeclSpec) import GHC.Types.SrcLoc (SrcSpan) import GHC.Types.Basic (Activation, RuleName)-import {-# SOURCE #-} GHC.Tc.Types.Origin ( ClsInstOrQC(..) ) import GHC.Parser.Errors.Basic import GHC.Utils.Outputable import GHC.Data.FastString (fsLit, FastString)@@ -55,6 +54,7 @@   | UnnamedBinding   -- ^ An unknown binding (i.e. too complicated to turn into a 'Name') + data LanguageExtensionHint   = -- | Suggest to enable the input extension. This is the hint that     -- GHC emits if this is not a \"known\" fix, i.e. this is GHC giving@@ -298,13 +298,13 @@     -}   | SuggestQualifyStarOperator -    {-| Suggests that a type signature should have form <variable> :: <type>+    {-| Suggests that for a type signature 'M.x :: ...' the qualifier should be omitted         in order to be accepted by GHC.          Triggered by: 'GHC.Parser.Errors.Types.PsErrInvalidTypeSignature'-        Test case(s): parser/should_fail/T3811+        Test case(s): module/mod98     -}-  | SuggestTypeSignatureForm+  | SuggestTypeSignatureRemoveQualifier      {-| Suggests to move an orphan instance (for a typeclass or a type or data         family), or to newtype-wrap it.@@ -346,11 +346,6 @@     -}   | SuggestFillInWildcardConstraint -  {-| Suggests to use an identifier other than 'forall'-      Triggered by: 'GHC.Tc.Errors.Types.TcRnForallIdentifier'-  -}-  | SuggestRenameForall-     {-| Suggests to use the appropriate Template Haskell tick:         a single tick for a term-level 'NameSpace', or a double tick         for a type-level 'NameSpace'.@@ -433,8 +428,6 @@     -}   | SuggestRenameTypeVariable -  | LoopySuperclassSolveHint PredType ClsInstOrQC-   | SuggestExplicitBidiPatSyn Name (LPat GhcRn) [LIdP GhcRn]      {-| Suggest enabling one of the SafeHaskell modes Safe, Unsafe or@@ -473,6 +466,13 @@   {-| Suggest binding the type variable on the LHS of the type declaration   -}   | SuggestBindTyVarOnLhs RdrName++  {-| Suggest using an anonymous wildcard instead of a named wildcard -}+  | SuggestAnonymousWildcard++  {-| Suggest explicitly quantifying a type variable instead of relying on implicit quantification -}+  | SuggestExplicitQuantification RdrName+    {-| Suggest binding explicitly; e.g   data T @k (a :: F k) = .... -}   | SuggestBindTyVarExplicitly Name
compiler/GHC/Types/Hint/Ppr.hs view
@@ -16,7 +16,6 @@ import GHC.Core.TyCon import GHC.Core.TyCo.Rep     ( mkVisFunTyMany ) import GHC.Hs.Expr ()   -- instance Outputable-import GHC.Tc.Types.Origin ( ClsInstOrQC(..) ) import GHC.Types.Id import GHC.Types.Name import GHC.Types.Name.Reader (RdrName,ImpDeclSpec (..), rdrNameOcc, rdrNameSpace)@@ -128,8 +127,8 @@       -> text "To use (or export) this operator in"             <+> text "modules with StarIsType,"          $$ text "    including the definition module, you must qualify it."-    SuggestTypeSignatureForm-      -> text "A type signature should be of form <variables> :: <type>"+    SuggestTypeSignatureRemoveQualifier+      -> text "Perhaps you meant to omit the qualifier"     SuggestAddToHSigExportList _name mb_mod       -> let header = text "Try adding it to the export list of"          in case mb_mod of@@ -150,11 +149,6 @@       -> text "Add a standalone kind signature for" <+> quotes (ppr name)     SuggestFillInWildcardConstraint       -> text "Fill in the wildcard constraint yourself"-    SuggestRenameForall-      -> vcat [ text "Consider using another name, such as"-              , quotes (text "forAll") <> comma <+>-                quotes (text "for_all") <> comma <+> text "or" <+>-                quotes (text "forall_") <> dot ]     SuggestAppropriateTHTick ns       -> text "Perhaps use a" <+> how_many <+> text "tick"         where@@ -217,14 +211,6 @@            mod = nameModule name     SuggestRenameTypeVariable       -> text "Consider renaming the type variable."-    LoopySuperclassSolveHint pty cls_or_qc-      -> vcat [ text "Add the constraint" <+> quotes (ppr pty) <+> text "to the" <+> what <> comma-              , text "even though it seems logically implied by other constraints in the context." ]-        where-          what :: SDoc-          what = case cls_or_qc of-            IsClsInst -> text "instance context"-            IsQC {}   -> text "context of the quantified constraint"     SuggestExplicitBidiPatSyn name pat args       -> hang (text "Instead use an explicitly bidirectional"                <+> text "pattern synonym, e.g.")@@ -266,6 +252,11 @@             ppr_r = quotes $ ppr r     SuggestBindTyVarOnLhs tv       -> text "Bind" <+> quotes (ppr tv) <+> text "on the LHS of the type declaration"+    SuggestAnonymousWildcard+      -> text "Use an anonymous wildcard" <+> quotes (text "_")+    SuggestExplicitQuantification tv+      -> hsep [ text "Use an explicit", quotes (text "forall")+              , text "to quantify over", quotes (ppr tv) ]     SuggestBindTyVarExplicitly tv       -> text "bind" <+> quotes (ppr tv)          <+> text "explicitly with" <+> quotes (char '@' <> ppr tv)@@ -319,12 +310,12 @@         | (mod,imv) <- NE.toList mods         ]) pprImportSuggestion occ_name (CouldAddTypeKeyword mod)- = vcat [ text "Add the" <+> quotes (text "type")+  = vcat [ text "Add the" <+> quotes (text "type")           <+> text "keyword to the import statement:"-        , nest 2 $ text "import"+         , nest 2 $ text "import"             <+> ppr mod             <+> parens_sp (text "type" <+> pprPrefixOcc occ_name)-        ]+         ]   where     parens_sp d = parens (space <> d <> space) pprImportSuggestion occ_name (CouldRemoveTypeKeyword mod)
compiler/GHC/Types/Id.hs view
@@ -78,7 +78,8 @@         hasNoBinding,          -- ** Join variables-        JoinId, isJoinId, isJoinId_maybe, idJoinArity,+        JoinId, JoinPointHood,+        isJoinId, idJoinPointHood, idJoinArity,         asJoinId, asJoinId_maybe, zapJoinId,          -- ** Inline pragma stuff@@ -165,7 +166,6 @@ import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Utils.Panic.Plain import GHC.Stg.InferTags.TagSig  -- infixl so you can say (id `set` a `set` b)@@ -296,28 +296,26 @@ mkGlobalId = Var.mkGlobalVar  -- | Make a global 'Id' without any extra information at all-mkVanillaGlobal :: HasDebugCallStack => Name -> Type -> Id+mkVanillaGlobal :: Name -> Type -> Id mkVanillaGlobal name ty = mkVanillaGlobalWithInfo name ty vanillaIdInfo  -- | Make a global 'Id' with no global information but some generic 'IdInfo'-mkVanillaGlobalWithInfo :: HasDebugCallStack => Name -> Type -> IdInfo -> Id-mkVanillaGlobalWithInfo nm =-  assertPpr (not $ isFieldNameSpace $ nameNameSpace nm)-    (text "mkVanillaGlobalWithInfo called on record field:" <+> ppr nm) $-    mkGlobalId VanillaId nm+mkVanillaGlobalWithInfo :: Name -> Type -> IdInfo -> Id+mkVanillaGlobalWithInfo = mkGlobalId VanillaId + -- | For an explanation of global vs. local 'Id's, see "GHC.Types.Var#globalvslocal" mkLocalId :: HasDebugCallStack => Name -> Mult -> Type -> Id mkLocalId name w ty = mkLocalIdWithInfo name w (assert (not (isCoVarType ty)) ty) vanillaIdInfo  -- | Make a local CoVar-mkLocalCoVar :: HasDebugCallStack => Name -> Type -> CoVar+mkLocalCoVar :: Name -> Type -> CoVar mkLocalCoVar name ty   = assert (isCoVarType ty) $     Var.mkLocalVar CoVarId name ManyTy ty vanillaIdInfo  -- | Like 'mkLocalId', but checks the type to see if it should make a covar-mkLocalIdOrCoVar :: HasDebugCallStack => Name -> Mult -> Type -> Id+mkLocalIdOrCoVar :: Name -> Mult -> Type -> Id mkLocalIdOrCoVar name w ty   -- We should assert (eqType w Many) in the isCoVarType case.   -- However, currently this assertion does not hold.@@ -341,10 +339,7 @@         -- Note [Free type variables]  mkExportedVanillaId :: Name -> Type -> Id-mkExportedVanillaId name ty =-  assertPpr (not $ isFieldNameSpace $ nameNameSpace name)-    (text "mkExportedVanillaId called on record field:" <+> ppr name) $-    Var.mkExportedLocalVar VanillaId name ty vanillaIdInfo+mkExportedVanillaId name ty = Var.mkExportedLocalVar VanillaId name ty vanillaIdInfo         -- Note [Free type variables]  @@ -565,13 +560,12 @@   | otherwise = False  -- | Doesn't return strictness marks-isJoinId_maybe :: Var -> Maybe JoinArity-isJoinId_maybe id- | isId id  = assertPpr (isId id) (ppr id) $-              case Var.idDetails id of-                JoinId arity _marks -> Just arity-                _            -> Nothing- | otherwise = Nothing+idJoinPointHood :: Var -> JoinPointHood+idJoinPointHood id+ | isId id  = case Var.idDetails id of+                JoinId arity _marks -> JoinPoint arity+                _                   -> NotJoinPoint+ | otherwise = NotJoinPoint  idDataCon :: Id -> DataCon -- ^ Get from either the worker or the wrapper 'Id' to the 'DataCon'. Currently used only in the desugarer.@@ -644,7 +638,9 @@ -}  idJoinArity :: JoinId -> JoinArity-idJoinArity id = isJoinId_maybe id `orElse` pprPanic "idJoinArity" (ppr id)+idJoinArity id = case idJoinPointHood id of+                   JoinPoint ar -> ar+                   NotJoinPoint -> pprPanic "idJoinArity" (ppr id)  asJoinId :: Id -> JoinArity -> JoinId asJoinId id arity = warnPprTrace (not (isLocalId id))@@ -676,9 +672,9 @@                   _                     -> panic "zapJoinId: newIdDetails can only be used if Id was a join Id."  -asJoinId_maybe :: Id -> Maybe JoinArity -> Id-asJoinId_maybe id (Just arity) = asJoinId id arity-asJoinId_maybe id Nothing      = zapJoinId id+asJoinId_maybe :: Id -> JoinPointHood -> Id+asJoinId_maybe id (JoinPoint arity) = asJoinId id arity+asJoinId_maybe id NotJoinPoint      = zapJoinId id  {- ************************************************************************
compiler/GHC/Types/Id/Info.hs view
@@ -12,6 +12,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE TypeFamilies #-}  {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}@@ -21,6 +22,7 @@         IdDetails(..), pprIdDetails, coVarDetails, isCoVarDetails,         JoinArity, isJoinIdDetails_maybe,         RecSelParent(..), recSelParentName, recSelFirstConName,+        recSelParentCons, idDetailsConcreteTvs,          -- * The IdInfo type         IdInfo,         -- Abstract@@ -99,14 +101,15 @@ import GHC.Core.TyCon import GHC.Core.Type (mkTyConApp) import GHC.Core.PatSyn+import GHC.Core.ConLike import GHC.Types.ForeignCall import GHC.Unit.Module import GHC.Types.Demand import GHC.Types.Cpr+import {-# SOURCE #-} GHC.Tc.Utils.TcType ( ConcreteTyVars, noConcreteTyVars )  import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Utils.Panic.Plain import GHC.Stg.InferTags.TagSig import GHC.StgToCmm.Types (LambdaFormInfo) @@ -146,7 +149,13 @@     , sel_fieldLabel :: FieldLabel     , sel_naughty    :: Bool    -- True <=> a "naughty" selector which can't actually exist, for example @x@ in:                                 --    data T = forall a. MkT { x :: a }-    }                           -- See Note [Naughty record selectors] in GHC.Tc.TyCl+                                -- See Note [Naughty record selectors] in GHC.Tc.TyCl+    , sel_cons       :: ([ConLike], [ConLike])+                                -- If record selector is not defined for all constructors+                                -- of a parent type, this is the pair of lists of constructors that+                                -- it is and is not defined for. Otherwise, it's Nothing.+                                -- Cached here based on the RecSelParent.+    }                           -- See Note [Detecting incomplete record selectors] in GHC.HsToCore.Pmc    | DataConWorkId DataCon       -- ^ The 'Id' is for a data constructor /worker/   | DataConWrapId DataCon       -- ^ The 'Id' is for a data constructor /wrapper/@@ -163,11 +172,28 @@                                 --   and Note [exprOkForSpeculation and type classes]                                 --       in GHC.Core.Utils -  | PrimOpId PrimOp Bool        -- ^ The 'Id' is for a primitive operator-                                -- True <=> is representation-polymorphic,-                                --          and hence has no binding-                                -- This lev-poly flag is used only in GHC.Types.Id.hasNoBinding+  -- | A representation-polymorphic pseudo-op.+  | RepPolyId+      { id_concrete_tvs :: ConcreteTyVars }+        -- ^ Which type variables of this representation-polymorphic 'Id+        -- should be instantiated to concrete type variables?+        --+        -- See Note [Representation-polymorphism checking built-ins]+        -- in GHC.Tc.Gen.Head. +  -- | The 'Id' is for a primitive operator.+  | PrimOpId+     { id_primop :: PrimOp+     , id_concrete_tvs :: ConcreteTyVars }+        -- ^ Which type variables of this primop should be instantiated+        -- to concrete type variables?+        --+        -- Only ever non-empty when the PrimOp has representation-polymorphic+        -- type variables.+        --+        -- See Note [Representation-polymorphism checking built-ins]+        -- in GHC.Tc.Gen.Head.+   | FCallId ForeignCall         -- ^ The 'Id' is for a foreign call.                                 -- Type will be simple: no type families, newtypes, etc @@ -197,6 +223,15 @@         -- The [CbvMark] is always empty (and ignored) until after Tidy for ids from the current         -- module. +idDetailsConcreteTvs :: IdDetails -> ConcreteTyVars+idDetailsConcreteTvs = \ case+    PrimOpId _ conc_tvs -> conc_tvs+    RepPolyId  conc_tvs -> conc_tvs+    DataConWorkId dc    -> dataConConcreteTyVars dc+    DataConWrapId dc    -> dataConConcreteTyVars dc+    _                   -> noConcreteTyVars++ {- Note [CBV Function Ids] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ A WorkerLikeId essentially allows us to constrain the calling convention@@ -303,6 +338,15 @@ recSelFirstConName (RecSelData   tc) = dataConName $ head $ tyConDataCons tc recSelFirstConName (RecSelPatSyn ps) = patSynName ps +recSelParentCons :: RecSelParent -> [ConLike]+recSelParentCons (RecSelData tc)+  | isAlgTyCon tc+      = map RealDataCon $ visibleDataCons+      $ algTyConRhs tc+  | otherwise+      = []+recSelParentCons (RecSelPatSyn ps) = [PatSynCon ps]+ instance Outputable RecSelParent where   ppr p = case p of     RecSelData tc@@ -339,6 +383,7 @@    pp (DataConWorkId _)       = text "DataCon"    pp (DataConWrapId _)       = text "DataConWrapper"    pp (ClassOpId {})          = text "ClassOp"+   pp (RepPolyId {})          = text "RepPolyId"    pp (PrimOpId {})           = text "PrimOp"    pp (FCallId _)             = text "ForeignCall"    pp (TickBoxOpId _)         = text "TickBoxOp"
compiler/GHC/Types/Id/Make.hs view
@@ -12,9 +12,8 @@ - primitive operations -} -- {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+{-# LANGUAGE DataKinds #-}  module GHC.Types.Id.Make (         mkDictFunId, mkDictSelId, mkDictSelRhs,@@ -38,6 +37,9 @@         noinlineId, noinlineIdName,         noinlineConstraintId, noinlineConstraintIdName,         coerceName, leftSectionName, rightSectionName,+        pcRepPolyId,++        mkRepPolyIdConcreteTyVars,     ) where  import GHC.Prelude@@ -65,9 +67,10 @@  import GHC.Types.Literal import GHC.Types.SourceText-import GHC.Types.RepType ( countFunRepArgs )+import GHC.Types.RepType ( countFunRepArgs, typePrimRep ) import GHC.Types.Name.Set import GHC.Types.Name+import GHC.Types.Name.Env import GHC.Types.ForeignCall import GHC.Types.Id import GHC.Types.Id.Info@@ -75,14 +78,14 @@ import GHC.Types.Cpr import GHC.Types.Unique.Supply import GHC.Types.Basic       hiding ( SuccessFlag(..) )-import GHC.Types.Var (VarBndr(Bndr), visArgConstraintLike)+import GHC.Types.Var (VarBndr(Bndr), visArgConstraintLike, tyVarName) +import GHC.Tc.Types.Origin import GHC.Tc.Utils.TcType as TcType  import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Utils.Panic.Plain  import GHC.Data.FastString import GHC.Data.List.SetOps@@ -379,7 +382,7 @@ Note [Representation polymorphism invariants] in GHC.Core), and it's saturated, no representation-polymorphic code ends up in the code generator. The saturation condition is effectively checked in-GHC.Tc.Gen.App.hasFixedRuntimeRep_remainingValArgs.+GHC.Tc.Gen.Head.rejectRepPolyNewtypes.  However, if we make a *wrapper* for a newtype, we get into trouble. In that case, we generate a forbidden representation-polymorphic@@ -899,25 +902,15 @@     -- needs a wrapper. This wrapper is injected into the program later in the     -- CoreTidy pass. See Note [Injecting implicit bindings] in GHC.Iface.Tidy,     -- along with the accompanying implementation in getTyConImplicitBinds.-    wrapper_reqd-      | isTypeDataTyCon tycon-        -- `type data` declarations never have data-constructor wrappers-        -- Their data constructors only live at the type level, in the-        -- form of PromotedDataCon, and therefore do not need wrappers.-        -- See wrinkle (W0) in Note [Type data declarations] in GHC.Rename.Module.-      = False--      | otherwise-      = (not new_tycon+    wrapper_reqd =+        (not new_tycon                      -- (Most) newtypes have only a worker, with the exception                      -- of some newtypes written with GADT syntax.                      -- See dataConUserTyVarsNeedWrapper below.          && (any isBanged (ev_ibangs ++ arg_ibangs)))                      -- Some forcing/unboxing (includes eq_spec)-       || isFamInstTyCon tycon -- Cast result--      || dataConUserTyVarsNeedWrapper data_con+      || (dataConUserTyVarsNeedWrapper data_con                      -- If the data type was written with GADT syntax and                      -- orders the type variables differently from what the                      -- worker expects, it needs a data con wrapper to reorder@@ -926,7 +919,19 @@                      --                      -- NB: All GADTs return true from this function, but there                      -- is one exception that we must check below.-+         && not (isTypeDataTyCon tycon))+                     -- An exception to this rule is `type data` declarations.+                     -- Their data constructors only live at the type level and+                     -- therefore do not need wrappers.+                     -- See Note [Type data declarations] in GHC.Rename.Module.+                     --+                     -- Note that the other checks in this definition will+                     -- return False for `type data` declarations, as:+                     --+                     -- - They cannot be newtypes+                     -- - They cannot have strict fields+                     -- - They cannot be data family instances+                     -- - They cannot have datatype contexts       || not (null stupid_theta)                      -- If the data constructor has a datatype context,                      -- we need a wrapper in order to drop the stupid arguments.@@ -941,8 +946,7 @@     mk_boxer boxers = DCB (\ ty_args src_vars ->                       do { let (ex_vars, term_vars) = splitAtList ex_tvs src_vars                                subst1 = zipTvSubst univ_tvs ty_args-                               subst2 = extendTCvSubstList subst1 ex_tvs-                                                           (mkTyCoVarTys ex_vars)+                               subst2 = foldl2 extendTvSubstWithClone subst1 ex_tvs ex_vars                          ; (rep_ids, binds) <- go subst2 boxers term_vars                          ; return (ex_vars ++ rep_ids, binds) } ) @@ -1512,16 +1516,27 @@           | otherwise   -- Wrinkle (W4) of Note [Recursive unboxing]           -> bang_opt_unbox_strict bang_opts              || (bang_opt_unbox_small bang_opts-                 && rep_tys `lengthAtMost` 1)  -- See Note [Unpack one-wide fields]+                 && is_small_rep)  -- See Note [Unpack one-wide fields]       where         (rep_tys, _) = dataConArgUnpack arg_ty +        -- Takes in the list of reps used to represent the dataCon after it's unpacked+        -- and tells us if they can fit into 8 bytes. See Note [Unpack one-wide fields]+        is_small_rep =+          let -- Neccesary to look through unboxed tuples.+              prim_reps = concatMap (typePrimRep . scaledThing . fst) $ rep_tys+              -- And then get the actual size of the unpacked constructor.+              rep_size = sum $ map primRepSizeW64_B prim_reps+          in rep_size <= 8+     is_sum :: [DataCon] -> Bool     -- We never unpack sum types automatically     -- (Product types, we do. Empty types are weeded out by unpackable_type_datacons.)     is_sum (_:_:_) = True     is_sum _       = False ++ -- Given a type already assumed to have been normalized by topNormaliseType, -- unpackable_type_datacons ty = Just datacons -- iff ty is of the form@@ -1580,6 +1595,14 @@  Here we can represent T with an Int#. +Special care has to be taken to make sure we don't mistake fields with unboxed+tuple/sum rep or very large reps. See #22309++For consistency we unpack anything that fits into 8 bytes on a 64-bit platform,+even when compiling for 32bit platforms. This way unpacking decisions will be the+same for 32bit and 64bit systems. To do so we use primRepSizeW64_B instead of+primRepSizeB. See also the tests in test case T22309.+ Note [Recursive unboxing] ~~~~~~~~~~~~~~~~~~~~~~~~~ Consider@@ -1803,6 +1826,7 @@ failure when trying.) -} + nullAddrName, seqName,    realWorldName, voidPrimIdName, coercionTokenName,    coerceName, proxyName,@@ -1850,7 +1874,7 @@  ------------------------------------------------ seqId :: Id     -- See Note [seqId magic]-seqId = pcMiscPrelId seqName ty info+seqId = pcRepPolyId seqName ty concs info   where     info = noCafIdInfo `setInlinePragInfo` inline_prag                        `setUnfoldingInfo`  mkCompulsoryUnfolding rhs@@ -1874,6 +1898,9 @@     rhs = mkLams ([runtimeRep2TyVar, alphaTyVar, openBetaTyVar, x, y]) $           Case (Var x) x openBetaTy [Alt DEFAULT [] (Var y)] +    concs = mkRepPolyIdConcreteTyVars+        [ ((openBetaTy, Argument 2 Top), runtimeRep2TyVar)]+     arity = 2  ------------------------------------------------@@ -1911,12 +1938,13 @@     info = noCafIdInfo     ty  = mkSpecForAllTys [alphaTyVar] (mkVisFunTyMany alphaTy alphaTy) -oneShotId :: Id -- See Note [The oneShot function]-oneShotId = pcMiscPrelId oneShotName ty info+oneShotId :: Id -- See Note [oneShot magic]+oneShotId = pcRepPolyId oneShotName ty concs info   where     info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma                        `setUnfoldingInfo`  mkCompulsoryUnfolding rhs                        `setArityInfo`      arity+    -- oneShot :: forall {r1 r2} (a :: TYPE r1) (b :: TYPE r2). (a -> b) -> (a -> b)     ty  = mkInfForAllTys  [ runtimeRep1TyVar, runtimeRep2TyVar ] $           mkSpecForAllTys [ openAlphaTyVar, openBetaTyVar ]      $           mkVisFunTyMany fun_ty fun_ty@@ -1929,6 +1957,9 @@           Var body `App` Var x'     arity = 2 +    concs = mkRepPolyIdConcreteTyVars+        [((openAlphaTy, Argument 2 Top), runtimeRep1TyVar)]+ ---------------------------------------------------------------------- {- Note [Wired-in Ids for rebindable syntax] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1953,7 +1984,7 @@ --   is () and not undefined -- Important that is is multiplicity-polymorphic (test linear/should_compile/OldList) leftSectionId :: Id-leftSectionId = pcMiscPrelId leftSectionName ty info+leftSectionId = pcRepPolyId leftSectionName ty concs info   where     info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma                        `setUnfoldingInfo`  mkCompulsoryUnfolding rhs@@ -1971,6 +2002,9 @@     body = mkLams [f,xmult] $ App (Var f) (Var xmult)     arity = 2 +    concs = mkRepPolyIdConcreteTyVars+            [((openAlphaTy, Argument 2 Top), runtimeRep1TyVar)]+ -- See Note [Left and right sections] in GHC.Rename.Expr -- See Note [Wired-in Ids for rebindable syntax] --   rightSection :: forall r1 r2 r3 n1 n2 (a::TYPE r1) (b::TYPE r2) (c::TYPE r3).@@ -1978,7 +2012,7 @@ --   rightSection f y x = f x y -- Again, multiplicity polymorphism is important rightSectionId :: Id-rightSectionId = pcMiscPrelId rightSectionName ty info+rightSectionId = pcRepPolyId rightSectionName ty concs info   where     info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma                        `setUnfoldingInfo`  mkCompulsoryUnfolding rhs@@ -2001,10 +2035,15 @@     body = mkLams [f,ymult,xmult] $ mkVarApps (Var f) [xmult,ymult]     arity = 3 +    concs =+      mkRepPolyIdConcreteTyVars+        [ ((openAlphaTy, Argument 3 Top), runtimeRep1TyVar)+        , ((openBetaTy , Argument 2 Top), runtimeRep2TyVar)]+ --------------------------------------------------------------------------------  coerceId :: Id-coerceId = pcMiscPrelId coerceName ty info+coerceId = pcRepPolyId coerceName ty concs info   where     info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma                        `setUnfoldingInfo`  mkCompulsoryUnfolding rhs@@ -2028,6 +2067,9 @@           mkWildCase (Var eqR) (unrestricted eqRTy) b $           [Alt (DataAlt coercibleDataCon) [eq] (Cast (Var x) (mkCoVarCo eq))] +    concs = mkRepPolyIdConcreteTyVars+            [((mkTyVarTy av, Argument 1 Top), rv)]+ {- Note [seqId magic] ~~~~~~~~~~~~~~~~~~@@ -2195,7 +2237,7 @@ * To defeat the specialiser when we have incoherent instances.   See Note [Coherence and specialisation: overview] in GHC.Core.InstEnv. -Note [The oneShot function]+Note [oneShot magic] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ In the context of making left-folds fuse somewhat okish (see ticket #7994 and Note [Left folds via right fold]) it was determined that it would be useful@@ -2220,13 +2262,19 @@  --> \x[oneshot] e[x/y] which is what we want. -It is only effective if the one-shot info survives as long as possible; in-particular it must make it into the interface in unfoldings. See Note [Preserve-OneShotInfo] in GHC.Core.Tidy.- Also see https://gitlab.haskell.org/ghc/ghc/wikis/one-shot. +Wrinkles:+(OS1)  It is only effective if the one-shot info survives as long as possible; in+       particular it must make it into the interface in unfoldings. See Note [Preserve+       OneShotInfo] in GHC.Core.Tidy. +(OS2) (oneShot (error "urk")) rewrites to+           \x[oneshot]. error "urk" x+      thereby hiding the `error` under a lambda, which might be surprising,+      particularly if you have `-fpedantic-bottoms` on.  See #24296.++ ------------------------------------------------------------- @realWorld#@ used to be a magic literal, \tr{void#}.  If things get nasty as-is, change it back to a literal (@Literal@).@@ -2277,3 +2325,28 @@ pcMiscPrelId :: Name -> Type -> IdInfo -> Id pcMiscPrelId name ty info   = mkVanillaGlobalWithInfo name ty info++pcRepPolyId :: Name -> Type -> (Name -> ConcreteTyVars) -> IdInfo -> Id+pcRepPolyId name ty conc_tvs info =+  mkGlobalId (RepPolyId $ conc_tvs name) name ty info++-- | Directly specify which outer forall'd type variables of a+-- representation-polymorphic 'Id' such become concrete metavariables when+-- instantiated.+mkRepPolyIdConcreteTyVars :: [((Type, Position Neg), TyVar)]+                               -- ^ ((ty, pos), tv)+                               -- 'ty' is the type on which the representation-polymorphism+                               -- check is done+                               -- 'tv' is the type variable we are checking for concreteness+                               -- (usually the kind of 'ty')+                               -- 'pos' is the position of 'ty' in the+                               -- type of the 'Id'+                          -> Name -- ^ 'Name' of the rep-poly 'Id'+                          -> ConcreteTyVars+mkRepPolyIdConcreteTyVars vars nm =+  mkNameEnv [ (tyVarName tv, mk_conc_frr ty pos)+            | ((ty,pos), tv) <- vars ]+  where+    mk_conc_frr ty pos =+      ConcreteFRR $ FixedRuntimeRepOrigin ty+                  $ FRRRepPolyId nm RepPolyFunction pos
compiler/GHC/Types/Literal.hs view
@@ -136,8 +136,8 @@   | LitRubbish                  -- ^ A nonsense value; See Note [Rubbish literals].       TypeOrConstraint          -- t_or_c: whether this is a type or a constraint       RuntimeRepType            -- rr: a type of kind RuntimeRep-      -- The type of the literal is forall (a:TYPE rr). a-      --                         or forall (a:CONSTRAINT rr). a+      -- The type of the literal is forall (a::TYPE rr). a+      --                         or forall (a::CONSTRAINT rr). a       --       -- INVARIANT: the Type has no free variables       --    and so substitution etc can ignore it
compiler/GHC/Types/Name.hs view
@@ -67,6 +67,8 @@         isTyVarName, isTyConName, isDataConName,         isValName, isVarName, isDynLinkName, isFieldName,         isWiredInName, isWiredIn, isBuiltInSyntax, isTupleTyConName,+        isSumTyConName,+        isUnboxedTupleDataConLikeName,         isHoleName,         wiredInNameTyThing_maybe,         nameIsLocalOrFrom, nameIsExternalOrFrom, nameIsHomePackage,@@ -102,12 +104,13 @@ import GHC.Data.FastString import GHC.Utils.Outputable import GHC.Utils.Panic+import GHC.OldList (intersperse)  import Control.DeepSeq import Data.Data import qualified Data.Semigroup as S-import GHC.Types.Basic (Boxity(Boxed))-import GHC.Builtin.Uniques (isTupleTyConUnique)+import GHC.Types.Basic (Boxity(Boxed, Unboxed))+import GHC.Builtin.Uniques (isTupleTyConUnique, isSumTyConUnique, isTupleDataConLikeUnique)  {- ************************************************************************@@ -143,12 +146,16 @@ -- See Note [About the NameSorts] data NameSort   = External Module+        -- Either an import from another module+        -- or a top-level name+        -- See Note [About the NameSorts]    | WiredIn Module TyThing BuiltInSyntax         -- A variant of External, for wired-in things -  | Internal            -- A user-defined Id or TyVar+  | Internal            -- A user-defined local Id or TyVar                         -- defined in the module being compiled+                        -- See Note [About the NameSorts]    | System              -- A system-defined Id or TyVar.  Typically the                         -- OccName is very uninformative (like 's')@@ -185,18 +192,18 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider this wired-in Name in GHC.Builtin.Names: -   int8TyConName = tcQual gHC_INT  (fsLit "Int8")  int8TyConKey+   int8TyConName = tcQual gHC_INTERNAL_INT  (fsLit "Int8")  int8TyConKey  Ultimately this turns into something like: -   int8TyConName = Name gHC_INT (mkOccName ..."Int8") int8TyConKey+   int8TyConName = Name gHC_INTERNAL_INT (mkOccName ..."Int8") int8TyConKey  So a comparison like `x == int8TyConName` will turn into `getUnique x == int8TyConKey`, nice and efficient.  But if the `n_occ` field is strict, that definition will look like: -   int8TyCOnName = case (mkOccName..."Int8") of occ ->-                   Name gHC_INT occ int8TyConKey+   int8TyConName = case (mkOccName..."Int8") of occ ->+                   Name gHC_INTERNAL_INT occ int8TyConKey  and now the comparison will not optimise.  This matters even more when there are numerous comparisons (see #19386):@@ -213,21 +220,32 @@ {- Note [About the NameSorts] ~~~~~~~~~~~~~~~~~~~~~~~~~~+1.  Initially:+    * All types, classes, data constructors get Extenal Names+    * Top-level Ids (including locally-defined ones) get External Names,+    * All other local (non-top-level) Ids get Internal names -1.  Initially, top-level Ids (including locally-defined ones) get External names,-    and all other local Ids get Internal names+2.  In the Tidy phase (GHC.Iface.Tidy):+      * An Id that is "externally-visible" is given an External Name,+        even if the name was Internal up to that point+      * An Id that is not externally visible is given an Internal Name.+        even if the name was External up to that point+    See GHC.Iface.Tidy.tidyTopName -2.  In any invocation of GHC, an External Name for "M.x" has one and only one+    An Id is externally visible if it is mentioned in the interface file; e.g.+        - it is exported+        - it is mentioned in an unfolding+    See GHC.Iface.Tidy.chooseExternalIds++3.  In any invocation of GHC, an External Name for "M.x" has one and only one     unique.  This unique association is ensured via the Name Cache;     see Note [The Name Cache] in GHC.Iface.Env. -3.  Things with a External name are given C static labels, so they finally-    appear in the .o file's symbol table.  They appear in the symbol table-    in the form M.n.  If originally-local things have this property they-    must be made @External@ first.+4.  In code generation, things with a External name are given C static+    labels, so they finally appear in the .o file's symbol table.  They+    appear in the symbol table in the form M.n. That is why+    externally-visible things are made External (see (2) above). -4.  In the tidy-core phase, a External that is not visible to an importer-    is changed to Internal, and a Internal that is visible is changed to External  5.  A System Name differs in the following ways:         a) has unique attached when printing dumps@@ -239,13 +257,13 @@     If any desugarer sys-locals have survived that far, they get changed to     "ds1", "ds2", etc. -Built-in syntax => It's a syntactic form, not "in scope" (e.g. [])+6. A WiredIn Name is used for things (Id, TyCon) that are fully known to the compiler,+   not read from an interface file. E.g. Bool, True, Int, Float, and many others. -Wired-in thing  => The thing (Id, TyCon) is fully known to the compiler,-                   not read from an interface file.-                   E.g. Bool, True, Int, Float, and many others+   A WiredIn Name contains contains a TyThing, so we don't have to look it up. -All built-in syntax is for wired-in things.+   The BuiltInSyntax flag => It's a syntactic form, not "in scope" (e.g. [])+   All built-in syntax thigs are WiredIn. -}  instance HasOccName Name where@@ -294,6 +312,15 @@ isTupleTyConName :: Name -> Bool isTupleTyConName = isJust . isTupleTyConUnique . getUnique +isSumTyConName :: Name -> Bool+isSumTyConName = isJust . isSumTyConUnique . getUnique++-- | This matches a datacon as well as its worker and promoted tycon.+isUnboxedTupleDataConLikeName :: Name -> Bool+isUnboxedTupleDataConLikeName n+  | Just (Unboxed, _) <- isTupleDataConLikeUnique (getUnique n) = True+  | otherwise = False+ isExternalName (Name {n_sort = External _})    = True isExternalName (Name {n_sort = WiredIn _ _ _}) = True isExternalName _                               = False@@ -350,14 +377,26 @@  -- Return the pun for a name if available. -- Used for pretty-printing under ListTuplePuns.+-- Arity 1 is skipped here because unary tuples have no prefix representation,+-- since that is occupied by the unit tuple. namePun_maybe :: Name -> Maybe FastString namePun_maybe name   | getUnique name == getUnique listTyCon = Just (fsLit "[]") -  | Just (Boxed, ar) <- isTupleTyConUnique (getUnique name)-  , ar /= 1 = Just (fsLit $ '(' : commas ar ++ ")")+  | Just (boxity, ar) <- isTupleTyConUnique (getUnique name)+  , ar /= 1 =+    let+      (lpar, rpar) =+        case boxity of+          Boxed -> ("(", ")")+          Unboxed -> ("(#", "#)")+    in Just (fsLit $ lpar ++ commas ar ++ rpar)++  | Just ar <- isSumTyConUnique (getUnique name)+  = Just (fsLit $ "(# " ++ bars ar ++ " #)")   where     commas ar = replicate (ar-1) ','+    bars ar = intersperse ' ' (replicate (ar-1) '|')  namePun_maybe _ = Nothing @@ -591,7 +630,7 @@ -- | __Caution__: This instance is implemented via `nonDetCmpUnique`, which -- means that the ordering is not stable across deserialization or rebuilds. ----- See `nonDetCmpUnique` for further information, and trac #15240 for a bug+-- See `nonDetCmpUnique` for further information, and #15240 for a bug -- caused by improper use of this instance.  -- For a deterministic lexicographic ordering, use `stableNameCmp`.
compiler/GHC/Types/Name/Cache.hs view
@@ -31,7 +31,6 @@ import Control.Monad import Control.Applicative - {-  Note [The Name Cache]@@ -104,7 +103,7 @@  lookupOrigNameCache :: OrigNameCache -> Module -> OccName -> Maybe Name lookupOrigNameCache nc mod occ-  | mod == gHC_TYPES || mod == gHC_PRIM || mod == gHC_TUPLE_PRIM+  | mod == gHC_TYPES || mod == gHC_PRIM || mod == gHC_INTERNAL_TUPLE || mod == gHC_CLASSES   , Just name <- isBuiltInOcc_maybe occ <|> isPunOcc_maybe mod occ   =     -- See Note [Known-key names], 3(c) in GHC.Builtin.Names         -- Special case for tuples; there are too many
compiler/GHC/Types/Name/Env.hs view
@@ -5,10 +5,6 @@ \section[NameEnv]{@NameEnv@: name environments} -} --{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE ScopedTypeVariables #-}- module GHC.Types.Name.Env (         -- * Var, Id and TyVar environments (maps)         NameEnv,
compiler/GHC/Types/Name/Occurrence.hs view
@@ -3,9 +3,6 @@ (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -} ---{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE BangPatterns #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE OverloadedStrings #-}@@ -80,7 +77,7 @@          isVarOcc, isTvOcc, isTcOcc, isDataOcc, isDataSymOcc, isSymOcc, isValOcc,         isFieldOcc, fieldOcc_maybe,-        parenSymOcc, startsWithUnderscore,+        parenSymOcc, startsWithUnderscore, isUnderscore,          isTcClsNameSpace, isTvNameSpace, isDataConNameSpace, isVarNameSpace, isValNameSpace,         isFieldNameSpace, isTermVarOrFieldNameSpace,@@ -519,7 +516,9 @@ -- See Note [Promotion] in GHC.Rename.Env. promoteOccName :: OccName -> Maybe OccName promoteOccName (OccName space name) = do-  space' <- promoteNameSpace space+  promoted_space <- promoteNameSpace space+  let tyop   = isTvNameSpace promoted_space && isLexVarSym name+      space' = if tyop then tcClsName else promoted_space   -- special case for type operators (#24570)   return $ OccName space' name  {- | Other names in the compiler add additional information to an OccName.@@ -817,7 +816,7 @@  -------------------------------------------------------------------------------- -type OccSet = FastStringEnv (UniqSet NameSpace)+newtype OccSet = OccSet (FastStringEnv (UniqSet NameSpace))  emptyOccSet       :: OccSet unitOccSet        :: OccName -> OccSet@@ -829,15 +828,15 @@ elemOccSet        :: OccName -> OccSet -> Bool isEmptyOccSet     :: OccSet -> Bool -emptyOccSet       = emptyFsEnv-unitOccSet (OccName ns s) = unitFsEnv s (unitUniqSet ns)+emptyOccSet       = OccSet emptyFsEnv+unitOccSet (OccName ns s) = OccSet $ unitFsEnv s (unitUniqSet ns) mkOccSet          = extendOccSetList emptyOccSet-extendOccSet      occs (OccName ns s) = extendFsEnv occs s (unitUniqSet ns)-extendOccSetList  = foldl extendOccSet-unionOccSets      = plusFsEnv_C unionUniqSets+extendOccSet      (OccSet occs) (OccName ns s) = OccSet $ extendFsEnv occs s (unitUniqSet ns)+extendOccSetList  = foldl' extendOccSet+unionOccSets      (OccSet xs) (OccSet ys) = OccSet $ plusFsEnv_C unionUniqSets xs ys unionManyOccSets  = foldl' unionOccSets emptyOccSet-elemOccSet (OccName ns s) occs = maybe False (elementOfUniqSet ns) $ lookupFsEnv occs s-isEmptyOccSet     = isNullUFM+elemOccSet (OccName ns s) (OccSet occs) = maybe False (elementOfUniqSet ns) $ lookupFsEnv occs s+isEmptyOccSet     (OccSet occs) = isNullUFM occs  {- ************************************************************************@@ -911,6 +910,9 @@ startsWithUnderscore occ = case unpackFS (occNameFS occ) of   '_':_ -> True   _     -> False++isUnderscore :: OccName -> Bool+isUnderscore occ = occNameFS occ == fsLit "_"  {- ************************************************************************
compiler/GHC/Types/Name/Ppr.hs view
@@ -125,6 +125,7 @@             , listTyConName             , manyDataConName ]           || isJust (isTupleTyOcc_maybe mod occ)+          || isJust (isSumTyOcc_maybe mod occ)          right_name gre = greDefinitionModule gre == Just mod 
compiler/GHC/Types/Name/Reader.hs view
@@ -803,7 +803,7 @@                                 , recFieldCons  = fl_cons } ]   where     -- We are given a map taking a constructor to its fields, but we want-    -- a map taking a field to the contructors which have it.+    -- a map taking a field to the constructors which have it.     -- We thus need to convert [(Con, [Field])] into [(Field, [Con])].     flds = Map.toList          $ Map.fromListWith unionUniqSets
compiler/GHC/Types/Name/Set.hs view
@@ -22,7 +22,7 @@         -- ** Manipulating sets of free variables         isEmptyFVs, emptyFVs, plusFVs, plusFV,         mkFVs, addOneFV, unitFV, delFV, delFVs,-        intersectFVs,+        intersectFVs, intersectsFVs,          -- * Defs and uses         Defs, Uses, DefUse, DefUses,@@ -127,6 +127,7 @@ delFV    :: Name -> FreeVars -> FreeVars delFVs   :: [Name] -> FreeVars -> FreeVars intersectFVs :: FreeVars -> FreeVars -> FreeVars+intersectsFVs :: FreeVars -> FreeVars -> Bool  isEmptyFVs :: NameSet -> Bool isEmptyFVs  = isEmptyNameSet@@ -139,6 +140,7 @@ delFV n s   = delFromNameSet s n delFVs ns s = delListFromNameSet s ns intersectFVs = intersectNameSet+intersectsFVs = intersectsNameSet  {- ************************************************************************
compiler/GHC/Types/RepType.hs view
@@ -4,22 +4,22 @@ module GHC.Types.RepType   (     -- * Code generator views onto Types-    UnaryType, NvUnaryType, isNvUnaryType,+    UnaryType, NvUnaryType, isNvUnaryRep,     unwrapType,      -- * Predicates on types     isZeroBitTy,      -- * Type representation for the code generator-    typePrimRep, typePrimRep1,-    runtimeRepPrimRep, typePrimRepArgs,+    typePrimRep, typePrimRep1, typePrimRepU,+    runtimeRepPrimRep,     PrimRep(..), primRepToRuntimeRep, primRepToType,     countFunRepArgs, countConRepArgs, dataConRuntimeRepStrictness,-    tyConPrimRep, tyConPrimRep1,+    tyConPrimRep,     runtimeRepPrimRep_maybe, kindPrimRep_maybe, typePrimRep_maybe,      -- * Unboxed sum representation type-    ubxSumRepType, layoutUbxSum, typeSlotTy, SlotTy (..),+    ubxSumRepType, layoutUbxSum, repSlotTy, SlotTy (..),     slotPrimRep, primRepSlot,      -- * Is this type known to be data?@@ -38,7 +38,7 @@ import GHC.Core.Type import {-# SOURCE #-} GHC.Builtin.Types ( anyTypeOfKind   , vecRepDataConTyCon-  , liftedRepTy, unliftedRepTy, zeroBitRepTy+  , liftedRepTy, unliftedRepTy   , intRepDataConTy   , int8RepDataConTy, int16RepDataConTy, int32RepDataConTy, int64RepDataConTy   , wordRepDataConTy@@ -76,21 +76,9 @@      --   UnaryType   : never an unboxed tuple or sum;      --                 can be Void# or (# #) -isNvUnaryType :: Type -> Bool-isNvUnaryType ty-  | [_] <- typePrimRep ty-  = True-  | otherwise-  = False---- INVARIANT: the result list is never empty.-typePrimRepArgs :: HasDebugCallStack => Type -> NonEmpty PrimRep-typePrimRepArgs ty-  = case reps of-      [] -> VoidRep :| []-      (x:xs) ->   x :| xs-  where-    reps = typePrimRep ty+isNvUnaryRep :: [PrimRep] -> Bool+isNvUnaryRep [_] = True+isNvUnaryRep _ = False  -- | Gets rid of the stuff that prevents us from understanding the -- runtime representation of a type. Including:@@ -132,7 +120,10 @@   = 0 countFunRepArgs n ty   | FunTy _ _ arg res <- unwrapType ty-  = length (typePrimRepArgs arg) + countFunRepArgs (n - 1) res+  = (length (typePrimRep arg) `max` 1)+    + countFunRepArgs (n - 1) res+    -- If typePrimRep returns [] that means a void arg,+    -- and we count 1 for that   | otherwise   = pprPanic "countFunRepArgs: arity greater than type can handle" (ppr (n, ty, typePrimRep ty)) @@ -163,21 +154,18 @@      go repMarks repTys []   where     go (mark:marks) (ty:types) out_marks-      -- Zero-width argument, mark is irrelevant at runtime.-      |  -- pprTrace "VoidTy" (ppr ty) $-        (isZeroBitTy ty)-      = go marks types out_marks-      -- Single rep argument, e.g. Int-      -- Keep mark as-is-      | [_] <- reps-      = go marks types (mark:out_marks)-      -- Multi-rep argument, e.g. (# Int, Bool #) or (# Int | Bool #)-      -- Make up one non-strict mark per runtime argument.-      | otherwise -- TODO: Assert real_reps /= null-      = go marks types ((replicate (length real_reps) NotMarkedStrict)++out_marks)+      = case reps of+          -- Zero-width argument, mark is irrelevant at runtime.+          [] -> -- pprTrace "VoidTy" (ppr ty) $+                go marks types out_marks+          -- Single rep argument, e.g. Int+          -- Keep mark as-is+          [_] -> go marks types (mark:out_marks)+          -- Multi-rep argument, e.g. (# Int, Bool #) or (# Int | Bool #)+          -- Make up one non-strict mark per runtime argument.+          _ -> go marks types ((replicate (length reps) NotMarkedStrict)++out_marks)       where         reps = typePrimRep ty-        real_reps = filter (not . isVoidRep) $ reps     go [] [] out_marks = reverse out_marks     go _m _t _o = pprPanic "dataConRuntimeRepStrictness2" (ppr dc $$ ppr _m $$ ppr _t $$ ppr _o) @@ -307,14 +295,13 @@   ppr FloatSlot       = text "FloatSlot"   ppr (VecSlot n e)   = text "VecSlot" <+> ppr n <+> ppr e -typeSlotTy :: UnaryType -> Maybe SlotTy-typeSlotTy ty = case typePrimRep ty of+repSlotTy :: [PrimRep] -> Maybe SlotTy+repSlotTy reps = case reps of                   [] -> Nothing                   [rep] -> Just (primRepSlot rep)-                  reps -> pprPanic "typeSlotTy" (ppr ty $$ ppr reps)+                  _ -> pprPanic "repSlotTy" (ppr reps)  primRepSlot :: PrimRep -> SlotTy-primRepSlot VoidRep     = pprPanic "primRepSlot" (text "No slot for VoidRep") primRepSlot (BoxedRep mlev) = case mlev of   Nothing       -> panic "primRepSlot: levity polymorphic BoxedRep"   Just Lifted   -> PtrLiftedSlot@@ -397,8 +384,7 @@ enumerates all the possibilities.  data PrimRep-  = VoidRep       -- See Note [VoidRep]-  | LiftedRep     -- ^ Lifted pointer+  = LiftedRep     -- ^ Lifted pointer   | UnliftedRep   -- ^ Unlifted pointer   | Int8Rep       -- ^ Signed, 8-bit value   | Int16Rep      -- ^ Signed, 16-bit value@@ -447,19 +433,38 @@  Note [VoidRep] ~~~~~~~~~~~~~~-PrimRep contains a constructor VoidRep, while RuntimeRep does-not. Yet representations are often characterised by a list of PrimReps,-where a void would be denoted as []. (See also Note [RuntimeRep and PrimRep].)+PrimRep is used to denote one primitive representation.+Because of unboxed tuples and sums, the representation of a value+in general is a list of PrimReps. (See also Note [RuntimeRep and PrimRep].) -However, after the unariser, all identifiers have exactly one PrimRep, but-void arguments still exist. Thus, PrimRep includes VoidRep to describe these-binders. Perhaps post-unariser representations (which need VoidRep) should be-a different type than pre-unariser representations (which use a list and do-not need VoidRep), but we have what we have.+For example:+    typePrimRep Int#             = [IntRep]+    typePrimRep Int              = [LiftedRep]+    typePrimRep (# Int#, Int# #) = [IntRep,IntRep]+    typePrimRep (# #)            = []+    typePrimRep (State# s)       = [] -RuntimeRep instead uses TupleRep '[] to denote a void argument. When-converting a TupleRep '[] into a list of PrimReps, we get an empty list.+After the unariser, all identifiers have at most one PrimRep+(that is, the [PrimRep] for each identifier is empty or a singleton list).+More precisely: typePrimRep1 will succeed (not crash) on every binder+and argument type.+(See Note [Post-unarisation invariants] in GHC.Stg.Unarise.) +Thus, we have++1. typePrimRep :: Type -> [PrimRep]+   which returns the list++2. typePrimRepU :: Type -> PrimRep+   which asserts that the type has exactly one PrimRep and returns it++3. typePrimRep1 :: Type -> PrimOrVoidRep+   data PrimOrVoidRep = VoidRep | NVRep PrimRep+   which asserts that the type either has exactly one PrimRep or is void.++Likewise, we have idPrimRepU and idPrimRep1, stgArgRepU and stgArgRep1,+which have analogous preconditions.+ Note [Getting from RuntimeRep to PrimRep] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ General info on RuntimeRep and PrimRep is in Note [RuntimeRep and PrimRep].@@ -552,17 +557,22 @@ typePrimRep_maybe :: Type -> Maybe [PrimRep] typePrimRep_maybe ty = kindPrimRep_maybe (typeKind ty) --- | Like 'typePrimRep', but assumes that there is precisely one 'PrimRep' output;+-- | Like 'typePrimRep', but assumes that there is at most one 'PrimRep' output; -- an empty list of PrimReps becomes a VoidRep. -- This assumption holds after unarise, see Note [Post-unarisation invariants]. -- Before unarise it may or may not hold. -- See also Note [RuntimeRep and PrimRep] and Note [VoidRep]-typePrimRep1 :: HasDebugCallStack => UnaryType -> PrimRep+typePrimRep1 :: HasDebugCallStack => UnaryType -> PrimOrVoidRep typePrimRep1 ty = case typePrimRep ty of   []    -> VoidRep-  [rep] -> rep+  [rep] -> NVRep rep   _     -> pprPanic "typePrimRep1" (ppr ty $$ ppr (typePrimRep ty)) +typePrimRepU :: HasDebugCallStack => NvUnaryType -> PrimRep+typePrimRepU ty = case typePrimRep ty of+  [rep] -> rep+  _     -> pprPanic "typePrimRepU" (ppr ty $$ ppr (typePrimRep ty))+ -- | Find the runtime representation of a 'TyCon'. Defined here to -- avoid module loops. Returns a list of the register shapes necessary. -- See also Note [Getting from RuntimeRep to PrimRep]@@ -573,15 +583,6 @@   where     res_kind = tyConResKind tc --- | Like 'tyConPrimRep', but assumed that there is precisely zero or--- one 'PrimRep' output--- See also Note [Getting from RuntimeRep to PrimRep] and Note [VoidRep]-tyConPrimRep1 :: HasDebugCallStack => TyCon -> PrimRep-tyConPrimRep1 tc = case tyConPrimRep tc of-  []    -> VoidRep-  [rep] -> rep-  _     -> pprPanic "tyConPrimRep1" (ppr tc $$ ppr (tyConPrimRep tc))- -- | Take a kind (of shape @TYPE rr@) and produce the 'PrimRep's -- of values of types of this kind. -- See also Note [Getting from RuntimeRep to PrimRep]@@ -609,8 +610,6 @@ -- | Take a type of kind RuntimeRep and extract the list of 'PrimRep' that -- it encodes. See also Note [Getting from RuntimeRep to PrimRep]. -- The @[PrimRep]@ is the final runtime representation /after/ unarisation.------ The result does not contain any VoidRep. runtimeRepPrimRep :: HasDebugCallStack => SDoc -> RuntimeRepType -> [PrimRep] runtimeRepPrimRep doc rr_ty   | Just rr_ty' <- coreView rr_ty@@ -623,8 +622,7 @@  -- | Take a type of kind RuntimeRep and extract the list of 'PrimRep' that -- it encodes. See also Note [Getting from RuntimeRep to PrimRep].--- The @[PrimRep]@ is the final runtime representation /after/ unarisation--- and does not contain VoidRep.+-- The @[PrimRep]@ is the final runtime representation /after/ unarisation. -- -- Returns @Nothing@ if rep can't be determined. Eg. levity polymorphic types. runtimeRepPrimRep_maybe :: Type -> Maybe [PrimRep]@@ -640,7 +638,6 @@ -- | Convert a 'PrimRep' to a 'Type' of kind RuntimeRep primRepToRuntimeRep :: PrimRep -> RuntimeRepType primRepToRuntimeRep rep = case rep of-  VoidRep       -> zeroBitRepTy   BoxedRep mlev -> case mlev of     Nothing       -> panic "primRepToRuntimeRep: levity polymorphic BoxedRep"     Just Lifted   -> liftedRepTy
compiler/GHC/Types/SourceText.hs view
@@ -305,21 +305,17 @@                        { sl_st :: SourceText, -- literal raw source.                                               -- See Note [Literal source text]                          sl_fs :: FastString, -- literal string value-                         sl_tc :: Maybe RealSrcSpan -- Location of+                         sl_tc :: Maybe NoCommentsLocation+                                                    -- Location of                                                     -- possible                                                     -- trailing comma                        -- AZ: if we could have a LocatedA                        -- StringLiteral we would not need sl_tc, but                        -- that would cause import loops.--                       -- AZ:2: sl_tc should be an EpaAnchor, to allow-                       -- editing and reprinting the AST. Need a more-                       -- robust solution.-                        } deriving Data  instance Eq StringLiteral where   (StringLiteral _ a _) == (StringLiteral _ b _) = a == b  instance Outputable StringLiteral where-  ppr sl = pprWithSourceText (sl_st sl) (ftext $ sl_fs sl)+  ppr sl = pprWithSourceText (sl_st sl) (doubleQuotes $ ftext $ sl_fs sl)
compiler/GHC/Types/SrcLoc.hs view
@@ -109,6 +109,10 @@         mkSrcSpanPs,         combineRealSrcSpans,         psLocatedToLocated,++        -- * Exact print locations+        EpaLocation'(..), NoCommentsLocation, NoComments(..),+        DeltaPos(..), deltaPos, getDeltaLine,     ) where  import GHC.Prelude@@ -426,12 +430,14 @@   json (RealSrcSpan rss _) = json rss  instance ToJson RealSrcSpan where-  json (RealSrcSpan'{..}) = JSObject [ ("file", JSString (unpackFS srcSpanFile))-                                     , ("startLine", JSInt srcSpanSLine)-                                     , ("startCol", JSInt srcSpanSCol)-                                     , ("endLine", JSInt srcSpanELine)-                                     , ("endCol", JSInt srcSpanECol)+  json (RealSrcSpan'{..}) = JSObject [ ("file", JSString (unpackFS srcSpanFile)),+                                       ("start", start),+                                       ("end", end)                                      ]+    where start = JSObject [ ("line", JSInt srcSpanSLine),+                             ("column", JSInt srcSpanSCol) ]+          end = JSObject [ ("line", JSInt srcSpanELine),+                           ("column", JSInt srcSpanECol) ]  instance NFData SrcSpan where   rnf x = x `seq` ()@@ -892,3 +898,70 @@  mkSrcSpanPs :: PsSpan -> SrcSpan mkSrcSpanPs (PsSpan r b) = RealSrcSpan r (Strict.Just b)++-- ---------------------------------------------------------------------+-- The following section contains basic types related to exact printing.+-- See https://gitlab.haskell.org/ghc/ghc/wikis/api-annotations for+-- details.+-- This is only s subset, to prevent import loops. The balance are in+-- GHC.Parser.Annotation+-- ---------------------------------------------------------------------+++-- | The anchor for an @'AnnKeywordId'@. The Parser inserts the+-- @'EpaSpan'@ variant, giving the exact location of the original item+-- in the parsed source.  This can be replaced by the @'EpaDelta'@+-- version, to provide a position for the item relative to the end of+-- the previous item in the source.  This is useful when editing an+-- AST prior to exact printing the changed one. The list of comments+-- in the @'EpaDelta'@ variant captures any comments between the prior+-- output and the thing being marked here, since we cannot otherwise+-- sort the relative order.++data EpaLocation' a = EpaSpan !SrcSpan+                    | EpaDelta !DeltaPos !a+                    deriving (Data,Eq,Show)++type NoCommentsLocation = EpaLocation' NoComments++data NoComments = NoComments+  deriving (Data,Eq,Ord,Show)++-- | Spacing between output items when exact printing.  It captures+-- the spacing from the current print position on the page to the+-- position required for the thing about to be printed.  This is+-- either on the same line in which case is is simply the number of+-- spaces to emit, or it is some number of lines down, with a given+-- column offset.  The exact printing algorithm keeps track of the+-- column offset pertaining to the current anchor position, so the+-- `deltaColumn` is the additional spaces to add in this case.  See+-- https://gitlab.haskell.org/ghc/ghc/wikis/api-annotations for+-- details.+data DeltaPos+  = SameLine { deltaColumn :: !Int }+  | DifferentLine+      { deltaLine   :: !Int, -- ^ deltaLine should always be > 0+        deltaColumn :: !Int+      } deriving (Show,Eq,Ord,Data)++-- | Smart constructor for a 'DeltaPos'. It preserves the invariant+-- that for the 'DifferentLine' constructor 'deltaLine' is always > 0.+deltaPos :: Int -> Int -> DeltaPos+deltaPos l c = case l of+  0 -> SameLine c+  _ -> DifferentLine l c++getDeltaLine :: DeltaPos -> Int+getDeltaLine (SameLine _) = 0+getDeltaLine (DifferentLine r _) = r++instance Outputable NoComments where+  ppr NoComments = text "NoComments"++instance (Outputable a) => Outputable (EpaLocation' a) where+  ppr (EpaSpan r) = text "EpaSpan" <+> ppr r+  ppr (EpaDelta d cs) = text "EpaDelta" <+> ppr d <+> ppr cs++instance Outputable DeltaPos where+  ppr (SameLine c) = text "SameLine" <+> ppr c+  ppr (DifferentLine l c) = text "DifferentLine" <+> ppr l <+> ppr c
compiler/GHC/Types/Tickish.hs view
@@ -134,6 +134,7 @@                                 --                                 -- Careful about substitution!  See                                 -- Note [substTickish] in "GHC.Core.Subst".+    , breakpointModule :: Module     }    -- | A source note.
compiler/GHC/Types/TyThing.hs view
@@ -356,11 +356,11 @@             RecSelData   tc ->               let dcs = map RealDataCon $ tyConDataCons tc in               case conLikesWithFields dcs [flLabel fl] of-                [] -> pprPanic "tyThingGREInfo: no DataCons with this FieldLabel" $+                ([], _) -> pprPanic "tyThingGREInfo: no DataCons with this FieldLabel" $                         vcat [ text "id:"  <+> ppr id                              , text "fl:"  <+> ppr fl                              , text "dcs:" <+> ppr dcs ]-                cons -> mkUniqSet $ map conLikeConLikeName cons+                (cons, _) -> mkUniqSet $ map conLikeConLikeName cons        in IAmRecField $             RecFieldInfo               { recFieldLabel = fl
compiler/GHC/Types/TyThing/Ppr.hs view
@@ -145,17 +145,25 @@ -- parts omitted. pprTyThingInContext :: ShowSub -> TyThing -> SDoc pprTyThingInContext show_sub thing-  = go [] thing+  = case parents thing of+      -- If there are no parents print everything.+      [] -> print_it Nothing thing+      -- If `thing` has a parent, print the parent and only its child `thing`+      thing':rest -> let subs = map getOccName (thing:rest)+                         filt = (`elem` subs)+                     in print_it (Just filt) thing'   where-    go ss thing-      = case tyThingParent_maybe thing of-          Just parent ->-            go (getOccName thing : ss) parent-          Nothing ->-            pprTyThing-              (show_sub { ss_how_much = ShowSome ss (AltPpr Nothing) })-              thing+    parents = go+      where+        go thing =+          case tyThingParent_maybe thing of+            Just parent -> parent : go parent+            Nothing     -> [] +    print_it :: Maybe (OccName -> Bool) -> TyThing -> SDoc+    print_it mb_filt thing =+      pprTyThing (show_sub { ss_how_much = ShowSome mb_filt (AltPpr Nothing) }) thing+ -- | Like 'pprTyThingInContext', but adds the defining location. pprTyThingInContextLoc :: TyThing -> SDoc pprTyThingInContextLoc tyThing@@ -171,8 +179,8 @@       pprIfaceDecl ss' (tyThingToIfaceDecl show_linear_types ty_thing)   where     ss' = case ss_how_much ss of-      ShowHeader (AltPpr Nothing)  -> ss { ss_how_much = ShowHeader ppr' }-      ShowSome xs (AltPpr Nothing) -> ss { ss_how_much = ShowSome xs ppr' }+      ShowHeader (AltPpr Nothing)    -> ss { ss_how_much = ShowHeader ppr' }+      ShowSome filt (AltPpr Nothing) -> ss { ss_how_much = ShowSome filt ppr' }       _                   -> ss      ppr' = AltPpr $ ppr_bndr $ getName ty_thing
compiler/GHC/Types/Unique.hs view
@@ -18,7 +18,7 @@ -}  {-# LANGUAGE CPP #-}-{-# LANGUAGE BangPatterns, MagicHash #-}+{-# LANGUAGE MagicHash #-}  module GHC.Types.Unique (         -- * Main data types
compiler/GHC/Types/Unique/DFM.hs view
@@ -212,13 +212,16 @@  addListToUDFM :: Uniquable key => UniqDFM key elt -> [(key,elt)] -> UniqDFM key elt addListToUDFM = foldl' (\m (k, v) -> addToUDFM m k v)+{-# INLINEABLE addListToUDFM #-}  addListToUDFM_Directly :: UniqDFM key elt -> [(Unique,elt)] -> UniqDFM key elt addListToUDFM_Directly = foldl' (\m (k, v) -> addToUDFM_Directly m k v)+{-# INLINEABLE addListToUDFM_Directly #-}  addListToUDFM_Directly_C   :: (elt -> elt -> elt) -> UniqDFM key elt -> [(Unique,elt)] -> UniqDFM key elt addListToUDFM_Directly_C f = foldl' (\m (k, v) -> addToUDFM_C_Directly f m k v)+{-# INLINEABLE addListToUDFM_Directly_C #-}  delFromUDFM :: Uniquable key => UniqDFM key elt -> key -> UniqDFM key elt delFromUDFM (UDFM m i) k = UDFM (M.delete (getKey $ getUnique k) m) i
compiler/GHC/Types/Unique/FM.hs view
@@ -65,6 +65,7 @@         intersectUFM_C,         disjointUFM,         equalKeysUFM,+        diffUFM,         nonDetStrictFoldUFM, nonDetFoldUFM, nonDetStrictFoldUFM_DirectlyM,         nonDetFoldWithKeyUFM,         nonDetStrictFoldUFM_Directly,@@ -139,9 +140,11 @@  listToUFM :: Uniquable key => [(key,elt)] -> UniqFM key elt listToUFM = foldl' (\m (k, v) -> addToUFM m k v) emptyUFM+{-# INLINEABLE listToUFM #-}  listToUFM_Directly :: [(Unique, elt)] -> UniqFM key elt listToUFM_Directly = foldl' (\m (u, v) -> addToUFM_Directly m u v) emptyUFM+{-# INLINEABLE listToUFM_Directly #-}  listToIdentityUFM :: Uniquable key => [key] -> UniqFM key key listToIdentityUFM = foldl' (\m x -> addToUFM m x x) emptyUFM@@ -152,6 +155,7 @@   -> [(key, elt)]   -> UniqFM key elt listToUFM_C f = foldl' (\m (k, v) -> addToUFM_C f m k v) emptyUFM+{-# INLINEABLE listToUFM_C #-}  addToUFM :: Uniquable key => UniqFM key elt -> key -> elt  -> UniqFM key elt addToUFM (UFM m) k v = UFM (M.insert (getKey $ getUnique k) v m)@@ -520,6 +524,28 @@ -- Determines whether two 'UniqFM's contain the same keys. equalKeysUFM :: UniqFM key a -> UniqFM key b -> Bool equalKeysUFM (UFM m1) (UFM m2) = liftEq (\_ _ -> True) m1 m2++-- | An edit on type @a@, relating an element of a container (like an entry in a+-- map or a line in a file) before and after.+data Edit a+  = Removed !a    -- ^ Element was removed from the container+  | Added !a      -- ^ Element was added to the container+  | Changed !a !a -- ^ Element was changed. Carries the values before and after+  deriving Eq++instance Outputable a => Outputable (Edit a) where+  ppr (Removed a) = text "-" <> ppr a+  ppr (Added a) = text "+" <> ppr a+  ppr (Changed l r) = ppr l <> text "->" <> ppr r++-- A very convient function to have for debugging:+-- | Computes the diff of two 'UniqFM's in terms of 'Edit's.+-- Equal points will not be present in the result map at all.+diffUFM :: Eq a => UniqFM key a -> UniqFM key a -> UniqFM key (Edit a)+diffUFM = mergeUFM both (mapUFM Removed) (mapUFM Added)+  where+    both x y | x == y    = Nothing+             | otherwise = Just $! Changed x y  -- Instances 
compiler/GHC/Types/Unique/Set.hs view
@@ -74,12 +74,14 @@  mkUniqSet :: Uniquable a => [a] -> UniqSet a mkUniqSet = foldl' addOneToUniqSet emptyUniqSet+{-# INLINEABLE mkUniqSet #-}  addOneToUniqSet :: Uniquable a => UniqSet a -> a -> UniqSet a addOneToUniqSet (UniqSet set) x = UniqSet (addToUFM set x x)  addListToUniqSet :: Uniquable a => UniqSet a -> [a] -> UniqSet a addListToUniqSet = foldl' addOneToUniqSet+{-# INLINEABLE addListToUniqSet #-}  delOneFromUniqSet :: Uniquable a => UniqSet a -> a -> UniqSet a delOneFromUniqSet (UniqSet s) a = UniqSet (delFromUFM s a)@@ -89,10 +91,12 @@  delListFromUniqSet :: Uniquable a => UniqSet a -> [a] -> UniqSet a delListFromUniqSet (UniqSet s) l = UniqSet (delListFromUFM s l)+{-# INLINEABLE delListFromUniqSet #-}  delListFromUniqSet_Directly :: UniqSet a -> [Unique] -> UniqSet a delListFromUniqSet_Directly (UniqSet s) l =     UniqSet (delListFromUFM_Directly s l)+{-# INLINEABLE delListFromUniqSet_Directly #-}  unionUniqSets :: UniqSet a -> UniqSet a -> UniqSet a unionUniqSets (UniqSet s) (UniqSet t) = UniqSet (plusUFM s t)
compiler/GHC/Types/Unique/Supply.hs view
@@ -3,7 +3,6 @@ (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -} -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE PatternSynonyms #-}@@ -45,15 +44,20 @@  #include "MachDeps.h" -#if MIN_VERSION_GLASGOW_HASKELL(9,1,0,0) && WORD_SIZE_IN_BITS == 64-import GHC.Word( Word64(..) )-import GHC.Exts( fetchAddWordAddr#, plusWord#, readWordOffAddr# )-#if MIN_VERSION_GLASGOW_HASKELL(9,3,0,0)-import GHC.Exts( wordToWord64# )+#if WORD_SIZE_IN_BITS != 64+#define NO_FETCH_ADD #endif++#if defined(NO_FETCH_ADD)+import GHC.Exts ( atomicCasWord64Addr#, eqWord64#, readWord64OffAddr# )+#else+import GHC.Exts( fetchAddWordAddr#, word64ToWord# ) #endif -#include "Unique.h"+import GHC.Exts ( Addr#, State#, Word64#, RealWorld )+import GHC.Int ( Int(..) )+import GHC.Word( Word64(..) )+import GHC.Exts( plusWord64#, int2Word#, wordToWord64# )  {- ************************************************************************@@ -228,25 +232,37 @@         (# s4, MkSplitUniqSupply (tag .|. u) x y #)         }}}} --- If a word is not 64 bits then we would need a fetchAddWord64Addr# primitive,--- which does not exist. So we fall back on the C implementation in that case.--#if !MIN_VERSION_GLASGOW_HASKELL(9,1,0,0) || WORD_SIZE_IN_BITS != 64-foreign import ccall unsafe "ghc_lib_parser_genSym" genSym :: IO Word64+#if defined(NO_FETCH_ADD)+-- GHC currently does not provide this operation on 32-bit platforms,+-- hence the CAS-based implementation.+fetchAddWord64Addr# :: Addr# -> Word64# -> State# RealWorld+                    -> (# State# RealWorld, Word64# #)+fetchAddWord64Addr# = go+  where+    go ptr inc s0 =+      case readWord64OffAddr# ptr 0# s0 of+        (# s1, n0 #) ->+          case atomicCasWord64Addr# ptr n0 (n0 `plusWord64#` inc) s1 of+            (# s2, res #)+              | 1# <- res `eqWord64#` n0 -> (# s2, n0 #)+              | otherwise -> go ptr inc s2 #else+fetchAddWord64Addr# :: Addr# -> Word64# -> State# RealWorld+                    -> (# State# RealWorld, Word64# #)+fetchAddWord64Addr# addr inc s0 =+    case fetchAddWordAddr# addr (word64ToWord# inc) s0 of+      (# s1, res #) -> (# s1, wordToWord64# res #)+#endif+ genSym :: IO Word64 genSym = do     let !mask = (1 `unsafeShiftL` uNIQUE_BITS) - 1     let !(Ptr counter) = ghc_unique_counter64-    let !(Ptr inc_ptr) = ghc_unique_inc-    u <- IO $ \s0 -> case readWordOffAddr# inc_ptr 0# s0 of-        (# s1, inc #) -> case fetchAddWordAddr# counter inc s1 of+    I# inc# <- peek ghc_unique_inc+    let !inc = wordToWord64# (int2Word# inc#)+    u <- IO $ \s1 -> case fetchAddWord64Addr# counter inc s1 of             (# s2, val #) ->-#if !MIN_VERSION_GLASGOW_HASKELL(9,3,0,0)-                let !u = W64# (val `plusWord#` inc) .&. mask-#else-                let !u = W64# (wordToWord64# (val `plusWord#` inc)) .&. mask-#endif+                let !u = W64# (val `plusWord64#` inc) .&. mask                 in (# s2, u #) #if defined(DEBUG)     -- Uh oh! We will overflow next time a unique is requested.@@ -254,7 +270,6 @@     massert (u /= mask) #endif     return u-#endif  foreign import ccall unsafe "&ghc_unique_counter64" ghc_unique_counter64 :: Ptr Word64 foreign import ccall unsafe "&ghc_unique_inc"       ghc_unique_inc       :: Ptr Int
compiler/GHC/Types/Var.hs view
@@ -5,9 +5,9 @@ \section{@Vars@: Variables} -} -{-# LANGUAGE FlexibleContexts, MultiWayIf, FlexibleInstances, DeriveDataTypeable,-             PatternSynonyms, BangPatterns #-}+{-# LANGUAGE MultiWayIf, PatternSynonyms #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}+{-# LANGUAGE DeriveFunctor #-}  -- | -- #name_types#@@ -61,7 +61,7 @@          -- ** Predicates         isId, isTyVar, isTcTyVar,-        isLocalVar, isLocalId, isCoVar, isNonCoVarId, isTyCoVar,+        isLocalVar, isLocalId, isLocalId_maybe, isCoVar, isNonCoVarId, isTyCoVar,         isGlobalId, isExportedId,         mustHaveLocalBinding, @@ -69,6 +69,8 @@         ForAllTyFlag(Invisible,Required,Specified,Inferred),         Specificity(..),         isVisibleForAllTyFlag, isInvisibleForAllTyFlag, isInferredForAllTyFlag,+        isSpecifiedForAllTyFlag,+        coreTyLamForAllTyFlag,          -- * FunTyFlag         FunTyFlag(..), isVisibleFunArg, isInvisibleFunArg, isFUNArg,@@ -90,10 +92,13 @@         binderVar, binderVars, binderFlag, binderFlags, binderType,         mkForAllTyBinder, mkForAllTyBinders,         mkTyVarBinder, mkTyVarBinders,-        isTyVarBinder,+        isVisibleForAllTyBinder, isInvisibleForAllTyBinder, isTyVarBinder,         tyVarSpecToBinder, tyVarSpecToBinders, tyVarReqToBinder, tyVarReqToBinders,         mapVarBndr, mapVarBndrs, +        -- ** ExportFlag+        ExportFlag(..),+         -- ** Constructing TyVar's         mkTyVar, mkTcTyVar, @@ -123,9 +128,9 @@ import GHC.Utils.Binary import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Utils.Panic.Plain  import Data.Data+import Control.DeepSeq  {- ************************************************************************@@ -317,7 +322,10 @@   * or defined at top level in the module being compiled   * always treated as a candidate by the free-variable finder -After CoreTidy, top-level LocalIds are turned into GlobalIds+In the output of CoreTidy, top level Ids are all GlobalIds, which are then+serialised into interface files. Do note however that CorePrep may introduce new+LocalIds for local floats (even at the top level). These will be visible in STG+and end up in generated code.  Note [Multiplicity of let binders] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -453,7 +461,7 @@ -- permitted by request ('Specified') (visible type application), or -- prohibited entirely from appearing in source Haskell ('Inferred')? -- See Note [VarBndrs, ForAllTyBinders, TyConBinders, and visibility] in "GHC.Core.TyCo.Rep"-data ForAllTyFlag = Invisible Specificity+data ForAllTyFlag = Invisible !Specificity                   | Required   deriving (Eq, Ord, Data)   -- (<) on ForAllTyFlag means "is less visible than"@@ -487,6 +495,17 @@ isInferredForAllTyFlag (Invisible InferredSpec) = True isInferredForAllTyFlag _                        = False +isSpecifiedForAllTyFlag :: ForAllTyFlag -> Bool+-- More restrictive than isInvisibleForAllTyFlag+isSpecifiedForAllTyFlag (Invisible SpecifiedSpec) = True+isSpecifiedForAllTyFlag _                         = False++coreTyLamForAllTyFlag :: ForAllTyFlag+-- ^ The ForAllTyFlag on a (Lam a e) term, where `a` is a type variable.+-- If you want other ForAllTyFlag, use a cast.+-- See Note [ForAllCo] in GHC.Core.TyCo.Rep+coreTyLamForAllTyFlag = Specified+ instance Outputable ForAllTyFlag where   ppr Required  = text "[req]"   ppr Specified = text "[spec]"@@ -514,6 +533,13 @@       1 -> return Specified       _ -> return Inferred +instance NFData Specificity where+  rnf SpecifiedSpec = ()+  rnf InferredSpec = ()+instance NFData ForAllTyFlag where+  rnf (Invisible spec) = rnf spec+  rnf Required = ()+ {- ********************************************************************* *                                                                      * *                   FunTyFlag@@ -704,8 +730,8 @@ -- -- A 'TyVarBinder' is a binder with only TyVar type ForAllTyBinder = VarBndr TyCoVar ForAllTyFlag-type InvisTyBinder  = VarBndr TyCoVar   Specificity-type ReqTyBinder    = VarBndr TyCoVar   ()+type InvisTyBinder  = VarBndr TyCoVar Specificity+type ReqTyBinder    = VarBndr TyCoVar ()  type TyVarBinder    = VarBndr TyVar   ForAllTyFlag type InvisTVBinder  = VarBndr TyVar   Specificity@@ -723,6 +749,12 @@ tyVarReqToBinder :: VarBndr a () -> VarBndr a ForAllTyFlag tyVarReqToBinder (Bndr tv _) = Bndr tv Required +isVisibleForAllTyBinder :: ForAllTyBinder -> Bool+isVisibleForAllTyBinder (Bndr _ vis) = isVisibleForAllTyFlag vis++isInvisibleForAllTyBinder :: ForAllTyBinder -> Bool+isInvisibleForAllTyBinder (Bndr _ vis) = isInvisibleForAllTyFlag vis+ binderVar :: VarBndr tv argf -> tv binderVar (Bndr v _) = v @@ -888,7 +920,7 @@   Note [VarBndrs, ForAllTyBinders, TyConBinders, and visibility]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ * A ForAllTy (used for both types and kinds) contains a ForAllTyBinder.   Each ForAllTyBinder       Bndr a tvis@@ -911,8 +943,7 @@ |  tvis = Inferred:            f :: forall {a}. type    Arg not allowed:  f                                f :: forall {co}. type   Arg not allowed:  f |  tvis = Specified:           f :: forall a. type      Arg optional:     f  or  f @Int-|  tvis = Required:            T :: forall k -> type    Arg required:     T *-|    This last form is illegal in terms: See Note [No Required PiTyBinder in terms]+|  tvis = Required:            f :: forall k -> type    Arg required:     f (type Int) | | Bndr k cvis :: TyConBinder, in the TyConBinders of a TyCon |  cvis :: TyConBndrVis@@ -943,22 +974,28 @@      f3 :: forall a. a -> a; f3 x = x   So f3 gets the type f3 :: forall a. a -> a, with 'a' Specified +* Required.  Function defn, with signature (explicit forall):+     f4 :: forall a -> a -> a; f4 (type _) x = x+  So f4 gets the type f4 :: forall a -> a -> a, with 'a' Required+  This is the experimental RequiredTypeArguments extension,+  see GHC Proposal #281 "Visible forall in types of terms"+ * Inferred.  Function defn, with signature (explicit forall), marked as inferred:-     f4 :: forall {a}. a -> a; f4 x = x-  So f4 gets the type f4 :: forall {a}. a -> a, with 'a' Inferred+     f5 :: forall {a}. a -> a; f5 x = x+  So f5 gets the type f5 :: forall {a}. a -> a, with 'a' Inferred   It's Inferred because the user marked it as such, even though it does appear-  in the user-written signature for f4+  in the user-written signature for f5  * Inferred/Specified.  Function signature with inferred kind polymorphism.-     f5 :: a b -> Int-  So 'f5' gets the type f5 :: forall {k} (a:k->*) (b:k). a b -> Int+     f6 :: a b -> Int+  So 'f6' gets the type f6 :: forall {k} (a :: k -> Type) (b :: k). a b -> Int   Here 'k' is Inferred (it's not mentioned in the type),   but 'a' and 'b' are Specified.  * Specified.  Function signature with explicit kind polymorphism-     f6 :: a (b :: k) -> Int+     f7 :: a (b :: k) -> Int   This time 'k' is Specified, because it is mentioned explicitly,-  so we get f6 :: forall (k:*) (a:k->*) (b:k). a b -> Int+  so we get f7 :: forall (k :: Type) (a :: k -> Type) (b :: k). a b -> Int  * Similarly pattern synonyms:   Inferred - from inferred types (e.g. no pattern type signature)@@ -1018,7 +1055,7 @@                const :: forall a b. a -> b -> a   Inferred: like Specified, but every binder is written in braces:-               f :: forall {k} (a:k). S k a -> Int+               f :: forall {k} (a :: k). S k a -> Int   Required: binders are put between `forall` and `->`:               T :: forall k -> *@@ -1030,19 +1067,6 @@  * Inferred variables correspond to "generalized" variables from the   Visible Type Applications paper (ESOP'16).--Note [No Required PiTyBinder in terms]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-We don't allow Required foralls for term variables, including pattern-synonyms and data constructors.  Why?  Because then an application-would need a /compulsory/ type argument (possibly without an "@"?),-thus (f Int); and we don't have concrete syntax for that.--We could change this decision, but Required, Named PiTyBinders are rare-anyway.  (Most are Anons.)--However the type of a term can (just about) have a required quantifier;-see Note [Required quantifiers in the type of a term] in GHC.Tc.Gen.Expr. -}  @@ -1244,6 +1268,10 @@ isLocalId :: Var -> Bool isLocalId (Id { idScope = LocalId _ }) = True isLocalId _                            = False++isLocalId_maybe :: Var -> Maybe ExportFlag+isLocalId_maybe (Id { idScope = LocalId ef }) = Just ef+isLocalId_maybe _                             = Nothing  -- | 'isLocalVar' returns @True@ for type variables as well as local 'Id's -- These are the variables that we need to pay attention to when finding free
compiler/GHC/Unit/Env.hs view
@@ -74,13 +74,12 @@ import GHC.Platform import GHC.Settings import GHC.Data.Maybe-import GHC.Utils.Panic.Plain import Data.Map.Strict (Map) import qualified Data.Map.Strict as Map import GHC.Utils.Misc (HasDebugCallStack) import GHC.Driver.DynFlags import GHC.Utils.Outputable-import GHC.Utils.Panic (pprPanic)+import GHC.Utils.Panic import GHC.Unit.Module.ModIface import GHC.Unit.Module import qualified Data.Set as Set
compiler/GHC/Unit/Info.hs view
@@ -234,8 +234,7 @@         -- will eventually be unused.         --         -- This change elevates the need to add custom hooks-        -- and handling specifically for the `rts` package for-        -- example in ghc-cabal.+        -- and handling specifically for the `rts` package.         addSuffix rts@"HSrts"       = rts       ++ (expandTag rts_tag)         addSuffix rts@"HSrts-1.0.2" = rts       ++ (expandTag rts_tag)         addSuffix other_lib         = other_lib ++ (expandTag tag)
compiler/GHC/Unit/Module/Graph.hs view
@@ -58,6 +58,7 @@ import GHC.Unit.Module.ModSummary import GHC.Unit.Types import GHC.Utils.Outputable+import GHC.Utils.Misc ( partitionWith )  import System.FilePath import qualified Data.Map as Map@@ -68,7 +69,6 @@ import GHC.Linker.Static.Utils  import Data.Bifunctor-import Data.Either import Data.Function import Data.List (sort) import GHC.Data.List.SetOps@@ -336,7 +336,7 @@   (graphFromEdgedVerticesUniq nodes, lookup_node)   where     -- Map from module to extra boot summary dependencies which need to be merged in-    (boot_summaries, nodes) = bimap Map.fromList id $ partitionEithers (map go numbered_summaries)+    (boot_summaries, nodes) = bimap Map.fromList id $ partitionWith go numbered_summaries        where         go (s, key) =
compiler/GHC/Unit/Module/Warnings.hs view
@@ -1,6 +1,6 @@+{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}@@ -8,6 +8,7 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TypeFamilies #-}  -- | Warnings for a module module GHC.Unit.Module.Warnings@@ -28,6 +29,7 @@     , Warnings (..)    , WarningTxt (..)+   , LWarningTxt    , DeclWarnOccNames    , ExportWarnNames    , warningTxtCategory@@ -54,12 +56,13 @@ import GHC.Types.Unique import GHC.Types.Unique.Set import GHC.Hs.Doc+import GHC.Hs.Extension+import GHC.Parser.Annotation  import GHC.Utils.Outputable import GHC.Utils.Binary import GHC.Unicode -import Language.Haskell.Syntax.Concrete (HsToken (HsTok)) import Language.Haskell.Syntax.Extension  import Data.Data@@ -116,13 +119,13 @@  data InWarningCategory   = InWarningCategory-    { iwc_in :: !(Located (HsToken "in")),+    { iwc_in :: !(EpToken "in"),       iwc_st :: !SourceText,-      iwc_wc :: (Located WarningCategory)+      iwc_wc :: (LocatedE WarningCategory)     } deriving Data  fromWarningCategory :: WarningCategory -> InWarningCategory-fromWarningCategory wc = InWarningCategory (noLoc HsTok) NoSourceText (noLoc wc)+fromWarningCategory wc = InWarningCategory noAnn NoSourceText (noLocA wc)   -- See Note [Warning categories]@@ -191,20 +194,21 @@ deleteWarningCategorySet c (FiniteWarningCategorySet   s) = FiniteWarningCategorySet   (delOneFromUniqSet s c) deleteWarningCategorySet c (CofiniteWarningCategorySet s) = CofiniteWarningCategorySet (addOneToUniqSet   s c) +type LWarningTxt pass = XRec pass (WarningTxt pass)  -- | Warning Text -- -- reason/explanation from a WARNING or DEPRECATED pragma data WarningTxt pass    = WarningTxt-      (Maybe (Located InWarningCategory))+      (Maybe (LocatedE InWarningCategory))         -- ^ Warning category attached to this WARNING pragma, if any;         -- see Note [Warning categories]-      (Located SourceText)-      [Located (WithHsDocIdentifiers StringLiteral pass)]+      SourceText+      [LocatedE (WithHsDocIdentifiers StringLiteral pass)]    | DeprecatedTxt-      (Located SourceText)-      [Located (WithHsDocIdentifiers StringLiteral pass)]+      SourceText+      [LocatedE (WithHsDocIdentifiers StringLiteral pass)]   deriving Generic  -- | To which warning category does this WARNING or DEPRECATED pragma belong?@@ -214,7 +218,7 @@ warningTxtCategory _ = defaultWarningCategory  -- | The message that the WarningTxt was specified to output-warningTxtMessage :: WarningTxt p -> [Located (WithHsDocIdentifiers StringLiteral p)]+warningTxtMessage :: WarningTxt p -> [LocatedE (WithHsDocIdentifiers StringLiteral p)] warningTxtMessage (WarningTxt _ _ m) = m warningTxtMessage (DeprecatedTxt _ m) = m @@ -233,16 +237,18 @@  deriving instance Eq InWarningCategory -deriving instance (Eq (HsToken "in"), Eq (IdP pass)) => Eq (WarningTxt pass)+deriving instance (Eq (IdP pass)) => Eq (WarningTxt pass) deriving instance (Data pass, Data (IdP pass)) => Data (WarningTxt pass) +type instance Anno (WarningTxt (GhcPass pass)) = SrcSpanAnnP+ instance Outputable InWarningCategory where   ppr (InWarningCategory _ _ wt) = text "in" <+> doubleQuotes (ppr wt)   instance Outputable (WarningTxt pass) where     ppr (WarningTxt mcat lsrc ws)-      = case unLoc lsrc of+      = case lsrc of             NoSourceText   -> pp_ws ws             SourceText src -> ftext src <+> ctg_doc <+> pp_ws ws <+> text "#-}"         where@@ -250,11 +256,11 @@       ppr (DeprecatedTxt lsrc  ds)-      = case unLoc lsrc of+      = case lsrc of           NoSourceText   -> pp_ws ds           SourceText src -> ftext src <+> pp_ws ds <+> text "#-}" -pp_ws :: [Located (WithHsDocIdentifiers StringLiteral pass)] -> SDoc+pp_ws :: [LocatedE (WithHsDocIdentifiers StringLiteral pass)] -> SDoc pp_ws [l] = ppr $ unLoc l pp_ws ws   = text "["
compiler/GHC/Unit/State.hs view
@@ -1,8 +1,6 @@ -- (c) The University of Glasgow, 2006 -{-# LANGUAGE ScopedTypeVariables, BangPatterns, FlexibleContexts #-} {-# LANGUAGE LambdaCase #-}-{-# LANGUAGE NamedFieldPuns #-}  -- | Unit manipulation module GHC.Unit.State (
compiler/GHC/Unit/Types.hs view
@@ -62,6 +62,7 @@      -- * Wired-in units    , primUnitId    , bignumUnitId+   , ghcInternalUnitId    , baseUnitId    , rtsUnitId    , thUnitId@@ -71,12 +72,14 @@     , primUnit    , bignumUnit+   , ghcInternalUnit    , baseUnit    , rtsUnit    , thUnit    , mainUnit    , thisGhcUnit    , interactiveUnit+   , experimentalUnit     , isInteractiveModule    , wiredInUnitIds@@ -101,9 +104,9 @@ import GHC.Utils.Misc import GHC.Settings.Config (cProjectUnitId) -import Control.DeepSeq (NFData(..))+import Control.DeepSeq import Data.Data-import Data.List (sortBy)+import Data.List (sortBy ) import Data.Function import Data.Bifunctor import qualified Data.ByteString as BS@@ -149,7 +152,8 @@  instance Binary a => Binary (GenModule a) where   put_ bh (Module p n) = put_ bh p >> put_ bh n-  get bh = do p <- get bh; n <- get bh; return (Module p n)+  -- Module has strict fields, so use $! in order not to allocate a thunk+  get bh = do p <- get bh; n <- get bh; return $! Module p n  instance NFData (GenModule a) where   rnf (Module unit name) = unit `seq` name `seq` ()@@ -317,13 +321,14 @@     cid   <- get bh     insts <- get bh     let fs = mkInstantiatedUnitHash cid insts-    return InstantiatedUnit {-            instUnitInstanceOf = cid,-            instUnitInsts = insts,-            instUnitHoles = unionManyUniqDSets (map (moduleFreeHoles.snd) insts),-            instUnitFS = fs,-            instUnitKey = getUnique fs-           }+    -- InstantiatedUnit has strict fields, so use $! in order not to allocate a thunk+    return $! InstantiatedUnit {+                instUnitInstanceOf = cid,+                instUnitInsts = insts,+                instUnitHoles = unionManyUniqDSets (map (moduleFreeHoles.snd) insts),+                instUnitFS = fs,+                instUnitKey = getUnique fs+              }  instance IsUnitId u => Eq (GenUnit u) where   uid1 == uid2 = unitUnique uid1 == unitUnique uid2@@ -369,10 +374,12 @@   put_ bh HoleUnit =     putByte bh 2   get bh = do b <- getByte bh-              case b of+              u <- case b of                 0 -> fmap RealUnit (get bh)                 1 -> fmap VirtUnit (get bh)                 _ -> pure HoleUnit+              -- Unit has strict fields that need forcing; otherwise we allocate a thunk.+              pure $! u  -- | Retrieve the set of free module holes of a 'Unit'. unitFreeModuleHoles :: GenUnit u -> UniqDSet ModuleName@@ -588,27 +595,32 @@  -} -bignumUnitId, primUnitId, baseUnitId, rtsUnitId,-  thUnitId, mainUnitId, thisGhcUnitId, interactiveUnitId  :: UnitId+bignumUnitId, primUnitId, ghcInternalUnitId, baseUnitId, rtsUnitId,+  thUnitId, mainUnitId, thisGhcUnitId, interactiveUnitId,+  experimentalUnitId :: UnitId -bignumUnit, primUnit, baseUnit, rtsUnit,-  thUnit, mainUnit, thisGhcUnit, interactiveUnit  :: Unit+bignumUnit, primUnit, ghcInternalUnit, baseUnit, rtsUnit,+  thUnit, mainUnit, thisGhcUnit, interactiveUnit, experimentalUnit  :: Unit  primUnitId        = UnitId (fsLit "ghc-prim") bignumUnitId      = UnitId (fsLit "ghc-bignum")+ghcInternalUnitId = UnitId (fsLit "ghc-internal") baseUnitId        = UnitId (fsLit "base") rtsUnitId         = UnitId (fsLit "rts") thisGhcUnitId     = UnitId (fsLit cProjectUnitId) -- See Note [GHC's Unit Id] interactiveUnitId = UnitId (fsLit "interactive") thUnitId          = UnitId (fsLit "template-haskell")+experimentalUnitId = UnitId (fsLit "ghc-experimental")  thUnit            = RealUnit (Definite thUnitId) primUnit          = RealUnit (Definite primUnitId) bignumUnit        = RealUnit (Definite bignumUnitId)+ghcInternalUnit   = RealUnit (Definite ghcInternalUnitId) baseUnit          = RealUnit (Definite baseUnitId) rtsUnit           = RealUnit (Definite rtsUnitId) thisGhcUnit       = RealUnit (Definite thisGhcUnitId) interactiveUnit   = RealUnit (Definite interactiveUnitId)+experimentalUnit  = RealUnit (Definite experimentalUnitId)  -- | This is the package Id for the current program.  It is the default -- package Id if you don't specify a package name.  We don't add this prefix@@ -623,9 +635,11 @@ wiredInUnitIds =    [ primUnitId    , bignumUnitId+   , ghcInternalUnitId    , baseUnitId    , rtsUnitId    , thUnitId+   , experimentalUnitId    ]    -- NB: ghc is no longer part of the wired-in units since its unit-id, given    -- by hadrian or cabal, is no longer overwritten and now matches both the
compiler/GHC/Utils/Binary.hs view
@@ -1,18 +1,9 @@  {-# LANGUAGE CPP #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE GADTs #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE UnboxedTuples #-}  {-# OPTIONS_GHC -O2 -funbox-strict-fields #-}-#if MIN_VERSION_base(4,16,0)-#define HAS_TYPELITCHAR-#endif -- We always optimise this, otherwise performance of a non-optimised -- compiler is severely affected @@ -56,6 +47,8 @@    -- * For writing instances    putByte,    getByte,+   putByteString,+   getByteString,     -- * Variable length encodings    putULEB128,@@ -97,6 +90,7 @@ import GHC.Types.SrcLoc import GHC.Types.Unique import qualified GHC.Data.Strict as Strict+import GHC.Utils.Outputable( JoinPointHood(..) )  import Control.DeepSeq import Foreign hiding (shiftL, shiftR, void)@@ -606,9 +600,9 @@ -- is to the interface file without the variable length encoding we usually -- apply. --- | Encode the argument in it's full length. This is different from many default+-- | Encode the argument in its full length. This is different from many default -- binary instances which make no guarantee about the actual encoding and--- might do things use variable length encoding.+-- might do things using variable length encoding. newtype FixedLengthEncoding a   = FixedLengthEncoding { unFixedLength :: a }   deriving (Eq,Ord,Show)@@ -812,6 +806,17 @@     get bh = do r <- get bh                 return $ fromRational r +instance Binary JoinPointHood where+    put_ bh NotJoinPoint = putByte bh 0+    put_ bh (JoinPoint ar) = do+        putByte bh 1+        put_ bh ar+    get bh = do+        h <- getByte bh+        case h of+            0 -> return NotJoinPoint+            _ -> do { ar <- get bh; return (JoinPoint ar) }+ {- Finally - a reasonable portable Integer instance. @@ -822,11 +827,11 @@ This made some sense as it's highly portable but also not very efficient. -However GHC stores a surprisingly large number off large Integer+However GHC stores a surprisingly large number of large Integer values. In the examples looked at between 25% and 50% of Integers serialized were outside of the Int32 range. -Consider a valie like `2724268014499746065`, some sort of hash+Consider a value like `2724268014499746065`, some sort of hash actually generated by GHC. In the old scheme this was encoded as a list of 19 chars. This gave a size of 77 Bytes, one for the length of the list and 76@@ -1226,6 +1231,19 @@ getFS bh = do   l  <- get bh :: IO Int   getPrim bh l (\src -> pure $! mkFastStringBytes src l )++-- | Put a ByteString without its length (can't be read back without knowing the+-- length!)+putByteString :: BinHandle -> ByteString -> IO ()+putByteString bh bs =+  BS.unsafeUseAsCStringLen bs $ \(ptr, l) -> do+    putPrim bh l (\op -> copyBytes op (castPtr ptr) l)++-- | Get a ByteString whose length is known+getByteString :: BinHandle -> Int -> IO ByteString+getByteString bh l =+  BS.create l $ \dest -> do+    getPrim bh l (\src -> copyBytes dest src l)  putBS :: BinHandle -> ByteString -> IO () putBS bh bs =
compiler/GHC/Utils/Binary/Typeable.hs view
@@ -4,9 +4,6 @@  {-# OPTIONS_GHC -O2 -funbox-strict-fields #-} {-# OPTIONS_GHC -Wno-orphans -Wincomplete-patterns #-}-#if MIN_VERSION_base(4,16,0)-#define HAS_TYPELITCHAR-#endif  -- | Orphan Binary instances for Data.Typeable stuff module GHC.Utils.Binary.Typeable@@ -19,9 +16,7 @@ import GHC.Utils.Binary  import GHC.Exts (RuntimeRep(..), VecCount(..), VecElem(..))-#if __GLASGOW_HASKELL__ >= 901 import GHC.Exts (Levity(Lifted, Unlifted))-#endif import GHC.Serialized  import Foreign@@ -102,13 +97,8 @@     put_ bh (VecRep a b)    = putByte bh 0 >> put_ bh a >> put_ bh b     put_ bh (TupleRep reps) = putByte bh 1 >> put_ bh reps     put_ bh (SumRep reps)   = putByte bh 2 >> put_ bh reps-#if __GLASGOW_HASKELL__ >= 901     put_ bh (BoxedRep Lifted)   = putByte bh 3     put_ bh (BoxedRep Unlifted) = putByte bh 4-#else-    put_ bh LiftedRep       = putByte bh 3-    put_ bh UnliftedRep     = putByte bh 4-#endif     put_ bh IntRep          = putByte bh 5     put_ bh WordRep         = putByte bh 6     put_ bh Int64Rep        = putByte bh 7@@ -129,13 +119,8 @@           0  -> VecRep <$> get bh <*> get bh           1  -> TupleRep <$> get bh           2  -> SumRep <$> get bh-#if __GLASGOW_HASKELL__ >= 901           3  -> pure (BoxedRep Lifted)           4  -> pure (BoxedRep Unlifted)-#else-          3  -> pure LiftedRep-          4  -> pure UnliftedRep-#endif           5  -> pure IntRep           6  -> pure WordRep           7  -> pure Int64Rep@@ -173,17 +158,13 @@ instance Binary TypeLitSort where     put_ bh TypeLitSymbol = putByte bh 0     put_ bh TypeLitNat = putByte bh 1-#if defined(HAS_TYPELITCHAR)     put_ bh TypeLitChar = putByte bh 2-#endif     get bh = do         tag <- getByte bh         case tag of           0 -> pure TypeLitSymbol           1 -> pure TypeLitNat-#if defined(HAS_TYPELITCHAR)           2 -> pure TypeLitChar-#endif           _ -> fail "Binary.putTypeLitSort: invalid tag"  putTypeRep :: BinHandle -> TypeRep a -> IO ()@@ -198,12 +179,6 @@     put_ bh (2 :: Word8)     putTypeRep bh f     putTypeRep bh x-#if __GLASGOW_HASKELL__ < 903-putTypeRep bh (Fun arg res) = do-    put_ bh (3 :: Word8)-    putTypeRep bh arg-    putTypeRep bh res-#endif  instance Binary Serialized where     put_ bh (Serialized the_type bytes) = do
compiler/GHC/Utils/BufHandle.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE BangPatterns #-} {-# LANGUAGE MagicHash #-}  -----------------------------------------------------------------------------
compiler/GHC/Utils/Containers/Internal/BitUtil.hs view
@@ -1,10 +1,5 @@ {-# LANGUAGE CPP #-}-#if __GLASGOW_HASKELL__ {-# LANGUAGE MagicHash #-}-#endif-#if !defined(TESTING) && defined(__GLASGOW_HASKELL__)-{-# LANGUAGE Safe #-}-#endif  ----------------------------------------------------------------------------- -- |
compiler/GHC/Utils/Containers/Internal/StrictPair.hs view
@@ -1,7 +1,4 @@ {-# LANGUAGE CPP #-}-#if !defined(TESTING) && defined(__GLASGOW_HASKELL__)-{-# LANGUAGE Safe #-}-#endif  -- | A strict pair 
compiler/GHC/Utils/Error.hs view
@@ -1,8 +1,4 @@-{-# LANGUAGE BangPatterns    #-}-{-# LANGUAGE DeriveFunctor   #-}-{-# LANGUAGE RankNTypes      #-} {-# LANGUAGE ViewPatterns    #-}-{-# LANGUAGE TypeApplications #-}  {- (c) The AQUA Project, Glasgow University, 1994-1998@@ -75,7 +71,6 @@ import GHC.Utils.Exception import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic-import GHC.Utils.Panic.Plain import GHC.Utils.Logger import GHC.Types.Error import GHC.Types.SrcLoc as SrcLoc@@ -414,7 +409,7 @@             -> m a withTiming' logger what force_result prtimings action   = if logVerbAtLeast logger 2 || logHasDumpFlag logger Opt_D_dump_timings-    then do whenPrintTimings $+    then do when printTimingsNotDumpToFile $ liftIO $               logInfo logger $ withPprStyle defaultUserStyle $                 text "***" <+> what <> colon             let ctx = log_default_user_context (logFlags logger)@@ -432,7 +427,7 @@             let alloc = alloc0 - alloc1                 time = realToFrac (end - start) * 1e-9 -            when (logVerbAtLeast logger 2 && prtimings == PrintTimings)+            when (logVerbAtLeast logger 2 && printTimingsNotDumpToFile)                 $ liftIO $ logInfo logger $ withPprStyle defaultUserStyle                     (text "!!!" <+> what <> colon <+> text "finished in"                      <+> doublePrec 2 time@@ -452,7 +447,16 @@             pure r      else action -    where whenPrintTimings = liftIO . when (prtimings == PrintTimings)+    where whenPrintTimings =+            liftIO . when printTimings++          printTimings =+            prtimings == PrintTimings++          -- Avoid both printing to console and dumping to a file (#20316).+          printTimingsNotDumpToFile =+            printTimings+            && not (log_dump_to_file (logFlags logger))            recordAllocs alloc =             liftIO $ traceMarkerIO $ "GHC:allocs:" ++ show alloc
compiler/GHC/Utils/FV.hs view
@@ -3,8 +3,6 @@  -} -{-# LANGUAGE BangPatterns #-}- -- | Utilities for efficiently and deterministically computing free variables. module GHC.Utils.FV (         -- * Deterministic free vars computations
compiler/GHC/Utils/Lexeme.hs view
@@ -219,13 +219,14 @@   OtherNumber     -> True -- See #4373   _               -> c == '\'' || c == '_' --- | All reserved identifiers. Taken from section 2.4 of the 2010 Report.+-- | All reserved identifiers. Taken from section 2.4 of the 2010 Report,+-- plus the GHC-specific @forall@ keyword (see GHC Proposal #281). reservedIds :: Set.Set String reservedIds = Set.fromList [ "case", "class", "data", "default", "deriving"-                           , "do", "else", "foreign", "if", "import", "in"-                           , "infix", "infixl", "infixr", "instance", "let"-                           , "module", "newtype", "of", "then", "type", "where"-                           , "_" ]+                           , "do", "else", "forall", "foreign", "if", "import"+                           , "in", "infix", "infixl", "infixr", "instance"+                           , "let", "module", "newtype", "of", "then", "type"+                           , "where", "_" ]  -- | All reserved operators. Taken from section 2.4 of the 2010 Report, -- excluding @\@@ and @~@ that are allowed by GHC (see GHC Proposal #229).
compiler/GHC/Utils/Logger.hs view
@@ -24,6 +24,7 @@     -- * Logger setup     , initLogger     , LogAction+    , LogJsonAction     , DumpAction     , TraceAction     , DumpFormat (..)@@ -31,6 +32,8 @@     -- ** Hooks     , popLogHook     , pushLogHook+    , popJsonLogHook+    , pushJsonLogHook     , popDumpHook     , pushDumpHook     , popTraceHook@@ -49,12 +52,13 @@     , logVerbAtLeast      -- * Logging-    , jsonLogAction     , putLogMsg     , defaultLogAction+    , defaultLogJsonAction     , defaultLogActionHPrintDoc     , defaultLogActionHPutStrDoc     , logMsg+    , logJsonMsg     , logDumpMsg      -- * Dumping@@ -87,6 +91,7 @@  import GHC.Data.EnumSet (EnumSet) import qualified GHC.Data.EnumSet as EnumSet+import GHC.Data.FastString  import System.Directory import System.FilePath  ( takeDirectory, (</>) )@@ -111,6 +116,7 @@   , log_default_dump_context :: SDocContext   , log_dump_flags           :: !(EnumSet DumpFlag) -- ^ Dump flags   , log_show_caret           :: !Bool               -- ^ Show caret in diagnostics+  , log_diagnostics_as_json  :: !Bool               -- ^ Format diagnostics as JSON   , log_show_warn_groups     :: !Bool               -- ^ Show warning flag groups   , log_enable_timestamps    :: !Bool               -- ^ Enable timestamps   , log_dump_to_file         :: !Bool               -- ^ Enable dump to file@@ -130,6 +136,7 @@   , log_default_dump_context = defaultSDocContext   , log_dump_flags           = EnumSet.empty   , log_show_caret           = True+  , log_diagnostics_as_json  = False   , log_show_warn_groups     = True   , log_enable_timestamps    = True   , log_dump_to_file         = False@@ -177,6 +184,11 @@               -> SDoc               -> IO () +type LogJsonAction = LogFlags+                   -> MessageClass+                   -> JsonDoc+                   -> IO ()+ type DumpAction = LogFlags                -> PprStyle                -> DumpFlag@@ -214,6 +226,9 @@     { log_hook   :: [LogAction -> LogAction]         -- ^ Log hooks stack +    , json_log_hook :: [LogJsonAction -> LogJsonAction]+        -- ^ Json log hooks stack+     , dump_hook  :: [DumpAction -> DumpAction]         -- ^ Dump hooks stack @@ -249,6 +264,7 @@     dumps <- newMVar Map.empty     return $ Logger         { log_hook        = []+        , json_log_hook   = []         , dump_hook       = []         , trace_hook      = []         , generated_dumps = dumps@@ -260,6 +276,10 @@ putLogMsg :: Logger -> LogAction putLogMsg logger = foldr ($) defaultLogAction (log_hook logger) +-- | Log a JsonDoc+putJsonLogMsg :: Logger -> LogJsonAction+putJsonLogMsg logger = foldr ($) defaultLogJsonAction (json_log_hook logger)+ -- | Dump something putDumpFile :: Logger -> DumpAction putDumpFile logger =@@ -284,6 +304,15 @@     []   -> panic "popLogHook: empty hook stack"     _:hs -> logger { log_hook = hs } +-- | Push a json log hook+pushJsonLogHook :: (LogJsonAction -> LogJsonAction) -> Logger -> Logger+pushJsonLogHook h logger = logger { json_log_hook = h:json_log_hook logger }++popJsonLogHook :: Logger -> Logger+popJsonLogHook logger = case json_log_hook logger of+    []   -> panic "popJsonLogHook: empty hook stack"+    _:hs -> logger { json_log_hook = hs}+ -- | Push a dump hook pushDumpHook :: (DumpAction -> DumpAction) -> Logger -> Logger pushDumpHook h logger = logger { dump_hook = h:dump_hook logger }@@ -328,7 +357,23 @@            $ logger  -- See Note [JSON Error Messages]---+defaultLogJsonAction :: LogJsonAction+defaultLogJsonAction logflags msg_class jsdoc =+  case msg_class of+      MCOutput                     -> printOut msg+      MCDump                       -> printOut (msg $$ blankLine)+      MCInteractive                -> putStrSDoc msg+      MCInfo                       -> printErrs msg+      MCFatal                      -> printErrs msg+      MCDiagnostic SevIgnore _ _   -> pure () -- suppress the message+      MCDiagnostic _sev _rea _code -> printErrs msg+  where+    printOut   = defaultLogActionHPrintDoc  logflags False stdout+    printErrs  = defaultLogActionHPrintDoc  logflags False stderr+    putStrSDoc = defaultLogActionHPutStrDoc logflags False stdout+    msg = renderJSON jsdoc+-- See Note [JSON Error Messages]+-- this is to be removed jsonLogAction :: LogAction jsonLogAction _ (MCDiagnostic SevIgnore _ _) _ _ = return () -- suppress the message jsonLogAction logflags msg_class srcSpan msg@@ -338,10 +383,20 @@     where       str = renderWithContext (log_default_user_context logflags) msg       doc = renderJSON $-              JSObject [ ( "span", json srcSpan )+              JSObject [ ( "span", spanToDumpJSON srcSpan )                        , ( "doc" , JSString str )                        , ( "messageClass", json msg_class )                        ]+      spanToDumpJSON :: SrcSpan -> JsonDoc+      spanToDumpJSON s = case s of+                 (RealSrcSpan rss _) -> JSObject [ ("file", json file)+                                                , ("startLine", json $ srcSpanStartLine rss)+                                                , ("startCol", json $ srcSpanStartCol rss)+                                                , ("endLine", json $ srcSpanEndLine rss)+                                                , ("endCol", json $ srcSpanEndCol rss)+                                                ]+                   where file = unpackFS $ srcSpanFile rss+                 UnhelpfulSpan _ -> JSNull  defaultLogAction :: LogAction defaultLogAction logflags msg_class srcSpan msg@@ -362,14 +417,13 @@       message = mkLocMessageWarningGroups (log_show_warn_groups logflags) msg_class srcSpan msg        printDiagnostics = do-        hPutChar stderr '\n'         caretDiagnostic <-             if log_show_caret logflags             then getCaretDiagnostic msg_class srcSpan             else pure empty         printErrs $ getPprStyle $ \style ->           withPprStyle (setStyleColoured True style)-            (message $+$ caretDiagnostic)+            (message $+$ caretDiagnostic $+$ blankLine)         -- careful (#2302): printErrs prints in UTF-8,         -- whereas converting to string first and using         -- hPutStr would just emit the low 8 bits of@@ -403,6 +457,12 @@ -- information to provide to the user but refactoring log_action is quite -- invasive as it is called in many places. So, for now I left it alone -- and we can refine its behaviour as users request different output.+--+-- The recent work here replaces the purpose of flag -ddump-json with+-- -fdiagnostics-as-json. For temporary backwards compatibility while+-- -ddump-json is being deprecated, `jsonLogAction` has been added in, but+-- it should be removed along with -ddump-json. Similarly, the guard in+-- `defaultLogAction` should be removed. This cleanup is tracked in #24113.  -- | Default action for 'dumpAction' hook defaultDumpAction :: DumpCache -> LogAction -> DumpAction@@ -505,7 +565,7 @@      getPrefix          -- dump file location is being forced-         --      by the --ddump-file-prefix flag.+         --      by the -ddump-file-prefix flag.        | Just prefix <- log_dump_prefix_override logflags           = prefix          -- dump file locations, module specified to [modulename] set by@@ -531,6 +591,9 @@ -- | Log something logMsg :: Logger -> MessageClass -> SrcSpan -> SDoc -> IO () logMsg logger mc loc msg = putLogMsg logger (logFlags logger) mc loc msg++logJsonMsg :: ToJson a => Logger -> MessageClass -> a -> IO ()+logJsonMsg logger mc d = putJsonLogMsg logger (logFlags logger) mc  (json d)  -- | Dump something logDumpFile :: Logger -> PprStyle -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
compiler/GHC/Utils/Misc.hs view
@@ -1,10 +1,6 @@ -- (c) The University of Glasgow 2006  {-# LANGUAGE CPP #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE MagicHash #-}  -- | Highly random utility functions@@ -23,7 +19,7 @@          mapFst, mapSnd, chkAppend,         mapAndUnzip, mapAndUnzip3, mapAndUnzip4,-        filterOut, partitionWith,+        filterOut, partitionWith, partitionWithM,          dropWhileEndLE, spanEnd, last2, lastMaybe, onJust, @@ -37,12 +33,9 @@         isSingleton, only, expectOnly, GHC.Utils.Misc.singleton,         notNull, expectNonEmpty, snocView, -        chunkList,-         holes,          changeLast,-        mapLastM,          whenNonEmpty, @@ -132,7 +125,6 @@ import Data.Data import qualified Data.List as List import Data.List.NonEmpty  ( NonEmpty(..), last, nonEmpty )-import qualified Data.List.NonEmpty as NE  import GHC.Exts import GHC.Stack (HasCallStack)@@ -221,6 +213,17 @@                          Right c -> (bs, c:cs)     where (bs,cs) = partitionWith f xs +partitionWithM :: Monad m => (a -> m (Either b c)) -> [a] -> m ([b], [c])+-- ^ Monadic version of `partitionWith`+partitionWithM _ [] = return ([], [])+partitionWithM f (x:xs) = do+  y <- f x+  (bs, cs) <- partitionWithM f xs+  case y of+    Left  b -> return (b:bs, cs)+    Right c -> return (bs, c:cs)+{-# INLINEABLE partitionWithM #-}+ chkAppend :: [a] -> [a] -> [a] -- Checks for the second argument being empty -- Used in situations where that situation is common@@ -485,7 +488,7 @@ -- | Extract the single element of a list and panic with the given message if -- there are more elements or the list was empty. -- Like 'expectJust', but for lists.-expectOnly :: HasDebugCallStack => String -> [a] -> a+expectOnly :: HasCallStack => String -> [a] -> a {-# INLINE expectOnly #-} #if defined(DEBUG) expectOnly _   [a]   = a@@ -494,11 +497,6 @@ #endif expectOnly msg _     = panic ("expectOnly: " ++ msg) --- | Split a list into chunks of /n/ elements-chunkList :: Int -> [a] -> [[a]]-chunkList _ [] = []-chunkList n xs = as : chunkList n bs where (as,bs) = splitAt n xs- -- | Compute all the ways of removing a single element from a list. -- --  > holes [1,2,3] = [(1, [2,3]), (2, [1,3]), (3, [1,2])]@@ -513,7 +511,7 @@ changeLast (x:xs) x' = x : changeLast xs x'  -- | Like @expectJust msg . nonEmpty@; a better alternative to 'NE.fromList'.-expectNonEmpty :: HasDebugCallStack => String -> [a] -> NonEmpty a+expectNonEmpty :: HasCallStack => String -> [a] -> NonEmpty a {-# INLINE expectNonEmpty #-} expectNonEmpty _   (x:xs) = x:|xs expectNonEmpty msg []     = expectNonEmptyPanic msg@@ -521,11 +519,6 @@ expectNonEmptyPanic :: String -> a expectNonEmptyPanic msg = panic ("expectNonEmpty: " ++ msg) {-# NOINLINE expectNonEmptyPanic #-}---- | Apply an effectful function to the last list element.-mapLastM :: Functor f => (a -> f a) -> NonEmpty a -> f (NonEmpty a)-mapLastM f (x:|[]) = NE.singleton <$> f x-mapLastM f (x0:|x1:xs) = (x0 NE.<|) <$> mapLastM f (x1:|xs)  whenNonEmpty :: Applicative m => [a] -> (NonEmpty a -> m ()) -> m () whenNonEmpty []     _ = pure ()
compiler/GHC/Utils/Outputable.hs view
@@ -23,6 +23,7 @@ module GHC.Utils.Outputable (         -- * Type classes         Outputable(..), OutputableBndr(..), OutputableP(..),+        BindingSite(..),  JoinPointHood(..), isJoinPoint,          IsOutput(..), IsLine(..), IsDoc(..),         HLine, HDoc,@@ -38,7 +39,7 @@         isEmpty, nest,         ptext,         int, intWithCommas, integer, word64, word, float, double, rational, doublePrec,-        parens, cparen, brackets, braces, quotes, quote,+        parens, cparen, brackets, braces, quotes, quote, quoteIfPunsEnabled,         doubleQuotes, angleBrackets,         semi, comma, colon, dcolon, space, equals, dot, vbar,         arrow, lollipop, larrow, darrow, arrowt, larrowt, arrowtt, larrowtt,@@ -87,8 +88,6 @@         pprModuleName,          -- * Controlling the style in which output is printed-        BindingSite(..),-         PprStyle(..), NamePprCtx(..),         QueryQualifyName, QueryQualifyModule, QueryQualifyPackage, QueryPromotionTick,         PromotedItem(..), IsEmptyOrSingleton(..), isListEmptyOrSingleton,@@ -157,6 +156,7 @@ import Data.Time ( UTCTime ) import Data.Time.Format.ISO8601 import Data.Void+import Control.DeepSeq (NFData(rnf))  import GHC.Fingerprint import GHC.Show         ( showMultiLineString )@@ -397,6 +397,7 @@   , sdocCanUseUnicode               :: !Bool       -- ^ True if Unicode encoding is supported       -- and not disabled by GHC_NO_UNICODE environment variable+  , sdocPrintErrIndexLinks          :: !Bool   , sdocHexWordLiterals             :: !Bool   , sdocPprDebug                    :: !Bool   , sdocPrintUnicodeSyntax          :: !Bool@@ -458,6 +459,7 @@   , sdocDefaultDepth                = 5   , sdocLineLength                  = 100   , sdocCanUseUnicode               = False+  , sdocPrintErrIndexLinks          = False   , sdocHexWordLiterals             = False   , sdocPprDebug                    = False   , sdocPrintUnicodeSyntax          = False@@ -732,6 +734,12 @@ {-# INLINE CONLIKE cparen #-} cparen b d = SDoc $ Pretty.maybeParens b . runSDoc d +quoteIfPunsEnabled :: SDoc -> SDoc+quoteIfPunsEnabled doc =+  sdocOption sdocListTuplePuns $ \case+    True -> quote doc+    False -> doc+ -- 'quotes' encloses something in single quotes... -- but it omits them if the thing begins or ends in a single quote -- so that we don't get `foo''.  Instead we just have foo'.@@ -1221,16 +1229,6 @@ ************************************************************************ -} --- | 'BindingSite' is used to tell the thing that prints binder what--- language construct is binding the identifier.  This can be used--- to decide how much info to print.--- Also see Note [Binding-site specific printing] in "GHC.Core.Ppr"-data BindingSite-    = LambdaBind  -- ^ The x in   (\x. e)-    | CaseBind    -- ^ The x in   case scrut of x { (y,z) -> ... }-    | CasePatBind -- ^ The y,z in case scrut of x { (y,z) -> ... }-    | LetBind     -- ^ The x in   (let x = rhs in e)-    deriving Eq -- | When we print a binder, we often want to print its type too. -- The @OutputableBndr@ class encapsulates this idea. class Outputable a => OutputableBndr a where@@ -1242,12 +1240,39 @@       -- prefix position of an application, thus   (f a b) or  ((+) x)       -- or infix position,                 thus   (a `f` b) or  (x + y) -   bndrIsJoin_maybe :: a -> Maybe Int-   bndrIsJoin_maybe _ = Nothing+   bndrIsJoin_maybe :: a -> JoinPointHood+   bndrIsJoin_maybe _ = NotJoinPoint       -- When pretty-printing we sometimes want to find       -- whether the binder is a join point.  You might think       -- we could have a function of type (a->Var), but Var       -- isn't available yet, alas++-- | 'BindingSite' is used to tell the thing that prints binder what+-- language construct is binding the identifier.  This can be used+-- to decide how much info to print.+-- Also see Note [Binding-site specific printing] in "GHC.Core.Ppr"+data BindingSite+    = LambdaBind  -- ^ The x in   (\x. e)+    | CaseBind    -- ^ The x in   case scrut of x { (y,z) -> ... }+    | CasePatBind -- ^ The y,z in case scrut of x { (y,z) -> ... }+    | LetBind     -- ^ The x in   (let x = rhs in e)+    deriving Eq++data JoinPointHood+  = JoinPoint {-# UNPACK #-} !Int   -- The JoinArity (but an Int here because+  | NotJoinPoint                    -- synonym JoinArity is defined in Types.Basic+  deriving( Eq )++isJoinPoint :: JoinPointHood -> Bool+isJoinPoint (JoinPoint {}) = True+isJoinPoint NotJoinPoint   = False++instance Outputable JoinPointHood where+  ppr NotJoinPoint      = text "NotJoinPoint"+  ppr (JoinPoint arity) = text "JoinPoint" <> parens (ppr arity)++instance NFData JoinPointHood where+  rnf x = x `seq` ()  {- ************************************************************************
compiler/GHC/Utils/Panic.hs view
@@ -23,17 +23,11 @@    , handleGhcException       -- * Command error throwing patterns-   , pgmError-   , panic    , pprPanic-   , sorry    , panicDoc    , sorryDoc    , pgmErrorDoc-   , cmdLineError-   , cmdLineErrorIO      -- ** Assertions-   , assertPanic    , assertPprPanic    , assertPpr    , assertPprMaybe@@ -52,6 +46,7 @@    , tryMost    , throwTo    , withSignalHandlers+   , module GHC.Utils.Panic.Plain    ) where @@ -131,6 +126,10 @@           PlainInstallationError str -> InstallationError str           PlainProgramError str -> ProgramError str     | otherwise = Nothing++  -- Explicitly omit ExceptionContext since we generally don't+  -- want backtraces and other context in GHC's user errors.+  displayException exc = showGhcExceptionUnsafe exc ""  instance Show GhcException where   showsPrec _ e = showGhcExceptionUnsafe e
compiler/GHC/Utils/Panic/Plain.hs view
@@ -5,15 +5,10 @@ -- type.  It omits the exception constructors that involve -- pretty-printing via 'GHC.Utils.Outputable.SDoc'. ----- There are two reasons for this:------ 1. To avoid import cycles / use of boot files. "GHC.Utils.Outputable" has--- many transitive dependencies. To throw exceptions from these--- modules, the functions here can be used without introducing import--- cycles.------ 2. To reduce the number of modules that need to be compiled to--- object code when loading GHC into GHCi. See #13101+-- The reason for this is to avoid import cycles / use of boot files.+-- "GHC.Utils.Outputable" has many transitive dependencies.+-- To throw exceptions from these modules, the functions here can be used+-- without introducing import cycles. module GHC.Utils.Panic.Plain   ( PlainGhcException(..)   , showPlainGhcException
compiler/GHC/Utils/Ppr.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE BangPatterns #-} {-# LANGUAGE MagicHash #-}  -----------------------------------------------------------------------------
compiler/GHC/Utils/Trace.hs view
@@ -8,6 +8,7 @@   , pprSTrace   , pprTraceException   , warnPprTrace+  , warnPprTraceM   , pprTraceUserWarning   , trace   )@@ -83,6 +84,9 @@   = pprDebugAndThen traceSDocContext trace (text "WARNING:")                     (text s $$ msg $$ withFrozenCallStack traceCallStackDoc )                     x++warnPprTraceM :: (Applicative f, HasCallStack) => Bool -> String -> SDoc -> f ()+warnPprTraceM b s doc = withFrozenCallStack warnPprTrace b s doc (pure ())  -- | For when we want to show the user a non-fatal WARNING so that they can -- report a GHC bug, but don't want to panic.
compiler/Language/Haskell/Syntax.hs view
@@ -25,7 +25,6 @@         module Language.Haskell.Syntax.Module.Name,         module Language.Haskell.Syntax.Pat,         module Language.Haskell.Syntax.Type,-        module Language.Haskell.Syntax.Concrete,         module Language.Haskell.Syntax.Extension,         ModuleName(..), HsModule(..) ) where@@ -36,7 +35,6 @@ import Language.Haskell.Syntax.ImpExp import Language.Haskell.Syntax.Module.Name import Language.Haskell.Syntax.Lit-import Language.Haskell.Syntax.Concrete import Language.Haskell.Syntax.Extension import Language.Haskell.Syntax.Pat import Language.Haskell.Syntax.Type
compiler/Language/Haskell/Syntax/Binds.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -162,6 +163,25 @@     Just x = e     (x) = e     x :: Ty = e++Note [Multiplicity annotations]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Multiplicity annotations are stored in the pat_mult field on PatBinds,+represented by the HsMultAnn data type++  HsNoMultAnn <=> no annotation in the source file+  HsPct1Ann   <=> the %1 annotation+  HsMultAnn   <=> the %t annotation, where `t` is some type++In case of HsNoMultAnn the typechecker infers a multiplicity.++We don't need to store a multiplicity on FunBinds:+- let %1 x = … is parsed as a PatBind. So we don't need an annotation before+  typechecking.+- the multiplicity that the typechecker infers is stored in the binder's Var for+  the desugarer to use. It's only relevant for strict FunBinds, see Wrinkle 1 in+  Note [Desugar Strict binds] in GHC.HsToCore.Binds as, in Core, let expressions+  don't have multiplicity annotations. -}  -- | Haskell Binding with separate Left and Right id's@@ -219,6 +239,8 @@   | PatBind {         pat_ext    :: XPatBind idL idR,         pat_lhs    :: LPat idL,+        pat_mult   :: HsMultAnn idL,+        -- ^ See Note [Multiplicity annotations].         pat_rhs    :: GRHSs idR (LHsExpr idR)     } @@ -263,7 +285,20 @@      }    | XPatSynBind !(XXPatSynBind idL idR) +-- | Multiplicity annotations, on binders, are always resolved (to a unification+-- variable if there is no annotation) during type-checking. The resolved+-- multiplicity is stored in the extension fields.+data HsMultAnn pass+  = HsNoMultAnn !(XNoMultAnn pass)+  | HsPct1Ann   !(XPct1Ann pass)+  | HsMultAnn   !(XMultAnn pass) (LHsType (NoGhcTc pass))+  | XMultAnn    !(XXMultAnn pass) +type family XNoMultAnn p+type family XPct1Ann   p+type family XMultAnn   p+type family XXMultAnn  p+ {- ************************************************************************ *                                                                      *@@ -452,7 +487,7 @@        -- complete matchings which, for example, arise from pattern        -- synonym definitions.   | CompleteMatchSig (XCompleteMatchSig pass)-                     (XRec pass [LIdP pass])+                     [LIdP pass]                      (Maybe (LIdP pass))   | XSig !(XXSig pass) 
− compiler/Language/Haskell/Syntax/Concrete.hs 
@@ -1,64 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE DeriveDataTypeable #-}---- | Bits of concrete syntax (tokens, layout).--module Language.Haskell.Syntax.Concrete-  ( LHsToken, LHsUniToken,-    HsToken(HsTok),-    HsUniToken(HsNormalTok, HsUnicodeTok),-    LayoutInfo(ExplicitBraces, VirtualBraces, NoLayoutInfo)-  ) where--import GHC.Prelude-import GHC.TypeLits (Symbol, KnownSymbol)-import Data.Data-import Language.Haskell.Syntax.Extension--type LHsToken tok p = XRec p (HsToken tok)-type LHsUniToken tok utok p = XRec p (HsUniToken tok utok)---- | A token stored in the syntax tree. For example, when parsing a--- let-expression, we store @HsToken "let"@ and @HsToken "in"@.--- The locations of those tokens can be used to faithfully reproduce--- (exactprint) the original program text.-data HsToken (tok :: Symbol) = HsTok---- | With @UnicodeSyntax@, there might be multiple ways to write the same--- token. For example an arrow could be either @->@ or @→@. This choice must be--- recorded in order to exactprint such tokens, so instead of @HsToken "->"@ we--- introduce @HsUniToken "->" "→"@.------ See also @IsUnicodeSyntax@ in @GHC.Parser.Annotation@; we do not use here to--- avoid a dependency.-data HsUniToken (tok :: Symbol) (utok :: Symbol) = HsNormalTok | HsUnicodeTok--deriving instance Eq (HsToken tok)-deriving instance KnownSymbol tok => Data (HsToken tok)-deriving instance (KnownSymbol tok, KnownSymbol utok) => Data (HsUniToken tok utok)---- | Layout information for declarations.-data LayoutInfo pass =--    -- | Explicit braces written by the user.-    ---    -- @-    -- class C a where { foo :: a; bar :: a }-    -- @-    ExplicitBraces !(LHsToken "{" pass) !(LHsToken "}" pass)-  |-    -- | Virtual braces inserted by the layout algorithm.-    ---    -- @-    -- class C a where-    --   foo :: a-    --   bar :: a-    -- @-    VirtualBraces-      !Int -- ^ Layout column (indentation level, begins at 1)-  |-    -- | Empty or compiler-generated blocks do not have layout information-    -- associated with them.-    NoLayoutInfo
compiler/Language/Haskell/Syntax/Decls.hs view
@@ -49,7 +49,7 @@   TyFamInstDecl(..), LTyFamInstDecl,   TyFamDefltDecl, LTyFamDefltDecl,   DataFamInstDecl(..), LDataFamInstDecl,-  FamEqn(..), TyFamInstEqn, LTyFamInstEqn, HsTyPats,+  FamEqn(..), TyFamInstEqn, LTyFamInstEqn, HsFamEqnPats,   LClsInstDecl, ClsInstDecl(..),    -- ** Standalone deriving declarations@@ -70,7 +70,8 @@   CImportSpec(..),   -- ** Data-constructor declarations   ConDecl(..), LConDecl,-  HsConDeclH98Details, HsConDeclGADTDetails(..),+  HsConDeclH98Details,+  HsConDeclGADTDetails(..), XPrefixConGADT, XRecConGADT, XXConDeclGADTDetails,   -- ** Document comments   DocDecl(..), LDocDecl, docDeclDoc,   -- ** Deprecations@@ -94,7 +95,6 @@         -- Because Expr imports Decls via HsBracket  import Language.Haskell.Syntax.Binds-import Language.Haskell.Syntax.Concrete import Language.Haskell.Syntax.Extension import Language.Haskell.Syntax.Type import Language.Haskell.Syntax.Basic (Role)@@ -457,8 +457,6 @@     --                          'GHC.Parser.Annotation.AnnRarrow'     -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation   | ClassDecl { tcdCExt    :: XClassDecl pass,         -- ^ Post renamer, FVs-                tcdLayout  :: !(LayoutInfo pass),      -- ^ Explicit or virtual braces-                              -- See Note [Class LayoutInfo]                 tcdCtxt    :: Maybe (LHsContext pass), -- ^ Context...                 tcdLName   :: LIdP pass,               -- ^ Name of the class                 tcdTyVars  :: LHsQTyVars pass,         -- ^ Class type variables@@ -501,9 +499,9 @@      Note [Family instance declaration binders] -} -{- Note [Class LayoutInfo]-~~~~~~~~~~~~~~~~~~~~~~~~~~-The LayoutInfo is used to associate Haddock comments with parts of the declaration.+{- Note [Class EpLayout]+~~~~~~~~~~~~~~~~~~~~~~~~+The EpLayout is used to associate Haddock comments with parts of the declaration. Compare the following examples:      class C a where@@ -1081,7 +1079,6 @@   = ConDeclGADT       { con_g_ext   :: XConDeclGADT pass       , con_names   :: NonEmpty (LIdP pass)-      , con_dcolon  :: !(LHsUniToken "::" "∷" pass)       -- The following fields describe the type after the '::'       -- See Note [GADT abstract syntax]       , con_bndrs   :: XRec pass (HsOuterSigTyVarBndrs pass)@@ -1242,9 +1239,14 @@ -- derived Show instances—see Note [Infix GADT constructors] in -- GHC.Tc.TyCl—but that is an orthogonal concern.) data HsConDeclGADTDetails pass-   = PrefixConGADT [HsScaled pass (LBangType pass)]-   | RecConGADT (XRec pass [LConDeclField pass]) (LHsUniToken "->" "→" pass)+   = PrefixConGADT !(XPrefixConGADT pass) [HsScaled pass (LBangType pass)]+   | RecConGADT !(XRecConGADT pass) (XRec pass [LConDeclField pass])+   | XConDeclGADTDetails !(XXConDeclGADTDetails pass) +type family XPrefixConGADT       p+type family XRecConGADT          p+type family XXConDeclGADTDetails p+ {- ************************************************************************ *                                                                      *@@ -1283,8 +1285,12 @@  -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation --- | Haskell Type Patterns-type HsTyPats pass = [LHsTypeArg pass]+-- | HsFamEqnPats represents patterns on the left-hand side of a type instance,+-- e.g. `type instance F @k (a :: k) = a` has patterns `@k` and `(a :: k)`.+--+-- HsFamEqnPats used to be called HsTyPats but it was renamed to avoid confusion+-- with a different notion of type patterns, see #23657.+type HsFamEqnPats pass = [LHsTypeArg pass]  {- Note [Family instance declaration binders] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1374,7 +1380,7 @@        { feqn_ext    :: XCFamEqn pass rhs        , feqn_tycon  :: LIdP pass        , feqn_bndrs  :: HsOuterFamEqnTyVarBndrs pass -- ^ Optional quantified type vars-       , feqn_pats   :: HsTyPats pass+       , feqn_pats   :: HsFamEqnPats pass        , feqn_fixity :: LexicalFixity -- ^ Fixity used in the declaration        , feqn_rhs    :: rhs        }
compiler/Language/Haskell/Syntax/Expr.hs view
@@ -25,7 +25,6 @@ import Language.Haskell.Syntax.Decls import Language.Haskell.Syntax.Pat import Language.Haskell.Syntax.Lit-import Language.Haskell.Syntax.Concrete import Language.Haskell.Syntax.Extension import Language.Haskell.Syntax.Type import Language.Haskell.Syntax.Binds@@ -240,7 +239,7 @@  NB 2: The notation getField @"size" e is short for HsApp (HsAppType (HsVar "getField") (HsWC (HsTyLit (HsStrTy "size")) [])) e.-We track the original parsed syntax via HsExpanded.+We track the original parsed syntax via ExpandedThingRn.  -} @@ -296,16 +295,7 @@   | HsLit     (XLitE p)               (HsLit p)      -- ^ Simple (non-overloaded) literals -  | HsLam     (XLam p)-              (MatchGroup p (LHsExpr p))-                       -- ^ Lambda abstraction. Currently always a single match-       ---       -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLam',-       --       'GHC.Parser.Annotation.AnnRarrow',--       -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation--  -- | Lambda-case+  -- | Lambda, Lambda-case, and Lambda-cases   --   -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLam',   --           'GHC.Parser.Annotation.AnnCase','GHC.Parser.Annotation.AnnOpen',@@ -315,13 +305,22 @@   --           'GHC.Parser.Annotation.AnnClose'    -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation-  | HsLamCase (XLamCase p) LamCaseVariant (MatchGroup p (LHsExpr p))+  | HsLam     (XLam p)+              HsLamVariant -- ^ Tells whether this is for lambda, \case, or \cases+              (MatchGroup p (LHsExpr p))+                       -- ^ LamSingle: one match of arity >= 1+                       --   LamCase: many arity-1 matches+                       --   LamCases: many matches of uniform arity >= 1+       --+       -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLam',+       --       'GHC.Parser.Annotation.AnnRarrow', +       -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation+   | HsApp     (XApp p) (LHsExpr p) (LHsExpr p) -- ^ Application    | HsAppType (XAppTypeE p) -- After typechecking: the type argument               (LHsExpr p)-             !(LHsToken "@" p)               (LHsWcType (NoGhcTc p))  -- ^ Visible type application        --        -- Explicit type argument; e.g  f @Int x y@@ -355,9 +354,7 @@    -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation   | HsPar       (XPar p)-               !(LHsToken "(" p)                 (LHsExpr p)  -- ^ Parenthesised expr; see Note [Parens in HsSyn]-               !(LHsToken ")" p)    | SectionL    (XSectionL p)                 (LHsExpr p)    -- operand; see Note [Sections in HsSyn]@@ -428,9 +425,7 @@    -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation   | HsLet       (XLet p)-               !(LHsToken "let" p)                 (HsLocalBinds p)-               !(LHsToken "in" p)                 (LHsExpr  p)    -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnDo',@@ -579,9 +574,14 @@   -- Expressions annotated with pragmas, written as {-# ... #-}   | HsPragE (XPragE p) (HsPragE p) (LHsExpr p) +  -- Embed the syntax of types into expressions.+  -- Used with RequiredTypeArguments, e.g. fn (type (Int -> Bool))+  | HsEmbTy   (XEmbTy p)+              (LHsWcType (NoGhcTc p))+   | XExpr       !(XXExpr p)   -- Note [Trees That Grow] in Language.Haskell.Syntax.Extension for the-  -- general idea, and Note [Rebindable syntax and HsExpansion] in GHC.Hs.Expr+  -- general idea, and Note [Rebindable syntax and XXExprGhcRn] in GHC.Hs.Expr   -- for an example of how we use it.  -- ---------------------------------------------------------------------@@ -630,9 +630,10 @@                              -- in Language.Haskell.Syntax.Extension  -- | Which kind of lambda case are we dealing with?-data LamCaseVariant-  = LamCase -- ^ `\case`-  | LamCases -- ^ `\cases`+data HsLamVariant+  = LamSingle  -- ^ `\p -> e`+  | LamCase    -- ^ `\case pi -> ei `+  | LamCases   -- ^ `\cases psi -> ei`   deriving (Data, Eq)  {-@@ -839,17 +840,21 @@                 (LHsCmd id)                 (LHsExpr id) -  | HsCmdLam    (XCmdLam id)-                (MatchGroup id (LHsCmd id))     -- kappa-       -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLam',-       --       'GHC.Parser.Annotation.AnnRarrow',+  -- | Lambda-case+  --+  -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLam',+  --     'GHC.Parser.Annotation.AnnCase','GHC.Parser.Annotation.AnnOpen' @'{'@,+  --     'GHC.Parser.Annotation.AnnClose' @'}'@+  -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLam',+  --     'GHC.Parser.Annotation.AnnCases','GHC.Parser.Annotation.AnnOpen' @'{'@,+  --     'GHC.Parser.Annotation.AnnClose' @'}'@ -       -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation+  -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation+  | HsCmdLam (XCmdLamCase id) HsLamVariant+             (MatchGroup id (LHsCmd id)) -- bodies are HsCmd's    | HsCmdPar    (XCmdPar id)-               !(LHsToken "(" id)                 (LHsCmd id)                     -- parenthesised command-               !(LHsToken ")" id)     -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'('@,     --             'GHC.Parser.Annotation.AnnClose' @')'@ @@ -864,19 +869,6 @@      -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation -  -- | Lambda-case-  ---  -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLam',-  --     'GHC.Parser.Annotation.AnnCase','GHC.Parser.Annotation.AnnOpen' @'{'@,-  --     'GHC.Parser.Annotation.AnnClose' @'}'@-  -- - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLam',-  --     'GHC.Parser.Annotation.AnnCases','GHC.Parser.Annotation.AnnOpen' @'{'@,-  --     'GHC.Parser.Annotation.AnnClose' @'}'@--  -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation-  | HsCmdLamCase (XCmdLamCase id) LamCaseVariant-                 (MatchGroup id (LHsCmd id)) -- bodies are HsCmd's-   | HsCmdIf     (XCmdIf id)                 (SyntaxExpr id)         -- cond function                 (LHsExpr id)            -- predicate@@ -890,9 +882,7 @@     -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation    | HsCmdLet    (XCmdLet id)-               !(LHsToken "let" id)                 (HsLocalBinds id)      -- let(rec)-               !(LHsToken "in" id)                 (LHsCmd  id)     -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLet',     --       'GHC.Parser.Annotation.AnnOpen' @'{'@,@@ -987,10 +977,9 @@ -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation data Match p body   = Match {-        m_ext :: XCMatch p body,-        m_ctxt :: HsMatchContext p,-          -- See Note [m_ctxt in Match]-        m_pats :: [LPat p], -- The patterns+        m_ext   :: XCMatch p body,+        m_ctxt  :: HsMatchContext (LIdP (NoGhcTc p)), -- See Note [m_ctxt in Match]+        m_pats  :: [LPat p],                          -- The patterns         m_grhss :: (GRHSs p body)   }   | XMatch !(XXMatch p body)@@ -998,7 +987,6 @@ {- Note [m_ctxt in Match] ~~~~~~~~~~~~~~~~~~~~~~- A Match can occur in a number of contexts, such as a FunBind, HsCase, HsLam and so on. @@ -1027,9 +1015,6 @@     (&&&  ) [] [] =  []     xs    &&&   [] =  xs     (  &&&  ) [] ys =  ys--- -}  @@ -1543,21 +1528,19 @@ -- -- Context of a pattern match. This is more subtle than it would seem. See -- Note [FunBind vs PatBind].-data HsMatchContext p+data HsMatchContext fn   = FunRhs     -- ^ A pattern matching on an argument of a     -- function binding-      { mc_fun        :: LIdP (NoGhcTc p)    -- ^ function binder of @f@-                                             -- See Note [mc_fun field of FunRhs]-                                             -- See #20415 for a long discussion about-                                             -- this field and why it uses NoGhcTc.+      { mc_fun        :: fn    -- ^ function binder of @f@+                               -- See Note [mc_fun field of FunRhs]+                               -- See #20415 for a long discussion about this field       , mc_fixity     :: LexicalFixity -- ^ fixing of @f@       , mc_strictness :: SrcStrictness -- ^ was @f@ banged?                                        -- See Note [FunBind vs PatBind]       }-  | LambdaExpr                  -- ^Patterns of a lambda   | CaseAlt                     -- ^Patterns and guards in a case alternative-  | LamCaseAlt LamCaseVariant   -- ^Patterns and guards in @\case@ and @\cases@+  | LamAlt HsLamVariant         -- ^Patterns and guards in @\@, @\case@ and @\cases@   | IfAlt                       -- ^Guards of a multi-way if alternative   | ArrowMatchCtxt              -- ^A pattern match inside arrow notation       HsArrowMatchContext@@ -1570,48 +1553,57 @@                                 --    tell matchWrapper what sort of                                 --    runtime error message to generate] -  | StmtCtxt (HsStmtContext p)  -- ^Pattern of a do-stmt, list comprehension,-                                -- pattern guard, etc+  | StmtCtxt (HsStmtContext fn)  -- ^Pattern of a do-stmt, list comprehension,+                                 --  pattern guard, etc    | ThPatSplice            -- ^A Template Haskell pattern splice   | ThPatQuote             -- ^A Template Haskell pattern quotation [p| (a,b) |]   | PatSyn                 -- ^A pattern synonym declaration+  | LazyPatCtx             -- ^An irrefutable pattern -{--Note [mc_fun field of FunRhs]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The mc_fun field of FunRhs has type `LIdP (NoGhcTc p)`, which means it will be-a `RdrName` in pass `GhcPs`, a `Name` in `GhcRn`, and (importantly) still a-`Name` in `GhcTc` -- not an `Id`.  See Note [NoGhcTc] in GHC.Hs.Extension.+{- Note [mc_fun field of FunRhs]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+HsMatchContext is parameterised over `fn`, the function binder stored in `FunRhs`.+This makes pretty printing easy. -Why a `Name` in the typechecker phase?  Because:-* A `Name` is all we need, as it turns out.-* Using an `Id` involves knot-tying in the monad, which led to #22695.+In the use of `HsMatchContext` in `Match`, it is parameterised thus:+    data Match p body = Match { m_ctxt  :: HsMatchContext (LIdP (NoGhcTc p)), ... }+So in a Match, the mc_fun field `FunRhs` will be a `RdrName` in pass `GhcPs`, a `Name`+in `GhcRn`, and (importantly) still a `Name` in `GhcTc` -- not an `Id`.+See Note [NoGhcTc] in GHC.Hs.Extension. -See #20415 for a long discussion.+* Why a `Name` in the typechecker phase?  Because:+  * A `Name` is all we need, as it turns out.+  * Using an `Id` involves knot-tying in the monad, which led to #22695. --}+* Why a /located/ name?  Because we want to record the location of the Id+  on the LHS of /this/ match.  See Note [m_ctxt in Match].  Example:+    (&&&) [] [] = []+    xs  &&&  [] = xs+  The two occurrences of `&&&` have different locations. -isPatSynCtxt :: HsMatchContext p -> Bool-isPatSynCtxt ctxt =-  case ctxt of-    PatSyn -> True-    _      -> False+* Why parameterise `HsMatchContext` over `fn` rather than over the pass `p`?+  Because during typechecking (specifically GHC.Tc.Gen.Match.tcMatch) we need to convert+     HsMatchContext (LIdP (NoGhcTc GhcRn)) --> HsMatchContext (LIdP (NoGhcTc GhcTc))+  With this parameterisation it's easy; if it was parametersed over `p` we'd  need+  a recursive traversal of the HsMatchContext. +See #20415 for a long discussion.+-}+ -- | Haskell Statement Context.-data HsStmtContext p-  = HsDoStmt HsDoFlavour             -- ^ Context for HsDo (do-notation and comprehensions)-  | PatGuard (HsMatchContext p)      -- ^ Pattern guard for specified thing-  | ParStmtCtxt (HsStmtContext p)    -- ^ A branch of a parallel stmt-  | TransStmtCtxt (HsStmtContext p)  -- ^ A branch of a transform stmt-  | ArrowExpr                        -- ^ do-notation in an arrow-command context+data HsStmtContext fn+  = HsDoStmt HsDoFlavour              -- ^ Context for HsDo (do-notation and comprehensions)+  | PatGuard (HsMatchContext fn)      -- ^ Pattern guard for specified thing+  | ParStmtCtxt (HsStmtContext fn)    -- ^ A branch of a parallel stmt+  | TransStmtCtxt (HsStmtContext fn)  -- ^ A branch of a transform stmt+  | ArrowExpr                         -- ^ do-notation in an arrow-command context  -- | Haskell arrow match context. data HsArrowMatchContext   = ProcExpr                       -- ^ A proc expression   | ArrowCaseAlt                   -- ^ A case alternative inside arrow notation-  | ArrowLamCaseAlt LamCaseVariant -- ^ A \case or \cases alternative inside arrow notation-  | KappaExpr                      -- ^ An arrow kappa abstraction+  | ArrowLamAlt HsLamVariant       -- ^ A \, \case or \cases alternative inside arrow notation  data HsDoFlavour   = DoExpr (Maybe ModuleName)        -- ^[ModuleName.]do { ... }@@ -1619,14 +1611,21 @@   | GhciStmtCtxt                     -- ^A command-line Stmt in GHCi pat <- rhs   | ListComp   | MonadComp+  deriving (Eq, Data) -qualifiedDoModuleName_maybe :: HsStmtContext p -> Maybe ModuleName+qualifiedDoModuleName_maybe :: HsStmtContext fn -> Maybe ModuleName qualifiedDoModuleName_maybe ctxt = case ctxt of   HsDoStmt (DoExpr m) -> m   HsDoStmt (MDoExpr m) -> m   _ -> Nothing -isComprehensionContext :: HsStmtContext id -> Bool+isPatSynCtxt :: HsMatchContext fn -> Bool+isPatSynCtxt ctxt =+  case ctxt of+    PatSyn -> True+    _      -> False++isComprehensionContext :: HsStmtContext fn -> Bool -- Uses comprehension syntax [ e | quals ] isComprehensionContext (ParStmtCtxt c)   = isComprehensionContext c isComprehensionContext (TransStmtCtxt c) = isComprehensionContext c@@ -1642,7 +1641,7 @@ isDoComprehensionContext MonadComp = True  -- | Is this a monadic context?-isMonadStmtContext :: HsStmtContext id -> Bool+isMonadStmtContext :: HsStmtContext fn -> Bool isMonadStmtContext (ParStmtCtxt ctxt)   = isMonadStmtContext ctxt isMonadStmtContext (TransStmtCtxt ctxt) = isMonadStmtContext ctxt isMonadStmtContext (HsDoStmt flavour) = isMonadDoStmtContext flavour@@ -1656,7 +1655,7 @@ isMonadDoStmtContext MDoExpr{}    = True isMonadDoStmtContext GhciStmtCtxt = True -isMonadCompContext :: HsStmtContext id -> Bool+isMonadCompContext :: HsStmtContext fn -> Bool isMonadCompContext (HsDoStmt flavour)   = isMonadDoCompContext flavour isMonadCompContext (ParStmtCtxt _)   = False isMonadCompContext (TransStmtCtxt _) = False
compiler/Language/Haskell/Syntax/Expr.hs-boot view
@@ -9,6 +9,9 @@ import Language.Haskell.Syntax.Extension ( XRec ) import Data.Kind  ( Type ) +import GHC.Prelude (Eq)+import Data.Data (Data)+ type role HsExpr nominal type role MatchGroup nominal nominal type role GRHSs nominal nominal@@ -20,3 +23,7 @@ type family SyntaxExpr (i :: Type)  type LHsExpr a = XRec a (HsExpr a)++data HsDoFlavour+instance Eq HsDoFlavour+instance Data HsDoFlavour
compiler/Language/Haskell/Syntax/Extension.hs view
@@ -447,6 +447,7 @@ type family XTick           x type family XBinTick        x type family XPragE          x+type family XEmbTy          x type family XXExpr          x  -- -------------------------------------@@ -606,6 +607,8 @@ type family XNPat        x type family XNPlusKPat   x type family XSigPat      x+type family XEmbTyPat    x+type family XInvisPat    x type family XCoPat       x type family XXPat        x type family XHsFieldBind x@@ -639,6 +642,11 @@ -- HsPatSigType type families type family XHsPS x type family XXHsPatSigType x++-- -------------------------------------+-- HsTyPat type families+type family XHsTP x+type family XXHsTyPat x  -- ------------------------------------- -- HsType type families
compiler/Language/Haskell/Syntax/ImpExp.hs view
@@ -94,28 +94,45 @@          -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation +-- | A docstring attached to an export list item.+type ExportDoc pass = LHsDoc pass+ -- | Imported or exported entity. data IE pass-  = IEVar       (XIEVar pass) (LIEWrappedName pass)-        -- ^ Imported or Exported Variable+  = IEVar       (XIEVar pass) (LIEWrappedName pass) (Maybe (ExportDoc pass))+        -- ^ Imported or exported variable+        --+        -- @+        -- module Mod ( test )+        -- import Mod ( test )+        -- @ -  | IEThingAbs  (XIEThingAbs pass) (LIEWrappedName pass)-        -- ^ Imported or exported Thing with Absent list+  | IEThingAbs  (XIEThingAbs pass) (LIEWrappedName pass) (Maybe (ExportDoc pass))+        -- ^ Imported or exported Thing with absent subordinate list         ---        -- The thing is a Class/Type (can't tell)+        -- The thing is a typeclass or type (can't tell)         --  - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnPattern',         --             'GHC.Parser.Annotation.AnnType','GHC.Parser.Annotation.AnnVal'+        --+        -- @+        -- module Mod ( Test )+        -- import Mod ( Test )+        -- @          -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation         -- See Note [Located RdrNames] in GHC.Hs.Expr-  | IEThingAll  (XIEThingAll pass) (LIEWrappedName pass)-        -- ^ Imported or exported Thing with All imported or exported+  | IEThingAll  (XIEThingAll pass) (LIEWrappedName pass) (Maybe (ExportDoc pass))+        -- ^ Imported or exported thing with wildcard subordinate list (e..g @(..)@)         --         -- The thing is a Class/Type and the All refers to methods/constructors         --         -- - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnOpen',         --       'GHC.Parser.Annotation.AnnDotdot','GHC.Parser.Annotation.AnnClose',         --                                 'GHC.Parser.Annotation.AnnType'+        -- @+        -- module Mod ( Test(..) )+        -- import Mod ( Test(..) )+        -- @          -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation         -- See Note [Located RdrNames] in GHC.Hs.Expr@@ -124,7 +141,8 @@                 (LIEWrappedName pass)                 IEWildcard                 [LIEWrappedName pass]-        -- ^ Imported or exported Thing With given imported or exported+                (Maybe (ExportDoc pass))+        -- ^ Imported or exported thing with explicit subordinate list.         --         -- The thing is a Class/Type and the imported or exported things are         -- its children.@@ -132,6 +150,10 @@         --                                   'GHC.Parser.Annotation.AnnClose',         --                                   'GHC.Parser.Annotation.AnnComma',         --                                   'GHC.Parser.Annotation.AnnType'+        -- @+        -- module Mod ( Test(..) )+        -- import Mod ( Test(..) )+        -- @          -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation   | IEModuleContents  (XIEModuleContents pass) (XRec pass ModuleName)@@ -140,11 +162,39 @@         -- (Export Only)         --         -- - 'GHC.Parser.Annotation.AnnKeywordId's : 'GHC.Parser.Annotation.AnnModule'+        --+        -- @+        -- module Mod ( module Mod2 )+        -- @          -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation   | IEGroup             (XIEGroup pass) Int (LHsDoc pass) -- ^ Doc section heading+        -- ^ A Haddock section in an export list.+        --+        -- @+        -- module Mod+        --   ( -- * Section heading+        --     ...+        --   )+        -- @   | IEDoc               (XIEDoc pass) (LHsDoc pass)       -- ^ Some documentation+        -- ^ A bit of unnamed documentation.+        --+        -- @+        -- module Mod+        --   ( -- | Documentation+        --     ...+        --   )+        -- @   | IEDocNamed          (XIEDocNamed pass) String    -- ^ Reference to named doc+        -- ^ A reference to a named documentation chunk.+        --+        -- @+        -- module Mod+        --   ( -- $chunkName+        --     ...+        --   )+        -- @   | XIE !(XXIE pass)  -- | Wildcard in an import or export sublist, like the @..@ in
compiler/Language/Haskell/Syntax/Pat.hs view
@@ -20,10 +20,11 @@ -- See Note [Language.Haskell.Syntax.* Hierarchy] for why not GHC.Hs.* module Language.Haskell.Syntax.Pat (         Pat(..), LPat,-        ConLikeP,+        ConLikeP, isInvisArgPat,+        isVisArgPat, -        HsConPatDetails, hsConPatArgs,-        HsConPatTyArg(..),+        HsConPatDetails, hsConPatArgs, hsConPatTyArgs,+        HsConPatTyArg(..), XConPatTyArg,         HsRecFields(..), HsFieldBind(..), LHsFieldBind,         HsRecField, LHsRecField,         HsRecUpdField, LHsRecUpdField,@@ -36,7 +37,6 @@ -- friends: import Language.Haskell.Syntax.Basic import Language.Haskell.Syntax.Lit-import Language.Haskell.Syntax.Concrete import Language.Haskell.Syntax.Extension import Language.Haskell.Syntax.Type @@ -79,16 +79,13 @@    | AsPat       (XAsPat p)                 (LIdP p)-               !(LHsToken "@" p)                 (LPat p)    -- ^ As pattern     -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnAt'      -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation    | ParPat      (XParPat p)-               !(LHsToken "(" p)                 (LPat p)                -- ^ Parenthesised pattern-               !(LHsToken ")" p)                                         -- See Note [Parens in HsSyn] in GHC.Hs.Expr     -- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnOpen' @'('@,     --                                    'GHC.Parser.Annotation.AnnClose' @')'@@@ -219,6 +216,14 @@      -- ^ Pattern with a type signature +  -- Embed the syntax of types into patterns.+  -- Used with RequiredTypeArguments, e.g. fn (type t) = rhs+  | EmbTyPat        (XEmbTyPat p)+                    (HsTyPat (NoGhcTc p))++  -- See Note [Invisible binders in functions] in GHC.Hs.Pat+  | InvisPat (XInvisPat p) (HsTyPat (NoGhcTc p))+   -- Extension point; see Note [Trees That Grow] in Language.Haskell.Syntax.Extension   | XPat       !(XXPat p)@@ -230,11 +235,17 @@  -- | Type argument in a data constructor pattern, --   e.g. the @\@a@ in @f (Just \@a x) = ...@.-data HsConPatTyArg p =-  HsConPatTyArg-    !(LHsToken "@" p)-     (HsPatSigType p)+data HsConPatTyArg p = HsConPatTyArg !(XConPatTyArg p) (HsTyPat p) +type family XConPatTyArg p++isInvisArgPat :: Pat p -> Bool+isInvisArgPat InvisPat{} = True+isInvisArgPat _   = False++isVisArgPat :: Pat p -> Bool+isVisArgPat = not . isInvisArgPat+ -- | Haskell Constructor Pattern Details type HsConPatDetails p = HsConDetails (HsConPatTyArg (NoGhcTc p)) (LPat p) (HsRecFields p (LPat p)) @@ -242,6 +253,11 @@ hsConPatArgs (PrefixCon _ ps) = ps hsConPatArgs (RecCon fs)      = Data.List.map (hfbRHS . unXRec @p) (rec_flds fs) hsConPatArgs (InfixCon p1 p2) = [p1,p2]++hsConPatTyArgs :: forall p. HsConPatDetails p -> [HsConPatTyArg (NoGhcTc p)]+hsConPatTyArgs (PrefixCon tyargs _) = tyargs+hsConPatTyArgs (RecCon _)           = []+hsConPatTyArgs (InfixCon _ _)       = []  -- | Haskell Record Fields --
compiler/Language/Haskell/Syntax/Type.hs view
@@ -22,22 +22,24 @@ module Language.Haskell.Syntax.Type (         HsScaled(..),         hsMult, hsScaledThing,-        HsArrow(..),-        HsLinearArrowTokens(..),+        HsArrow(..), XUnrestrictedArrow, XLinearArrow, XExplicitMult, XXArrow,          HsType(..), LHsType, HsKind, LHsKind,-        HsBndrVis(..), isHsBndrInvisible,+        HsBndrVis(..), XBndrRequired, XBndrInvisible, XXBndrVis,+        isHsBndrInvisible,         HsForAllTelescope(..), HsTyVarBndr(..), LHsTyVarBndr,         LHsQTyVars(..),         HsOuterTyVarBndrs(..), HsOuterFamEqnTyVarBndrs, HsOuterSigTyVarBndrs,         HsWildCardBndrs(..),         HsPatSigType(..),         HsSigType(..), LHsSigType, LHsSigWcType, LHsWcType,+        HsTyPat(..), LHsTyPat,         HsTupleSort(..),         HsContext, LHsContext,         HsTyLit(..),         HsIPName(..), hsIPNameFS,-        HsArg(..),+        HsArg(..), XValArg, XTypeArg, XArgPar, XXArg,+         LHsTypeArg,          LBangType, BangType,@@ -59,13 +61,11 @@  import {-# SOURCE #-} Language.Haskell.Syntax.Expr ( HsUntypedSplice ) -import Language.Haskell.Syntax.Concrete import Language.Haskell.Syntax.Extension  import GHC.Types.Name.Reader ( RdrName ) import GHC.Core.DataCon( HsSrcBang(..) ) import GHC.Core.Type (Specificity)-import GHC.Types.SrcLoc (SrcSpan) import GHC.Types.Basic (Arity)  import GHC.Hs.Doc (LHsDoc)@@ -359,7 +359,7 @@ -- the forall-or-nothing rule. These are used to represent the outermost -- quantification in: --    * Type signatures (LHsSigType/LHsSigWcType)---    * Patterns in a type/data family instance (HsTyPats)+--    * Patterns in a type/data family instance (HsFamEqnPats) -- -- We support two forms: --   HsOuterImplicit (implicit quantification, added by renamer)@@ -448,6 +448,14 @@ -- | Located Haskell Signature Wildcard Type type LHsSigWcType pass = HsWildCardBndrs pass (LHsSigType pass) -- Both +data HsTyPat pass+  = HsTP { hstp_ext  :: XHsTP pass   -- ^ After renamer: 'HsTyPatRn'+         , hstp_body :: LHsType pass -- ^ Main payload (the type itself)+    }+  | XHsTyPat !(XXHsTyPat pass)++type LHsTyPat  pass = XRec pass (HsTyPat pass)+ -- | A type signature that obeys the @forall@-or-nothing rule. In other -- words, an 'LHsType' that uses an 'HsOuterSigTyVarBndrs' to represent its -- outermost type variable quantification.@@ -717,19 +725,26 @@       !(XXTyVarBndr pass)  data HsBndrVis pass-  = HsBndrRequired+  = HsBndrRequired !(XBndrRequired pass)       -- Binder for a visible (required) variable:       --     type Dup a = (a, a)       --             ^^^ -  | HsBndrInvisible (LHsToken "@" pass)+  | HsBndrInvisible !(XBndrInvisible pass)       -- Binder for an invisible (specified) variable:       --     type KindOf @k (a :: k) = k       --                ^^^ +  | XXBndrVis !(XXBndrVis pass)++type family XBndrRequired  p+type family XBndrInvisible p+type family XXBndrVis      p+ isHsBndrInvisible :: HsBndrVis pass -> Bool isHsBndrInvisible HsBndrInvisible{} = True-isHsBndrInvisible HsBndrRequired    = False+isHsBndrInvisible HsBndrRequired{}  = False+isHsBndrInvisible (XXBndrVis _)     = False  -- | Does this 'HsTyVarBndr' come with an explicit kind annotation? isHsKindedTyVar :: HsTyVarBndr flag pass -> Bool@@ -774,7 +789,6 @@    | HsAppKindTy         (XAppKindTy pass) -- type level type app                         (LHsType pass)-                       !(LHsToken "@" pass)                         (LHsKind pass)    | HsFunTy             (XFunTy pass)@@ -923,22 +937,25 @@  -- | Denotes the type of arrows in the surface language data HsArrow pass-  = HsUnrestrictedArrow !(LHsUniToken "->" "→" pass)+  = HsUnrestrictedArrow !(XUnrestrictedArrow pass)     -- ^ a -> b or a → b -  | HsLinearArrow !(HsLinearArrowTokens pass)+  | HsLinearArrow !(XLinearArrow pass)     -- ^ a %1 -> b or a %1 → b, or a ⊸ b -  | HsExplicitMult !(LHsToken "%" pass) !(LHsType pass) !(LHsUniToken "->" "→" pass)+  | HsExplicitMult !(XExplicitMult pass) !(LHsType pass)     -- ^ a %m -> b or a %m → b (very much including `a %Many -> b`!     -- This is how the programmer wrote it). It is stored as an     -- `HsType` so as to preserve the syntax as written in the     -- program. -data HsLinearArrowTokens pass-  = HsPct1 !(LHsToken "%1" pass) !(LHsUniToken "->" "→" pass)-  | HsLolly !(LHsToken "⊸" pass)+  | XArrow !(XXArrow pass) +type family XUnrestrictedArrow p+type family XLinearArrow       p+type family XExplicitMult      p+type family XXArrow            p+ -- | This is used in the syntax. In constructor declaration. It must keep the -- arrow representation. data HsScaled pass a = HsScaled (HsArrow pass) a@@ -1137,36 +1154,62 @@  {- Note [hsScopedTvs and visible foralls] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--XScopedTypeVariables can be defined in terms of a desugaring to--XTypeAbstractions (GHC Proposal #50):+ScopedTypeVariables can be defined in terms of a desugaring to TypeAbstractions+(GHC Proposals #155 and #448):      fn :: forall a b c. tau(a,b,c)            fn :: forall a b c. tau(a,b,c)     fn = defn(a,b,c)                   ==>    fn @x @y @z = defn(x,y,z) -That is, for every type variable of the leading 'forall' in the type signature,-we add an invisible binder at term level.+That is, for every type variable of the leading `forall` in the type signature,+we add an invisible binder at the term level. -This model does not extend to visible forall, as discussed here:+This model does not extend to visible forall. (Visible forall is the one written+with an arrow instead of a dot, i.e. `forall a ->`. See GHC Proposal #281 and+the RequiredTypeArguments extension).  Here is an example that demonstrates the+issue: -* https://gitlab.haskell.org/ghc/ghc/issues/16734#note_203412-* https://github.com/ghc-proposals/ghc-proposals/pull/238+  vfn :: forall a b -> tau(a, b)+  vfn = case <scrutinee> of (p,q) -> \x y -> ... -The conclusion of these discussions can be summarized as follows:+The `a` and `b` cannot scope over the equations of `vfn`.  In particular,+`a` and `b` cannot be in scope in <scrutinee> because those type variables+are bound by the `\x y ->`. -  > Assuming support for visible 'forall' in terms, consider this example:-  >-  >     vfn :: forall x y -> tau(x,y)-  >     vfn = \a b -> ...-  >-  > The user has written their own binders 'a' and 'b' to stand for 'x' and-  > 'y', and we definitely should not desugar this into:-  >-  >     vfn :: forall x y -> tau(x,y)-  >     vfn x y = \a b -> ...         -- bad!+Our solution is simple: ScopedTypeVariables has no effect on visible forall.+It follows naturally from the fact that ScopedTypeVariables is already subject+to several restrictions: -This design choice is reflected in the design of HsOuterSigTyVarBndrs, which are-used in every place that ScopedTypeVariables takes effect:+  1. The type signature must be headed by an /explicit/ forall+      * `f :: forall a. a -> blah` brings `a` into scope in the body+      * `f ::           a -> blah` does not +  2. The forall is /not nested/+      * `f :: forall a b. blah`         brings `a` and `b` into scope in the body+      * `f :: forall a. forall b. blah` brings `a` but not `b` into scope in the body++With the introduction of visible forall, we also introduce a third condition:++  3. The forall has to be /invisible/+      * `f :: forall a b.   blah` brings `a` and `b` into scope in the body+      * `f :: forall a b -> blah` does not++For example:++   f1 :: forall a. a -> a+   f1 x = (x::a)          -- OK: `a` is in scope in the body++   f2 :: forall a b. a -> b -> (a, b)+   f2 x y = (x::a, y::b)  -- OK: both `a` and `b` are in scope in the body++   f3 :: forall a. forall b. a -> b -> (a, b)+   f3 x y = (x::a, y::b)  -- Wrong: the `forall b.` is not the outermost forall++   f4 :: forall a -> a -> a+   f4 t (x::t) = (x::a)   -- Wrong: the `forall a ->` does not bring `a` into scope++This design choice is reflected in the definition of HsOuterSigTyVarBndrs, which are+used in every place where ScopedTypeVariables takes effect:+   data HsOuterTyVarBndrs flag pass     = HsOuterImplicit { ... }     | HsOuterExplicit { ..., hso_bndrs :: [LHsTyVarBndr flag pass] }@@ -1180,21 +1223,6 @@ (in hsScopedTvs), we /only/ bring the type variables bound by the hso_bndrs in an HsOuterExplicit into scope. If we have an HsOuterImplicit instead, then we do not bring any type variables into scope over the body of a function at all.--At the moment, GHC does not support visible 'forall' in terms. Nevertheless,-it is still possible to write erroneous programs that use visible 'forall's in-terms, such as this example:--    x :: forall a -> a -> a-    x = x--Previous versions of GHC would bring `a` into scope over the body of `x` in the-hopes that the typechecker would error out later-(see `GHC.Tc.Validity.vdqAllowed`). However, this can wreak havoc in the-renamer before GHC gets to that point (see #17687 for an example of this).-Bottom line: nip problems in the bud by refraining from bringing any type-variables in an HsOuterImplicit into scope over the body of a function, even-if they correspond to a visible 'forall'. -}  {-@@ -1207,10 +1235,16 @@  -- | Arguments in an expression/type after splitting data HsArg p tm ty-  = HsValArg tm   -- Argument is an ordinary expression     (f arg)-  | HsTypeArg !(LHsToken "@" p) ty -- Argument is a visible type application (f @ty)-  | HsArgPar SrcSpan -- See Note [HsArgPar]+  = HsValArg !(XValArg p) tm   -- Argument is an ordinary expression     (f arg)+  | HsTypeArg !(XTypeArg p) ty -- Argument is a visible type application (f @ty)+  | HsArgPar !(XArgPar p)      -- See Note [HsArgPar]+  | XArg !(XXArg p) +type family XValArg  p+type family XTypeArg p+type family XArgPar  p+type family XXArg    p+ -- type level equivalent type LHsTypeArg p = HsArg p (LHsType p) (LHsKind p) @@ -1263,7 +1297,7 @@   , Eq (XXFieldOcc pass)   ) => Eq (FieldOcc pass) --- | Located Ambiguous Field Occurence+-- | Located Ambiguous Field Occurrence type LAmbiguousFieldOcc pass = XRec pass (AmbiguousFieldOcc pass)  -- | Ambiguous Field Occurrence
compiler/MachRegs.h view
@@ -51,638 +51,54 @@ #elif MACHREGS_NO_REGS == 0  /* -----------------------------------------------------------------------------   Caller saves and callee-saves regs.-+   Note [Caller saves and callee-saves regs.]+   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~    Caller-saves regs have to be saved around C-calls made from STG    land, so this file defines CALLER_SAVES_<reg> for each <reg> that    is designated caller-saves in that machine's C calling convention.+   NB: Caller-saved registers not mapped to a STG register don't+       require a CALLER_SAVES_ define.     As it stands, the only registers that are ever marked caller saves-   are the RX, FX, DX and USER registers; as a result, if you+   are the RX, FX, DX, XMM and USER registers; as a result, if you    decide to caller save a system register (e.g. SP, HP, etc), note that    this code path is completely untested! -- EZY     See Note [Register parameter passing] for details.    -------------------------------------------------------------------------- */ -/* ------------------------------------------------------------------------------   The x86 register mapping--   Ok, we've only got 6 general purpose registers, a frame pointer and a-   stack pointer.  \tr{%eax} and \tr{%edx} are return values from C functions,-   hence they get trashed across ccalls and are caller saves. \tr{%ebx},-   \tr{%esi}, \tr{%edi}, \tr{%ebp} are all callee-saves.--   Reg     STG-Reg-   ----------------   ebx     Base-   ebp     Sp-   esi     R1-   edi     Hp--   Leaving SpLim out of the picture.-   -------------------------------------------------------------------------- */--#if defined(MACHREGS_i386)--#define REG(x) __asm__("%" #x)--#if !defined(not_doing_dynamic_linking)-#define REG_Base    ebx-#endif-#define REG_Sp      ebp--#if !defined(STOLEN_X86_REGS)-#define STOLEN_X86_REGS 4-#endif--#if STOLEN_X86_REGS >= 3-# define REG_R1     esi-#endif--#if STOLEN_X86_REGS >= 4-# define REG_Hp     edi-#endif-#define REG_MachSp  esp--#define REG_XMM1    xmm0-#define REG_XMM2    xmm1-#define REG_XMM3    xmm2-#define REG_XMM4    xmm3--#define REG_YMM1    ymm0-#define REG_YMM2    ymm1-#define REG_YMM3    ymm2-#define REG_YMM4    ymm3--#define REG_ZMM1    zmm0-#define REG_ZMM2    zmm1-#define REG_ZMM3    zmm2-#define REG_ZMM4    zmm3--#define MAX_REAL_VANILLA_REG 1  /* always, since it defines the entry conv */-#define MAX_REAL_FLOAT_REG   0-#define MAX_REAL_DOUBLE_REG  0-#define MAX_REAL_LONG_REG    0-#define MAX_REAL_XMM_REG     4-#define MAX_REAL_YMM_REG     4-#define MAX_REAL_ZMM_REG     4--/* ------------------------------------------------------------------------------  The x86-64 register mapping--  %rax          caller-saves, don't steal this one-  %rbx          YES-  %rcx          arg reg, caller-saves-  %rdx          arg reg, caller-saves-  %rsi          arg reg, caller-saves-  %rdi          arg reg, caller-saves-  %rbp          YES (our *prime* register)-  %rsp          (unavailable - stack pointer)-  %r8           arg reg, caller-saves-  %r9           arg reg, caller-saves-  %r10          caller-saves-  %r11          caller-saves-  %r12          YES-  %r13          YES-  %r14          YES-  %r15          YES--  %xmm0-7       arg regs, caller-saves-  %xmm8-15      caller-saves--  Use the caller-saves regs for Rn, because we don't always have to-  save those (as opposed to Sp/Hp/SpLim etc. which always have to be-  saved).--  --------------------------------------------------------------------------- */--#elif defined(MACHREGS_x86_64)--#define REG(x) __asm__("%" #x)--#define REG_Base  r13-#define REG_Sp    rbp-#define REG_Hp    r12-#define REG_R1    rbx-#define REG_R2    r14-#define REG_R3    rsi-#define REG_R4    rdi-#define REG_R5    r8-#define REG_R6    r9-#define REG_SpLim r15-#define REG_MachSp  rsp--/*-Map both Fn and Dn to register xmmn so that we can pass a function any-combination of up to six Float# or Double# arguments without touching-the stack. See Note [Overlapping global registers] for implications.-*/--#define REG_F1    xmm1-#define REG_F2    xmm2-#define REG_F3    xmm3-#define REG_F4    xmm4-#define REG_F5    xmm5-#define REG_F6    xmm6--#define REG_D1    xmm1-#define REG_D2    xmm2-#define REG_D3    xmm3-#define REG_D4    xmm4-#define REG_D5    xmm5-#define REG_D6    xmm6--#define REG_XMM1    xmm1-#define REG_XMM2    xmm2-#define REG_XMM3    xmm3-#define REG_XMM4    xmm4-#define REG_XMM5    xmm5-#define REG_XMM6    xmm6--#define REG_YMM1    ymm1-#define REG_YMM2    ymm2-#define REG_YMM3    ymm3-#define REG_YMM4    ymm4-#define REG_YMM5    ymm5-#define REG_YMM6    ymm6--#define REG_ZMM1    zmm1-#define REG_ZMM2    zmm2-#define REG_ZMM3    zmm3-#define REG_ZMM4    zmm4-#define REG_ZMM5    zmm5-#define REG_ZMM6    zmm6--#if !defined(mingw32_HOST_OS)-#define CALLER_SAVES_R3-#define CALLER_SAVES_R4-#endif-#define CALLER_SAVES_R5-#define CALLER_SAVES_R6--#define CALLER_SAVES_F1-#define CALLER_SAVES_F2-#define CALLER_SAVES_F3-#define CALLER_SAVES_F4-#define CALLER_SAVES_F5-#if !defined(mingw32_HOST_OS)-#define CALLER_SAVES_F6-#endif--#define CALLER_SAVES_D1-#define CALLER_SAVES_D2-#define CALLER_SAVES_D3-#define CALLER_SAVES_D4-#define CALLER_SAVES_D5-#if !defined(mingw32_HOST_OS)-#define CALLER_SAVES_D6-#endif--#define CALLER_SAVES_XMM1-#define CALLER_SAVES_XMM2-#define CALLER_SAVES_XMM3-#define CALLER_SAVES_XMM4-#define CALLER_SAVES_XMM5-#if !defined(mingw32_HOST_OS)-#define CALLER_SAVES_XMM6-#endif--#define CALLER_SAVES_YMM1-#define CALLER_SAVES_YMM2-#define CALLER_SAVES_YMM3-#define CALLER_SAVES_YMM4-#define CALLER_SAVES_YMM5-#if !defined(mingw32_HOST_OS)-#define CALLER_SAVES_YMM6-#endif--#define CALLER_SAVES_ZMM1-#define CALLER_SAVES_ZMM2-#define CALLER_SAVES_ZMM3-#define CALLER_SAVES_ZMM4-#define CALLER_SAVES_ZMM5-#if !defined(mingw32_HOST_OS)-#define CALLER_SAVES_ZMM6-#endif--#define MAX_REAL_VANILLA_REG 6-#define MAX_REAL_FLOAT_REG   6-#define MAX_REAL_DOUBLE_REG  6-#define MAX_REAL_LONG_REG    0-#define MAX_REAL_XMM_REG     6-#define MAX_REAL_YMM_REG     6-#define MAX_REAL_ZMM_REG     6--/* ------------------------------------------------------------------------------   The PowerPC register mapping--   0            system glue?    (caller-save, volatile)-   1            SP              (callee-save, non-volatile)-   2            AIX, powerpc64-linux:-                    RTOC        (a strange special case)-                powerpc32-linux:-                                reserved for use by system--   3-10         args/return     (caller-save, volatile)-   11,12        system glue?    (caller-save, volatile)-   13           on 64-bit:      reserved for thread state pointer-                on 32-bit:      (callee-save, non-volatile)-   14-31                        (callee-save, non-volatile)--   f0                           (caller-save, volatile)-   f1-f13       args/return     (caller-save, volatile)-   f14-f31                      (callee-save, non-volatile)--   \tr{14}--\tr{31} are wonderful callee-save registers on all ppc OSes.-   \tr{0}--\tr{12} are caller-save registers.--   \tr{%f14}--\tr{%f31} are callee-save floating-point registers.+/* Define STG <-> machine register mappings. */+#if defined(MACHREGS_i386) || defined(MACHREGS_x86_64) -   We can do the Whole Business with callee-save registers only!-   -------------------------------------------------------------------------- */+#include "MachRegs/x86.h"  #elif defined(MACHREGS_powerpc) -#define REG(x) __asm__(#x)--#define REG_R1          r14-#define REG_R2          r15-#define REG_R3          r16-#define REG_R4          r17-#define REG_R5          r18-#define REG_R6          r19-#define REG_R7          r20-#define REG_R8          r21-#define REG_R9          r22-#define REG_R10         r23--#define REG_F1          fr14-#define REG_F2          fr15-#define REG_F3          fr16-#define REG_F4          fr17-#define REG_F5          fr18-#define REG_F6          fr19--#define REG_D1          fr20-#define REG_D2          fr21-#define REG_D3          fr22-#define REG_D4          fr23-#define REG_D5          fr24-#define REG_D6          fr25--#define REG_Sp          r24-#define REG_SpLim       r25-#define REG_Hp          r26-#define REG_Base        r27--#define MAX_REAL_FLOAT_REG   6-#define MAX_REAL_DOUBLE_REG  6--/* ------------------------------------------------------------------------------   The ARM EABI register mapping--   Here we consider ARM mode (i.e. 32bit isns)-   and also CPU with full VFPv3 implementation--   ARM registers (see Chapter 5.1 in ARM IHI 0042D and-   Section 9.2.2 in ARM Software Development Toolkit Reference Guide)--   r15  PC         The Program Counter.-   r14  LR         The Link Register.-   r13  SP         The Stack Pointer.-   r12  IP         The Intra-Procedure-call scratch register.-   r11  v8/fp      Variable-register 8.-   r10  v7/sl      Variable-register 7.-   r9   v6/SB/TR   Platform register. The meaning of this register is-                   defined by the platform standard.-   r8   v5         Variable-register 5.-   r7   v4         Variable register 4.-   r6   v3         Variable register 3.-   r5   v2         Variable register 2.-   r4   v1         Variable register 1.-   r3   a4         Argument / scratch register 4.-   r2   a3         Argument / scratch register 3.-   r1   a2         Argument / result / scratch register 2.-   r0   a1         Argument / result / scratch register 1.--   VFPv2/VFPv3/NEON registers-   s0-s15/d0-d7/q0-q3    Argument / result/ scratch registers-   s16-s31/d8-d15/q4-q7  callee-saved registers (must be preserved across-                         subroutine calls)--   VFPv3/NEON registers (added to the VFPv2 registers set)-   d16-d31/q8-q15        Argument / result/ scratch registers-   ----------------------------------------------------------------------------- */+#include "MachRegs/ppc.h"  #elif defined(MACHREGS_arm) -#define REG(x) __asm__(#x)--#define REG_Base        r4-#define REG_Sp          r5-#define REG_Hp          r6-#define REG_R1          r7-#define REG_R2          r8-#define REG_R3          r9-#define REG_R4          r10-#define REG_SpLim       r11--#if !defined(arm_HOST_ARCH_PRE_ARMv6)-/* d8 */-#define REG_F1    s16-#define REG_F2    s17-/* d9 */-#define REG_F3    s18-#define REG_F4    s19--#define REG_D1    d10-#define REG_D2    d11-#endif--/* ------------------------------------------------------------------------------   The ARMv8/AArch64 ABI register mapping--   The AArch64 provides 31 64-bit general purpose registers-   and 32 128-bit SIMD/floating point registers.--   General purpose registers (see Chapter 5.1.1 in ARM IHI 0055B)--   Register | Special | Role in the procedure call standard-   ---------+---------+-------------------------------------     SP     |         | The Stack Pointer-     r30    |  LR     | The Link Register-     r29    |  FP     | The Frame Pointer-   r19-r28  |         | Callee-saved registers-     r18    |         | The Platform Register, if needed;-            |         | or temporary register-     r17    |  IP1    | The second intra-procedure-call temporary register-     r16    |  IP0    | The first intra-procedure-call scratch register-    r9-r15  |         | Temporary registers-     r8     |         | Indirect result location register-    r0-r7   |         | Parameter/result registers---   FPU/SIMD registers--   s/d/q/v0-v7    Argument / result/ scratch registers-   s/d/q/v8-v15   callee-saved registers (must be preserved across subroutine calls,-                  but only bottom 64-bit value needs to be preserved)-   s/d/q/v16-v31  temporary registers--   ----------------------------------------------------------------------------- */+#include "MachRegs/arm32.h"  #elif defined(MACHREGS_aarch64) -#define REG(x) __asm__(#x)--#define REG_Base        r19-#define REG_Sp          r20-#define REG_Hp          r21-#define REG_R1          r22-#define REG_R2          r23-#define REG_R3          r24-#define REG_R4          r25-#define REG_R5          r26-#define REG_R6          r27-#define REG_SpLim       r28--#define REG_F1          s8-#define REG_F2          s9-#define REG_F3          s10-#define REG_F4          s11--#define REG_D1          d12-#define REG_D2          d13-#define REG_D3          d14-#define REG_D4          d15--#define REG_XMM1        q4-#define REG_XMM2        q5--#define CALLER_SAVES_XMM1-#define CALLER_SAVES_XMM2--/* ------------------------------------------------------------------------------   The s390x register mapping--   Register    | Role(s)                                 | Call effect-   ------------+-------------------------------------+------------------   r0,r1       | -                                       | caller-saved-   r2          | Argument / return value                 | caller-saved-   r3,r4,r5    | Arguments                               | caller-saved-   r6          | Argument                                | callee-saved-   r7...r11    | -                                       | callee-saved-   r12         | (Commonly used as GOT pointer)          | callee-saved-   r13         | (Commonly used as literal pool pointer) | callee-saved-   r14         | Return address                          | caller-saved-   r15         | Stack pointer                           | callee-saved-   f0          | Argument / return value                 | caller-saved-   f2,f4,f6    | Arguments                               | caller-saved-   f1,f3,f5,f7 | -                                       | caller-saved-   f8...f15    | -                                       | callee-saved-   v0...v31    | -                                       | caller-saved--   Each general purpose register r0 through r15 as well as each floating-point-   register f0 through f15 is 64 bits wide. Each vector register v0 through v31-   is 128 bits wide.--   Note, the vector registers v0 through v15 overlap with the floating-point-   registers f0 through f15.--   -------------------------------------------------------------------------- */+#include "MachRegs/arm64.h"  #elif defined(MACHREGS_s390x) -#define REG(x) __asm__("%" #x)--#define REG_Base        r7-#define REG_Sp          r8-#define REG_Hp          r10-#define REG_R1          r11-#define REG_R2          r12-#define REG_R3          r13-#define REG_R4          r6-#define REG_R5          r2-#define REG_R6          r3-#define REG_R7          r4-#define REG_R8          r5-#define REG_SpLim       r9-#define REG_MachSp      r15--#define REG_F1          f8-#define REG_F2          f9-#define REG_F3          f10-#define REG_F4          f11-#define REG_F5          f0-#define REG_F6          f1--#define REG_D1          f12-#define REG_D2          f13-#define REG_D3          f14-#define REG_D4          f15-#define REG_D5          f2-#define REG_D6          f3--#define CALLER_SAVES_R5-#define CALLER_SAVES_R6-#define CALLER_SAVES_R7-#define CALLER_SAVES_R8--#define CALLER_SAVES_F5-#define CALLER_SAVES_F6--#define CALLER_SAVES_D5-#define CALLER_SAVES_D6--/* ------------------------------------------------------------------------------   The riscv64 register mapping--   Register    | Role(s)                                 | Call effect-   ------------+-----------------------------------------+--------------   zero        | Hard-wired zero                         | --   ra          | Return address                          | caller-saved-   sp          | Stack pointer                           | callee-saved-   gp          | Global pointer                          | callee-saved-   tp          | Thread pointer                          | callee-saved-   t0,t1,t2    | -                                       | caller-saved-   s0          | Frame pointer                           | callee-saved-   s1          | -                                       | callee-saved-   a0,a1       | Arguments / return values               | caller-saved-   a2..a7      | Arguments                               | caller-saved-   s2..s11     | -                                       | callee-saved-   t3..t6      | -                                       | caller-saved-   ft0..ft7    | -                                       | caller-saved-   fs0,fs1     | -                                       | callee-saved-   fa0,fa1     | Arguments / return values               | caller-saved-   fa2..fa7    | Arguments                               | caller-saved-   fs2..fs11   | -                                       | callee-saved-   ft8..ft11   | -                                       | caller-saved--   Each general purpose register as well as each floating-point-   register is 64 bits wide.--   -------------------------------------------------------------------------- */+#include "MachRegs/s390x.h"  #elif defined(MACHREGS_riscv64) -#define REG(x) __asm__(#x)--#define REG_Base        s1-#define REG_Sp          s2-#define REG_Hp          s3-#define REG_R1          s4-#define REG_R2          s5-#define REG_R3          s6-#define REG_R4          s7-#define REG_R5          s8-#define REG_R6          s9-#define REG_R7          s10-#define REG_SpLim       s11--#define REG_F1          fs0-#define REG_F2          fs1-#define REG_F3          fs2-#define REG_F4          fs3-#define REG_F5          fs4-#define REG_F6          fs5--#define REG_D1          fs6-#define REG_D2          fs7-#define REG_D3          fs8-#define REG_D4          fs9-#define REG_D5          fs10-#define REG_D6          fs11--#define MAX_REAL_FLOAT_REG   6-#define MAX_REAL_DOUBLE_REG  6+#include "MachRegs/riscv64.h"  #elif defined(MACHREGS_wasm32) -#define REG_Base           0--#define REG_R1             1-#define REG_R2             2-#define REG_R3             3-#define REG_R4             4-#define REG_R5             5-#define REG_R6             6-#define REG_R7             7-#define REG_R8             8-#define REG_R9             9-#define REG_R10            10--#define REG_F1             11-#define REG_F2             12-#define REG_F3             13-#define REG_F4             14-#define REG_F5             15-#define REG_F6             16--#define REG_D1             17-#define REG_D2             18-#define REG_D3             19-#define REG_D4             20-#define REG_D5             21-#define REG_D6             22--#define REG_L1             23--#define REG_Sp             24-#define REG_SpLim          25-#define REG_Hp             26-#define REG_HpLim          27--/* ------------------------------------------------------------------------------   The loongarch64 register mapping--   Register    | Role(s)                                 | Call effect-   ------------+-----------------------------------------+--------------   zero        | Hard-wired zero                         | --   ra          | Return address                          | caller-saved-   tp          | Thread pointer                          | --   sp          | Stack pointer                           | callee-saved-   a0,a1       | Arguments / return values               | caller-saved-   a2..a7      | Arguments                               | caller-saved-   t0..t8      | -                                       | caller-saved-   u0          | Reserve                                 | --   fp          | Frame pointer                           | callee-saved-   s0..s8      | -                                       | callee-saved-   fa0,fa1     | Arguments / return values               | caller-saved-   fa2..fa7    | Arguments                               | caller-saved-   ft0..ft15   | -                                       | caller-saved-   fs0..fs7    | -                                       | callee-saved--   Each general purpose register as well as each floating-point-   register is 64 bits wide, also, the u0 register is called r21 in some cases.+#include "MachRegs/wasm32.h" -   -------------------------------------------------------------------------- */ #elif defined(MACHREGS_loongarch64) -#define REG(x) __asm__("$" #x)--#define REG_Base        s0-#define REG_Sp          s1-#define REG_Hp          s2-#define REG_R1          s3-#define REG_R2          s4-#define REG_R3          s5-#define REG_R4          s6-#define REG_R5          s7-#define REG_SpLim       s8--#define REG_F1          fs0-#define REG_F2          fs1-#define REG_F3          fs2-#define REG_F4          fs3--#define REG_D1          fs4-#define REG_D2          fs5-#define REG_D3          fs6-#define REG_D4          fs7--#define MAX_REAL_FLOAT_REG   4-#define MAX_REAL_DOUBLE_REG  4+#include "MachRegs/loongarch64.h"  #else 
compiler/cbits/genSym.c view
@@ -9,42 +9,9 @@ // // The CPP is thus about the RTS version GHC is linked against, and not the // version of the GHC being built.--#if MIN_VERSION_GLASGOW_HASKELL(9,9,0,0)-// Unique64 patch was present in 9.10 and later-#define HAVE_UNIQUE64 1-#elif !MIN_VERSION_GLASGOW_HASKELL(9,9,0,0) && MIN_VERSION_GLASGOW_HASKELL(9,8,4,0)-// Unique64 patch was backported to 9.8.4-#define HAVE_UNIQUE64 1-#elif !MIN_VERSION_GLASGOW_HASKELL(9,7,0,0) && MIN_VERSION_GLASGOW_HASKELL(9,6,7,0)-// Unique64 patch was backported to 9.6.7-#define HAVE_UNIQUE64 1-#endif--#if !defined(HAVE_UNIQUE64)+#if !MIN_VERSION_GLASGOW_HASKELL(9,9,0,0) HsWord64 ghc_unique_counter64 = 0; #endif--// This function has been added to the RTS. Here we pessimistically assume-// that a threaded RTS is used. This function is only used for bootstrapping.-#if !MIN_VERSION_GLASGOW_HASKELL(9,7,0,0)-EXTERN_INLINE StgWord64-atomic_inc64(StgWord64 volatile* p, StgWord64 incr)-{-#if defined(HAVE_C11_ATOMICS)-    return __atomic_add_fetch(p, incr, __ATOMIC_SEQ_CST);-#else-    return __sync_add_and_fetch(p, incr);-#endif-}+#if !MIN_VERSION_GLASGOW_HASKELL(9,3,0,0)+HsInt ghc_unique_inc     = 1; #endif--#define UNIQUE_BITS (sizeof (HsWord64) * 8 - UNIQUE_TAG_BITS)-#define UNIQUE_MASK ((1ULL << UNIQUE_BITS) - 1)--HsWord64 ghc_lib_parser_genSym(void) {-    HsWord64 u = atomic_inc64((StgWord64 *)&ghc_unique_counter64, ghc_unique_inc) & UNIQUE_MASK;-    // Uh oh! We will overflow next time a unique is requested.-    ASSERT(u != UNIQUE_MASK);-    return u;-}
compiler/cbits/keepCAFsForGHCi.c view
@@ -1,7 +1,7 @@ #include <Rts.h> #include <ghcversion.h> -// Note [ghc_lib_parser_keepCAFsForGHCi]+// Note [keepCAFsForGHCi] // ~~~~~~~~~~~~~~~~~~~~~~ // This file is only included in the dynamic library. // It contains an __attribute__((constructor)) function (run prior to main())@@ -14,7 +14,7 @@ // an archive and not otherwise referenced the linker would ignore the object. // To avoid this: // * When initializing a GHC session in initGhcMonad we assert keeping cafs has been-//   enabled by calling ghc_lib_parser_keepCAFsForGHCi.+//   enabled by calling keepCAFsForGHCi. // * This causes the GHC module from the ghc package to carry a reference to this object //   file. // * Which in turn ensures the linker doesn't discard this object file, causing@@ -23,9 +23,9 @@   -bool ghc_lib_parser_keepCAFsForGHCi(void) __attribute__((constructor));+bool keepCAFsForGHCi(void) __attribute__((constructor)); -bool ghc_lib_parser_keepCAFsForGHCi(void)+bool keepCAFsForGHCi(void) {     bool was_set = keepCAFs;     setKeepCAFs();
− compiler/ghc-llvm-version.h 
@@ -1,11 +0,0 @@-/* compiler/ghc-llvm-version.h.  Generated from ghc-llvm-version.h.in by configure.  */-#if !defined(__GHC_LLVM_VERSION_H__)-#define __GHC_LLVM_VERSION_H__--/* The maximum supported LLVM version number */-#define sUPPORTED_LLVM_VERSION_MAX (16)--/* The minimum supported LLVM version number */-#define sUPPORTED_LLVM_VERSION_MIN (11)--#endif /* __GHC_LLVM_VERSION_H__ */
compiler/ghc.cabal view
@@ -3,7 +3,7 @@ -- ./configure.  Make sure you are editing ghc.cabal.in, not ghc.cabal.  Name: ghc-Version: 9.8.4.20250206+Version: 9.10.1 License: BSD-3-Clause License-File: LICENSE Author: The GHC Team@@ -20,6 +20,11 @@     .     See <https://gitlab.haskell.org/ghc/ghc/-/wikis/commentary/compiler>     for more information.+    .+    __This package is not PVP-compliant.__+    .+    This package directly exposes GHC internals, which can and do change with+    every release. Category: Development Build-Type: Custom @@ -34,7 +39,14 @@     ClosureTypes.h     FunTypes.h     MachRegs.h-    ghc-llvm-version.h+    MachRegs/arm32.h+    MachRegs/arm64.h+    MachRegs/loongarch64.h+    MachRegs/ppc.h+    MachRegs/riscv64.h+    MachRegs/s390x.h+    MachRegs/wasm32.h+    MachRegs/x86.h   custom-setup@@ -71,7 +83,7 @@     Manual: True  Library-    Default-Language: Haskell2010+    Default-Language: GHC2021     Exposed: False     Includes: Unique.h               -- CodeGen.Platform.h -- invalid as C, skip@@ -79,7 +91,6 @@               Bytecodes.h               ClosureTypes.h               FunTypes.h-              ghc-llvm-version.h      if flag(build-tool-depends)       build-tool-depends: alex:alex >= 3.2.6, happy:happy >= 1.20.0, genprimopcode:genprimopcode, deriveConstants:deriveConstants@@ -94,28 +105,28 @@         extra-libraries: zstd       CPP-Options: -DHAVE_LIBZSTD -    Build-Depends: base       >= 4.11 && < 4.20,+    Build-Depends: base       >= 4.11 && < 4.21,                    deepseq    >= 1.4 && < 1.6,                    directory  >= 1   && < 1.4,                    process    >= 1   && < 1.7,                    bytestring >= 0.9 && < 0.13,                    binary     == 0.8.*,                    time       >= 1.4 && < 1.13,-                   containers >= 0.6.2.1 && < 0.7,+                   containers >= 0.6.2.1 && < 0.8,                    array      >= 0.1 && < 0.6,-                   filepath   >= 1   && < 1.5,-                   template-haskell == 2.21.*,+                   filepath   >= 1   && < 1.6,+                   template-haskell == 2.22.*,                    hpc        >= 0.6 && < 0.8,                    transformers >= 0.5 && < 0.7,                    exceptions == 0.10.*,                    semaphore-compat,                    stm,-                   ghc-boot   == 9.8.4.20250206,-                   ghc-heap   == 9.8.4.20250206,-                   ghci == 9.8.4.20250206+                   ghc-boot   == 9.10.1,+                   ghc-heap   == 9.10.1,+                   ghci == 9.10.1      if os(windows)-        Build-Depends: Win32  >= 2.3 && < 2.14+        Build-Depends: Win32  >= 2.3 && < 2.15     else         Build-Depends: unix   >= 2.7 && < 2.9 @@ -180,10 +191,7 @@     -- we use an explicit Prelude     Default-Extensions:         NoImplicitPrelude-       ,BangPatterns-       ,ScopedTypeVariables        ,MonoLocalBinds-       ,TypeOperators      Exposed-Modules:         GHC@@ -211,11 +219,11 @@         GHC.Cmm.ContFlowOpt         GHC.Cmm.Dataflow         GHC.Cmm.Dataflow.Block-        GHC.Cmm.Dataflow.Collections         GHC.Cmm.Dataflow.Graph         GHC.Cmm.Dataflow.Label         GHC.Cmm.DebugBlock         GHC.Cmm.Expr+        GHC.Cmm.GenericOpt         GHC.Cmm.Graph         GHC.Cmm.Info         GHC.Cmm.Info.Build@@ -308,6 +316,9 @@         GHC.CmmToLlvm.Mangler         GHC.CmmToLlvm.Ppr         GHC.CmmToLlvm.Regs+        GHC.CmmToLlvm.Version+        GHC.CmmToLlvm.Version.Bounds+        GHC.CmmToLlvm.Version.Type         GHC.Cmm.Dominators         GHC.Cmm.Reducibility         GHC.Cmm.Type@@ -325,6 +336,10 @@         GHC.Core.Lint         GHC.Core.Lint.Interactive         GHC.Core.LateCC+        GHC.Core.LateCC.Types+        GHC.Core.LateCC.TopLevelBinds+        GHC.Core.LateCC.Utils+        GHC.Core.LateCC.OverloadedCalls         GHC.Core.Make         GHC.Core.Map.Expr         GHC.Core.Map.Type@@ -518,6 +533,7 @@         GHC.HsToCore.Foreign.JavaScript         GHC.HsToCore.Foreign.Prim         GHC.HsToCore.Foreign.Utils+        GHC.HsToCore.Foreign.Wasm         GHC.HsToCore.GuardedRHSs         GHC.HsToCore.ListComp         GHC.HsToCore.Match@@ -562,16 +578,20 @@         GHC.Iface.Tidy.StaticPtrTable         GHC.IfaceToCore         GHC.Iface.Type+        GHC.JS.Ident         GHC.JS.Make         GHC.JS.Optimizer+        GHC.JS.Opt.Expr+        GHC.JS.Opt.Simple         GHC.JS.Ppr         GHC.JS.Syntax+        GHC.JS.JStg.Syntax+        GHC.JS.JStg.Monad         GHC.JS.Transform-        GHC.JS.Unsat.Syntax-        GHC.Linker         GHC.Linker.Config         GHC.Linker.Deps         GHC.Linker.Dynamic+        GHC.Linker.External         GHC.Linker.ExtraObj         GHC.Linker.Loader         GHC.Linker.MacOS@@ -726,7 +746,6 @@         GHC.SysTools.BaseDir         GHC.SysTools.Cpp         GHC.SysTools.Elf-        GHC.SysTools.Info         GHC.SysTools.Process         GHC.SysTools.Tasks         GHC.SysTools.Terminal@@ -748,6 +767,7 @@         GHC.Tc.Gen.Arrow         GHC.Tc.Gen.Bind         GHC.Tc.Gen.Default+        GHC.Tc.Gen.Do         GHC.Tc.Gen.Export         GHC.Tc.Gen.Expr         GHC.Tc.Gen.Foreign@@ -916,6 +936,7 @@         GHC.Utils.Ppr         GHC.Utils.Ppr.Colour         GHC.Utils.TmpFs+        GHC.Utils.Touch         GHC.Utils.Trace         GHC.Utils.Unique         GHC.Utils.Word64@@ -930,7 +951,6 @@         Language.Haskell.Syntax         Language.Haskell.Syntax.Basic         Language.Haskell.Syntax.Binds-        Language.Haskell.Syntax.Concrete         Language.Haskell.Syntax.Decls         Language.Haskell.Syntax.Expr         Language.Haskell.Syntax.Extension
ghc-lib-parser.cabal view
@@ -1,7 +1,7 @@ cabal-version: 3.0 build-type: Simple name: ghc-lib-parser-version: 9.8.5.20250214+version: 9.10.1.20240511 license: BSD-3-Clause license-file: LICENSE category: Development@@ -24,15 +24,15 @@     libraries/ghc-boot/ghc-boot.cabal     libraries/ghci/ghci.cabal     compiler/ghc.cabal+    libraries/ghc-platform/ghc-platform.cabal     ghc-lib/stage0/rts/build/include/ghcautoconf.h     ghc-lib/stage0/rts/build/include/ghcplatform.h     ghc-lib/stage0/rts/build/include/GhclibDerivedConstants.h-    ghc-lib/stage0/compiler/build/primop-can-fail.hs-incl     ghc-lib/stage0/compiler/build/primop-code-size.hs-incl     ghc-lib/stage0/compiler/build/primop-commutable.hs-incl     ghc-lib/stage0/compiler/build/primop-data-decl.hs-incl     ghc-lib/stage0/compiler/build/primop-fixity.hs-incl-    ghc-lib/stage0/compiler/build/primop-has-side-effects.hs-incl+    ghc-lib/stage0/compiler/build/primop-effects.hs-incl     ghc-lib/stage0/compiler/build/primop-list.hs-incl     ghc-lib/stage0/compiler/build/primop-out-of-line.hs-incl     ghc-lib/stage0/compiler/build/primop-primop-info.hs-incl@@ -43,6 +43,8 @@     ghc-lib/stage0/compiler/build/primop-vector-tys.hs-incl     ghc-lib/stage0/compiler/build/primop-vector-uniques.hs-incl     ghc-lib/stage0/compiler/build/primop-docs.hs-incl+    ghc-lib/stage0/compiler/build/primop-is-work-free.hs-incl+    ghc-lib/stage0/compiler/build/primop-is-cheap.hs-incl     ghc-lib/stage0/compiler/build/GHC/Platform/Constants.hs     ghc-lib/stage0/compiler/build/GHC/Settings/Config.hs     ghc-lib/stage0/libraries/ghc-boot/build/GHC/Version.hs@@ -51,8 +53,15 @@     compiler/GHC/Parser/Lexer.x     compiler/GHC/Parser/HaddockLex.x     compiler/GHC/Parser.hs-boot+    rts/include/stg/MachRegs/arm32.h+    rts/include/stg/MachRegs/arm64.h+    rts/include/stg/MachRegs/loongarch64.h+    rts/include/stg/MachRegs/ppc.h+    rts/include/stg/MachRegs/riscv64.h+    rts/include/stg/MachRegs/s390x.h+    rts/include/stg/MachRegs/wasm32.h+    rts/include/stg/MachRegs/x86.h     libraries/containers/containers/include/containers.h-    compiler/ghc-llvm-version.h     rts/include/ghcconfig.h     compiler/MachRegs.h     compiler/CodeGen.Platform.h@@ -68,16 +77,16 @@   manual: True   description: Pass -DTHREADED_RTS to the C toolchain library-    default-language: Haskell2010+    default-language:   GHC2021     exposed: False     include-dirs:         rts/include+        rts/include/stg         ghc-lib/stage0/lib         ghc-lib/stage0/compiler/build         compiler         libraries/containers/containers/include-    if impl(ghc >= 8.8.1)-        ghc-options: -fno-safe-haskell+    ghc-options: -fno-safe-haskell     if flag(threaded-rts)         ghc-options: -fobject-code -package=ghc-boot-th -optc-DTHREADED_RTS         cc-options: -DTHREADED_RTS@@ -90,11 +99,11 @@     else         build-depends: Win32     build-depends:-        base >= 4.17 && < 4.20,+        base >= 4.18 && < 4.21,         ghc-prim > 0.2 && < 0.12,         containers >= 0.6.2.1 && < 0.8,         bytestring >= 0.11.4 && < 0.13,-        time >= 1.4 && < 1.15,+        time >= 1.4 && < 1.13,         filepath >= 1 && < 1.6,         exceptions == 0.10.*,         parsec,@@ -107,7 +116,7 @@         process >= 1 && < 1.7     if impl(ghc >= 9.10)       build-depends: ghc-internal-    build-tool-depends: alex:alex >= 3.1, happy:happy == 1.20.* || == 2.0.2 || >= 2.1.2 && < 2.2+    build-tool-depends: alex:alex >= 3.1, happy:happy > 1.20     other-extensions:         BangPatterns         CPP@@ -142,12 +151,9 @@         UnboxedTuples         UndecidableInstances     default-extensions:-        BangPatterns         ImplicitPrelude         MonoLocalBinds         NoImplicitPrelude-        ScopedTypeVariables-        TypeOperators     if impl(ghc >= 9.2.2)       cmm-sources:             libraries/ghc-heap/cbits/HeapPrim.cmm@@ -161,7 +167,9 @@     hs-source-dirs:         ghc-lib/stage0/libraries/ghc-boot/build         ghc-lib/stage0/compiler/build+        libraries/ghc-platform/src         libraries/template-haskell+        libraries/ghc-platform         libraries/ghc-boot-th         libraries/ghc-boot         libraries/ghc-heap@@ -183,7 +191,6 @@         GHC.Cmm.BlockId         GHC.Cmm.CLabel         GHC.Cmm.Dataflow.Block-        GHC.Cmm.Dataflow.Collections         GHC.Cmm.Dataflow.Graph         GHC.Cmm.Dataflow.Label         GHC.Cmm.Expr@@ -194,6 +201,7 @@         GHC.Cmm.Type         GHC.CmmToAsm.CFG.Weight         GHC.CmmToLlvm.Config+        GHC.CmmToLlvm.Version.Type         GHC.Core         GHC.Core.Class         GHC.Core.Coercion@@ -353,14 +361,17 @@         GHC.Iface.Recomp.Binary         GHC.Iface.Syntax         GHC.Iface.Type+        GHC.JS.Ident+        GHC.JS.JStg.Monad+        GHC.JS.JStg.Syntax         GHC.JS.Make         GHC.JS.Ppr         GHC.JS.Syntax         GHC.JS.Transform-        GHC.JS.Unsat.Syntax         GHC.LanguageExtensions         GHC.LanguageExtensions.Type         GHC.Lexeme+        GHC.Linker.Config         GHC.Linker.Static.Utils         GHC.Linker.Types         GHC.Parser@@ -548,15 +559,16 @@         GHC.Utils.Trace         GHC.Utils.Word64         GHC.Version+        GHCi.BinaryArray         GHCi.BreakArray         GHCi.FFI         GHCi.Message         GHCi.RemoteTypes+        GHCi.ResolvedBCO         GHCi.TH.Binary         Language.Haskell.Syntax         Language.Haskell.Syntax.Basic         Language.Haskell.Syntax.Binds-        Language.Haskell.Syntax.Concrete         Language.Haskell.Syntax.Decls         Language.Haskell.Syntax.Expr         Language.Haskell.Syntax.Extension
ghc-lib/stage0/compiler/build/GHC/Platform/Constants.hs view
@@ -83,6 +83,7 @@       pc_OFFSET_StgEntCounter_link :: {-# UNPACK #-} !Int,       pc_OFFSET_StgEntCounter_entry_count :: {-# UNPACK #-} !Int,       pc_SIZEOF_StgUpdateFrame_NoHdr :: {-# UNPACK #-} !Int,+      pc_SIZEOF_StgOrigThunkInfoFrame_NoHdr :: {-# UNPACK #-} !Int,       pc_SIZEOF_StgMutArrPtrs_NoHdr :: {-# UNPACK #-} !Int,       pc_OFFSET_StgMutArrPtrs_ptrs :: {-# UNPACK #-} !Int,       pc_OFFSET_StgMutArrPtrs_size :: {-# UNPACK #-} !Int,@@ -96,6 +97,7 @@       pc_OFFSET_StgStack_sp :: {-# UNPACK #-} !Int,       pc_OFFSET_StgStack_stack :: {-# UNPACK #-} !Int,       pc_OFFSET_StgUpdateFrame_updatee :: {-# UNPACK #-} !Int,+      pc_OFFSET_StgOrigThunkInfoFrame_info_ptr :: {-# UNPACK #-} !Int,       pc_OFFSET_StgFunInfoExtraFwd_arity :: {-# UNPACK #-} !Int,       pc_REP_StgFunInfoExtraFwd_arity :: {-# UNPACK #-} !Int,       pc_SIZEOF_StgFunInfoExtraRev :: {-# UNPACK #-} !Int,@@ -166,7 +168,7 @@      ,v80,v81,v82,v83,v84,v85,v86,v87,v88,v89,v90,v91,v92,v93,v94,v95      ,v96,v97,v98,v99,v100,v101,v102,v103,v104,v105,v106,v107,v108,v109,v110,v111      ,v112,v113,v114,v115,v116,v117,v118,v119,v120,v121,v122,v123,v124,v125,v126,v127-     ,v128+     ,v128,v129,v130      ] -> PlatformConstants             { pc_CONTROL_GROUP_CONST_291 = fromIntegral v0             , pc_STD_HDR_SIZE = fromIntegral v1@@ -247,56 +249,58 @@             , pc_OFFSET_StgEntCounter_link = fromIntegral v76             , pc_OFFSET_StgEntCounter_entry_count = fromIntegral v77             , pc_SIZEOF_StgUpdateFrame_NoHdr = fromIntegral v78-            , pc_SIZEOF_StgMutArrPtrs_NoHdr = fromIntegral v79-            , pc_OFFSET_StgMutArrPtrs_ptrs = fromIntegral v80-            , pc_OFFSET_StgMutArrPtrs_size = fromIntegral v81-            , pc_SIZEOF_StgSmallMutArrPtrs_NoHdr = fromIntegral v82-            , pc_OFFSET_StgSmallMutArrPtrs_ptrs = fromIntegral v83-            , pc_SIZEOF_StgArrBytes_NoHdr = fromIntegral v84-            , pc_OFFSET_StgArrBytes_bytes = fromIntegral v85-            , pc_OFFSET_StgTSO_alloc_limit = fromIntegral v86-            , pc_OFFSET_StgTSO_cccs = fromIntegral v87-            , pc_OFFSET_StgTSO_stackobj = fromIntegral v88-            , pc_OFFSET_StgStack_sp = fromIntegral v89-            , pc_OFFSET_StgStack_stack = fromIntegral v90-            , pc_OFFSET_StgUpdateFrame_updatee = fromIntegral v91-            , pc_OFFSET_StgFunInfoExtraFwd_arity = fromIntegral v92-            , pc_REP_StgFunInfoExtraFwd_arity = fromIntegral v93-            , pc_SIZEOF_StgFunInfoExtraRev = fromIntegral v94-            , pc_OFFSET_StgFunInfoExtraRev_arity = fromIntegral v95-            , pc_REP_StgFunInfoExtraRev_arity = fromIntegral v96-            , pc_MAX_SPEC_SELECTEE_SIZE = fromIntegral v97-            , pc_MAX_SPEC_AP_SIZE = fromIntegral v98-            , pc_MIN_PAYLOAD_SIZE = fromIntegral v99-            , pc_MIN_INTLIKE = fromIntegral v100-            , pc_MAX_INTLIKE = fromIntegral v101-            , pc_MIN_CHARLIKE = fromIntegral v102-            , pc_MAX_CHARLIKE = fromIntegral v103-            , pc_MUT_ARR_PTRS_CARD_BITS = fromIntegral v104-            , pc_MAX_Vanilla_REG = fromIntegral v105-            , pc_MAX_Float_REG = fromIntegral v106-            , pc_MAX_Double_REG = fromIntegral v107-            , pc_MAX_Long_REG = fromIntegral v108-            , pc_MAX_XMM_REG = fromIntegral v109-            , pc_MAX_Real_Vanilla_REG = fromIntegral v110-            , pc_MAX_Real_Float_REG = fromIntegral v111-            , pc_MAX_Real_Double_REG = fromIntegral v112-            , pc_MAX_Real_XMM_REG = fromIntegral v113-            , pc_MAX_Real_Long_REG = fromIntegral v114-            , pc_RESERVED_C_STACK_BYTES = fromIntegral v115-            , pc_RESERVED_STACK_WORDS = fromIntegral v116-            , pc_AP_STACK_SPLIM = fromIntegral v117-            , pc_WORD_SIZE = fromIntegral v118-            , pc_CINT_SIZE = fromIntegral v119-            , pc_CLONG_SIZE = fromIntegral v120-            , pc_CLONG_LONG_SIZE = fromIntegral v121-            , pc_BITMAP_BITS_SHIFT = fromIntegral v122-            , pc_TAG_BITS = fromIntegral v123-            , pc_LDV_SHIFT = fromIntegral v124-            , pc_ILDV_CREATE_MASK = v125-            , pc_ILDV_STATE_CREATE = v126-            , pc_ILDV_STATE_USE = v127-            , pc_USE_INLINE_SRT_FIELD = 0 < v128+            , pc_SIZEOF_StgOrigThunkInfoFrame_NoHdr = fromIntegral v79+            , pc_SIZEOF_StgMutArrPtrs_NoHdr = fromIntegral v80+            , pc_OFFSET_StgMutArrPtrs_ptrs = fromIntegral v81+            , pc_OFFSET_StgMutArrPtrs_size = fromIntegral v82+            , pc_SIZEOF_StgSmallMutArrPtrs_NoHdr = fromIntegral v83+            , pc_OFFSET_StgSmallMutArrPtrs_ptrs = fromIntegral v84+            , pc_SIZEOF_StgArrBytes_NoHdr = fromIntegral v85+            , pc_OFFSET_StgArrBytes_bytes = fromIntegral v86+            , pc_OFFSET_StgTSO_alloc_limit = fromIntegral v87+            , pc_OFFSET_StgTSO_cccs = fromIntegral v88+            , pc_OFFSET_StgTSO_stackobj = fromIntegral v89+            , pc_OFFSET_StgStack_sp = fromIntegral v90+            , pc_OFFSET_StgStack_stack = fromIntegral v91+            , pc_OFFSET_StgUpdateFrame_updatee = fromIntegral v92+            , pc_OFFSET_StgOrigThunkInfoFrame_info_ptr = fromIntegral v93+            , pc_OFFSET_StgFunInfoExtraFwd_arity = fromIntegral v94+            , pc_REP_StgFunInfoExtraFwd_arity = fromIntegral v95+            , pc_SIZEOF_StgFunInfoExtraRev = fromIntegral v96+            , pc_OFFSET_StgFunInfoExtraRev_arity = fromIntegral v97+            , pc_REP_StgFunInfoExtraRev_arity = fromIntegral v98+            , pc_MAX_SPEC_SELECTEE_SIZE = fromIntegral v99+            , pc_MAX_SPEC_AP_SIZE = fromIntegral v100+            , pc_MIN_PAYLOAD_SIZE = fromIntegral v101+            , pc_MIN_INTLIKE = fromIntegral v102+            , pc_MAX_INTLIKE = fromIntegral v103+            , pc_MIN_CHARLIKE = fromIntegral v104+            , pc_MAX_CHARLIKE = fromIntegral v105+            , pc_MUT_ARR_PTRS_CARD_BITS = fromIntegral v106+            , pc_MAX_Vanilla_REG = fromIntegral v107+            , pc_MAX_Float_REG = fromIntegral v108+            , pc_MAX_Double_REG = fromIntegral v109+            , pc_MAX_Long_REG = fromIntegral v110+            , pc_MAX_XMM_REG = fromIntegral v111+            , pc_MAX_Real_Vanilla_REG = fromIntegral v112+            , pc_MAX_Real_Float_REG = fromIntegral v113+            , pc_MAX_Real_Double_REG = fromIntegral v114+            , pc_MAX_Real_XMM_REG = fromIntegral v115+            , pc_MAX_Real_Long_REG = fromIntegral v116+            , pc_RESERVED_C_STACK_BYTES = fromIntegral v117+            , pc_RESERVED_STACK_WORDS = fromIntegral v118+            , pc_AP_STACK_SPLIM = fromIntegral v119+            , pc_WORD_SIZE = fromIntegral v120+            , pc_CINT_SIZE = fromIntegral v121+            , pc_CLONG_SIZE = fromIntegral v122+            , pc_CLONG_LONG_SIZE = fromIntegral v123+            , pc_BITMAP_BITS_SHIFT = fromIntegral v124+            , pc_TAG_BITS = fromIntegral v125+            , pc_LDV_SHIFT = fromIntegral v126+            , pc_ILDV_CREATE_MASK = v127+            , pc_ILDV_STATE_CREATE = v128+            , pc_ILDV_STATE_USE = v129+            , pc_USE_INLINE_SRT_FIELD = 0 < v130             }     _ -> error "Invalid platform constants" 
ghc-lib/stage0/compiler/build/GHC/Settings/Config.hs view
@@ -22,10 +22,10 @@ cProjectName          = "The Glorious Glasgow Haskell Compilation System"  cBooterVersion        :: String-cBooterVersion        = "9.6.6"+cBooterVersion        = "9.6.4"  cStage                :: String cStage                = show (1 :: Int)  cProjectUnitId :: String-cProjectUnitId = "ghc-9.8.4.20250206-inplace"+cProjectUnitId = "ghc-9.10.1-inplace"
− ghc-lib/stage0/compiler/build/primop-can-fail.hs-incl 
@@ -1,261 +0,0 @@-primOpCanFail Int8QuotOp = True-primOpCanFail Int8RemOp = True-primOpCanFail Int8QuotRemOp = True-primOpCanFail Word8QuotOp = True-primOpCanFail Word8RemOp = True-primOpCanFail Word8QuotRemOp = True-primOpCanFail Int16QuotOp = True-primOpCanFail Int16RemOp = True-primOpCanFail Int16QuotRemOp = True-primOpCanFail Word16QuotOp = True-primOpCanFail Word16RemOp = True-primOpCanFail Word16QuotRemOp = True-primOpCanFail Int32QuotOp = True-primOpCanFail Int32RemOp = True-primOpCanFail Int32QuotRemOp = True-primOpCanFail Word32QuotOp = True-primOpCanFail Word32RemOp = True-primOpCanFail Word32QuotRemOp = True-primOpCanFail Int64QuotOp = True-primOpCanFail Int64RemOp = True-primOpCanFail Word64QuotOp = True-primOpCanFail Word64RemOp = True-primOpCanFail IntQuotOp = True-primOpCanFail IntRemOp = True-primOpCanFail IntQuotRemOp = True-primOpCanFail WordQuotOp = True-primOpCanFail WordRemOp = True-primOpCanFail WordQuotRemOp = True-primOpCanFail WordQuotRem2Op = True-primOpCanFail DoubleDivOp = True-primOpCanFail DoubleLogOp = True-primOpCanFail DoubleLog1POp = True-primOpCanFail DoubleAsinOp = True-primOpCanFail DoubleAcosOp = True-primOpCanFail FloatDivOp = True-primOpCanFail FloatLogOp = True-primOpCanFail FloatLog1POp = True-primOpCanFail FloatAsinOp = True-primOpCanFail FloatAcosOp = True-primOpCanFail ReadArrayOp = True-primOpCanFail WriteArrayOp = True-primOpCanFail IndexArrayOp = True-primOpCanFail CopyArrayOp = True-primOpCanFail CopyMutableArrayOp = True-primOpCanFail CloneArrayOp = True-primOpCanFail CloneMutableArrayOp = True-primOpCanFail FreezeArrayOp = True-primOpCanFail ThawArrayOp = True-primOpCanFail CasArrayOp = True-primOpCanFail ReadSmallArrayOp = True-primOpCanFail WriteSmallArrayOp = True-primOpCanFail IndexSmallArrayOp = True-primOpCanFail CopySmallArrayOp = True-primOpCanFail CopySmallMutableArrayOp = True-primOpCanFail CloneSmallArrayOp = True-primOpCanFail CloneSmallMutableArrayOp = True-primOpCanFail FreezeSmallArrayOp = True-primOpCanFail ThawSmallArrayOp = True-primOpCanFail CasSmallArrayOp = True-primOpCanFail IndexByteArrayOp_Char = True-primOpCanFail IndexByteArrayOp_WideChar = True-primOpCanFail IndexByteArrayOp_Int = True-primOpCanFail IndexByteArrayOp_Word = True-primOpCanFail IndexByteArrayOp_Addr = True-primOpCanFail IndexByteArrayOp_Float = True-primOpCanFail IndexByteArrayOp_Double = True-primOpCanFail IndexByteArrayOp_StablePtr = True-primOpCanFail IndexByteArrayOp_Int8 = True-primOpCanFail IndexByteArrayOp_Word8 = True-primOpCanFail IndexByteArrayOp_Int16 = True-primOpCanFail IndexByteArrayOp_Word16 = True-primOpCanFail IndexByteArrayOp_Int32 = True-primOpCanFail IndexByteArrayOp_Word32 = True-primOpCanFail IndexByteArrayOp_Int64 = True-primOpCanFail IndexByteArrayOp_Word64 = True-primOpCanFail IndexByteArrayOp_Word8AsChar = True-primOpCanFail IndexByteArrayOp_Word8AsWideChar = True-primOpCanFail IndexByteArrayOp_Word8AsInt = True-primOpCanFail IndexByteArrayOp_Word8AsWord = True-primOpCanFail IndexByteArrayOp_Word8AsAddr = True-primOpCanFail IndexByteArrayOp_Word8AsFloat = True-primOpCanFail IndexByteArrayOp_Word8AsDouble = True-primOpCanFail IndexByteArrayOp_Word8AsStablePtr = True-primOpCanFail IndexByteArrayOp_Word8AsInt16 = True-primOpCanFail IndexByteArrayOp_Word8AsWord16 = True-primOpCanFail IndexByteArrayOp_Word8AsInt32 = True-primOpCanFail IndexByteArrayOp_Word8AsWord32 = True-primOpCanFail IndexByteArrayOp_Word8AsInt64 = True-primOpCanFail IndexByteArrayOp_Word8AsWord64 = True-primOpCanFail ReadByteArrayOp_Char = True-primOpCanFail ReadByteArrayOp_WideChar = True-primOpCanFail ReadByteArrayOp_Int = True-primOpCanFail ReadByteArrayOp_Word = True-primOpCanFail ReadByteArrayOp_Addr = True-primOpCanFail ReadByteArrayOp_Float = True-primOpCanFail ReadByteArrayOp_Double = True-primOpCanFail ReadByteArrayOp_StablePtr = True-primOpCanFail ReadByteArrayOp_Int8 = True-primOpCanFail ReadByteArrayOp_Word8 = True-primOpCanFail ReadByteArrayOp_Int16 = True-primOpCanFail ReadByteArrayOp_Word16 = True-primOpCanFail ReadByteArrayOp_Int32 = True-primOpCanFail ReadByteArrayOp_Word32 = True-primOpCanFail ReadByteArrayOp_Int64 = True-primOpCanFail ReadByteArrayOp_Word64 = True-primOpCanFail ReadByteArrayOp_Word8AsChar = True-primOpCanFail ReadByteArrayOp_Word8AsWideChar = True-primOpCanFail ReadByteArrayOp_Word8AsInt = True-primOpCanFail ReadByteArrayOp_Word8AsWord = True-primOpCanFail ReadByteArrayOp_Word8AsAddr = True-primOpCanFail ReadByteArrayOp_Word8AsFloat = True-primOpCanFail ReadByteArrayOp_Word8AsDouble = True-primOpCanFail ReadByteArrayOp_Word8AsStablePtr = True-primOpCanFail ReadByteArrayOp_Word8AsInt16 = True-primOpCanFail ReadByteArrayOp_Word8AsWord16 = True-primOpCanFail ReadByteArrayOp_Word8AsInt32 = True-primOpCanFail ReadByteArrayOp_Word8AsWord32 = True-primOpCanFail ReadByteArrayOp_Word8AsInt64 = True-primOpCanFail ReadByteArrayOp_Word8AsWord64 = True-primOpCanFail WriteByteArrayOp_Char = True-primOpCanFail WriteByteArrayOp_WideChar = True-primOpCanFail WriteByteArrayOp_Int = True-primOpCanFail WriteByteArrayOp_Word = True-primOpCanFail WriteByteArrayOp_Addr = True-primOpCanFail WriteByteArrayOp_Float = True-primOpCanFail WriteByteArrayOp_Double = True-primOpCanFail WriteByteArrayOp_StablePtr = True-primOpCanFail WriteByteArrayOp_Int8 = True-primOpCanFail WriteByteArrayOp_Word8 = True-primOpCanFail WriteByteArrayOp_Int16 = True-primOpCanFail WriteByteArrayOp_Word16 = True-primOpCanFail WriteByteArrayOp_Int32 = True-primOpCanFail WriteByteArrayOp_Word32 = True-primOpCanFail WriteByteArrayOp_Int64 = True-primOpCanFail WriteByteArrayOp_Word64 = True-primOpCanFail WriteByteArrayOp_Word8AsChar = True-primOpCanFail WriteByteArrayOp_Word8AsWideChar = True-primOpCanFail WriteByteArrayOp_Word8AsInt = True-primOpCanFail WriteByteArrayOp_Word8AsWord = True-primOpCanFail WriteByteArrayOp_Word8AsAddr = True-primOpCanFail WriteByteArrayOp_Word8AsFloat = True-primOpCanFail WriteByteArrayOp_Word8AsDouble = True-primOpCanFail WriteByteArrayOp_Word8AsStablePtr = True-primOpCanFail WriteByteArrayOp_Word8AsInt16 = True-primOpCanFail WriteByteArrayOp_Word8AsWord16 = True-primOpCanFail WriteByteArrayOp_Word8AsInt32 = True-primOpCanFail WriteByteArrayOp_Word8AsWord32 = True-primOpCanFail WriteByteArrayOp_Word8AsInt64 = True-primOpCanFail WriteByteArrayOp_Word8AsWord64 = True-primOpCanFail CompareByteArraysOp = True-primOpCanFail CopyByteArrayOp = True-primOpCanFail CopyMutableByteArrayOp = True-primOpCanFail CopyMutableByteArrayNonOverlappingOp = True-primOpCanFail CopyByteArrayToAddrOp = True-primOpCanFail CopyMutableByteArrayToAddrOp = True-primOpCanFail CopyAddrToByteArrayOp = True-primOpCanFail CopyAddrToAddrOp = True-primOpCanFail CopyAddrToAddrNonOverlappingOp = True-primOpCanFail SetByteArrayOp = True-primOpCanFail SetAddrRangeOp = True-primOpCanFail AtomicReadByteArrayOp_Int = True-primOpCanFail AtomicWriteByteArrayOp_Int = True-primOpCanFail CasByteArrayOp_Int = True-primOpCanFail CasByteArrayOp_Int8 = True-primOpCanFail CasByteArrayOp_Int16 = True-primOpCanFail CasByteArrayOp_Int32 = True-primOpCanFail CasByteArrayOp_Int64 = True-primOpCanFail FetchAddByteArrayOp_Int = True-primOpCanFail FetchSubByteArrayOp_Int = True-primOpCanFail FetchAndByteArrayOp_Int = True-primOpCanFail FetchNandByteArrayOp_Int = True-primOpCanFail FetchOrByteArrayOp_Int = True-primOpCanFail FetchXorByteArrayOp_Int = True-primOpCanFail IndexOffAddrOp_Char = True-primOpCanFail IndexOffAddrOp_WideChar = True-primOpCanFail IndexOffAddrOp_Int = True-primOpCanFail IndexOffAddrOp_Word = True-primOpCanFail IndexOffAddrOp_Addr = True-primOpCanFail IndexOffAddrOp_Float = True-primOpCanFail IndexOffAddrOp_Double = True-primOpCanFail IndexOffAddrOp_StablePtr = True-primOpCanFail IndexOffAddrOp_Int8 = True-primOpCanFail IndexOffAddrOp_Word8 = True-primOpCanFail IndexOffAddrOp_Int16 = True-primOpCanFail IndexOffAddrOp_Word16 = True-primOpCanFail IndexOffAddrOp_Int32 = True-primOpCanFail IndexOffAddrOp_Word32 = True-primOpCanFail IndexOffAddrOp_Int64 = True-primOpCanFail IndexOffAddrOp_Word64 = True-primOpCanFail ReadOffAddrOp_Char = True-primOpCanFail ReadOffAddrOp_WideChar = True-primOpCanFail ReadOffAddrOp_Int = True-primOpCanFail ReadOffAddrOp_Word = True-primOpCanFail ReadOffAddrOp_Addr = True-primOpCanFail ReadOffAddrOp_Float = True-primOpCanFail ReadOffAddrOp_Double = True-primOpCanFail ReadOffAddrOp_StablePtr = True-primOpCanFail ReadOffAddrOp_Int8 = True-primOpCanFail ReadOffAddrOp_Word8 = True-primOpCanFail ReadOffAddrOp_Int16 = True-primOpCanFail ReadOffAddrOp_Word16 = True-primOpCanFail ReadOffAddrOp_Int32 = True-primOpCanFail ReadOffAddrOp_Word32 = True-primOpCanFail ReadOffAddrOp_Int64 = True-primOpCanFail ReadOffAddrOp_Word64 = True-primOpCanFail WriteOffAddrOp_Char = True-primOpCanFail WriteOffAddrOp_WideChar = True-primOpCanFail WriteOffAddrOp_Int = True-primOpCanFail WriteOffAddrOp_Word = True-primOpCanFail WriteOffAddrOp_Addr = True-primOpCanFail WriteOffAddrOp_Float = True-primOpCanFail WriteOffAddrOp_Double = True-primOpCanFail WriteOffAddrOp_StablePtr = True-primOpCanFail WriteOffAddrOp_Int8 = True-primOpCanFail WriteOffAddrOp_Word8 = True-primOpCanFail WriteOffAddrOp_Int16 = True-primOpCanFail WriteOffAddrOp_Word16 = True-primOpCanFail WriteOffAddrOp_Int32 = True-primOpCanFail WriteOffAddrOp_Word32 = True-primOpCanFail WriteOffAddrOp_Int64 = True-primOpCanFail WriteOffAddrOp_Word64 = True-primOpCanFail InterlockedExchange_Addr = True-primOpCanFail InterlockedExchange_Word = True-primOpCanFail CasAddrOp_Addr = True-primOpCanFail CasAddrOp_Word = True-primOpCanFail CasAddrOp_Word8 = True-primOpCanFail CasAddrOp_Word16 = True-primOpCanFail CasAddrOp_Word32 = True-primOpCanFail CasAddrOp_Word64 = True-primOpCanFail FetchAddAddrOp_Word = True-primOpCanFail FetchSubAddrOp_Word = True-primOpCanFail FetchAndAddrOp_Word = True-primOpCanFail FetchNandAddrOp_Word = True-primOpCanFail FetchOrAddrOp_Word = True-primOpCanFail FetchXorAddrOp_Word = True-primOpCanFail AtomicReadAddrOp_Word = True-primOpCanFail AtomicWriteAddrOp_Word = True-primOpCanFail AtomicModifyMutVar2Op = True-primOpCanFail AtomicModifyMutVar_Op = True-primOpCanFail RaiseOp = True-primOpCanFail RaiseUnderflowOp = True-primOpCanFail RaiseOverflowOp = True-primOpCanFail RaiseDivZeroOp = True-primOpCanFail ReallyUnsafePtrEqualityOp = True-primOpCanFail (VecInsertOp _ _ _) = True-primOpCanFail (VecDivOp _ _ _) = True-primOpCanFail (VecQuotOp _ _ _) = True-primOpCanFail (VecRemOp _ _ _) = True-primOpCanFail (VecIndexByteArrayOp _ _ _) = True-primOpCanFail (VecReadByteArrayOp _ _ _) = True-primOpCanFail (VecWriteByteArrayOp _ _ _) = True-primOpCanFail (VecIndexOffAddrOp _ _ _) = True-primOpCanFail (VecReadOffAddrOp _ _ _) = True-primOpCanFail (VecWriteOffAddrOp _ _ _) = True-primOpCanFail (VecIndexScalarByteArrayOp _ _ _) = True-primOpCanFail (VecReadScalarByteArrayOp _ _ _) = True-primOpCanFail (VecWriteScalarByteArrayOp _ _ _) = True-primOpCanFail (VecIndexScalarOffAddrOp _ _ _) = True-primOpCanFail (VecReadScalarOffAddrOp _ _ _) = True-primOpCanFail (VecWriteScalarOffAddrOp _ _ _) = True-primOpCanFail _ = False
ghc-lib/stage0/compiler/build/primop-code-size.hs-incl view
@@ -52,6 +52,8 @@ primOpCodeSize FloatAtanhOp =  primOpCodeSizeForeignCall  primOpCodeSize FloatPowerOp =  primOpCodeSizeForeignCall  primOpCodeSize WriteArrayOp = 2+primOpCodeSize UnsafeFreezeByteArrayOp = 0+primOpCodeSize UnsafeThawByteArrayOp = 0 primOpCodeSize CopyByteArrayOp =  primOpCodeSizeForeignCall + 4 primOpCodeSize CopyMutableByteArrayOp =  primOpCodeSizeForeignCall + 4  primOpCodeSize CopyMutableByteArrayNonOverlappingOp =  primOpCodeSizeForeignCall + 4 @@ -68,9 +70,9 @@ primOpCodeSize RaiseUnderflowOp =  primOpCodeSizeForeignCall  primOpCodeSize RaiseOverflowOp =  primOpCodeSizeForeignCall  primOpCodeSize RaiseDivZeroOp =  primOpCodeSizeForeignCall -primOpCodeSize TouchOp =  0 +primOpCodeSize TouchOp = 0 primOpCodeSize ParOp =  primOpCodeSizeForeignCall  primOpCodeSize SparkOp =  primOpCodeSizeForeignCall  primOpCodeSize AddrToAnyOp = 0 primOpCodeSize AnyToAddrOp = 0-primOpCodeSize _ =  primOpCodeSizeDefault +primOpCodeSize _thisOp =  primOpCodeSizeDefault 
ghc-lib/stage0/compiler/build/primop-commutable.hs-incl view
@@ -55,4 +55,4 @@ commutableOp FloatMulOp = True commutableOp (VecAddOp _ _ _) = True commutableOp (VecMulOp _ _ _) = True-commutableOp _ = False+commutableOp _thisOp = False
ghc-lib/stage0/compiler/build/primop-data-decl.hs-incl view
@@ -292,6 +292,8 @@    | DoublePowerOp    | DoubleDecode_2IntOp    | DoubleDecode_Int64Op+   | CastDoubleToWord64Op+   | CastWord64ToDoubleOp    | FloatGtOp    | FloatGeOp    | FloatEqOp@@ -325,6 +327,8 @@    | FloatPowerOp    | FloatToDoubleOp    | FloatDecode_IntOp+   | CastFloatToWord32Op+   | CastWord32ToFloatOp    | FloatFMAdd    | FloatFMSub    | FloatFNMAdd@@ -375,6 +379,7 @@    | ShrinkMutableByteArrayOp_Char    | ResizeMutableByteArrayOp_Char    | UnsafeFreezeByteArrayOp+   | UnsafeThawByteArrayOp    | SizeofByteArrayOp    | SizeofMutableByteArrayOp    | GetSizeofMutableByteArrayOp@@ -519,6 +524,20 @@    | IndexOffAddrOp_Word32    | IndexOffAddrOp_Int64    | IndexOffAddrOp_Word64+   | IndexOffAddrOp_Word8AsChar+   | IndexOffAddrOp_Word8AsWideChar+   | IndexOffAddrOp_Word8AsInt+   | IndexOffAddrOp_Word8AsWord+   | IndexOffAddrOp_Word8AsAddr+   | IndexOffAddrOp_Word8AsFloat+   | IndexOffAddrOp_Word8AsDouble+   | IndexOffAddrOp_Word8AsStablePtr+   | IndexOffAddrOp_Word8AsInt16+   | IndexOffAddrOp_Word8AsWord16+   | IndexOffAddrOp_Word8AsInt32+   | IndexOffAddrOp_Word8AsWord32+   | IndexOffAddrOp_Word8AsInt64+   | IndexOffAddrOp_Word8AsWord64    | ReadOffAddrOp_Char    | ReadOffAddrOp_WideChar    | ReadOffAddrOp_Int@@ -535,6 +554,20 @@    | ReadOffAddrOp_Word32    | ReadOffAddrOp_Int64    | ReadOffAddrOp_Word64+   | ReadOffAddrOp_Word8AsChar+   | ReadOffAddrOp_Word8AsWideChar+   | ReadOffAddrOp_Word8AsInt+   | ReadOffAddrOp_Word8AsWord+   | ReadOffAddrOp_Word8AsAddr+   | ReadOffAddrOp_Word8AsFloat+   | ReadOffAddrOp_Word8AsDouble+   | ReadOffAddrOp_Word8AsStablePtr+   | ReadOffAddrOp_Word8AsInt16+   | ReadOffAddrOp_Word8AsWord16+   | ReadOffAddrOp_Word8AsInt32+   | ReadOffAddrOp_Word8AsWord32+   | ReadOffAddrOp_Word8AsInt64+   | ReadOffAddrOp_Word8AsWord64    | WriteOffAddrOp_Char    | WriteOffAddrOp_WideChar    | WriteOffAddrOp_Int@@ -551,6 +584,20 @@    | WriteOffAddrOp_Word32    | WriteOffAddrOp_Int64    | WriteOffAddrOp_Word64+   | WriteOffAddrOp_Word8AsChar+   | WriteOffAddrOp_Word8AsWideChar+   | WriteOffAddrOp_Word8AsInt+   | WriteOffAddrOp_Word8AsWord+   | WriteOffAddrOp_Word8AsAddr+   | WriteOffAddrOp_Word8AsFloat+   | WriteOffAddrOp_Word8AsDouble+   | WriteOffAddrOp_Word8AsStablePtr+   | WriteOffAddrOp_Word8AsInt16+   | WriteOffAddrOp_Word8AsWord16+   | WriteOffAddrOp_Word8AsInt32+   | WriteOffAddrOp_Word8AsWord32+   | WriteOffAddrOp_Word8AsInt64+   | WriteOffAddrOp_Word8AsWord64    | InterlockedExchange_Addr    | InterlockedExchange_Word    | CasAddrOp_Addr@@ -649,7 +696,8 @@    | GetSparkOp    | NumSparks    | KeepAliveOp-   | DataToTagOp+   | DataToTagSmallOp+   | DataToTagLargeOp    | TagToEnumOp    | AddrToAnyOp    | AnyToAddrOp
ghc-lib/stage0/compiler/build/primop-docs.hs-incl view
@@ -63,8 +63,12 @@   , ("**##","Exponentiation.")   , ("decodeDouble_2Int#","Convert to integer.\n    First component of the result is -1 or 1, indicating the sign of the\n    mantissa. The next two are the high and low 32 bits of the mantissa\n    respectively, and the last is the exponent.")   , ("decodeDouble_Int64#","Decode 'Double#' into mantissa and base-2 exponent.")+  , ("castDoubleToWord64#","Bitcast a 'Double#' into a 'Word64#'")+  , ("castWord64ToDouble#","Bitcast a 'Word64#' into a 'Double#'")   , ("float2Int#","Truncates a 'Float#' value to the nearest 'Int#'.\n    Results are undefined if the truncation if truncation yields\n    a value outside the range of 'Int#'.")   , ("decodeFloat_Int#","Convert to integers.\n    First 'Int#' in result is the mantissa; second is the exponent.")+  , ("castFloatToWord32#","Bitcast a 'Float#' into a 'Word32#'")+  , ("castWord32ToFloat#","Bitcast a 'Word32#' into a 'Float#'")   , ("fmaddFloat#","Fused multiply-add operation @x*y+z@. See \"GHC.Prim#fma\".")   , ("fmsubFloat#","Fused multiply-subtract operation @x*y-z@. See \"GHC.Prim#fma\".")   , ("fnmaddFloat#","Fused negate-multiply-add operation @-x*y+z@. See \"GHC.Prim#fma\".")@@ -117,6 +121,7 @@   , ("shrinkMutableByteArray#","Shrink mutable byte array to new specified size (in bytes), in\n    the specified state thread. The new size argument must be less than or\n    equal to the current size as reported by 'getSizeofMutableByteArray#'.\n\n    Assuming the non-profiling RTS, this primitive compiles to an O(1)\n    operation in C--, modifying the array in-place. Backends bypassing C--\n    representation (such as JavaScript) might behave differently.\n\n    @since 0.4.0.0")   , ("resizeMutableByteArray#","Resize mutable byte array to new specified size (in bytes), shrinking or growing it.\n    The returned 'MutableByteArray#' is either the original\n    'MutableByteArray#' resized in-place or, if not possible, a newly\n    allocated (unpinned) 'MutableByteArray#' (with the original content\n    copied over).\n\n    To avoid undefined behaviour, the original 'MutableByteArray#' shall\n    not be accessed anymore after a 'resizeMutableByteArray#' has been\n    performed.  Moreover, no reference to the old one should be kept in order\n    to allow garbage collection of the original 'MutableByteArray#' in\n    case a new 'MutableByteArray#' had to be allocated.\n\n    @since 0.4.0.0")   , ("unsafeFreezeByteArray#","Make a mutable byte array immutable, without copying.")+  , ("unsafeThawByteArray#","Make an immutable byte array mutable, without copying.\n\n    @since 0.12.0.0")   , ("sizeofByteArray#","Return the size of the array in bytes.")   , ("sizeofMutableByteArray#","Return the size of the array in bytes. __Deprecated__, it is\n   unsafe in the presence of 'shrinkMutableByteArray#' and 'resizeMutableByteArray#'\n   operations on the same mutable byte\n   array.")   , ("getSizeofMutableByteArray#","Return the number of elements in the array, correctly accounting for\n   the effect of 'shrinkMutableByteArray#' and 'resizeMutableByteArray#'.\n\n   @since 0.5.0.0")@@ -210,7 +215,7 @@   , ("writeWord8ArrayAsWord32#","Write a 32-bit unsigned integer; offset in bytes.")   , ("writeWord8ArrayAsInt64#","Write a 64-bit signed integer; offset in bytes.")   , ("writeWord8ArrayAsWord64#","Write a 64-bit unsigned integer; offset in bytes.")-  , ("compareByteArrays#","@'compareByteArrays#' src1 src1_ofs src2 src2_ofs n@ compares\n    @n@ bytes starting at offset @src1_ofs@ in the first\n    'ByteArray#' @src1@ to the range of @n@ bytes\n    (i.e. same length) starting at offset @src2_ofs@ of the second\n    'ByteArray#' @src2@.  Both arrays must fully contain the\n    specified ranges, but this is not checked.  Returns an 'Int#'\n    less than, equal to, or greater than zero if the range is found,\n    respectively, to be byte-wise lexicographically less than, to\n    match, or be greater than the second range.")+  , ("compareByteArrays#","@'compareByteArrays#' src1 src1_ofs src2 src2_ofs n@ compares\n    @n@ bytes starting at offset @src1_ofs@ in the first\n    'ByteArray#' @src1@ to the range of @n@ bytes\n    (i.e. same length) starting at offset @src2_ofs@ of the second\n    'ByteArray#' @src2@.  Both arrays must fully contain the\n    specified ranges, but this is not checked.  Returns an 'Int#'\n    less than, equal to, or greater than zero if the range is found,\n    respectively, to be byte-wise lexicographically less than, to\n    match, or be greater than the second range.\n\n    @since 0.5.2.0")   , ("copyByteArray#"," @'copyByteArray#' src src_ofs dst dst_ofs len@ copies the range\n    starting at offset @src_ofs@ of length @len@ from the\n    'ByteArray#' @src@ to the 'MutableByteArray#' @dst@\n    starting at offset @dst_ofs@.  Both arrays must fully contain\n    the specified ranges, but this is not checked.  The two arrays must\n    not be the same array in different states, but this is not checked\n    either.\n  ")   , ("copyMutableByteArray#"," @'copyMutableByteArray#' src src_ofs dst dst_ofs len@ copies the\n    range starting at offset @src_ofs@ of length @len@ from the\n    'MutableByteArray#' @src@ to the 'MutableByteArray#' @dst@\n    starting at offset @dst_ofs@.  Both arrays must fully contain the\n    specified ranges, but this is not checked.  The regions are\n    allowed to overlap, although this is only possible when the same\n    array is provided as both the source and the destination.\n  ")   , ("copyMutableByteArrayNonOverlapping#"," @'copyMutableByteArrayNonOverlapping#' src src_ofs dst dst_ofs len@\n    copies the range starting at offset @src_ofs@ of length @len@ from\n    the 'MutableByteArray#' @src@ to the 'MutableByteArray#' @dst@\n    starting at offset @dst_ofs@.  Both arrays must fully contain the\n    specified ranges, but this is not checked.  The regions are /not/\n    allowed to overlap, but this is also not checked.\n\n    @since 0.11.0\n  ")@@ -256,6 +261,20 @@   , ("indexWord32OffAddr#","Read a 32-bit unsigned integer; offset in 4-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")   , ("indexInt64OffAddr#","Read a 64-bit signed integer; offset in 8-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")   , ("indexWord64OffAddr#","Read a 64-bit unsigned integer; offset in 8-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")+  , ("indexWord8OffAddrAsChar#","Read an 8-bit character; offset in bytes.")+  , ("indexWord8OffAddrAsWideChar#","Read a 32-bit character; offset in bytes.")+  , ("indexWord8OffAddrAsInt#","Read a word-sized integer; offset in bytes.")+  , ("indexWord8OffAddrAsWord#","Read a word-sized unsigned integer; offset in bytes.")+  , ("indexWord8OffAddrAsAddr#","Read a machine address; offset in bytes.")+  , ("indexWord8OffAddrAsFloat#","Read a single-precision floating-point value; offset in bytes.")+  , ("indexWord8OffAddrAsDouble#","Read a double-precision floating-point value; offset in bytes.")+  , ("indexWord8OffAddrAsStablePtr#","Read a 'StablePtr#' value; offset in bytes.")+  , ("indexWord8OffAddrAsInt16#","Read a 16-bit signed integer; offset in bytes.")+  , ("indexWord8OffAddrAsWord16#","Read a 16-bit unsigned integer; offset in bytes.")+  , ("indexWord8OffAddrAsInt32#","Read a 32-bit signed integer; offset in bytes.")+  , ("indexWord8OffAddrAsWord32#","Read a 32-bit unsigned integer; offset in bytes.")+  , ("indexWord8OffAddrAsInt64#","Read a 64-bit signed integer; offset in bytes.")+  , ("indexWord8OffAddrAsWord64#","Read a 64-bit unsigned integer; offset in bytes.")   , ("readCharOffAddr#","Read an 8-bit character; offset in bytes.\n\n")   , ("readWideCharOffAddr#","Read a 32-bit character; offset in 4-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")   , ("readIntOffAddr#","Read a word-sized integer; offset in machine words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")@@ -272,6 +291,20 @@   , ("readWord32OffAddr#","Read a 32-bit unsigned integer; offset in 4-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")   , ("readInt64OffAddr#","Read a 64-bit signed integer; offset in 8-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")   , ("readWord64OffAddr#","Read a 64-bit unsigned integer; offset in 8-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")+  , ("readWord8OffAddrAsChar#","Read an 8-bit character; offset in bytes.")+  , ("readWord8OffAddrAsWideChar#","Read a 32-bit character; offset in bytes.")+  , ("readWord8OffAddrAsInt#","Read a word-sized integer; offset in bytes.")+  , ("readWord8OffAddrAsWord#","Read a word-sized unsigned integer; offset in bytes.")+  , ("readWord8OffAddrAsAddr#","Read a machine address; offset in bytes.")+  , ("readWord8OffAddrAsFloat#","Read a single-precision floating-point value; offset in bytes.")+  , ("readWord8OffAddrAsDouble#","Read a double-precision floating-point value; offset in bytes.")+  , ("readWord8OffAddrAsStablePtr#","Read a 'StablePtr#' value; offset in bytes.")+  , ("readWord8OffAddrAsInt16#","Read a 16-bit signed integer; offset in bytes.")+  , ("readWord8OffAddrAsWord16#","Read a 16-bit unsigned integer; offset in bytes.")+  , ("readWord8OffAddrAsInt32#","Read a 32-bit signed integer; offset in bytes.")+  , ("readWord8OffAddrAsWord32#","Read a 32-bit unsigned integer; offset in bytes.")+  , ("readWord8OffAddrAsInt64#","Read a 64-bit signed integer; offset in bytes.")+  , ("readWord8OffAddrAsWord64#","Read a 64-bit unsigned integer; offset in bytes.")   , ("writeCharOffAddr#","Write an 8-bit character; offset in bytes.\n\n")   , ("writeWideCharOffAddr#","Write a 32-bit character; offset in 4-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")   , ("writeIntOffAddr#","Write a word-sized integer; offset in machine words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")@@ -288,6 +321,20 @@   , ("writeWord32OffAddr#","Write a 32-bit unsigned integer; offset in 4-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")   , ("writeInt64OffAddr#","Write a 64-bit signed integer; offset in 8-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")   , ("writeWord64OffAddr#","Write a 64-bit unsigned integer; offset in 8-byte words.\n\nOn some platforms, the access may fail\nfor an insufficiently aligned @Addr#@.")+  , ("writeWord8OffAddrAsChar#","Write an 8-bit character; offset in bytes.")+  , ("writeWord8OffAddrAsWideChar#","Write a 32-bit character; offset in bytes.")+  , ("writeWord8OffAddrAsInt#","Write a word-sized integer; offset in bytes.")+  , ("writeWord8OffAddrAsWord#","Write a word-sized unsigned integer; offset in bytes.")+  , ("writeWord8OffAddrAsAddr#","Write a machine address; offset in bytes.")+  , ("writeWord8OffAddrAsFloat#","Write a single-precision floating-point value; offset in bytes.")+  , ("writeWord8OffAddrAsDouble#","Write a double-precision floating-point value; offset in bytes.")+  , ("writeWord8OffAddrAsStablePtr#","Write a 'StablePtr#' value; offset in bytes.")+  , ("writeWord8OffAddrAsInt16#","Write a 16-bit signed integer; offset in bytes.")+  , ("writeWord8OffAddrAsWord16#","Write a 16-bit unsigned integer; offset in bytes.")+  , ("writeWord8OffAddrAsInt32#","Write a 32-bit signed integer; offset in bytes.")+  , ("writeWord8OffAddrAsWord32#","Write a 32-bit unsigned integer; offset in bytes.")+  , ("writeWord8OffAddrAsInt64#","Write a 64-bit signed integer; offset in bytes.")+  , ("writeWord8OffAddrAsWord64#","Write a 64-bit unsigned integer; offset in bytes.")   , ("atomicExchangeAddrAddr#","The atomic exchange operation. Atomically exchanges the value at the first address\n    with the Addr# given as second argument. Implies a read barrier.")   , ("atomicExchangeWordAddr#","The atomic exchange operation. Atomically exchanges the value at the address\n    with the given value. Returns the old value. Implies a read barrier.")   , ("atomicCasAddrAddr#"," Compare and swap on a word-sized memory location.\n\n     Use as: \\s -> atomicCasAddrAddr# location expected desired s\n\n     This version always returns the old value read. This follows the normal\n     protocol for CAS operations (and matches the underlying instruction on\n     most architectures).\n\n     Implies a full memory barrier.")@@ -364,7 +411,8 @@   , ("reallyUnsafePtrEquality#"," Returns @1#@ if the given pointers are equal and @0#@ otherwise. ")   , ("numSparks#"," Returns the number of sparks in the local spark pool. ")   , ("keepAlive#"," @'keepAlive#' x s k@ keeps the value @x@ alive during the execution\n     of the computation @k@.\n\n     Note that the result type here isn't quite as unrestricted as the\n     polymorphic type might suggest; see the section \\\"RuntimeRep polymorphism\n     in continuation-style primops\\\" for details. ")-  , ("dataToTag#"," Evaluates the argument and returns the tag of the result.\n     Tags are Zero-indexed; the first constructor has tag zero. ")+  , ("dataToTagSmall#"," Used internally to implement @dataToTag#@: Use that function instead!\n     This one normally offers /no advantage/ and comes with no stability\n     guarantees: it may change its type, its name, or its behavior\n     with /no warning/ between compiler releases.\n\n     It is expected that this function will be un-exposed in a future\n     release of ghc.\n\n     For more details, look at @Note [DataToTag overview]@\n     in GHC.Tc.Instance.Class in the source code for\n     /the specific compiler version you are using./\n   ")+  , ("dataToTagLarge#"," Used internally to implement @dataToTag#@: Use that function instead!\n     This one offers /no advantage/ and comes with no stability\n     guarantees: it may change its type, its name, or its behavior\n     with /no warning/ between compiler releases.\n\n     It is expected that this function will be un-exposed in a future\n     release of ghc.\n\n     For more details, look at @Note [DataToTag overview]@\n     in GHC.Tc.Instance.Class in the source code for\n     /the specific compiler version you are using./\n   ")   , ("BCO"," Primitive bytecode type. ")   , ("addrToAny#"," Convert an 'Addr#' to a followable Any type. ")   , ("anyToAddr#"," Retrieve the address of any Haskell value. This is\n     essentially an 'unsafeCoerce#', but if implemented as such\n     the core lint pass complains and fails to compile.\n     As a primop, it is opaque to core/stg, and only appears\n     in cmm (where the copy propagation pass will get rid of it).\n     Note that \"a\" must be a value, not a thunk! It's too late\n     for strictness analysis to enforce this, so you're on your\n     own to guarantee this. Also note that 'Addr#' is not a GC\n     pointer - up to you to guarantee that it does not become\n     a dangling pointer immediately after you get it.")@@ -374,7 +422,7 @@   , ("closureSize#"," @'closureSize#' closure@ returns the size of the given closure in\n     machine words. ")   , ("getCurrentCCS#"," Returns the current 'CostCentreStack' (value is @NULL@ if\n     not profiling).  Takes a dummy argument which can be used to\n     avoid the call to 'getCurrentCCS#' being floated out by the\n     simplifier, which would result in an uninformative stack\n     (\"CAF\"). ")   , ("clearCCS#"," Run the supplied IO action with an empty CCS.  For example, this\n     is used by the interpreter to run an interpreted computation\n     without the call stack showing that it was invoked from GHC. ")-  , ("whereFrom#"," Returns the @InfoProvEnt @ for the info table of the given object\n     (value is @NULL@ if the table does not exist or there is no information\n     about the closure).")+  , ("whereFrom#"," Fills the given buffer with the @InfoProvEnt@ for the info table of the\n     given object. Returns @1#@ on success and @0#@ otherwise.")   , ("FUN","The builtin function type, written in infix form as @a % m -> b@.\n   Values of this type are functions taking inputs of type @a@ and\n   producing outputs of type @b@. The multiplicity of the input is\n   @m@.\n\n   Note that @'FUN' m a b@ permits representation polymorphism in both\n   @a@ and @b@, so that types like @'Int#' -> 'Int#'@ can still be\n   well-kinded.\n  ")   , ("realWorld#"," The token used in the implementation of the IO monad as a state monad.\n     It does not pass any information at runtime.\n     See also 'GHC.Magic.runRW#'. ")   , ("void#"," This is an alias for the unboxed unit tuple constructor.\n     In earlier versions of GHC, 'void#' was a value\n     of the primitive type 'Void#', which is now defined to be @(# #)@.\n   ")
+ ghc-lib/stage0/compiler/build/primop-effects.hs-incl view
@@ -0,0 +1,410 @@+primOpEffect Int8QuotOp = CanFail+primOpEffect Int8RemOp = CanFail+primOpEffect Int8QuotRemOp = CanFail+primOpEffect Word8QuotOp = CanFail+primOpEffect Word8RemOp = CanFail+primOpEffect Word8QuotRemOp = CanFail+primOpEffect Int16QuotOp = CanFail+primOpEffect Int16RemOp = CanFail+primOpEffect Int16QuotRemOp = CanFail+primOpEffect Word16QuotOp = CanFail+primOpEffect Word16RemOp = CanFail+primOpEffect Word16QuotRemOp = CanFail+primOpEffect Int32QuotOp = CanFail+primOpEffect Int32RemOp = CanFail+primOpEffect Int32QuotRemOp = CanFail+primOpEffect Word32QuotOp = CanFail+primOpEffect Word32RemOp = CanFail+primOpEffect Word32QuotRemOp = CanFail+primOpEffect Int64QuotOp = CanFail+primOpEffect Int64RemOp = CanFail+primOpEffect Word64QuotOp = CanFail+primOpEffect Word64RemOp = CanFail+primOpEffect IntQuotOp = CanFail+primOpEffect IntRemOp = CanFail+primOpEffect IntQuotRemOp = CanFail+primOpEffect WordQuotOp = CanFail+primOpEffect WordRemOp = CanFail+primOpEffect WordQuotRemOp = CanFail+primOpEffect WordQuotRem2Op = CanFail+primOpEffect DoubleDivOp = CanFail+primOpEffect DoubleLogOp = CanFail+primOpEffect DoubleLog1POp = CanFail+primOpEffect DoubleAsinOp = CanFail+primOpEffect DoubleAcosOp = CanFail+primOpEffect FloatDivOp = CanFail+primOpEffect FloatLogOp = CanFail+primOpEffect FloatLog1POp = CanFail+primOpEffect FloatAsinOp = CanFail+primOpEffect FloatAcosOp = CanFail+primOpEffect NewArrayOp = ReadWriteEffect+primOpEffect ReadArrayOp = ReadWriteEffect+primOpEffect WriteArrayOp = ReadWriteEffect+primOpEffect IndexArrayOp = CanFail+primOpEffect UnsafeFreezeArrayOp = ReadWriteEffect+primOpEffect UnsafeThawArrayOp = ReadWriteEffect+primOpEffect CopyArrayOp = ReadWriteEffect+primOpEffect CopyMutableArrayOp = ReadWriteEffect+primOpEffect CloneArrayOp = ReadWriteEffect+primOpEffect CloneMutableArrayOp = ReadWriteEffect+primOpEffect FreezeArrayOp = ReadWriteEffect+primOpEffect ThawArrayOp = ReadWriteEffect+primOpEffect CasArrayOp = ReadWriteEffect+primOpEffect NewSmallArrayOp = ReadWriteEffect+primOpEffect ShrinkSmallMutableArrayOp_Char = ReadWriteEffect+primOpEffect ReadSmallArrayOp = ReadWriteEffect+primOpEffect WriteSmallArrayOp = ReadWriteEffect+primOpEffect IndexSmallArrayOp = CanFail+primOpEffect UnsafeFreezeSmallArrayOp = ReadWriteEffect+primOpEffect UnsafeThawSmallArrayOp = ReadWriteEffect+primOpEffect CopySmallArrayOp = ReadWriteEffect+primOpEffect CopySmallMutableArrayOp = ReadWriteEffect+primOpEffect CloneSmallArrayOp = ReadWriteEffect+primOpEffect CloneSmallMutableArrayOp = ReadWriteEffect+primOpEffect FreezeSmallArrayOp = ReadWriteEffect+primOpEffect ThawSmallArrayOp = ReadWriteEffect+primOpEffect CasSmallArrayOp = ReadWriteEffect+primOpEffect NewByteArrayOp_Char = ReadWriteEffect+primOpEffect NewPinnedByteArrayOp_Char = ReadWriteEffect+primOpEffect NewAlignedPinnedByteArrayOp_Char = ReadWriteEffect+primOpEffect ShrinkMutableByteArrayOp_Char = ReadWriteEffect+primOpEffect ResizeMutableByteArrayOp_Char = ReadWriteEffect+primOpEffect UnsafeFreezeByteArrayOp = NoEffect+primOpEffect UnsafeThawByteArrayOp = NoEffect+primOpEffect IndexByteArrayOp_Char = CanFail+primOpEffect IndexByteArrayOp_WideChar = CanFail+primOpEffect IndexByteArrayOp_Int = CanFail+primOpEffect IndexByteArrayOp_Word = CanFail+primOpEffect IndexByteArrayOp_Addr = CanFail+primOpEffect IndexByteArrayOp_Float = CanFail+primOpEffect IndexByteArrayOp_Double = CanFail+primOpEffect IndexByteArrayOp_StablePtr = CanFail+primOpEffect IndexByteArrayOp_Int8 = CanFail+primOpEffect IndexByteArrayOp_Word8 = CanFail+primOpEffect IndexByteArrayOp_Int16 = CanFail+primOpEffect IndexByteArrayOp_Word16 = CanFail+primOpEffect IndexByteArrayOp_Int32 = CanFail+primOpEffect IndexByteArrayOp_Word32 = CanFail+primOpEffect IndexByteArrayOp_Int64 = CanFail+primOpEffect IndexByteArrayOp_Word64 = CanFail+primOpEffect IndexByteArrayOp_Word8AsChar = CanFail+primOpEffect IndexByteArrayOp_Word8AsWideChar = CanFail+primOpEffect IndexByteArrayOp_Word8AsInt = CanFail+primOpEffect IndexByteArrayOp_Word8AsWord = CanFail+primOpEffect IndexByteArrayOp_Word8AsAddr = CanFail+primOpEffect IndexByteArrayOp_Word8AsFloat = CanFail+primOpEffect IndexByteArrayOp_Word8AsDouble = CanFail+primOpEffect IndexByteArrayOp_Word8AsStablePtr = CanFail+primOpEffect IndexByteArrayOp_Word8AsInt16 = CanFail+primOpEffect IndexByteArrayOp_Word8AsWord16 = CanFail+primOpEffect IndexByteArrayOp_Word8AsInt32 = CanFail+primOpEffect IndexByteArrayOp_Word8AsWord32 = CanFail+primOpEffect IndexByteArrayOp_Word8AsInt64 = CanFail+primOpEffect IndexByteArrayOp_Word8AsWord64 = CanFail+primOpEffect ReadByteArrayOp_Char = ReadWriteEffect+primOpEffect ReadByteArrayOp_WideChar = ReadWriteEffect+primOpEffect ReadByteArrayOp_Int = ReadWriteEffect+primOpEffect ReadByteArrayOp_Word = ReadWriteEffect+primOpEffect ReadByteArrayOp_Addr = ReadWriteEffect+primOpEffect ReadByteArrayOp_Float = ReadWriteEffect+primOpEffect ReadByteArrayOp_Double = ReadWriteEffect+primOpEffect ReadByteArrayOp_StablePtr = ReadWriteEffect+primOpEffect ReadByteArrayOp_Int8 = ReadWriteEffect+primOpEffect ReadByteArrayOp_Word8 = ReadWriteEffect+primOpEffect ReadByteArrayOp_Int16 = ReadWriteEffect+primOpEffect ReadByteArrayOp_Word16 = ReadWriteEffect+primOpEffect ReadByteArrayOp_Int32 = ReadWriteEffect+primOpEffect ReadByteArrayOp_Word32 = ReadWriteEffect+primOpEffect ReadByteArrayOp_Int64 = ReadWriteEffect+primOpEffect ReadByteArrayOp_Word64 = ReadWriteEffect+primOpEffect ReadByteArrayOp_Word8AsChar = ReadWriteEffect+primOpEffect ReadByteArrayOp_Word8AsWideChar = ReadWriteEffect+primOpEffect ReadByteArrayOp_Word8AsInt = ReadWriteEffect+primOpEffect ReadByteArrayOp_Word8AsWord = ReadWriteEffect+primOpEffect ReadByteArrayOp_Word8AsAddr = ReadWriteEffect+primOpEffect ReadByteArrayOp_Word8AsFloat = ReadWriteEffect+primOpEffect ReadByteArrayOp_Word8AsDouble = ReadWriteEffect+primOpEffect ReadByteArrayOp_Word8AsStablePtr = ReadWriteEffect+primOpEffect ReadByteArrayOp_Word8AsInt16 = ReadWriteEffect+primOpEffect ReadByteArrayOp_Word8AsWord16 = ReadWriteEffect+primOpEffect ReadByteArrayOp_Word8AsInt32 = ReadWriteEffect+primOpEffect ReadByteArrayOp_Word8AsWord32 = ReadWriteEffect+primOpEffect ReadByteArrayOp_Word8AsInt64 = ReadWriteEffect+primOpEffect ReadByteArrayOp_Word8AsWord64 = ReadWriteEffect+primOpEffect WriteByteArrayOp_Char = ReadWriteEffect+primOpEffect WriteByteArrayOp_WideChar = ReadWriteEffect+primOpEffect WriteByteArrayOp_Int = ReadWriteEffect+primOpEffect WriteByteArrayOp_Word = ReadWriteEffect+primOpEffect WriteByteArrayOp_Addr = ReadWriteEffect+primOpEffect WriteByteArrayOp_Float = ReadWriteEffect+primOpEffect WriteByteArrayOp_Double = ReadWriteEffect+primOpEffect WriteByteArrayOp_StablePtr = ReadWriteEffect+primOpEffect WriteByteArrayOp_Int8 = ReadWriteEffect+primOpEffect WriteByteArrayOp_Word8 = ReadWriteEffect+primOpEffect WriteByteArrayOp_Int16 = ReadWriteEffect+primOpEffect WriteByteArrayOp_Word16 = ReadWriteEffect+primOpEffect WriteByteArrayOp_Int32 = ReadWriteEffect+primOpEffect WriteByteArrayOp_Word32 = ReadWriteEffect+primOpEffect WriteByteArrayOp_Int64 = ReadWriteEffect+primOpEffect WriteByteArrayOp_Word64 = ReadWriteEffect+primOpEffect WriteByteArrayOp_Word8AsChar = ReadWriteEffect+primOpEffect WriteByteArrayOp_Word8AsWideChar = ReadWriteEffect+primOpEffect WriteByteArrayOp_Word8AsInt = ReadWriteEffect+primOpEffect WriteByteArrayOp_Word8AsWord = ReadWriteEffect+primOpEffect WriteByteArrayOp_Word8AsAddr = ReadWriteEffect+primOpEffect WriteByteArrayOp_Word8AsFloat = ReadWriteEffect+primOpEffect WriteByteArrayOp_Word8AsDouble = ReadWriteEffect+primOpEffect WriteByteArrayOp_Word8AsStablePtr = ReadWriteEffect+primOpEffect WriteByteArrayOp_Word8AsInt16 = ReadWriteEffect+primOpEffect WriteByteArrayOp_Word8AsWord16 = ReadWriteEffect+primOpEffect WriteByteArrayOp_Word8AsInt32 = ReadWriteEffect+primOpEffect WriteByteArrayOp_Word8AsWord32 = ReadWriteEffect+primOpEffect WriteByteArrayOp_Word8AsInt64 = ReadWriteEffect+primOpEffect WriteByteArrayOp_Word8AsWord64 = ReadWriteEffect+primOpEffect CompareByteArraysOp = CanFail+primOpEffect CopyByteArrayOp = ReadWriteEffect+primOpEffect CopyMutableByteArrayOp = ReadWriteEffect+primOpEffect CopyMutableByteArrayNonOverlappingOp = ReadWriteEffect+primOpEffect CopyByteArrayToAddrOp = ReadWriteEffect+primOpEffect CopyMutableByteArrayToAddrOp = ReadWriteEffect+primOpEffect CopyAddrToByteArrayOp = ReadWriteEffect+primOpEffect CopyAddrToAddrOp = ReadWriteEffect+primOpEffect CopyAddrToAddrNonOverlappingOp = ReadWriteEffect+primOpEffect SetByteArrayOp = ReadWriteEffect+primOpEffect SetAddrRangeOp = ReadWriteEffect+primOpEffect AtomicReadByteArrayOp_Int = ReadWriteEffect+primOpEffect AtomicWriteByteArrayOp_Int = ReadWriteEffect+primOpEffect CasByteArrayOp_Int = ReadWriteEffect+primOpEffect CasByteArrayOp_Int8 = ReadWriteEffect+primOpEffect CasByteArrayOp_Int16 = ReadWriteEffect+primOpEffect CasByteArrayOp_Int32 = ReadWriteEffect+primOpEffect CasByteArrayOp_Int64 = ReadWriteEffect+primOpEffect FetchAddByteArrayOp_Int = ReadWriteEffect+primOpEffect FetchSubByteArrayOp_Int = ReadWriteEffect+primOpEffect FetchAndByteArrayOp_Int = ReadWriteEffect+primOpEffect FetchNandByteArrayOp_Int = ReadWriteEffect+primOpEffect FetchOrByteArrayOp_Int = ReadWriteEffect+primOpEffect FetchXorByteArrayOp_Int = ReadWriteEffect+primOpEffect IndexOffAddrOp_Char = CanFail+primOpEffect IndexOffAddrOp_WideChar = CanFail+primOpEffect IndexOffAddrOp_Int = CanFail+primOpEffect IndexOffAddrOp_Word = CanFail+primOpEffect IndexOffAddrOp_Addr = CanFail+primOpEffect IndexOffAddrOp_Float = CanFail+primOpEffect IndexOffAddrOp_Double = CanFail+primOpEffect IndexOffAddrOp_StablePtr = CanFail+primOpEffect IndexOffAddrOp_Int8 = CanFail+primOpEffect IndexOffAddrOp_Word8 = CanFail+primOpEffect IndexOffAddrOp_Int16 = CanFail+primOpEffect IndexOffAddrOp_Word16 = CanFail+primOpEffect IndexOffAddrOp_Int32 = CanFail+primOpEffect IndexOffAddrOp_Word32 = CanFail+primOpEffect IndexOffAddrOp_Int64 = CanFail+primOpEffect IndexOffAddrOp_Word64 = CanFail+primOpEffect IndexOffAddrOp_Word8AsChar = CanFail+primOpEffect IndexOffAddrOp_Word8AsWideChar = CanFail+primOpEffect IndexOffAddrOp_Word8AsInt = CanFail+primOpEffect IndexOffAddrOp_Word8AsWord = CanFail+primOpEffect IndexOffAddrOp_Word8AsAddr = CanFail+primOpEffect IndexOffAddrOp_Word8AsFloat = CanFail+primOpEffect IndexOffAddrOp_Word8AsDouble = CanFail+primOpEffect IndexOffAddrOp_Word8AsStablePtr = CanFail+primOpEffect IndexOffAddrOp_Word8AsInt16 = CanFail+primOpEffect IndexOffAddrOp_Word8AsWord16 = CanFail+primOpEffect IndexOffAddrOp_Word8AsInt32 = CanFail+primOpEffect IndexOffAddrOp_Word8AsWord32 = CanFail+primOpEffect IndexOffAddrOp_Word8AsInt64 = CanFail+primOpEffect IndexOffAddrOp_Word8AsWord64 = CanFail+primOpEffect ReadOffAddrOp_Char = ReadWriteEffect+primOpEffect ReadOffAddrOp_WideChar = ReadWriteEffect+primOpEffect ReadOffAddrOp_Int = ReadWriteEffect+primOpEffect ReadOffAddrOp_Word = ReadWriteEffect+primOpEffect ReadOffAddrOp_Addr = ReadWriteEffect+primOpEffect ReadOffAddrOp_Float = ReadWriteEffect+primOpEffect ReadOffAddrOp_Double = ReadWriteEffect+primOpEffect ReadOffAddrOp_StablePtr = ReadWriteEffect+primOpEffect ReadOffAddrOp_Int8 = ReadWriteEffect+primOpEffect ReadOffAddrOp_Word8 = ReadWriteEffect+primOpEffect ReadOffAddrOp_Int16 = ReadWriteEffect+primOpEffect ReadOffAddrOp_Word16 = ReadWriteEffect+primOpEffect ReadOffAddrOp_Int32 = ReadWriteEffect+primOpEffect ReadOffAddrOp_Word32 = ReadWriteEffect+primOpEffect ReadOffAddrOp_Int64 = ReadWriteEffect+primOpEffect ReadOffAddrOp_Word64 = ReadWriteEffect+primOpEffect ReadOffAddrOp_Word8AsChar = ReadWriteEffect+primOpEffect ReadOffAddrOp_Word8AsWideChar = ReadWriteEffect+primOpEffect ReadOffAddrOp_Word8AsInt = ReadWriteEffect+primOpEffect ReadOffAddrOp_Word8AsWord = ReadWriteEffect+primOpEffect ReadOffAddrOp_Word8AsAddr = ReadWriteEffect+primOpEffect ReadOffAddrOp_Word8AsFloat = ReadWriteEffect+primOpEffect ReadOffAddrOp_Word8AsDouble = ReadWriteEffect+primOpEffect ReadOffAddrOp_Word8AsStablePtr = ReadWriteEffect+primOpEffect ReadOffAddrOp_Word8AsInt16 = ReadWriteEffect+primOpEffect ReadOffAddrOp_Word8AsWord16 = ReadWriteEffect+primOpEffect ReadOffAddrOp_Word8AsInt32 = ReadWriteEffect+primOpEffect ReadOffAddrOp_Word8AsWord32 = ReadWriteEffect+primOpEffect ReadOffAddrOp_Word8AsInt64 = ReadWriteEffect+primOpEffect ReadOffAddrOp_Word8AsWord64 = ReadWriteEffect+primOpEffect WriteOffAddrOp_Char = ReadWriteEffect+primOpEffect WriteOffAddrOp_WideChar = ReadWriteEffect+primOpEffect WriteOffAddrOp_Int = ReadWriteEffect+primOpEffect WriteOffAddrOp_Word = ReadWriteEffect+primOpEffect WriteOffAddrOp_Addr = ReadWriteEffect+primOpEffect WriteOffAddrOp_Float = ReadWriteEffect+primOpEffect WriteOffAddrOp_Double = ReadWriteEffect+primOpEffect WriteOffAddrOp_StablePtr = ReadWriteEffect+primOpEffect WriteOffAddrOp_Int8 = ReadWriteEffect+primOpEffect WriteOffAddrOp_Word8 = ReadWriteEffect+primOpEffect WriteOffAddrOp_Int16 = ReadWriteEffect+primOpEffect WriteOffAddrOp_Word16 = ReadWriteEffect+primOpEffect WriteOffAddrOp_Int32 = ReadWriteEffect+primOpEffect WriteOffAddrOp_Word32 = ReadWriteEffect+primOpEffect WriteOffAddrOp_Int64 = ReadWriteEffect+primOpEffect WriteOffAddrOp_Word64 = ReadWriteEffect+primOpEffect WriteOffAddrOp_Word8AsChar = ReadWriteEffect+primOpEffect WriteOffAddrOp_Word8AsWideChar = ReadWriteEffect+primOpEffect WriteOffAddrOp_Word8AsInt = ReadWriteEffect+primOpEffect WriteOffAddrOp_Word8AsWord = ReadWriteEffect+primOpEffect WriteOffAddrOp_Word8AsAddr = ReadWriteEffect+primOpEffect WriteOffAddrOp_Word8AsFloat = ReadWriteEffect+primOpEffect WriteOffAddrOp_Word8AsDouble = ReadWriteEffect+primOpEffect WriteOffAddrOp_Word8AsStablePtr = ReadWriteEffect+primOpEffect WriteOffAddrOp_Word8AsInt16 = ReadWriteEffect+primOpEffect WriteOffAddrOp_Word8AsWord16 = ReadWriteEffect+primOpEffect WriteOffAddrOp_Word8AsInt32 = ReadWriteEffect+primOpEffect WriteOffAddrOp_Word8AsWord32 = ReadWriteEffect+primOpEffect WriteOffAddrOp_Word8AsInt64 = ReadWriteEffect+primOpEffect WriteOffAddrOp_Word8AsWord64 = ReadWriteEffect+primOpEffect InterlockedExchange_Addr = ReadWriteEffect+primOpEffect InterlockedExchange_Word = ReadWriteEffect+primOpEffect CasAddrOp_Addr = ReadWriteEffect+primOpEffect CasAddrOp_Word = ReadWriteEffect+primOpEffect CasAddrOp_Word8 = ReadWriteEffect+primOpEffect CasAddrOp_Word16 = ReadWriteEffect+primOpEffect CasAddrOp_Word32 = ReadWriteEffect+primOpEffect CasAddrOp_Word64 = ReadWriteEffect+primOpEffect FetchAddAddrOp_Word = ReadWriteEffect+primOpEffect FetchSubAddrOp_Word = ReadWriteEffect+primOpEffect FetchAndAddrOp_Word = ReadWriteEffect+primOpEffect FetchNandAddrOp_Word = ReadWriteEffect+primOpEffect FetchOrAddrOp_Word = ReadWriteEffect+primOpEffect FetchXorAddrOp_Word = ReadWriteEffect+primOpEffect AtomicReadAddrOp_Word = ReadWriteEffect+primOpEffect AtomicWriteAddrOp_Word = ReadWriteEffect+primOpEffect NewMutVarOp = ReadWriteEffect+primOpEffect ReadMutVarOp = ReadWriteEffect+primOpEffect WriteMutVarOp = ReadWriteEffect+primOpEffect AtomicSwapMutVarOp = ReadWriteEffect+primOpEffect AtomicModifyMutVar2Op = ReadWriteEffect+primOpEffect AtomicModifyMutVar_Op = ReadWriteEffect+primOpEffect CasMutVarOp = ReadWriteEffect+primOpEffect CatchOp = ReadWriteEffect+primOpEffect RaiseOp = ThrowsException+primOpEffect RaiseUnderflowOp = ThrowsException+primOpEffect RaiseOverflowOp = ThrowsException+primOpEffect RaiseDivZeroOp = ThrowsException+primOpEffect RaiseIOOp = ThrowsException+primOpEffect MaskAsyncExceptionsOp = ReadWriteEffect+primOpEffect MaskUninterruptibleOp = ReadWriteEffect+primOpEffect UnmaskAsyncExceptionsOp = ReadWriteEffect+primOpEffect MaskStatus = ReadWriteEffect+primOpEffect NewPromptTagOp = ReadWriteEffect+primOpEffect PromptOp = ReadWriteEffect+primOpEffect Control0Op = ReadWriteEffect+primOpEffect AtomicallyOp = ReadWriteEffect+primOpEffect RetryOp = ReadWriteEffect+primOpEffect CatchRetryOp = ReadWriteEffect+primOpEffect CatchSTMOp = ReadWriteEffect+primOpEffect NewTVarOp = ReadWriteEffect+primOpEffect ReadTVarOp = ReadWriteEffect+primOpEffect ReadTVarIOOp = ReadWriteEffect+primOpEffect WriteTVarOp = ReadWriteEffect+primOpEffect NewMVarOp = ReadWriteEffect+primOpEffect TakeMVarOp = ReadWriteEffect+primOpEffect TryTakeMVarOp = ReadWriteEffect+primOpEffect PutMVarOp = ReadWriteEffect+primOpEffect TryPutMVarOp = ReadWriteEffect+primOpEffect ReadMVarOp = ReadWriteEffect+primOpEffect TryReadMVarOp = ReadWriteEffect+primOpEffect IsEmptyMVarOp = ReadWriteEffect+primOpEffect NewIOPortOp = ReadWriteEffect+primOpEffect ReadIOPortOp = ReadWriteEffect+primOpEffect WriteIOPortOp = ReadWriteEffect+primOpEffect DelayOp = ReadWriteEffect+primOpEffect WaitReadOp = ReadWriteEffect+primOpEffect WaitWriteOp = ReadWriteEffect+primOpEffect ForkOp = ReadWriteEffect+primOpEffect ForkOnOp = ReadWriteEffect+primOpEffect KillThreadOp = ReadWriteEffect+primOpEffect YieldOp = ReadWriteEffect+primOpEffect MyThreadIdOp = ReadWriteEffect+primOpEffect LabelThreadOp = ReadWriteEffect+primOpEffect IsCurrentThreadBoundOp = ReadWriteEffect+primOpEffect NoDuplicateOp = ReadWriteEffect+primOpEffect ThreadStatusOp = ReadWriteEffect+primOpEffect ListThreadsOp = ReadWriteEffect+primOpEffect MkWeakOp = ReadWriteEffect+primOpEffect MkWeakNoFinalizerOp = ReadWriteEffect+primOpEffect AddCFinalizerToWeakOp = ReadWriteEffect+primOpEffect DeRefWeakOp = ReadWriteEffect+primOpEffect FinalizeWeakOp = ReadWriteEffect+primOpEffect TouchOp = ReadWriteEffect+primOpEffect MakeStablePtrOp = ReadWriteEffect+primOpEffect DeRefStablePtrOp = ReadWriteEffect+primOpEffect EqStablePtrOp = ReadWriteEffect+primOpEffect MakeStableNameOp = ReadWriteEffect+primOpEffect CompactNewOp = ReadWriteEffect+primOpEffect CompactResizeOp = ReadWriteEffect+primOpEffect CompactAllocateBlockOp = ReadWriteEffect+primOpEffect CompactFixupPointersOp = ReadWriteEffect+primOpEffect CompactAdd = ReadWriteEffect+primOpEffect CompactAddWithSharing = ReadWriteEffect+primOpEffect CompactSize = ReadWriteEffect+primOpEffect ReallyUnsafePtrEqualityOp = CanFail+primOpEffect ParOp = ReadWriteEffect+primOpEffect SparkOp = ReadWriteEffect+primOpEffect SeqOp = ThrowsException+primOpEffect GetSparkOp = ReadWriteEffect+primOpEffect NumSparks = ReadWriteEffect+primOpEffect KeepAliveOp = ReadWriteEffect+primOpEffect DataToTagSmallOp = ThrowsException+primOpEffect DataToTagLargeOp = ThrowsException+primOpEffect TagToEnumOp = CanFail+primOpEffect NewBCOOp = ReadWriteEffect+primOpEffect TraceEventOp = ReadWriteEffect+primOpEffect TraceEventBinaryOp = ReadWriteEffect+primOpEffect TraceMarkerOp = ReadWriteEffect+primOpEffect SetThreadAllocationCounter = ReadWriteEffect+primOpEffect (VecInsertOp _ _ _) = CanFail+primOpEffect (VecDivOp _ _ _) = CanFail+primOpEffect (VecQuotOp _ _ _) = CanFail+primOpEffect (VecRemOp _ _ _) = CanFail+primOpEffect (VecIndexByteArrayOp _ _ _) = CanFail+primOpEffect (VecReadByteArrayOp _ _ _) = ReadWriteEffect+primOpEffect (VecWriteByteArrayOp _ _ _) = ReadWriteEffect+primOpEffect (VecIndexOffAddrOp _ _ _) = CanFail+primOpEffect (VecReadOffAddrOp _ _ _) = ReadWriteEffect+primOpEffect (VecWriteOffAddrOp _ _ _) = ReadWriteEffect+primOpEffect (VecIndexScalarByteArrayOp _ _ _) = CanFail+primOpEffect (VecReadScalarByteArrayOp _ _ _) = ReadWriteEffect+primOpEffect (VecWriteScalarByteArrayOp _ _ _) = ReadWriteEffect+primOpEffect (VecIndexScalarOffAddrOp _ _ _) = CanFail+primOpEffect (VecReadScalarOffAddrOp _ _ _) = ReadWriteEffect+primOpEffect (VecWriteScalarOffAddrOp _ _ _) = ReadWriteEffect+primOpEffect PrefetchByteArrayOp3 = ReadWriteEffect+primOpEffect PrefetchMutableByteArrayOp3 = ReadWriteEffect+primOpEffect PrefetchAddrOp3 = ReadWriteEffect+primOpEffect PrefetchValueOp3 = ReadWriteEffect+primOpEffect PrefetchByteArrayOp2 = ReadWriteEffect+primOpEffect PrefetchMutableByteArrayOp2 = ReadWriteEffect+primOpEffect PrefetchAddrOp2 = ReadWriteEffect+primOpEffect PrefetchValueOp2 = ReadWriteEffect+primOpEffect PrefetchByteArrayOp1 = ReadWriteEffect+primOpEffect PrefetchMutableByteArrayOp1 = ReadWriteEffect+primOpEffect PrefetchAddrOp1 = ReadWriteEffect+primOpEffect PrefetchValueOp1 = ReadWriteEffect+primOpEffect PrefetchByteArrayOp0 = ReadWriteEffect+primOpEffect PrefetchMutableByteArrayOp0 = ReadWriteEffect+primOpEffect PrefetchAddrOp0 = ReadWriteEffect+primOpEffect PrefetchValueOp0 = ReadWriteEffect+primOpEffect _thisOp = NoEffect
ghc-lib/stage0/compiler/build/primop-fixity.hs-incl view
@@ -17,4 +17,4 @@ primOpFixity DoubleSubOp = Just (Fixity NoSourceText 6 InfixL) primOpFixity DoubleMulOp = Just (Fixity NoSourceText 7 InfixL) primOpFixity DoubleDivOp = Just (Fixity NoSourceText 7 InfixL)-primOpFixity _ = Nothing+primOpFixity _thisOp = Nothing
− ghc-lib/stage0/compiler/build/primop-has-side-effects.hs-incl 
@@ -1,261 +0,0 @@-primOpHasSideEffects NewArrayOp = True-primOpHasSideEffects ReadArrayOp = True-primOpHasSideEffects WriteArrayOp = True-primOpHasSideEffects UnsafeFreezeArrayOp = True-primOpHasSideEffects UnsafeThawArrayOp = True-primOpHasSideEffects CopyArrayOp = True-primOpHasSideEffects CopyMutableArrayOp = True-primOpHasSideEffects CloneArrayOp = True-primOpHasSideEffects CloneMutableArrayOp = True-primOpHasSideEffects FreezeArrayOp = True-primOpHasSideEffects ThawArrayOp = True-primOpHasSideEffects CasArrayOp = True-primOpHasSideEffects NewSmallArrayOp = True-primOpHasSideEffects ShrinkSmallMutableArrayOp_Char = True-primOpHasSideEffects ReadSmallArrayOp = True-primOpHasSideEffects WriteSmallArrayOp = True-primOpHasSideEffects UnsafeFreezeSmallArrayOp = True-primOpHasSideEffects UnsafeThawSmallArrayOp = True-primOpHasSideEffects CopySmallArrayOp = True-primOpHasSideEffects CopySmallMutableArrayOp = True-primOpHasSideEffects CloneSmallArrayOp = True-primOpHasSideEffects CloneSmallMutableArrayOp = True-primOpHasSideEffects FreezeSmallArrayOp = True-primOpHasSideEffects ThawSmallArrayOp = True-primOpHasSideEffects CasSmallArrayOp = True-primOpHasSideEffects NewByteArrayOp_Char = True-primOpHasSideEffects NewPinnedByteArrayOp_Char = True-primOpHasSideEffects NewAlignedPinnedByteArrayOp_Char = True-primOpHasSideEffects ShrinkMutableByteArrayOp_Char = True-primOpHasSideEffects ResizeMutableByteArrayOp_Char = True-primOpHasSideEffects UnsafeFreezeByteArrayOp = True-primOpHasSideEffects ReadByteArrayOp_Char = True-primOpHasSideEffects ReadByteArrayOp_WideChar = True-primOpHasSideEffects ReadByteArrayOp_Int = True-primOpHasSideEffects ReadByteArrayOp_Word = True-primOpHasSideEffects ReadByteArrayOp_Addr = True-primOpHasSideEffects ReadByteArrayOp_Float = True-primOpHasSideEffects ReadByteArrayOp_Double = True-primOpHasSideEffects ReadByteArrayOp_StablePtr = True-primOpHasSideEffects ReadByteArrayOp_Int8 = True-primOpHasSideEffects ReadByteArrayOp_Word8 = True-primOpHasSideEffects ReadByteArrayOp_Int16 = True-primOpHasSideEffects ReadByteArrayOp_Word16 = True-primOpHasSideEffects ReadByteArrayOp_Int32 = True-primOpHasSideEffects ReadByteArrayOp_Word32 = True-primOpHasSideEffects ReadByteArrayOp_Int64 = True-primOpHasSideEffects ReadByteArrayOp_Word64 = True-primOpHasSideEffects ReadByteArrayOp_Word8AsChar = True-primOpHasSideEffects ReadByteArrayOp_Word8AsWideChar = True-primOpHasSideEffects ReadByteArrayOp_Word8AsInt = True-primOpHasSideEffects ReadByteArrayOp_Word8AsWord = True-primOpHasSideEffects ReadByteArrayOp_Word8AsAddr = True-primOpHasSideEffects ReadByteArrayOp_Word8AsFloat = True-primOpHasSideEffects ReadByteArrayOp_Word8AsDouble = True-primOpHasSideEffects ReadByteArrayOp_Word8AsStablePtr = True-primOpHasSideEffects ReadByteArrayOp_Word8AsInt16 = True-primOpHasSideEffects ReadByteArrayOp_Word8AsWord16 = True-primOpHasSideEffects ReadByteArrayOp_Word8AsInt32 = True-primOpHasSideEffects ReadByteArrayOp_Word8AsWord32 = True-primOpHasSideEffects ReadByteArrayOp_Word8AsInt64 = True-primOpHasSideEffects ReadByteArrayOp_Word8AsWord64 = True-primOpHasSideEffects WriteByteArrayOp_Char = True-primOpHasSideEffects WriteByteArrayOp_WideChar = True-primOpHasSideEffects WriteByteArrayOp_Int = True-primOpHasSideEffects WriteByteArrayOp_Word = True-primOpHasSideEffects WriteByteArrayOp_Addr = True-primOpHasSideEffects WriteByteArrayOp_Float = True-primOpHasSideEffects WriteByteArrayOp_Double = True-primOpHasSideEffects WriteByteArrayOp_StablePtr = True-primOpHasSideEffects WriteByteArrayOp_Int8 = True-primOpHasSideEffects WriteByteArrayOp_Word8 = True-primOpHasSideEffects WriteByteArrayOp_Int16 = True-primOpHasSideEffects WriteByteArrayOp_Word16 = True-primOpHasSideEffects WriteByteArrayOp_Int32 = True-primOpHasSideEffects WriteByteArrayOp_Word32 = True-primOpHasSideEffects WriteByteArrayOp_Int64 = True-primOpHasSideEffects WriteByteArrayOp_Word64 = True-primOpHasSideEffects WriteByteArrayOp_Word8AsChar = True-primOpHasSideEffects WriteByteArrayOp_Word8AsWideChar = True-primOpHasSideEffects WriteByteArrayOp_Word8AsInt = True-primOpHasSideEffects WriteByteArrayOp_Word8AsWord = True-primOpHasSideEffects WriteByteArrayOp_Word8AsAddr = True-primOpHasSideEffects WriteByteArrayOp_Word8AsFloat = True-primOpHasSideEffects WriteByteArrayOp_Word8AsDouble = True-primOpHasSideEffects WriteByteArrayOp_Word8AsStablePtr = True-primOpHasSideEffects WriteByteArrayOp_Word8AsInt16 = True-primOpHasSideEffects WriteByteArrayOp_Word8AsWord16 = True-primOpHasSideEffects WriteByteArrayOp_Word8AsInt32 = True-primOpHasSideEffects WriteByteArrayOp_Word8AsWord32 = True-primOpHasSideEffects WriteByteArrayOp_Word8AsInt64 = True-primOpHasSideEffects WriteByteArrayOp_Word8AsWord64 = True-primOpHasSideEffects CopyByteArrayOp = True-primOpHasSideEffects CopyMutableByteArrayOp = True-primOpHasSideEffects CopyMutableByteArrayNonOverlappingOp = True-primOpHasSideEffects CopyByteArrayToAddrOp = True-primOpHasSideEffects CopyMutableByteArrayToAddrOp = True-primOpHasSideEffects CopyAddrToByteArrayOp = True-primOpHasSideEffects CopyAddrToAddrOp = True-primOpHasSideEffects CopyAddrToAddrNonOverlappingOp = True-primOpHasSideEffects SetByteArrayOp = True-primOpHasSideEffects SetAddrRangeOp = True-primOpHasSideEffects AtomicReadByteArrayOp_Int = True-primOpHasSideEffects AtomicWriteByteArrayOp_Int = True-primOpHasSideEffects CasByteArrayOp_Int = True-primOpHasSideEffects CasByteArrayOp_Int8 = True-primOpHasSideEffects CasByteArrayOp_Int16 = True-primOpHasSideEffects CasByteArrayOp_Int32 = True-primOpHasSideEffects CasByteArrayOp_Int64 = True-primOpHasSideEffects FetchAddByteArrayOp_Int = True-primOpHasSideEffects FetchSubByteArrayOp_Int = True-primOpHasSideEffects FetchAndByteArrayOp_Int = True-primOpHasSideEffects FetchNandByteArrayOp_Int = True-primOpHasSideEffects FetchOrByteArrayOp_Int = True-primOpHasSideEffects FetchXorByteArrayOp_Int = True-primOpHasSideEffects ReadOffAddrOp_Char = True-primOpHasSideEffects ReadOffAddrOp_WideChar = True-primOpHasSideEffects ReadOffAddrOp_Int = True-primOpHasSideEffects ReadOffAddrOp_Word = True-primOpHasSideEffects ReadOffAddrOp_Addr = True-primOpHasSideEffects ReadOffAddrOp_Float = True-primOpHasSideEffects ReadOffAddrOp_Double = True-primOpHasSideEffects ReadOffAddrOp_StablePtr = True-primOpHasSideEffects ReadOffAddrOp_Int8 = True-primOpHasSideEffects ReadOffAddrOp_Word8 = True-primOpHasSideEffects ReadOffAddrOp_Int16 = True-primOpHasSideEffects ReadOffAddrOp_Word16 = True-primOpHasSideEffects ReadOffAddrOp_Int32 = True-primOpHasSideEffects ReadOffAddrOp_Word32 = True-primOpHasSideEffects ReadOffAddrOp_Int64 = True-primOpHasSideEffects ReadOffAddrOp_Word64 = True-primOpHasSideEffects WriteOffAddrOp_Char = True-primOpHasSideEffects WriteOffAddrOp_WideChar = True-primOpHasSideEffects WriteOffAddrOp_Int = True-primOpHasSideEffects WriteOffAddrOp_Word = True-primOpHasSideEffects WriteOffAddrOp_Addr = True-primOpHasSideEffects WriteOffAddrOp_Float = True-primOpHasSideEffects WriteOffAddrOp_Double = True-primOpHasSideEffects WriteOffAddrOp_StablePtr = True-primOpHasSideEffects WriteOffAddrOp_Int8 = True-primOpHasSideEffects WriteOffAddrOp_Word8 = True-primOpHasSideEffects WriteOffAddrOp_Int16 = True-primOpHasSideEffects WriteOffAddrOp_Word16 = True-primOpHasSideEffects WriteOffAddrOp_Int32 = True-primOpHasSideEffects WriteOffAddrOp_Word32 = True-primOpHasSideEffects WriteOffAddrOp_Int64 = True-primOpHasSideEffects WriteOffAddrOp_Word64 = True-primOpHasSideEffects InterlockedExchange_Addr = True-primOpHasSideEffects InterlockedExchange_Word = True-primOpHasSideEffects CasAddrOp_Addr = True-primOpHasSideEffects CasAddrOp_Word = True-primOpHasSideEffects CasAddrOp_Word8 = True-primOpHasSideEffects CasAddrOp_Word16 = True-primOpHasSideEffects CasAddrOp_Word32 = True-primOpHasSideEffects CasAddrOp_Word64 = True-primOpHasSideEffects FetchAddAddrOp_Word = True-primOpHasSideEffects FetchSubAddrOp_Word = True-primOpHasSideEffects FetchAndAddrOp_Word = True-primOpHasSideEffects FetchNandAddrOp_Word = True-primOpHasSideEffects FetchOrAddrOp_Word = True-primOpHasSideEffects FetchXorAddrOp_Word = True-primOpHasSideEffects AtomicReadAddrOp_Word = True-primOpHasSideEffects AtomicWriteAddrOp_Word = True-primOpHasSideEffects NewMutVarOp = True-primOpHasSideEffects ReadMutVarOp = True-primOpHasSideEffects WriteMutVarOp = True-primOpHasSideEffects AtomicSwapMutVarOp = True-primOpHasSideEffects AtomicModifyMutVar2Op = True-primOpHasSideEffects AtomicModifyMutVar_Op = True-primOpHasSideEffects CasMutVarOp = True-primOpHasSideEffects CatchOp = True-primOpHasSideEffects RaiseIOOp = True-primOpHasSideEffects MaskAsyncExceptionsOp = True-primOpHasSideEffects MaskUninterruptibleOp = True-primOpHasSideEffects UnmaskAsyncExceptionsOp = True-primOpHasSideEffects MaskStatus = True-primOpHasSideEffects NewPromptTagOp = True-primOpHasSideEffects PromptOp = True-primOpHasSideEffects Control0Op = True-primOpHasSideEffects AtomicallyOp = True-primOpHasSideEffects RetryOp = True-primOpHasSideEffects CatchRetryOp = True-primOpHasSideEffects CatchSTMOp = True-primOpHasSideEffects NewTVarOp = True-primOpHasSideEffects ReadTVarOp = True-primOpHasSideEffects ReadTVarIOOp = True-primOpHasSideEffects WriteTVarOp = True-primOpHasSideEffects NewMVarOp = True-primOpHasSideEffects TakeMVarOp = True-primOpHasSideEffects TryTakeMVarOp = True-primOpHasSideEffects PutMVarOp = True-primOpHasSideEffects TryPutMVarOp = True-primOpHasSideEffects ReadMVarOp = True-primOpHasSideEffects TryReadMVarOp = True-primOpHasSideEffects IsEmptyMVarOp = True-primOpHasSideEffects NewIOPortOp = True-primOpHasSideEffects ReadIOPortOp = True-primOpHasSideEffects WriteIOPortOp = True-primOpHasSideEffects DelayOp = True-primOpHasSideEffects WaitReadOp = True-primOpHasSideEffects WaitWriteOp = True-primOpHasSideEffects ForkOp = True-primOpHasSideEffects ForkOnOp = True-primOpHasSideEffects KillThreadOp = True-primOpHasSideEffects YieldOp = True-primOpHasSideEffects MyThreadIdOp = True-primOpHasSideEffects LabelThreadOp = True-primOpHasSideEffects IsCurrentThreadBoundOp = True-primOpHasSideEffects NoDuplicateOp = True-primOpHasSideEffects ThreadStatusOp = True-primOpHasSideEffects ListThreadsOp = True-primOpHasSideEffects MkWeakOp = True-primOpHasSideEffects MkWeakNoFinalizerOp = True-primOpHasSideEffects AddCFinalizerToWeakOp = True-primOpHasSideEffects DeRefWeakOp = True-primOpHasSideEffects FinalizeWeakOp = True-primOpHasSideEffects TouchOp = True-primOpHasSideEffects MakeStablePtrOp = True-primOpHasSideEffects DeRefStablePtrOp = True-primOpHasSideEffects EqStablePtrOp = True-primOpHasSideEffects MakeStableNameOp = True-primOpHasSideEffects CompactNewOp = True-primOpHasSideEffects CompactResizeOp = True-primOpHasSideEffects CompactAllocateBlockOp = True-primOpHasSideEffects CompactFixupPointersOp = True-primOpHasSideEffects CompactAdd = True-primOpHasSideEffects CompactAddWithSharing = True-primOpHasSideEffects CompactSize = True-primOpHasSideEffects ParOp = True-primOpHasSideEffects SparkOp = True-primOpHasSideEffects GetSparkOp = True-primOpHasSideEffects NumSparks = True-primOpHasSideEffects NewBCOOp = True-primOpHasSideEffects TraceEventOp = True-primOpHasSideEffects TraceEventBinaryOp = True-primOpHasSideEffects TraceMarkerOp = True-primOpHasSideEffects SetThreadAllocationCounter = True-primOpHasSideEffects (VecReadByteArrayOp _ _ _) = True-primOpHasSideEffects (VecWriteByteArrayOp _ _ _) = True-primOpHasSideEffects (VecReadOffAddrOp _ _ _) = True-primOpHasSideEffects (VecWriteOffAddrOp _ _ _) = True-primOpHasSideEffects (VecReadScalarByteArrayOp _ _ _) = True-primOpHasSideEffects (VecWriteScalarByteArrayOp _ _ _) = True-primOpHasSideEffects (VecReadScalarOffAddrOp _ _ _) = True-primOpHasSideEffects (VecWriteScalarOffAddrOp _ _ _) = True-primOpHasSideEffects PrefetchByteArrayOp3 = True-primOpHasSideEffects PrefetchMutableByteArrayOp3 = True-primOpHasSideEffects PrefetchAddrOp3 = True-primOpHasSideEffects PrefetchValueOp3 = True-primOpHasSideEffects PrefetchByteArrayOp2 = True-primOpHasSideEffects PrefetchMutableByteArrayOp2 = True-primOpHasSideEffects PrefetchAddrOp2 = True-primOpHasSideEffects PrefetchValueOp2 = True-primOpHasSideEffects PrefetchByteArrayOp1 = True-primOpHasSideEffects PrefetchMutableByteArrayOp1 = True-primOpHasSideEffects PrefetchAddrOp1 = True-primOpHasSideEffects PrefetchValueOp1 = True-primOpHasSideEffects PrefetchByteArrayOp0 = True-primOpHasSideEffects PrefetchMutableByteArrayOp0 = True-primOpHasSideEffects PrefetchAddrOp0 = True-primOpHasSideEffects PrefetchValueOp0 = True-primOpHasSideEffects _ = False
+ ghc-lib/stage0/compiler/build/primop-is-cheap.hs-incl view
@@ -0,0 +1,3 @@+primOpIsCheap DataToTagSmallOp = True+primOpIsCheap DataToTagLargeOp = True+primOpIsCheap _thisOp =  primOpOkForSpeculation _thisOp 
+ ghc-lib/stage0/compiler/build/primop-is-work-free.hs-incl view
@@ -0,0 +1,8 @@+primOpIsWorkFree RaiseOp = True+primOpIsWorkFree RaiseUnderflowOp = True+primOpIsWorkFree RaiseOverflowOp = True+primOpIsWorkFree RaiseDivZeroOp = True+primOpIsWorkFree RaiseIOOp = True+primOpIsWorkFree TouchOp = False+primOpIsWorkFree SeqOp = True+primOpIsWorkFree _thisOp =  primOpCodeSize _thisOp == 0 
ghc-lib/stage0/compiler/build/primop-list.hs-incl view
@@ -291,6 +291,8 @@    , DoublePowerOp    , DoubleDecode_2IntOp    , DoubleDecode_Int64Op+   , CastDoubleToWord64Op+   , CastWord64ToDoubleOp    , FloatGtOp    , FloatGeOp    , FloatEqOp@@ -324,6 +326,8 @@    , FloatPowerOp    , FloatToDoubleOp    , FloatDecode_IntOp+   , CastFloatToWord32Op+   , CastWord32ToFloatOp    , FloatFMAdd    , FloatFMSub    , FloatFNMAdd@@ -374,6 +378,7 @@    , ShrinkMutableByteArrayOp_Char    , ResizeMutableByteArrayOp_Char    , UnsafeFreezeByteArrayOp+   , UnsafeThawByteArrayOp    , SizeofByteArrayOp    , SizeofMutableByteArrayOp    , GetSizeofMutableByteArrayOp@@ -518,6 +523,20 @@    , IndexOffAddrOp_Word32    , IndexOffAddrOp_Int64    , IndexOffAddrOp_Word64+   , IndexOffAddrOp_Word8AsChar+   , IndexOffAddrOp_Word8AsWideChar+   , IndexOffAddrOp_Word8AsInt+   , IndexOffAddrOp_Word8AsWord+   , IndexOffAddrOp_Word8AsAddr+   , IndexOffAddrOp_Word8AsFloat+   , IndexOffAddrOp_Word8AsDouble+   , IndexOffAddrOp_Word8AsStablePtr+   , IndexOffAddrOp_Word8AsInt16+   , IndexOffAddrOp_Word8AsWord16+   , IndexOffAddrOp_Word8AsInt32+   , IndexOffAddrOp_Word8AsWord32+   , IndexOffAddrOp_Word8AsInt64+   , IndexOffAddrOp_Word8AsWord64    , ReadOffAddrOp_Char    , ReadOffAddrOp_WideChar    , ReadOffAddrOp_Int@@ -534,6 +553,20 @@    , ReadOffAddrOp_Word32    , ReadOffAddrOp_Int64    , ReadOffAddrOp_Word64+   , ReadOffAddrOp_Word8AsChar+   , ReadOffAddrOp_Word8AsWideChar+   , ReadOffAddrOp_Word8AsInt+   , ReadOffAddrOp_Word8AsWord+   , ReadOffAddrOp_Word8AsAddr+   , ReadOffAddrOp_Word8AsFloat+   , ReadOffAddrOp_Word8AsDouble+   , ReadOffAddrOp_Word8AsStablePtr+   , ReadOffAddrOp_Word8AsInt16+   , ReadOffAddrOp_Word8AsWord16+   , ReadOffAddrOp_Word8AsInt32+   , ReadOffAddrOp_Word8AsWord32+   , ReadOffAddrOp_Word8AsInt64+   , ReadOffAddrOp_Word8AsWord64    , WriteOffAddrOp_Char    , WriteOffAddrOp_WideChar    , WriteOffAddrOp_Int@@ -550,6 +583,20 @@    , WriteOffAddrOp_Word32    , WriteOffAddrOp_Int64    , WriteOffAddrOp_Word64+   , WriteOffAddrOp_Word8AsChar+   , WriteOffAddrOp_Word8AsWideChar+   , WriteOffAddrOp_Word8AsInt+   , WriteOffAddrOp_Word8AsWord+   , WriteOffAddrOp_Word8AsAddr+   , WriteOffAddrOp_Word8AsFloat+   , WriteOffAddrOp_Word8AsDouble+   , WriteOffAddrOp_Word8AsStablePtr+   , WriteOffAddrOp_Word8AsInt16+   , WriteOffAddrOp_Word8AsWord16+   , WriteOffAddrOp_Word8AsInt32+   , WriteOffAddrOp_Word8AsWord32+   , WriteOffAddrOp_Word8AsInt64+   , WriteOffAddrOp_Word8AsWord64    , InterlockedExchange_Addr    , InterlockedExchange_Word    , CasAddrOp_Addr@@ -648,7 +695,8 @@    , GetSparkOp    , NumSparks    , KeepAliveOp-   , DataToTagOp+   , DataToTagSmallOp+   , DataToTagLargeOp    , TagToEnumOp    , AddrToAnyOp    , AnyToAddrOp
ghc-lib/stage0/compiler/build/primop-out-of-line.hs-incl view
@@ -109,4 +109,4 @@ primOpOutOfLine TraceEventBinaryOp = True primOpOutOfLine TraceMarkerOp = True primOpOutOfLine SetThreadAllocationCounter = True-primOpOutOfLine _ = False+primOpOutOfLine _thisOp = False
ghc-lib/stage0/compiler/build/primop-primop-info.hs-incl view
@@ -291,6 +291,8 @@ primOpInfo DoublePowerOp = mkGenPrimOp (fsLit "**##")  [] [doublePrimTy, doublePrimTy] (doublePrimTy) primOpInfo DoubleDecode_2IntOp = mkGenPrimOp (fsLit "decodeDouble_2Int#")  [] [doublePrimTy] ((mkTupleTy Unboxed [intPrimTy, wordPrimTy, wordPrimTy, intPrimTy])) primOpInfo DoubleDecode_Int64Op = mkGenPrimOp (fsLit "decodeDouble_Int64#")  [] [doublePrimTy] ((mkTupleTy Unboxed [int64PrimTy, intPrimTy]))+primOpInfo CastDoubleToWord64Op = mkGenPrimOp (fsLit "castDoubleToWord64#")  [] [doublePrimTy] (word64PrimTy)+primOpInfo CastWord64ToDoubleOp = mkGenPrimOp (fsLit "castWord64ToDouble#")  [] [word64PrimTy] (doublePrimTy) primOpInfo FloatGtOp = mkCompare (fsLit "gtFloat#") floatPrimTy primOpInfo FloatGeOp = mkCompare (fsLit "geFloat#") floatPrimTy primOpInfo FloatEqOp = mkCompare (fsLit "eqFloat#") floatPrimTy@@ -324,6 +326,8 @@ primOpInfo FloatPowerOp = mkGenPrimOp (fsLit "powerFloat#")  [] [floatPrimTy, floatPrimTy] (floatPrimTy) primOpInfo FloatToDoubleOp = mkGenPrimOp (fsLit "float2Double#")  [] [floatPrimTy] (doublePrimTy) primOpInfo FloatDecode_IntOp = mkGenPrimOp (fsLit "decodeFloat_Int#")  [] [floatPrimTy] ((mkTupleTy Unboxed [intPrimTy, intPrimTy]))+primOpInfo CastFloatToWord32Op = mkGenPrimOp (fsLit "castFloatToWord32#")  [] [floatPrimTy] (word32PrimTy)+primOpInfo CastWord32ToFloatOp = mkGenPrimOp (fsLit "castWord32ToFloat#")  [] [word32PrimTy] (floatPrimTy) primOpInfo FloatFMAdd = mkGenPrimOp (fsLit "fmaddFloat#")  [] [floatPrimTy, floatPrimTy, floatPrimTy] (floatPrimTy) primOpInfo FloatFMSub = mkGenPrimOp (fsLit "fmsubFloat#")  [] [floatPrimTy, floatPrimTy, floatPrimTy] (floatPrimTy) primOpInfo FloatFNMAdd = mkGenPrimOp (fsLit "fnmaddFloat#")  [] [floatPrimTy, floatPrimTy, floatPrimTy] (floatPrimTy)@@ -374,6 +378,7 @@ primOpInfo ShrinkMutableByteArrayOp_Char = mkGenPrimOp (fsLit "shrinkMutableByteArray#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo ResizeMutableByteArrayOp_Char = mkGenPrimOp (fsLit "resizeMutableByteArray#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableByteArrayPrimTy deltaTy])) primOpInfo UnsafeFreezeByteArrayOp = mkGenPrimOp (fsLit "unsafeFreezeByteArray#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, byteArrayPrimTy]))+primOpInfo UnsafeThawByteArrayOp = mkGenPrimOp (fsLit "unsafeThawByteArray#")  [deltaTyVarSpec] [byteArrayPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkMutableByteArrayPrimTy deltaTy])) primOpInfo SizeofByteArrayOp = mkGenPrimOp (fsLit "sizeofByteArray#")  [] [byteArrayPrimTy] (intPrimTy) primOpInfo SizeofMutableByteArrayOp = mkGenPrimOp (fsLit "sizeofMutableByteArray#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy] (intPrimTy) primOpInfo GetSizeofMutableByteArrayOp = mkGenPrimOp (fsLit "getSizeofMutableByteArray#")  [deltaTyVarSpec] [mkMutableByteArrayPrimTy deltaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))@@ -518,6 +523,20 @@ primOpInfo IndexOffAddrOp_Word32 = mkGenPrimOp (fsLit "indexWord32OffAddr#")  [] [addrPrimTy, intPrimTy] (word32PrimTy) primOpInfo IndexOffAddrOp_Int64 = mkGenPrimOp (fsLit "indexInt64OffAddr#")  [] [addrPrimTy, intPrimTy] (int64PrimTy) primOpInfo IndexOffAddrOp_Word64 = mkGenPrimOp (fsLit "indexWord64OffAddr#")  [] [addrPrimTy, intPrimTy] (word64PrimTy)+primOpInfo IndexOffAddrOp_Word8AsChar = mkGenPrimOp (fsLit "indexWord8OffAddrAsChar#")  [] [addrPrimTy, intPrimTy] (charPrimTy)+primOpInfo IndexOffAddrOp_Word8AsWideChar = mkGenPrimOp (fsLit "indexWord8OffAddrAsWideChar#")  [] [addrPrimTy, intPrimTy] (charPrimTy)+primOpInfo IndexOffAddrOp_Word8AsInt = mkGenPrimOp (fsLit "indexWord8OffAddrAsInt#")  [] [addrPrimTy, intPrimTy] (intPrimTy)+primOpInfo IndexOffAddrOp_Word8AsWord = mkGenPrimOp (fsLit "indexWord8OffAddrAsWord#")  [] [addrPrimTy, intPrimTy] (wordPrimTy)+primOpInfo IndexOffAddrOp_Word8AsAddr = mkGenPrimOp (fsLit "indexWord8OffAddrAsAddr#")  [] [addrPrimTy, intPrimTy] (addrPrimTy)+primOpInfo IndexOffAddrOp_Word8AsFloat = mkGenPrimOp (fsLit "indexWord8OffAddrAsFloat#")  [] [addrPrimTy, intPrimTy] (floatPrimTy)+primOpInfo IndexOffAddrOp_Word8AsDouble = mkGenPrimOp (fsLit "indexWord8OffAddrAsDouble#")  [] [addrPrimTy, intPrimTy] (doublePrimTy)+primOpInfo IndexOffAddrOp_Word8AsStablePtr = mkGenPrimOp (fsLit "indexWord8OffAddrAsStablePtr#")  [alphaTyVarSpec] [addrPrimTy, intPrimTy] (mkStablePtrPrimTy alphaTy)+primOpInfo IndexOffAddrOp_Word8AsInt16 = mkGenPrimOp (fsLit "indexWord8OffAddrAsInt16#")  [] [addrPrimTy, intPrimTy] (int16PrimTy)+primOpInfo IndexOffAddrOp_Word8AsWord16 = mkGenPrimOp (fsLit "indexWord8OffAddrAsWord16#")  [] [addrPrimTy, intPrimTy] (word16PrimTy)+primOpInfo IndexOffAddrOp_Word8AsInt32 = mkGenPrimOp (fsLit "indexWord8OffAddrAsInt32#")  [] [addrPrimTy, intPrimTy] (int32PrimTy)+primOpInfo IndexOffAddrOp_Word8AsWord32 = mkGenPrimOp (fsLit "indexWord8OffAddrAsWord32#")  [] [addrPrimTy, intPrimTy] (word32PrimTy)+primOpInfo IndexOffAddrOp_Word8AsInt64 = mkGenPrimOp (fsLit "indexWord8OffAddrAsInt64#")  [] [addrPrimTy, intPrimTy] (int64PrimTy)+primOpInfo IndexOffAddrOp_Word8AsWord64 = mkGenPrimOp (fsLit "indexWord8OffAddrAsWord64#")  [] [addrPrimTy, intPrimTy] (word64PrimTy) primOpInfo ReadOffAddrOp_Char = mkGenPrimOp (fsLit "readCharOffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy])) primOpInfo ReadOffAddrOp_WideChar = mkGenPrimOp (fsLit "readWideCharOffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy])) primOpInfo ReadOffAddrOp_Int = mkGenPrimOp (fsLit "readIntOffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))@@ -534,6 +553,20 @@ primOpInfo ReadOffAddrOp_Word32 = mkGenPrimOp (fsLit "readWord32OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32PrimTy])) primOpInfo ReadOffAddrOp_Int64 = mkGenPrimOp (fsLit "readInt64OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64PrimTy])) primOpInfo ReadOffAddrOp_Word64 = mkGenPrimOp (fsLit "readWord64OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64PrimTy]))+primOpInfo ReadOffAddrOp_Word8AsChar = mkGenPrimOp (fsLit "readWord8OffAddrAsChar#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy]))+primOpInfo ReadOffAddrOp_Word8AsWideChar = mkGenPrimOp (fsLit "readWord8OffAddrAsWideChar#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, charPrimTy]))+primOpInfo ReadOffAddrOp_Word8AsInt = mkGenPrimOp (fsLit "readWord8OffAddrAsInt#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy]))+primOpInfo ReadOffAddrOp_Word8AsWord = mkGenPrimOp (fsLit "readWord8OffAddrAsWord#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy]))+primOpInfo ReadOffAddrOp_Word8AsAddr = mkGenPrimOp (fsLit "readWord8OffAddrAsAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy]))+primOpInfo ReadOffAddrOp_Word8AsFloat = mkGenPrimOp (fsLit "readWord8OffAddrAsFloat#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, floatPrimTy]))+primOpInfo ReadOffAddrOp_Word8AsDouble = mkGenPrimOp (fsLit "readWord8OffAddrAsDouble#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, doublePrimTy]))+primOpInfo ReadOffAddrOp_Word8AsStablePtr = mkGenPrimOp (fsLit "readWord8OffAddrAsStablePtr#")  [deltaTyVarSpec, alphaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, mkStablePtrPrimTy alphaTy]))+primOpInfo ReadOffAddrOp_Word8AsInt16 = mkGenPrimOp (fsLit "readWord8OffAddrAsInt16#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int16PrimTy]))+primOpInfo ReadOffAddrOp_Word8AsWord16 = mkGenPrimOp (fsLit "readWord8OffAddrAsWord16#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word16PrimTy]))+primOpInfo ReadOffAddrOp_Word8AsInt32 = mkGenPrimOp (fsLit "readWord8OffAddrAsInt32#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int32PrimTy]))+primOpInfo ReadOffAddrOp_Word8AsWord32 = mkGenPrimOp (fsLit "readWord8OffAddrAsWord32#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word32PrimTy]))+primOpInfo ReadOffAddrOp_Word8AsInt64 = mkGenPrimOp (fsLit "readWord8OffAddrAsInt64#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, int64PrimTy]))+primOpInfo ReadOffAddrOp_Word8AsWord64 = mkGenPrimOp (fsLit "readWord8OffAddrAsWord64#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, word64PrimTy])) primOpInfo WriteOffAddrOp_Char = mkGenPrimOp (fsLit "writeCharOffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteOffAddrOp_WideChar = mkGenPrimOp (fsLit "writeWideCharOffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteOffAddrOp_Int = mkGenPrimOp (fsLit "writeIntOffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)@@ -550,6 +583,20 @@ primOpInfo WriteOffAddrOp_Word32 = mkGenPrimOp (fsLit "writeWord32OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, word32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteOffAddrOp_Int64 = mkGenPrimOp (fsLit "writeInt64OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, int64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo WriteOffAddrOp_Word64 = mkGenPrimOp (fsLit "writeWord64OffAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, word64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteOffAddrOp_Word8AsChar = mkGenPrimOp (fsLit "writeWord8OffAddrAsChar#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteOffAddrOp_Word8AsWideChar = mkGenPrimOp (fsLit "writeWord8OffAddrAsWideChar#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, charPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteOffAddrOp_Word8AsInt = mkGenPrimOp (fsLit "writeWord8OffAddrAsInt#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteOffAddrOp_Word8AsWord = mkGenPrimOp (fsLit "writeWord8OffAddrAsWord#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, wordPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteOffAddrOp_Word8AsAddr = mkGenPrimOp (fsLit "writeWord8OffAddrAsAddr#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, addrPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteOffAddrOp_Word8AsFloat = mkGenPrimOp (fsLit "writeWord8OffAddrAsFloat#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, floatPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteOffAddrOp_Word8AsDouble = mkGenPrimOp (fsLit "writeWord8OffAddrAsDouble#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, doublePrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteOffAddrOp_Word8AsStablePtr = mkGenPrimOp (fsLit "writeWord8OffAddrAsStablePtr#")  [alphaTyVarSpec, deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStablePtrPrimTy alphaTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteOffAddrOp_Word8AsInt16 = mkGenPrimOp (fsLit "writeWord8OffAddrAsInt16#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, int16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteOffAddrOp_Word8AsWord16 = mkGenPrimOp (fsLit "writeWord8OffAddrAsWord16#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, word16PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteOffAddrOp_Word8AsInt32 = mkGenPrimOp (fsLit "writeWord8OffAddrAsInt32#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, int32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteOffAddrOp_Word8AsWord32 = mkGenPrimOp (fsLit "writeWord8OffAddrAsWord32#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, word32PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteOffAddrOp_Word8AsInt64 = mkGenPrimOp (fsLit "writeWord8OffAddrAsInt64#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, int64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)+primOpInfo WriteOffAddrOp_Word8AsWord64 = mkGenPrimOp (fsLit "writeWord8OffAddrAsWord64#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, word64PrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo InterlockedExchange_Addr = mkGenPrimOp (fsLit "atomicExchangeAddrAddr#")  [deltaTyVarSpec] [addrPrimTy, addrPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy])) primOpInfo InterlockedExchange_Word = mkGenPrimOp (fsLit "atomicExchangeWordAddr#")  [deltaTyVarSpec] [addrPrimTy, wordPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, wordPrimTy])) primOpInfo CasAddrOp_Addr = mkGenPrimOp (fsLit "atomicCasAddrAddr#")  [deltaTyVarSpec] [addrPrimTy, addrPrimTy, addrPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy]))@@ -648,7 +695,8 @@ primOpInfo GetSparkOp = mkGenPrimOp (fsLit "getSpark#")  [deltaTyVarSpec, alphaTyVarSpec] [mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy, alphaTy])) primOpInfo NumSparks = mkGenPrimOp (fsLit "numSparks#")  [deltaTyVarSpec] [mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) primOpInfo KeepAliveOp = mkGenPrimOp (fsLit "keepAlive#")  [levity1TyVarInf, runtimeRep2TyVarInf, levPolyAlphaTyVarSpec, deltaTyVarSpec, openBetaTyVarSpec] [levPolyAlphaTy, mkStatePrimTy deltaTy, (mkVisFunTyMany (mkStatePrimTy deltaTy) (openBetaTy))] (openBetaTy)-primOpInfo DataToTagOp = mkGenPrimOp (fsLit "dataToTag#")  [alphaTyVarSpec] [alphaTy] (intPrimTy)+primOpInfo DataToTagSmallOp = mkGenPrimOp (fsLit "dataToTagSmall#")  [levity1TyVarInf, levPolyAlphaTyVarSpec] [levPolyAlphaTy] (intPrimTy)+primOpInfo DataToTagLargeOp = mkGenPrimOp (fsLit "dataToTagLarge#")  [levity1TyVarInf, levPolyAlphaTyVarSpec] [levPolyAlphaTy] (intPrimTy) primOpInfo TagToEnumOp = mkGenPrimOp (fsLit "tagToEnum#")  [alphaTyVarSpec] [intPrimTy] (alphaTy) primOpInfo AddrToAnyOp = mkGenPrimOp (fsLit "addrToAny#")  [levity1TyVarInf, levPolyAlphaTyVarSpec] [addrPrimTy] ((mkTupleTy Unboxed [levPolyAlphaTy])) primOpInfo AnyToAddrOp = mkGenPrimOp (fsLit "anyToAddr#")  [alphaTyVarSpec] [alphaTy, mkStatePrimTy realWorldTy] ((mkTupleTy Unboxed [mkStatePrimTy realWorldTy, addrPrimTy]))@@ -660,7 +708,7 @@ primOpInfo GetCCSOfOp = mkGenPrimOp (fsLit "getCCSOf#")  [alphaTyVarSpec, deltaTyVarSpec] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy])) primOpInfo GetCurrentCCSOp = mkGenPrimOp (fsLit "getCurrentCCS#")  [alphaTyVarSpec, deltaTyVarSpec] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy])) primOpInfo ClearCCSOp = mkGenPrimOp (fsLit "clearCCS#")  [deltaTyVarSpec, alphaTyVarSpec] [(mkVisFunTyMany (mkStatePrimTy deltaTy) ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))), mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, alphaTy]))-primOpInfo WhereFromOp = mkGenPrimOp (fsLit "whereFrom#")  [alphaTyVarSpec, deltaTyVarSpec] [alphaTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, addrPrimTy]))+primOpInfo WhereFromOp = mkGenPrimOp (fsLit "whereFrom#")  [alphaTyVarSpec, deltaTyVarSpec] [alphaTy, addrPrimTy, mkStatePrimTy deltaTy] ((mkTupleTy Unboxed [mkStatePrimTy deltaTy, intPrimTy])) primOpInfo TraceEventOp = mkGenPrimOp (fsLit "traceEvent#")  [deltaTyVarSpec] [addrPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo TraceEventBinaryOp = mkGenPrimOp (fsLit "traceBinaryEvent#")  [deltaTyVarSpec] [addrPrimTy, intPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy) primOpInfo TraceMarkerOp = mkGenPrimOp (fsLit "traceMarker#")  [deltaTyVarSpec] [addrPrimTy, mkStatePrimTy deltaTy] (mkStatePrimTy deltaTy)
ghc-lib/stage0/compiler/build/primop-strictness.hs-incl view
@@ -11,7 +11,7 @@ primOpStrictness MaskAsyncExceptionsOp =  \ _arity -> mkClosedDmdSig [strictOnceApply1Dmd,topDmd] topDiv  primOpStrictness MaskUninterruptibleOp =  \ _arity -> mkClosedDmdSig [strictOnceApply1Dmd,topDmd] topDiv  primOpStrictness UnmaskAsyncExceptionsOp =  \ _arity -> mkClosedDmdSig [strictOnceApply1Dmd,topDmd] topDiv -primOpStrictness PromptOp =  \ _arity -> mkClosedDmdSig [topDmd, lazyApply1Dmd, topDmd] topDiv +primOpStrictness PromptOp =  \ _arity -> mkClosedDmdSig [topDmd, strictOnceApply1Dmd, topDmd] topDiv  primOpStrictness Control0Op =  \ _arity -> mkClosedDmdSig [topDmd, lazyApply2Dmd, topDmd] topDiv  primOpStrictness AtomicallyOp =  \ _arity -> mkClosedDmdSig [strictManyApply1Dmd,topDmd] topDiv  primOpStrictness RetryOp =  \ _arity -> mkClosedDmdSig [topDmd] botDiv @@ -27,5 +27,6 @@                                               , lazyApply1Dmd                                               , topDmd ] topDiv  primOpStrictness KeepAliveOp =  \ _arity -> mkClosedDmdSig [topDmd, topDmd, strictOnceApply1Dmd] topDiv -primOpStrictness DataToTagOp =  \ _arity -> mkClosedDmdSig [evalDmd] topDiv -primOpStrictness _ =  \ arity -> mkClosedDmdSig (replicate arity topDmd) topDiv +primOpStrictness DataToTagSmallOp =  \ _arity -> mkClosedDmdSig [evalDmd] topDiv +primOpStrictness DataToTagLargeOp =  \ _arity -> mkClosedDmdSig [evalDmd] topDiv +primOpStrictness _thisOp =  \ arity -> mkClosedDmdSig (replicate arity topDmd) topDiv 
ghc-lib/stage0/compiler/build/primop-tag.hs-incl view
@@ -1,1328 +1,1376 @@ maxPrimOpTag :: Int-maxPrimOpTag = 1324-primOpTag :: PrimOp -> Int-primOpTag CharGtOp = 0-primOpTag CharGeOp = 1-primOpTag CharEqOp = 2-primOpTag CharNeOp = 3-primOpTag CharLtOp = 4-primOpTag CharLeOp = 5-primOpTag OrdOp = 6-primOpTag Int8ToIntOp = 7-primOpTag IntToInt8Op = 8-primOpTag Int8NegOp = 9-primOpTag Int8AddOp = 10-primOpTag Int8SubOp = 11-primOpTag Int8MulOp = 12-primOpTag Int8QuotOp = 13-primOpTag Int8RemOp = 14-primOpTag Int8QuotRemOp = 15-primOpTag Int8SllOp = 16-primOpTag Int8SraOp = 17-primOpTag Int8SrlOp = 18-primOpTag Int8ToWord8Op = 19-primOpTag Int8EqOp = 20-primOpTag Int8GeOp = 21-primOpTag Int8GtOp = 22-primOpTag Int8LeOp = 23-primOpTag Int8LtOp = 24-primOpTag Int8NeOp = 25-primOpTag Word8ToWordOp = 26-primOpTag WordToWord8Op = 27-primOpTag Word8AddOp = 28-primOpTag Word8SubOp = 29-primOpTag Word8MulOp = 30-primOpTag Word8QuotOp = 31-primOpTag Word8RemOp = 32-primOpTag Word8QuotRemOp = 33-primOpTag Word8AndOp = 34-primOpTag Word8OrOp = 35-primOpTag Word8XorOp = 36-primOpTag Word8NotOp = 37-primOpTag Word8SllOp = 38-primOpTag Word8SrlOp = 39-primOpTag Word8ToInt8Op = 40-primOpTag Word8EqOp = 41-primOpTag Word8GeOp = 42-primOpTag Word8GtOp = 43-primOpTag Word8LeOp = 44-primOpTag Word8LtOp = 45-primOpTag Word8NeOp = 46-primOpTag Int16ToIntOp = 47-primOpTag IntToInt16Op = 48-primOpTag Int16NegOp = 49-primOpTag Int16AddOp = 50-primOpTag Int16SubOp = 51-primOpTag Int16MulOp = 52-primOpTag Int16QuotOp = 53-primOpTag Int16RemOp = 54-primOpTag Int16QuotRemOp = 55-primOpTag Int16SllOp = 56-primOpTag Int16SraOp = 57-primOpTag Int16SrlOp = 58-primOpTag Int16ToWord16Op = 59-primOpTag Int16EqOp = 60-primOpTag Int16GeOp = 61-primOpTag Int16GtOp = 62-primOpTag Int16LeOp = 63-primOpTag Int16LtOp = 64-primOpTag Int16NeOp = 65-primOpTag Word16ToWordOp = 66-primOpTag WordToWord16Op = 67-primOpTag Word16AddOp = 68-primOpTag Word16SubOp = 69-primOpTag Word16MulOp = 70-primOpTag Word16QuotOp = 71-primOpTag Word16RemOp = 72-primOpTag Word16QuotRemOp = 73-primOpTag Word16AndOp = 74-primOpTag Word16OrOp = 75-primOpTag Word16XorOp = 76-primOpTag Word16NotOp = 77-primOpTag Word16SllOp = 78-primOpTag Word16SrlOp = 79-primOpTag Word16ToInt16Op = 80-primOpTag Word16EqOp = 81-primOpTag Word16GeOp = 82-primOpTag Word16GtOp = 83-primOpTag Word16LeOp = 84-primOpTag Word16LtOp = 85-primOpTag Word16NeOp = 86-primOpTag Int32ToIntOp = 87-primOpTag IntToInt32Op = 88-primOpTag Int32NegOp = 89-primOpTag Int32AddOp = 90-primOpTag Int32SubOp = 91-primOpTag Int32MulOp = 92-primOpTag Int32QuotOp = 93-primOpTag Int32RemOp = 94-primOpTag Int32QuotRemOp = 95-primOpTag Int32SllOp = 96-primOpTag Int32SraOp = 97-primOpTag Int32SrlOp = 98-primOpTag Int32ToWord32Op = 99-primOpTag Int32EqOp = 100-primOpTag Int32GeOp = 101-primOpTag Int32GtOp = 102-primOpTag Int32LeOp = 103-primOpTag Int32LtOp = 104-primOpTag Int32NeOp = 105-primOpTag Word32ToWordOp = 106-primOpTag WordToWord32Op = 107-primOpTag Word32AddOp = 108-primOpTag Word32SubOp = 109-primOpTag Word32MulOp = 110-primOpTag Word32QuotOp = 111-primOpTag Word32RemOp = 112-primOpTag Word32QuotRemOp = 113-primOpTag Word32AndOp = 114-primOpTag Word32OrOp = 115-primOpTag Word32XorOp = 116-primOpTag Word32NotOp = 117-primOpTag Word32SllOp = 118-primOpTag Word32SrlOp = 119-primOpTag Word32ToInt32Op = 120-primOpTag Word32EqOp = 121-primOpTag Word32GeOp = 122-primOpTag Word32GtOp = 123-primOpTag Word32LeOp = 124-primOpTag Word32LtOp = 125-primOpTag Word32NeOp = 126-primOpTag Int64ToIntOp = 127-primOpTag IntToInt64Op = 128-primOpTag Int64NegOp = 129-primOpTag Int64AddOp = 130-primOpTag Int64SubOp = 131-primOpTag Int64MulOp = 132-primOpTag Int64QuotOp = 133-primOpTag Int64RemOp = 134-primOpTag Int64SllOp = 135-primOpTag Int64SraOp = 136-primOpTag Int64SrlOp = 137-primOpTag Int64ToWord64Op = 138-primOpTag Int64EqOp = 139-primOpTag Int64GeOp = 140-primOpTag Int64GtOp = 141-primOpTag Int64LeOp = 142-primOpTag Int64LtOp = 143-primOpTag Int64NeOp = 144-primOpTag Word64ToWordOp = 145-primOpTag WordToWord64Op = 146-primOpTag Word64AddOp = 147-primOpTag Word64SubOp = 148-primOpTag Word64MulOp = 149-primOpTag Word64QuotOp = 150-primOpTag Word64RemOp = 151-primOpTag Word64AndOp = 152-primOpTag Word64OrOp = 153-primOpTag Word64XorOp = 154-primOpTag Word64NotOp = 155-primOpTag Word64SllOp = 156-primOpTag Word64SrlOp = 157-primOpTag Word64ToInt64Op = 158-primOpTag Word64EqOp = 159-primOpTag Word64GeOp = 160-primOpTag Word64GtOp = 161-primOpTag Word64LeOp = 162-primOpTag Word64LtOp = 163-primOpTag Word64NeOp = 164-primOpTag IntAddOp = 165-primOpTag IntSubOp = 166-primOpTag IntMulOp = 167-primOpTag IntMul2Op = 168-primOpTag IntMulMayOfloOp = 169-primOpTag IntQuotOp = 170-primOpTag IntRemOp = 171-primOpTag IntQuotRemOp = 172-primOpTag IntAndOp = 173-primOpTag IntOrOp = 174-primOpTag IntXorOp = 175-primOpTag IntNotOp = 176-primOpTag IntNegOp = 177-primOpTag IntAddCOp = 178-primOpTag IntSubCOp = 179-primOpTag IntGtOp = 180-primOpTag IntGeOp = 181-primOpTag IntEqOp = 182-primOpTag IntNeOp = 183-primOpTag IntLtOp = 184-primOpTag IntLeOp = 185-primOpTag ChrOp = 186-primOpTag IntToWordOp = 187-primOpTag IntToFloatOp = 188-primOpTag IntToDoubleOp = 189-primOpTag WordToFloatOp = 190-primOpTag WordToDoubleOp = 191-primOpTag IntSllOp = 192-primOpTag IntSraOp = 193-primOpTag IntSrlOp = 194-primOpTag WordAddOp = 195-primOpTag WordAddCOp = 196-primOpTag WordSubCOp = 197-primOpTag WordAdd2Op = 198-primOpTag WordSubOp = 199-primOpTag WordMulOp = 200-primOpTag WordMul2Op = 201-primOpTag WordQuotOp = 202-primOpTag WordRemOp = 203-primOpTag WordQuotRemOp = 204-primOpTag WordQuotRem2Op = 205-primOpTag WordAndOp = 206-primOpTag WordOrOp = 207-primOpTag WordXorOp = 208-primOpTag WordNotOp = 209-primOpTag WordSllOp = 210-primOpTag WordSrlOp = 211-primOpTag WordToIntOp = 212-primOpTag WordGtOp = 213-primOpTag WordGeOp = 214-primOpTag WordEqOp = 215-primOpTag WordNeOp = 216-primOpTag WordLtOp = 217-primOpTag WordLeOp = 218-primOpTag PopCnt8Op = 219-primOpTag PopCnt16Op = 220-primOpTag PopCnt32Op = 221-primOpTag PopCnt64Op = 222-primOpTag PopCntOp = 223-primOpTag Pdep8Op = 224-primOpTag Pdep16Op = 225-primOpTag Pdep32Op = 226-primOpTag Pdep64Op = 227-primOpTag PdepOp = 228-primOpTag Pext8Op = 229-primOpTag Pext16Op = 230-primOpTag Pext32Op = 231-primOpTag Pext64Op = 232-primOpTag PextOp = 233-primOpTag Clz8Op = 234-primOpTag Clz16Op = 235-primOpTag Clz32Op = 236-primOpTag Clz64Op = 237-primOpTag ClzOp = 238-primOpTag Ctz8Op = 239-primOpTag Ctz16Op = 240-primOpTag Ctz32Op = 241-primOpTag Ctz64Op = 242-primOpTag CtzOp = 243-primOpTag BSwap16Op = 244-primOpTag BSwap32Op = 245-primOpTag BSwap64Op = 246-primOpTag BSwapOp = 247-primOpTag BRev8Op = 248-primOpTag BRev16Op = 249-primOpTag BRev32Op = 250-primOpTag BRev64Op = 251-primOpTag BRevOp = 252-primOpTag Narrow8IntOp = 253-primOpTag Narrow16IntOp = 254-primOpTag Narrow32IntOp = 255-primOpTag Narrow8WordOp = 256-primOpTag Narrow16WordOp = 257-primOpTag Narrow32WordOp = 258-primOpTag DoubleGtOp = 259-primOpTag DoubleGeOp = 260-primOpTag DoubleEqOp = 261-primOpTag DoubleNeOp = 262-primOpTag DoubleLtOp = 263-primOpTag DoubleLeOp = 264-primOpTag DoubleAddOp = 265-primOpTag DoubleSubOp = 266-primOpTag DoubleMulOp = 267-primOpTag DoubleDivOp = 268-primOpTag DoubleNegOp = 269-primOpTag DoubleFabsOp = 270-primOpTag DoubleToIntOp = 271-primOpTag DoubleToFloatOp = 272-primOpTag DoubleExpOp = 273-primOpTag DoubleExpM1Op = 274-primOpTag DoubleLogOp = 275-primOpTag DoubleLog1POp = 276-primOpTag DoubleSqrtOp = 277-primOpTag DoubleSinOp = 278-primOpTag DoubleCosOp = 279-primOpTag DoubleTanOp = 280-primOpTag DoubleAsinOp = 281-primOpTag DoubleAcosOp = 282-primOpTag DoubleAtanOp = 283-primOpTag DoubleSinhOp = 284-primOpTag DoubleCoshOp = 285-primOpTag DoubleTanhOp = 286-primOpTag DoubleAsinhOp = 287-primOpTag DoubleAcoshOp = 288-primOpTag DoubleAtanhOp = 289-primOpTag DoublePowerOp = 290-primOpTag DoubleDecode_2IntOp = 291-primOpTag DoubleDecode_Int64Op = 292-primOpTag FloatGtOp = 293-primOpTag FloatGeOp = 294-primOpTag FloatEqOp = 295-primOpTag FloatNeOp = 296-primOpTag FloatLtOp = 297-primOpTag FloatLeOp = 298-primOpTag FloatAddOp = 299-primOpTag FloatSubOp = 300-primOpTag FloatMulOp = 301-primOpTag FloatDivOp = 302-primOpTag FloatNegOp = 303-primOpTag FloatFabsOp = 304-primOpTag FloatToIntOp = 305-primOpTag FloatExpOp = 306-primOpTag FloatExpM1Op = 307-primOpTag FloatLogOp = 308-primOpTag FloatLog1POp = 309-primOpTag FloatSqrtOp = 310-primOpTag FloatSinOp = 311-primOpTag FloatCosOp = 312-primOpTag FloatTanOp = 313-primOpTag FloatAsinOp = 314-primOpTag FloatAcosOp = 315-primOpTag FloatAtanOp = 316-primOpTag FloatSinhOp = 317-primOpTag FloatCoshOp = 318-primOpTag FloatTanhOp = 319-primOpTag FloatAsinhOp = 320-primOpTag FloatAcoshOp = 321-primOpTag FloatAtanhOp = 322-primOpTag FloatPowerOp = 323-primOpTag FloatToDoubleOp = 324-primOpTag FloatDecode_IntOp = 325-primOpTag FloatFMAdd = 326-primOpTag FloatFMSub = 327-primOpTag FloatFNMAdd = 328-primOpTag FloatFNMSub = 329-primOpTag DoubleFMAdd = 330-primOpTag DoubleFMSub = 331-primOpTag DoubleFNMAdd = 332-primOpTag DoubleFNMSub = 333-primOpTag NewArrayOp = 334-primOpTag ReadArrayOp = 335-primOpTag WriteArrayOp = 336-primOpTag SizeofArrayOp = 337-primOpTag SizeofMutableArrayOp = 338-primOpTag IndexArrayOp = 339-primOpTag UnsafeFreezeArrayOp = 340-primOpTag UnsafeThawArrayOp = 341-primOpTag CopyArrayOp = 342-primOpTag CopyMutableArrayOp = 343-primOpTag CloneArrayOp = 344-primOpTag CloneMutableArrayOp = 345-primOpTag FreezeArrayOp = 346-primOpTag ThawArrayOp = 347-primOpTag CasArrayOp = 348-primOpTag NewSmallArrayOp = 349-primOpTag ShrinkSmallMutableArrayOp_Char = 350-primOpTag ReadSmallArrayOp = 351-primOpTag WriteSmallArrayOp = 352-primOpTag SizeofSmallArrayOp = 353-primOpTag SizeofSmallMutableArrayOp = 354-primOpTag GetSizeofSmallMutableArrayOp = 355-primOpTag IndexSmallArrayOp = 356-primOpTag UnsafeFreezeSmallArrayOp = 357-primOpTag UnsafeThawSmallArrayOp = 358-primOpTag CopySmallArrayOp = 359-primOpTag CopySmallMutableArrayOp = 360-primOpTag CloneSmallArrayOp = 361-primOpTag CloneSmallMutableArrayOp = 362-primOpTag FreezeSmallArrayOp = 363-primOpTag ThawSmallArrayOp = 364-primOpTag CasSmallArrayOp = 365-primOpTag NewByteArrayOp_Char = 366-primOpTag NewPinnedByteArrayOp_Char = 367-primOpTag NewAlignedPinnedByteArrayOp_Char = 368-primOpTag MutableByteArrayIsPinnedOp = 369-primOpTag ByteArrayIsPinnedOp = 370-primOpTag ByteArrayContents_Char = 371-primOpTag MutableByteArrayContents_Char = 372-primOpTag ShrinkMutableByteArrayOp_Char = 373-primOpTag ResizeMutableByteArrayOp_Char = 374-primOpTag UnsafeFreezeByteArrayOp = 375-primOpTag SizeofByteArrayOp = 376-primOpTag SizeofMutableByteArrayOp = 377-primOpTag GetSizeofMutableByteArrayOp = 378-primOpTag IndexByteArrayOp_Char = 379-primOpTag IndexByteArrayOp_WideChar = 380-primOpTag IndexByteArrayOp_Int = 381-primOpTag IndexByteArrayOp_Word = 382-primOpTag IndexByteArrayOp_Addr = 383-primOpTag IndexByteArrayOp_Float = 384-primOpTag IndexByteArrayOp_Double = 385-primOpTag IndexByteArrayOp_StablePtr = 386-primOpTag IndexByteArrayOp_Int8 = 387-primOpTag IndexByteArrayOp_Word8 = 388-primOpTag IndexByteArrayOp_Int16 = 389-primOpTag IndexByteArrayOp_Word16 = 390-primOpTag IndexByteArrayOp_Int32 = 391-primOpTag IndexByteArrayOp_Word32 = 392-primOpTag IndexByteArrayOp_Int64 = 393-primOpTag IndexByteArrayOp_Word64 = 394-primOpTag IndexByteArrayOp_Word8AsChar = 395-primOpTag IndexByteArrayOp_Word8AsWideChar = 396-primOpTag IndexByteArrayOp_Word8AsInt = 397-primOpTag IndexByteArrayOp_Word8AsWord = 398-primOpTag IndexByteArrayOp_Word8AsAddr = 399-primOpTag IndexByteArrayOp_Word8AsFloat = 400-primOpTag IndexByteArrayOp_Word8AsDouble = 401-primOpTag IndexByteArrayOp_Word8AsStablePtr = 402-primOpTag IndexByteArrayOp_Word8AsInt16 = 403-primOpTag IndexByteArrayOp_Word8AsWord16 = 404-primOpTag IndexByteArrayOp_Word8AsInt32 = 405-primOpTag IndexByteArrayOp_Word8AsWord32 = 406-primOpTag IndexByteArrayOp_Word8AsInt64 = 407-primOpTag IndexByteArrayOp_Word8AsWord64 = 408-primOpTag ReadByteArrayOp_Char = 409-primOpTag ReadByteArrayOp_WideChar = 410-primOpTag ReadByteArrayOp_Int = 411-primOpTag ReadByteArrayOp_Word = 412-primOpTag ReadByteArrayOp_Addr = 413-primOpTag ReadByteArrayOp_Float = 414-primOpTag ReadByteArrayOp_Double = 415-primOpTag ReadByteArrayOp_StablePtr = 416-primOpTag ReadByteArrayOp_Int8 = 417-primOpTag ReadByteArrayOp_Word8 = 418-primOpTag ReadByteArrayOp_Int16 = 419-primOpTag ReadByteArrayOp_Word16 = 420-primOpTag ReadByteArrayOp_Int32 = 421-primOpTag ReadByteArrayOp_Word32 = 422-primOpTag ReadByteArrayOp_Int64 = 423-primOpTag ReadByteArrayOp_Word64 = 424-primOpTag ReadByteArrayOp_Word8AsChar = 425-primOpTag ReadByteArrayOp_Word8AsWideChar = 426-primOpTag ReadByteArrayOp_Word8AsInt = 427-primOpTag ReadByteArrayOp_Word8AsWord = 428-primOpTag ReadByteArrayOp_Word8AsAddr = 429-primOpTag ReadByteArrayOp_Word8AsFloat = 430-primOpTag ReadByteArrayOp_Word8AsDouble = 431-primOpTag ReadByteArrayOp_Word8AsStablePtr = 432-primOpTag ReadByteArrayOp_Word8AsInt16 = 433-primOpTag ReadByteArrayOp_Word8AsWord16 = 434-primOpTag ReadByteArrayOp_Word8AsInt32 = 435-primOpTag ReadByteArrayOp_Word8AsWord32 = 436-primOpTag ReadByteArrayOp_Word8AsInt64 = 437-primOpTag ReadByteArrayOp_Word8AsWord64 = 438-primOpTag WriteByteArrayOp_Char = 439-primOpTag WriteByteArrayOp_WideChar = 440-primOpTag WriteByteArrayOp_Int = 441-primOpTag WriteByteArrayOp_Word = 442-primOpTag WriteByteArrayOp_Addr = 443-primOpTag WriteByteArrayOp_Float = 444-primOpTag WriteByteArrayOp_Double = 445-primOpTag WriteByteArrayOp_StablePtr = 446-primOpTag WriteByteArrayOp_Int8 = 447-primOpTag WriteByteArrayOp_Word8 = 448-primOpTag WriteByteArrayOp_Int16 = 449-primOpTag WriteByteArrayOp_Word16 = 450-primOpTag WriteByteArrayOp_Int32 = 451-primOpTag WriteByteArrayOp_Word32 = 452-primOpTag WriteByteArrayOp_Int64 = 453-primOpTag WriteByteArrayOp_Word64 = 454-primOpTag WriteByteArrayOp_Word8AsChar = 455-primOpTag WriteByteArrayOp_Word8AsWideChar = 456-primOpTag WriteByteArrayOp_Word8AsInt = 457-primOpTag WriteByteArrayOp_Word8AsWord = 458-primOpTag WriteByteArrayOp_Word8AsAddr = 459-primOpTag WriteByteArrayOp_Word8AsFloat = 460-primOpTag WriteByteArrayOp_Word8AsDouble = 461-primOpTag WriteByteArrayOp_Word8AsStablePtr = 462-primOpTag WriteByteArrayOp_Word8AsInt16 = 463-primOpTag WriteByteArrayOp_Word8AsWord16 = 464-primOpTag WriteByteArrayOp_Word8AsInt32 = 465-primOpTag WriteByteArrayOp_Word8AsWord32 = 466-primOpTag WriteByteArrayOp_Word8AsInt64 = 467-primOpTag WriteByteArrayOp_Word8AsWord64 = 468-primOpTag CompareByteArraysOp = 469-primOpTag CopyByteArrayOp = 470-primOpTag CopyMutableByteArrayOp = 471-primOpTag CopyMutableByteArrayNonOverlappingOp = 472-primOpTag CopyByteArrayToAddrOp = 473-primOpTag CopyMutableByteArrayToAddrOp = 474-primOpTag CopyAddrToByteArrayOp = 475-primOpTag CopyAddrToAddrOp = 476-primOpTag CopyAddrToAddrNonOverlappingOp = 477-primOpTag SetByteArrayOp = 478-primOpTag SetAddrRangeOp = 479-primOpTag AtomicReadByteArrayOp_Int = 480-primOpTag AtomicWriteByteArrayOp_Int = 481-primOpTag CasByteArrayOp_Int = 482-primOpTag CasByteArrayOp_Int8 = 483-primOpTag CasByteArrayOp_Int16 = 484-primOpTag CasByteArrayOp_Int32 = 485-primOpTag CasByteArrayOp_Int64 = 486-primOpTag FetchAddByteArrayOp_Int = 487-primOpTag FetchSubByteArrayOp_Int = 488-primOpTag FetchAndByteArrayOp_Int = 489-primOpTag FetchNandByteArrayOp_Int = 490-primOpTag FetchOrByteArrayOp_Int = 491-primOpTag FetchXorByteArrayOp_Int = 492-primOpTag AddrAddOp = 493-primOpTag AddrSubOp = 494-primOpTag AddrRemOp = 495-primOpTag AddrToIntOp = 496-primOpTag IntToAddrOp = 497-primOpTag AddrGtOp = 498-primOpTag AddrGeOp = 499-primOpTag AddrEqOp = 500-primOpTag AddrNeOp = 501-primOpTag AddrLtOp = 502-primOpTag AddrLeOp = 503-primOpTag IndexOffAddrOp_Char = 504-primOpTag IndexOffAddrOp_WideChar = 505-primOpTag IndexOffAddrOp_Int = 506-primOpTag IndexOffAddrOp_Word = 507-primOpTag IndexOffAddrOp_Addr = 508-primOpTag IndexOffAddrOp_Float = 509-primOpTag IndexOffAddrOp_Double = 510-primOpTag IndexOffAddrOp_StablePtr = 511-primOpTag IndexOffAddrOp_Int8 = 512-primOpTag IndexOffAddrOp_Word8 = 513-primOpTag IndexOffAddrOp_Int16 = 514-primOpTag IndexOffAddrOp_Word16 = 515-primOpTag IndexOffAddrOp_Int32 = 516-primOpTag IndexOffAddrOp_Word32 = 517-primOpTag IndexOffAddrOp_Int64 = 518-primOpTag IndexOffAddrOp_Word64 = 519-primOpTag ReadOffAddrOp_Char = 520-primOpTag ReadOffAddrOp_WideChar = 521-primOpTag ReadOffAddrOp_Int = 522-primOpTag ReadOffAddrOp_Word = 523-primOpTag ReadOffAddrOp_Addr = 524-primOpTag ReadOffAddrOp_Float = 525-primOpTag ReadOffAddrOp_Double = 526-primOpTag ReadOffAddrOp_StablePtr = 527-primOpTag ReadOffAddrOp_Int8 = 528-primOpTag ReadOffAddrOp_Word8 = 529-primOpTag ReadOffAddrOp_Int16 = 530-primOpTag ReadOffAddrOp_Word16 = 531-primOpTag ReadOffAddrOp_Int32 = 532-primOpTag ReadOffAddrOp_Word32 = 533-primOpTag ReadOffAddrOp_Int64 = 534-primOpTag ReadOffAddrOp_Word64 = 535-primOpTag WriteOffAddrOp_Char = 536-primOpTag WriteOffAddrOp_WideChar = 537-primOpTag WriteOffAddrOp_Int = 538-primOpTag WriteOffAddrOp_Word = 539-primOpTag WriteOffAddrOp_Addr = 540-primOpTag WriteOffAddrOp_Float = 541-primOpTag WriteOffAddrOp_Double = 542-primOpTag WriteOffAddrOp_StablePtr = 543-primOpTag WriteOffAddrOp_Int8 = 544-primOpTag WriteOffAddrOp_Word8 = 545-primOpTag WriteOffAddrOp_Int16 = 546-primOpTag WriteOffAddrOp_Word16 = 547-primOpTag WriteOffAddrOp_Int32 = 548-primOpTag WriteOffAddrOp_Word32 = 549-primOpTag WriteOffAddrOp_Int64 = 550-primOpTag WriteOffAddrOp_Word64 = 551-primOpTag InterlockedExchange_Addr = 552-primOpTag InterlockedExchange_Word = 553-primOpTag CasAddrOp_Addr = 554-primOpTag CasAddrOp_Word = 555-primOpTag CasAddrOp_Word8 = 556-primOpTag CasAddrOp_Word16 = 557-primOpTag CasAddrOp_Word32 = 558-primOpTag CasAddrOp_Word64 = 559-primOpTag FetchAddAddrOp_Word = 560-primOpTag FetchSubAddrOp_Word = 561-primOpTag FetchAndAddrOp_Word = 562-primOpTag FetchNandAddrOp_Word = 563-primOpTag FetchOrAddrOp_Word = 564-primOpTag FetchXorAddrOp_Word = 565-primOpTag AtomicReadAddrOp_Word = 566-primOpTag AtomicWriteAddrOp_Word = 567-primOpTag NewMutVarOp = 568-primOpTag ReadMutVarOp = 569-primOpTag WriteMutVarOp = 570-primOpTag AtomicSwapMutVarOp = 571-primOpTag AtomicModifyMutVar2Op = 572-primOpTag AtomicModifyMutVar_Op = 573-primOpTag CasMutVarOp = 574-primOpTag CatchOp = 575-primOpTag RaiseOp = 576-primOpTag RaiseUnderflowOp = 577-primOpTag RaiseOverflowOp = 578-primOpTag RaiseDivZeroOp = 579-primOpTag RaiseIOOp = 580-primOpTag MaskAsyncExceptionsOp = 581-primOpTag MaskUninterruptibleOp = 582-primOpTag UnmaskAsyncExceptionsOp = 583-primOpTag MaskStatus = 584-primOpTag NewPromptTagOp = 585-primOpTag PromptOp = 586-primOpTag Control0Op = 587-primOpTag AtomicallyOp = 588-primOpTag RetryOp = 589-primOpTag CatchRetryOp = 590-primOpTag CatchSTMOp = 591-primOpTag NewTVarOp = 592-primOpTag ReadTVarOp = 593-primOpTag ReadTVarIOOp = 594-primOpTag WriteTVarOp = 595-primOpTag NewMVarOp = 596-primOpTag TakeMVarOp = 597-primOpTag TryTakeMVarOp = 598-primOpTag PutMVarOp = 599-primOpTag TryPutMVarOp = 600-primOpTag ReadMVarOp = 601-primOpTag TryReadMVarOp = 602-primOpTag IsEmptyMVarOp = 603-primOpTag NewIOPortOp = 604-primOpTag ReadIOPortOp = 605-primOpTag WriteIOPortOp = 606-primOpTag DelayOp = 607-primOpTag WaitReadOp = 608-primOpTag WaitWriteOp = 609-primOpTag ForkOp = 610-primOpTag ForkOnOp = 611-primOpTag KillThreadOp = 612-primOpTag YieldOp = 613-primOpTag MyThreadIdOp = 614-primOpTag LabelThreadOp = 615-primOpTag IsCurrentThreadBoundOp = 616-primOpTag NoDuplicateOp = 617-primOpTag GetThreadLabelOp = 618-primOpTag ThreadStatusOp = 619-primOpTag ListThreadsOp = 620-primOpTag MkWeakOp = 621-primOpTag MkWeakNoFinalizerOp = 622-primOpTag AddCFinalizerToWeakOp = 623-primOpTag DeRefWeakOp = 624-primOpTag FinalizeWeakOp = 625-primOpTag TouchOp = 626-primOpTag MakeStablePtrOp = 627-primOpTag DeRefStablePtrOp = 628-primOpTag EqStablePtrOp = 629-primOpTag MakeStableNameOp = 630-primOpTag StableNameToIntOp = 631-primOpTag CompactNewOp = 632-primOpTag CompactResizeOp = 633-primOpTag CompactContainsOp = 634-primOpTag CompactContainsAnyOp = 635-primOpTag CompactGetFirstBlockOp = 636-primOpTag CompactGetNextBlockOp = 637-primOpTag CompactAllocateBlockOp = 638-primOpTag CompactFixupPointersOp = 639-primOpTag CompactAdd = 640-primOpTag CompactAddWithSharing = 641-primOpTag CompactSize = 642-primOpTag ReallyUnsafePtrEqualityOp = 643-primOpTag ParOp = 644-primOpTag SparkOp = 645-primOpTag SeqOp = 646-primOpTag GetSparkOp = 647-primOpTag NumSparks = 648-primOpTag KeepAliveOp = 649-primOpTag DataToTagOp = 650-primOpTag TagToEnumOp = 651-primOpTag AddrToAnyOp = 652-primOpTag AnyToAddrOp = 653-primOpTag MkApUpd0_Op = 654-primOpTag NewBCOOp = 655-primOpTag UnpackClosureOp = 656-primOpTag ClosureSizeOp = 657-primOpTag GetApStackValOp = 658-primOpTag GetCCSOfOp = 659-primOpTag GetCurrentCCSOp = 660-primOpTag ClearCCSOp = 661-primOpTag WhereFromOp = 662-primOpTag TraceEventOp = 663-primOpTag TraceEventBinaryOp = 664-primOpTag TraceMarkerOp = 665-primOpTag SetThreadAllocationCounter = 666-primOpTag (VecBroadcastOp IntVec 16 W8) = 667-primOpTag (VecBroadcastOp IntVec 8 W16) = 668-primOpTag (VecBroadcastOp IntVec 4 W32) = 669-primOpTag (VecBroadcastOp IntVec 2 W64) = 670-primOpTag (VecBroadcastOp IntVec 32 W8) = 671-primOpTag (VecBroadcastOp IntVec 16 W16) = 672-primOpTag (VecBroadcastOp IntVec 8 W32) = 673-primOpTag (VecBroadcastOp IntVec 4 W64) = 674-primOpTag (VecBroadcastOp IntVec 64 W8) = 675-primOpTag (VecBroadcastOp IntVec 32 W16) = 676-primOpTag (VecBroadcastOp IntVec 16 W32) = 677-primOpTag (VecBroadcastOp IntVec 8 W64) = 678-primOpTag (VecBroadcastOp WordVec 16 W8) = 679-primOpTag (VecBroadcastOp WordVec 8 W16) = 680-primOpTag (VecBroadcastOp WordVec 4 W32) = 681-primOpTag (VecBroadcastOp WordVec 2 W64) = 682-primOpTag (VecBroadcastOp WordVec 32 W8) = 683-primOpTag (VecBroadcastOp WordVec 16 W16) = 684-primOpTag (VecBroadcastOp WordVec 8 W32) = 685-primOpTag (VecBroadcastOp WordVec 4 W64) = 686-primOpTag (VecBroadcastOp WordVec 64 W8) = 687-primOpTag (VecBroadcastOp WordVec 32 W16) = 688-primOpTag (VecBroadcastOp WordVec 16 W32) = 689-primOpTag (VecBroadcastOp WordVec 8 W64) = 690-primOpTag (VecBroadcastOp FloatVec 4 W32) = 691-primOpTag (VecBroadcastOp FloatVec 2 W64) = 692-primOpTag (VecBroadcastOp FloatVec 8 W32) = 693-primOpTag (VecBroadcastOp FloatVec 4 W64) = 694-primOpTag (VecBroadcastOp FloatVec 16 W32) = 695-primOpTag (VecBroadcastOp FloatVec 8 W64) = 696-primOpTag (VecPackOp IntVec 16 W8) = 697-primOpTag (VecPackOp IntVec 8 W16) = 698-primOpTag (VecPackOp IntVec 4 W32) = 699-primOpTag (VecPackOp IntVec 2 W64) = 700-primOpTag (VecPackOp IntVec 32 W8) = 701-primOpTag (VecPackOp IntVec 16 W16) = 702-primOpTag (VecPackOp IntVec 8 W32) = 703-primOpTag (VecPackOp IntVec 4 W64) = 704-primOpTag (VecPackOp IntVec 64 W8) = 705-primOpTag (VecPackOp IntVec 32 W16) = 706-primOpTag (VecPackOp IntVec 16 W32) = 707-primOpTag (VecPackOp IntVec 8 W64) = 708-primOpTag (VecPackOp WordVec 16 W8) = 709-primOpTag (VecPackOp WordVec 8 W16) = 710-primOpTag (VecPackOp WordVec 4 W32) = 711-primOpTag (VecPackOp WordVec 2 W64) = 712-primOpTag (VecPackOp WordVec 32 W8) = 713-primOpTag (VecPackOp WordVec 16 W16) = 714-primOpTag (VecPackOp WordVec 8 W32) = 715-primOpTag (VecPackOp WordVec 4 W64) = 716-primOpTag (VecPackOp WordVec 64 W8) = 717-primOpTag (VecPackOp WordVec 32 W16) = 718-primOpTag (VecPackOp WordVec 16 W32) = 719-primOpTag (VecPackOp WordVec 8 W64) = 720-primOpTag (VecPackOp FloatVec 4 W32) = 721-primOpTag (VecPackOp FloatVec 2 W64) = 722-primOpTag (VecPackOp FloatVec 8 W32) = 723-primOpTag (VecPackOp FloatVec 4 W64) = 724-primOpTag (VecPackOp FloatVec 16 W32) = 725-primOpTag (VecPackOp FloatVec 8 W64) = 726-primOpTag (VecUnpackOp IntVec 16 W8) = 727-primOpTag (VecUnpackOp IntVec 8 W16) = 728-primOpTag (VecUnpackOp IntVec 4 W32) = 729-primOpTag (VecUnpackOp IntVec 2 W64) = 730-primOpTag (VecUnpackOp IntVec 32 W8) = 731-primOpTag (VecUnpackOp IntVec 16 W16) = 732-primOpTag (VecUnpackOp IntVec 8 W32) = 733-primOpTag (VecUnpackOp IntVec 4 W64) = 734-primOpTag (VecUnpackOp IntVec 64 W8) = 735-primOpTag (VecUnpackOp IntVec 32 W16) = 736-primOpTag (VecUnpackOp IntVec 16 W32) = 737-primOpTag (VecUnpackOp IntVec 8 W64) = 738-primOpTag (VecUnpackOp WordVec 16 W8) = 739-primOpTag (VecUnpackOp WordVec 8 W16) = 740-primOpTag (VecUnpackOp WordVec 4 W32) = 741-primOpTag (VecUnpackOp WordVec 2 W64) = 742-primOpTag (VecUnpackOp WordVec 32 W8) = 743-primOpTag (VecUnpackOp WordVec 16 W16) = 744-primOpTag (VecUnpackOp WordVec 8 W32) = 745-primOpTag (VecUnpackOp WordVec 4 W64) = 746-primOpTag (VecUnpackOp WordVec 64 W8) = 747-primOpTag (VecUnpackOp WordVec 32 W16) = 748-primOpTag (VecUnpackOp WordVec 16 W32) = 749-primOpTag (VecUnpackOp WordVec 8 W64) = 750-primOpTag (VecUnpackOp FloatVec 4 W32) = 751-primOpTag (VecUnpackOp FloatVec 2 W64) = 752-primOpTag (VecUnpackOp FloatVec 8 W32) = 753-primOpTag (VecUnpackOp FloatVec 4 W64) = 754-primOpTag (VecUnpackOp FloatVec 16 W32) = 755-primOpTag (VecUnpackOp FloatVec 8 W64) = 756-primOpTag (VecInsertOp IntVec 16 W8) = 757-primOpTag (VecInsertOp IntVec 8 W16) = 758-primOpTag (VecInsertOp IntVec 4 W32) = 759-primOpTag (VecInsertOp IntVec 2 W64) = 760-primOpTag (VecInsertOp IntVec 32 W8) = 761-primOpTag (VecInsertOp IntVec 16 W16) = 762-primOpTag (VecInsertOp IntVec 8 W32) = 763-primOpTag (VecInsertOp IntVec 4 W64) = 764-primOpTag (VecInsertOp IntVec 64 W8) = 765-primOpTag (VecInsertOp IntVec 32 W16) = 766-primOpTag (VecInsertOp IntVec 16 W32) = 767-primOpTag (VecInsertOp IntVec 8 W64) = 768-primOpTag (VecInsertOp WordVec 16 W8) = 769-primOpTag (VecInsertOp WordVec 8 W16) = 770-primOpTag (VecInsertOp WordVec 4 W32) = 771-primOpTag (VecInsertOp WordVec 2 W64) = 772-primOpTag (VecInsertOp WordVec 32 W8) = 773-primOpTag (VecInsertOp WordVec 16 W16) = 774-primOpTag (VecInsertOp WordVec 8 W32) = 775-primOpTag (VecInsertOp WordVec 4 W64) = 776-primOpTag (VecInsertOp WordVec 64 W8) = 777-primOpTag (VecInsertOp WordVec 32 W16) = 778-primOpTag (VecInsertOp WordVec 16 W32) = 779-primOpTag (VecInsertOp WordVec 8 W64) = 780-primOpTag (VecInsertOp FloatVec 4 W32) = 781-primOpTag (VecInsertOp FloatVec 2 W64) = 782-primOpTag (VecInsertOp FloatVec 8 W32) = 783-primOpTag (VecInsertOp FloatVec 4 W64) = 784-primOpTag (VecInsertOp FloatVec 16 W32) = 785-primOpTag (VecInsertOp FloatVec 8 W64) = 786-primOpTag (VecAddOp IntVec 16 W8) = 787-primOpTag (VecAddOp IntVec 8 W16) = 788-primOpTag (VecAddOp IntVec 4 W32) = 789-primOpTag (VecAddOp IntVec 2 W64) = 790-primOpTag (VecAddOp IntVec 32 W8) = 791-primOpTag (VecAddOp IntVec 16 W16) = 792-primOpTag (VecAddOp IntVec 8 W32) = 793-primOpTag (VecAddOp IntVec 4 W64) = 794-primOpTag (VecAddOp IntVec 64 W8) = 795-primOpTag (VecAddOp IntVec 32 W16) = 796-primOpTag (VecAddOp IntVec 16 W32) = 797-primOpTag (VecAddOp IntVec 8 W64) = 798-primOpTag (VecAddOp WordVec 16 W8) = 799-primOpTag (VecAddOp WordVec 8 W16) = 800-primOpTag (VecAddOp WordVec 4 W32) = 801-primOpTag (VecAddOp WordVec 2 W64) = 802-primOpTag (VecAddOp WordVec 32 W8) = 803-primOpTag (VecAddOp WordVec 16 W16) = 804-primOpTag (VecAddOp WordVec 8 W32) = 805-primOpTag (VecAddOp WordVec 4 W64) = 806-primOpTag (VecAddOp WordVec 64 W8) = 807-primOpTag (VecAddOp WordVec 32 W16) = 808-primOpTag (VecAddOp WordVec 16 W32) = 809-primOpTag (VecAddOp WordVec 8 W64) = 810-primOpTag (VecAddOp FloatVec 4 W32) = 811-primOpTag (VecAddOp FloatVec 2 W64) = 812-primOpTag (VecAddOp FloatVec 8 W32) = 813-primOpTag (VecAddOp FloatVec 4 W64) = 814-primOpTag (VecAddOp FloatVec 16 W32) = 815-primOpTag (VecAddOp FloatVec 8 W64) = 816-primOpTag (VecSubOp IntVec 16 W8) = 817-primOpTag (VecSubOp IntVec 8 W16) = 818-primOpTag (VecSubOp IntVec 4 W32) = 819-primOpTag (VecSubOp IntVec 2 W64) = 820-primOpTag (VecSubOp IntVec 32 W8) = 821-primOpTag (VecSubOp IntVec 16 W16) = 822-primOpTag (VecSubOp IntVec 8 W32) = 823-primOpTag (VecSubOp IntVec 4 W64) = 824-primOpTag (VecSubOp IntVec 64 W8) = 825-primOpTag (VecSubOp IntVec 32 W16) = 826-primOpTag (VecSubOp IntVec 16 W32) = 827-primOpTag (VecSubOp IntVec 8 W64) = 828-primOpTag (VecSubOp WordVec 16 W8) = 829-primOpTag (VecSubOp WordVec 8 W16) = 830-primOpTag (VecSubOp WordVec 4 W32) = 831-primOpTag (VecSubOp WordVec 2 W64) = 832-primOpTag (VecSubOp WordVec 32 W8) = 833-primOpTag (VecSubOp WordVec 16 W16) = 834-primOpTag (VecSubOp WordVec 8 W32) = 835-primOpTag (VecSubOp WordVec 4 W64) = 836-primOpTag (VecSubOp WordVec 64 W8) = 837-primOpTag (VecSubOp WordVec 32 W16) = 838-primOpTag (VecSubOp WordVec 16 W32) = 839-primOpTag (VecSubOp WordVec 8 W64) = 840-primOpTag (VecSubOp FloatVec 4 W32) = 841-primOpTag (VecSubOp FloatVec 2 W64) = 842-primOpTag (VecSubOp FloatVec 8 W32) = 843-primOpTag (VecSubOp FloatVec 4 W64) = 844-primOpTag (VecSubOp FloatVec 16 W32) = 845-primOpTag (VecSubOp FloatVec 8 W64) = 846-primOpTag (VecMulOp IntVec 16 W8) = 847-primOpTag (VecMulOp IntVec 8 W16) = 848-primOpTag (VecMulOp IntVec 4 W32) = 849-primOpTag (VecMulOp IntVec 2 W64) = 850-primOpTag (VecMulOp IntVec 32 W8) = 851-primOpTag (VecMulOp IntVec 16 W16) = 852-primOpTag (VecMulOp IntVec 8 W32) = 853-primOpTag (VecMulOp IntVec 4 W64) = 854-primOpTag (VecMulOp IntVec 64 W8) = 855-primOpTag (VecMulOp IntVec 32 W16) = 856-primOpTag (VecMulOp IntVec 16 W32) = 857-primOpTag (VecMulOp IntVec 8 W64) = 858-primOpTag (VecMulOp WordVec 16 W8) = 859-primOpTag (VecMulOp WordVec 8 W16) = 860-primOpTag (VecMulOp WordVec 4 W32) = 861-primOpTag (VecMulOp WordVec 2 W64) = 862-primOpTag (VecMulOp WordVec 32 W8) = 863-primOpTag (VecMulOp WordVec 16 W16) = 864-primOpTag (VecMulOp WordVec 8 W32) = 865-primOpTag (VecMulOp WordVec 4 W64) = 866-primOpTag (VecMulOp WordVec 64 W8) = 867-primOpTag (VecMulOp WordVec 32 W16) = 868-primOpTag (VecMulOp WordVec 16 W32) = 869-primOpTag (VecMulOp WordVec 8 W64) = 870-primOpTag (VecMulOp FloatVec 4 W32) = 871-primOpTag (VecMulOp FloatVec 2 W64) = 872-primOpTag (VecMulOp FloatVec 8 W32) = 873-primOpTag (VecMulOp FloatVec 4 W64) = 874-primOpTag (VecMulOp FloatVec 16 W32) = 875-primOpTag (VecMulOp FloatVec 8 W64) = 876-primOpTag (VecDivOp FloatVec 4 W32) = 877-primOpTag (VecDivOp FloatVec 2 W64) = 878-primOpTag (VecDivOp FloatVec 8 W32) = 879-primOpTag (VecDivOp FloatVec 4 W64) = 880-primOpTag (VecDivOp FloatVec 16 W32) = 881-primOpTag (VecDivOp FloatVec 8 W64) = 882-primOpTag (VecQuotOp IntVec 16 W8) = 883-primOpTag (VecQuotOp IntVec 8 W16) = 884-primOpTag (VecQuotOp IntVec 4 W32) = 885-primOpTag (VecQuotOp IntVec 2 W64) = 886-primOpTag (VecQuotOp IntVec 32 W8) = 887-primOpTag (VecQuotOp IntVec 16 W16) = 888-primOpTag (VecQuotOp IntVec 8 W32) = 889-primOpTag (VecQuotOp IntVec 4 W64) = 890-primOpTag (VecQuotOp IntVec 64 W8) = 891-primOpTag (VecQuotOp IntVec 32 W16) = 892-primOpTag (VecQuotOp IntVec 16 W32) = 893-primOpTag (VecQuotOp IntVec 8 W64) = 894-primOpTag (VecQuotOp WordVec 16 W8) = 895-primOpTag (VecQuotOp WordVec 8 W16) = 896-primOpTag (VecQuotOp WordVec 4 W32) = 897-primOpTag (VecQuotOp WordVec 2 W64) = 898-primOpTag (VecQuotOp WordVec 32 W8) = 899-primOpTag (VecQuotOp WordVec 16 W16) = 900-primOpTag (VecQuotOp WordVec 8 W32) = 901-primOpTag (VecQuotOp WordVec 4 W64) = 902-primOpTag (VecQuotOp WordVec 64 W8) = 903-primOpTag (VecQuotOp WordVec 32 W16) = 904-primOpTag (VecQuotOp WordVec 16 W32) = 905-primOpTag (VecQuotOp WordVec 8 W64) = 906-primOpTag (VecRemOp IntVec 16 W8) = 907-primOpTag (VecRemOp IntVec 8 W16) = 908-primOpTag (VecRemOp IntVec 4 W32) = 909-primOpTag (VecRemOp IntVec 2 W64) = 910-primOpTag (VecRemOp IntVec 32 W8) = 911-primOpTag (VecRemOp IntVec 16 W16) = 912-primOpTag (VecRemOp IntVec 8 W32) = 913-primOpTag (VecRemOp IntVec 4 W64) = 914-primOpTag (VecRemOp IntVec 64 W8) = 915-primOpTag (VecRemOp IntVec 32 W16) = 916-primOpTag (VecRemOp IntVec 16 W32) = 917-primOpTag (VecRemOp IntVec 8 W64) = 918-primOpTag (VecRemOp WordVec 16 W8) = 919-primOpTag (VecRemOp WordVec 8 W16) = 920-primOpTag (VecRemOp WordVec 4 W32) = 921-primOpTag (VecRemOp WordVec 2 W64) = 922-primOpTag (VecRemOp WordVec 32 W8) = 923-primOpTag (VecRemOp WordVec 16 W16) = 924-primOpTag (VecRemOp WordVec 8 W32) = 925-primOpTag (VecRemOp WordVec 4 W64) = 926-primOpTag (VecRemOp WordVec 64 W8) = 927-primOpTag (VecRemOp WordVec 32 W16) = 928-primOpTag (VecRemOp WordVec 16 W32) = 929-primOpTag (VecRemOp WordVec 8 W64) = 930-primOpTag (VecNegOp IntVec 16 W8) = 931-primOpTag (VecNegOp IntVec 8 W16) = 932-primOpTag (VecNegOp IntVec 4 W32) = 933-primOpTag (VecNegOp IntVec 2 W64) = 934-primOpTag (VecNegOp IntVec 32 W8) = 935-primOpTag (VecNegOp IntVec 16 W16) = 936-primOpTag (VecNegOp IntVec 8 W32) = 937-primOpTag (VecNegOp IntVec 4 W64) = 938-primOpTag (VecNegOp IntVec 64 W8) = 939-primOpTag (VecNegOp IntVec 32 W16) = 940-primOpTag (VecNegOp IntVec 16 W32) = 941-primOpTag (VecNegOp IntVec 8 W64) = 942-primOpTag (VecNegOp FloatVec 4 W32) = 943-primOpTag (VecNegOp FloatVec 2 W64) = 944-primOpTag (VecNegOp FloatVec 8 W32) = 945-primOpTag (VecNegOp FloatVec 4 W64) = 946-primOpTag (VecNegOp FloatVec 16 W32) = 947-primOpTag (VecNegOp FloatVec 8 W64) = 948-primOpTag (VecIndexByteArrayOp IntVec 16 W8) = 949-primOpTag (VecIndexByteArrayOp IntVec 8 W16) = 950-primOpTag (VecIndexByteArrayOp IntVec 4 W32) = 951-primOpTag (VecIndexByteArrayOp IntVec 2 W64) = 952-primOpTag (VecIndexByteArrayOp IntVec 32 W8) = 953-primOpTag (VecIndexByteArrayOp IntVec 16 W16) = 954-primOpTag (VecIndexByteArrayOp IntVec 8 W32) = 955-primOpTag (VecIndexByteArrayOp IntVec 4 W64) = 956-primOpTag (VecIndexByteArrayOp IntVec 64 W8) = 957-primOpTag (VecIndexByteArrayOp IntVec 32 W16) = 958-primOpTag (VecIndexByteArrayOp IntVec 16 W32) = 959-primOpTag (VecIndexByteArrayOp IntVec 8 W64) = 960-primOpTag (VecIndexByteArrayOp WordVec 16 W8) = 961-primOpTag (VecIndexByteArrayOp WordVec 8 W16) = 962-primOpTag (VecIndexByteArrayOp WordVec 4 W32) = 963-primOpTag (VecIndexByteArrayOp WordVec 2 W64) = 964-primOpTag (VecIndexByteArrayOp WordVec 32 W8) = 965-primOpTag (VecIndexByteArrayOp WordVec 16 W16) = 966-primOpTag (VecIndexByteArrayOp WordVec 8 W32) = 967-primOpTag (VecIndexByteArrayOp WordVec 4 W64) = 968-primOpTag (VecIndexByteArrayOp WordVec 64 W8) = 969-primOpTag (VecIndexByteArrayOp WordVec 32 W16) = 970-primOpTag (VecIndexByteArrayOp WordVec 16 W32) = 971-primOpTag (VecIndexByteArrayOp WordVec 8 W64) = 972-primOpTag (VecIndexByteArrayOp FloatVec 4 W32) = 973-primOpTag (VecIndexByteArrayOp FloatVec 2 W64) = 974-primOpTag (VecIndexByteArrayOp FloatVec 8 W32) = 975-primOpTag (VecIndexByteArrayOp FloatVec 4 W64) = 976-primOpTag (VecIndexByteArrayOp FloatVec 16 W32) = 977-primOpTag (VecIndexByteArrayOp FloatVec 8 W64) = 978-primOpTag (VecReadByteArrayOp IntVec 16 W8) = 979-primOpTag (VecReadByteArrayOp IntVec 8 W16) = 980-primOpTag (VecReadByteArrayOp IntVec 4 W32) = 981-primOpTag (VecReadByteArrayOp IntVec 2 W64) = 982-primOpTag (VecReadByteArrayOp IntVec 32 W8) = 983-primOpTag (VecReadByteArrayOp IntVec 16 W16) = 984-primOpTag (VecReadByteArrayOp IntVec 8 W32) = 985-primOpTag (VecReadByteArrayOp IntVec 4 W64) = 986-primOpTag (VecReadByteArrayOp IntVec 64 W8) = 987-primOpTag (VecReadByteArrayOp IntVec 32 W16) = 988-primOpTag (VecReadByteArrayOp IntVec 16 W32) = 989-primOpTag (VecReadByteArrayOp IntVec 8 W64) = 990-primOpTag (VecReadByteArrayOp WordVec 16 W8) = 991-primOpTag (VecReadByteArrayOp WordVec 8 W16) = 992-primOpTag (VecReadByteArrayOp WordVec 4 W32) = 993-primOpTag (VecReadByteArrayOp WordVec 2 W64) = 994-primOpTag (VecReadByteArrayOp WordVec 32 W8) = 995-primOpTag (VecReadByteArrayOp WordVec 16 W16) = 996-primOpTag (VecReadByteArrayOp WordVec 8 W32) = 997-primOpTag (VecReadByteArrayOp WordVec 4 W64) = 998-primOpTag (VecReadByteArrayOp WordVec 64 W8) = 999-primOpTag (VecReadByteArrayOp WordVec 32 W16) = 1000-primOpTag (VecReadByteArrayOp WordVec 16 W32) = 1001-primOpTag (VecReadByteArrayOp WordVec 8 W64) = 1002-primOpTag (VecReadByteArrayOp FloatVec 4 W32) = 1003-primOpTag (VecReadByteArrayOp FloatVec 2 W64) = 1004-primOpTag (VecReadByteArrayOp FloatVec 8 W32) = 1005-primOpTag (VecReadByteArrayOp FloatVec 4 W64) = 1006-primOpTag (VecReadByteArrayOp FloatVec 16 W32) = 1007-primOpTag (VecReadByteArrayOp FloatVec 8 W64) = 1008-primOpTag (VecWriteByteArrayOp IntVec 16 W8) = 1009-primOpTag (VecWriteByteArrayOp IntVec 8 W16) = 1010-primOpTag (VecWriteByteArrayOp IntVec 4 W32) = 1011-primOpTag (VecWriteByteArrayOp IntVec 2 W64) = 1012-primOpTag (VecWriteByteArrayOp IntVec 32 W8) = 1013-primOpTag (VecWriteByteArrayOp IntVec 16 W16) = 1014-primOpTag (VecWriteByteArrayOp IntVec 8 W32) = 1015-primOpTag (VecWriteByteArrayOp IntVec 4 W64) = 1016-primOpTag (VecWriteByteArrayOp IntVec 64 W8) = 1017-primOpTag (VecWriteByteArrayOp IntVec 32 W16) = 1018-primOpTag (VecWriteByteArrayOp IntVec 16 W32) = 1019-primOpTag (VecWriteByteArrayOp IntVec 8 W64) = 1020-primOpTag (VecWriteByteArrayOp WordVec 16 W8) = 1021-primOpTag (VecWriteByteArrayOp WordVec 8 W16) = 1022-primOpTag (VecWriteByteArrayOp WordVec 4 W32) = 1023-primOpTag (VecWriteByteArrayOp WordVec 2 W64) = 1024-primOpTag (VecWriteByteArrayOp WordVec 32 W8) = 1025-primOpTag (VecWriteByteArrayOp WordVec 16 W16) = 1026-primOpTag (VecWriteByteArrayOp WordVec 8 W32) = 1027-primOpTag (VecWriteByteArrayOp WordVec 4 W64) = 1028-primOpTag (VecWriteByteArrayOp WordVec 64 W8) = 1029-primOpTag (VecWriteByteArrayOp WordVec 32 W16) = 1030-primOpTag (VecWriteByteArrayOp WordVec 16 W32) = 1031-primOpTag (VecWriteByteArrayOp WordVec 8 W64) = 1032-primOpTag (VecWriteByteArrayOp FloatVec 4 W32) = 1033-primOpTag (VecWriteByteArrayOp FloatVec 2 W64) = 1034-primOpTag (VecWriteByteArrayOp FloatVec 8 W32) = 1035-primOpTag (VecWriteByteArrayOp FloatVec 4 W64) = 1036-primOpTag (VecWriteByteArrayOp FloatVec 16 W32) = 1037-primOpTag (VecWriteByteArrayOp FloatVec 8 W64) = 1038-primOpTag (VecIndexOffAddrOp IntVec 16 W8) = 1039-primOpTag (VecIndexOffAddrOp IntVec 8 W16) = 1040-primOpTag (VecIndexOffAddrOp IntVec 4 W32) = 1041-primOpTag (VecIndexOffAddrOp IntVec 2 W64) = 1042-primOpTag (VecIndexOffAddrOp IntVec 32 W8) = 1043-primOpTag (VecIndexOffAddrOp IntVec 16 W16) = 1044-primOpTag (VecIndexOffAddrOp IntVec 8 W32) = 1045-primOpTag (VecIndexOffAddrOp IntVec 4 W64) = 1046-primOpTag (VecIndexOffAddrOp IntVec 64 W8) = 1047-primOpTag (VecIndexOffAddrOp IntVec 32 W16) = 1048-primOpTag (VecIndexOffAddrOp IntVec 16 W32) = 1049-primOpTag (VecIndexOffAddrOp IntVec 8 W64) = 1050-primOpTag (VecIndexOffAddrOp WordVec 16 W8) = 1051-primOpTag (VecIndexOffAddrOp WordVec 8 W16) = 1052-primOpTag (VecIndexOffAddrOp WordVec 4 W32) = 1053-primOpTag (VecIndexOffAddrOp WordVec 2 W64) = 1054-primOpTag (VecIndexOffAddrOp WordVec 32 W8) = 1055-primOpTag (VecIndexOffAddrOp WordVec 16 W16) = 1056-primOpTag (VecIndexOffAddrOp WordVec 8 W32) = 1057-primOpTag (VecIndexOffAddrOp WordVec 4 W64) = 1058-primOpTag (VecIndexOffAddrOp WordVec 64 W8) = 1059-primOpTag (VecIndexOffAddrOp WordVec 32 W16) = 1060-primOpTag (VecIndexOffAddrOp WordVec 16 W32) = 1061-primOpTag (VecIndexOffAddrOp WordVec 8 W64) = 1062-primOpTag (VecIndexOffAddrOp FloatVec 4 W32) = 1063-primOpTag (VecIndexOffAddrOp FloatVec 2 W64) = 1064-primOpTag (VecIndexOffAddrOp FloatVec 8 W32) = 1065-primOpTag (VecIndexOffAddrOp FloatVec 4 W64) = 1066-primOpTag (VecIndexOffAddrOp FloatVec 16 W32) = 1067-primOpTag (VecIndexOffAddrOp FloatVec 8 W64) = 1068-primOpTag (VecReadOffAddrOp IntVec 16 W8) = 1069-primOpTag (VecReadOffAddrOp IntVec 8 W16) = 1070-primOpTag (VecReadOffAddrOp IntVec 4 W32) = 1071-primOpTag (VecReadOffAddrOp IntVec 2 W64) = 1072-primOpTag (VecReadOffAddrOp IntVec 32 W8) = 1073-primOpTag (VecReadOffAddrOp IntVec 16 W16) = 1074-primOpTag (VecReadOffAddrOp IntVec 8 W32) = 1075-primOpTag (VecReadOffAddrOp IntVec 4 W64) = 1076-primOpTag (VecReadOffAddrOp IntVec 64 W8) = 1077-primOpTag (VecReadOffAddrOp IntVec 32 W16) = 1078-primOpTag (VecReadOffAddrOp IntVec 16 W32) = 1079-primOpTag (VecReadOffAddrOp IntVec 8 W64) = 1080-primOpTag (VecReadOffAddrOp WordVec 16 W8) = 1081-primOpTag (VecReadOffAddrOp WordVec 8 W16) = 1082-primOpTag (VecReadOffAddrOp WordVec 4 W32) = 1083-primOpTag (VecReadOffAddrOp WordVec 2 W64) = 1084-primOpTag (VecReadOffAddrOp WordVec 32 W8) = 1085-primOpTag (VecReadOffAddrOp WordVec 16 W16) = 1086-primOpTag (VecReadOffAddrOp WordVec 8 W32) = 1087-primOpTag (VecReadOffAddrOp WordVec 4 W64) = 1088-primOpTag (VecReadOffAddrOp WordVec 64 W8) = 1089-primOpTag (VecReadOffAddrOp WordVec 32 W16) = 1090-primOpTag (VecReadOffAddrOp WordVec 16 W32) = 1091-primOpTag (VecReadOffAddrOp WordVec 8 W64) = 1092-primOpTag (VecReadOffAddrOp FloatVec 4 W32) = 1093-primOpTag (VecReadOffAddrOp FloatVec 2 W64) = 1094-primOpTag (VecReadOffAddrOp FloatVec 8 W32) = 1095-primOpTag (VecReadOffAddrOp FloatVec 4 W64) = 1096-primOpTag (VecReadOffAddrOp FloatVec 16 W32) = 1097-primOpTag (VecReadOffAddrOp FloatVec 8 W64) = 1098-primOpTag (VecWriteOffAddrOp IntVec 16 W8) = 1099-primOpTag (VecWriteOffAddrOp IntVec 8 W16) = 1100-primOpTag (VecWriteOffAddrOp IntVec 4 W32) = 1101-primOpTag (VecWriteOffAddrOp IntVec 2 W64) = 1102-primOpTag (VecWriteOffAddrOp IntVec 32 W8) = 1103-primOpTag (VecWriteOffAddrOp IntVec 16 W16) = 1104-primOpTag (VecWriteOffAddrOp IntVec 8 W32) = 1105-primOpTag (VecWriteOffAddrOp IntVec 4 W64) = 1106-primOpTag (VecWriteOffAddrOp IntVec 64 W8) = 1107-primOpTag (VecWriteOffAddrOp IntVec 32 W16) = 1108-primOpTag (VecWriteOffAddrOp IntVec 16 W32) = 1109-primOpTag (VecWriteOffAddrOp IntVec 8 W64) = 1110-primOpTag (VecWriteOffAddrOp WordVec 16 W8) = 1111-primOpTag (VecWriteOffAddrOp WordVec 8 W16) = 1112-primOpTag (VecWriteOffAddrOp WordVec 4 W32) = 1113-primOpTag (VecWriteOffAddrOp WordVec 2 W64) = 1114-primOpTag (VecWriteOffAddrOp WordVec 32 W8) = 1115-primOpTag (VecWriteOffAddrOp WordVec 16 W16) = 1116-primOpTag (VecWriteOffAddrOp WordVec 8 W32) = 1117-primOpTag (VecWriteOffAddrOp WordVec 4 W64) = 1118-primOpTag (VecWriteOffAddrOp WordVec 64 W8) = 1119-primOpTag (VecWriteOffAddrOp WordVec 32 W16) = 1120-primOpTag (VecWriteOffAddrOp WordVec 16 W32) = 1121-primOpTag (VecWriteOffAddrOp WordVec 8 W64) = 1122-primOpTag (VecWriteOffAddrOp FloatVec 4 W32) = 1123-primOpTag (VecWriteOffAddrOp FloatVec 2 W64) = 1124-primOpTag (VecWriteOffAddrOp FloatVec 8 W32) = 1125-primOpTag (VecWriteOffAddrOp FloatVec 4 W64) = 1126-primOpTag (VecWriteOffAddrOp FloatVec 16 W32) = 1127-primOpTag (VecWriteOffAddrOp FloatVec 8 W64) = 1128-primOpTag (VecIndexScalarByteArrayOp IntVec 16 W8) = 1129-primOpTag (VecIndexScalarByteArrayOp IntVec 8 W16) = 1130-primOpTag (VecIndexScalarByteArrayOp IntVec 4 W32) = 1131-primOpTag (VecIndexScalarByteArrayOp IntVec 2 W64) = 1132-primOpTag (VecIndexScalarByteArrayOp IntVec 32 W8) = 1133-primOpTag (VecIndexScalarByteArrayOp IntVec 16 W16) = 1134-primOpTag (VecIndexScalarByteArrayOp IntVec 8 W32) = 1135-primOpTag (VecIndexScalarByteArrayOp IntVec 4 W64) = 1136-primOpTag (VecIndexScalarByteArrayOp IntVec 64 W8) = 1137-primOpTag (VecIndexScalarByteArrayOp IntVec 32 W16) = 1138-primOpTag (VecIndexScalarByteArrayOp IntVec 16 W32) = 1139-primOpTag (VecIndexScalarByteArrayOp IntVec 8 W64) = 1140-primOpTag (VecIndexScalarByteArrayOp WordVec 16 W8) = 1141-primOpTag (VecIndexScalarByteArrayOp WordVec 8 W16) = 1142-primOpTag (VecIndexScalarByteArrayOp WordVec 4 W32) = 1143-primOpTag (VecIndexScalarByteArrayOp WordVec 2 W64) = 1144-primOpTag (VecIndexScalarByteArrayOp WordVec 32 W8) = 1145-primOpTag (VecIndexScalarByteArrayOp WordVec 16 W16) = 1146-primOpTag (VecIndexScalarByteArrayOp WordVec 8 W32) = 1147-primOpTag (VecIndexScalarByteArrayOp WordVec 4 W64) = 1148-primOpTag (VecIndexScalarByteArrayOp WordVec 64 W8) = 1149-primOpTag (VecIndexScalarByteArrayOp WordVec 32 W16) = 1150-primOpTag (VecIndexScalarByteArrayOp WordVec 16 W32) = 1151-primOpTag (VecIndexScalarByteArrayOp WordVec 8 W64) = 1152-primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W32) = 1153-primOpTag (VecIndexScalarByteArrayOp FloatVec 2 W64) = 1154-primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W32) = 1155-primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W64) = 1156-primOpTag (VecIndexScalarByteArrayOp FloatVec 16 W32) = 1157-primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W64) = 1158-primOpTag (VecReadScalarByteArrayOp IntVec 16 W8) = 1159-primOpTag (VecReadScalarByteArrayOp IntVec 8 W16) = 1160-primOpTag (VecReadScalarByteArrayOp IntVec 4 W32) = 1161-primOpTag (VecReadScalarByteArrayOp IntVec 2 W64) = 1162-primOpTag (VecReadScalarByteArrayOp IntVec 32 W8) = 1163-primOpTag (VecReadScalarByteArrayOp IntVec 16 W16) = 1164-primOpTag (VecReadScalarByteArrayOp IntVec 8 W32) = 1165-primOpTag (VecReadScalarByteArrayOp IntVec 4 W64) = 1166-primOpTag (VecReadScalarByteArrayOp IntVec 64 W8) = 1167-primOpTag (VecReadScalarByteArrayOp IntVec 32 W16) = 1168-primOpTag (VecReadScalarByteArrayOp IntVec 16 W32) = 1169-primOpTag (VecReadScalarByteArrayOp IntVec 8 W64) = 1170-primOpTag (VecReadScalarByteArrayOp WordVec 16 W8) = 1171-primOpTag (VecReadScalarByteArrayOp WordVec 8 W16) = 1172-primOpTag (VecReadScalarByteArrayOp WordVec 4 W32) = 1173-primOpTag (VecReadScalarByteArrayOp WordVec 2 W64) = 1174-primOpTag (VecReadScalarByteArrayOp WordVec 32 W8) = 1175-primOpTag (VecReadScalarByteArrayOp WordVec 16 W16) = 1176-primOpTag (VecReadScalarByteArrayOp WordVec 8 W32) = 1177-primOpTag (VecReadScalarByteArrayOp WordVec 4 W64) = 1178-primOpTag (VecReadScalarByteArrayOp WordVec 64 W8) = 1179-primOpTag (VecReadScalarByteArrayOp WordVec 32 W16) = 1180-primOpTag (VecReadScalarByteArrayOp WordVec 16 W32) = 1181-primOpTag (VecReadScalarByteArrayOp WordVec 8 W64) = 1182-primOpTag (VecReadScalarByteArrayOp FloatVec 4 W32) = 1183-primOpTag (VecReadScalarByteArrayOp FloatVec 2 W64) = 1184-primOpTag (VecReadScalarByteArrayOp FloatVec 8 W32) = 1185-primOpTag (VecReadScalarByteArrayOp FloatVec 4 W64) = 1186-primOpTag (VecReadScalarByteArrayOp FloatVec 16 W32) = 1187-primOpTag (VecReadScalarByteArrayOp FloatVec 8 W64) = 1188-primOpTag (VecWriteScalarByteArrayOp IntVec 16 W8) = 1189-primOpTag (VecWriteScalarByteArrayOp IntVec 8 W16) = 1190-primOpTag (VecWriteScalarByteArrayOp IntVec 4 W32) = 1191-primOpTag (VecWriteScalarByteArrayOp IntVec 2 W64) = 1192-primOpTag (VecWriteScalarByteArrayOp IntVec 32 W8) = 1193-primOpTag (VecWriteScalarByteArrayOp IntVec 16 W16) = 1194-primOpTag (VecWriteScalarByteArrayOp IntVec 8 W32) = 1195-primOpTag (VecWriteScalarByteArrayOp IntVec 4 W64) = 1196-primOpTag (VecWriteScalarByteArrayOp IntVec 64 W8) = 1197-primOpTag (VecWriteScalarByteArrayOp IntVec 32 W16) = 1198-primOpTag (VecWriteScalarByteArrayOp IntVec 16 W32) = 1199-primOpTag (VecWriteScalarByteArrayOp IntVec 8 W64) = 1200-primOpTag (VecWriteScalarByteArrayOp WordVec 16 W8) = 1201-primOpTag (VecWriteScalarByteArrayOp WordVec 8 W16) = 1202-primOpTag (VecWriteScalarByteArrayOp WordVec 4 W32) = 1203-primOpTag (VecWriteScalarByteArrayOp WordVec 2 W64) = 1204-primOpTag (VecWriteScalarByteArrayOp WordVec 32 W8) = 1205-primOpTag (VecWriteScalarByteArrayOp WordVec 16 W16) = 1206-primOpTag (VecWriteScalarByteArrayOp WordVec 8 W32) = 1207-primOpTag (VecWriteScalarByteArrayOp WordVec 4 W64) = 1208-primOpTag (VecWriteScalarByteArrayOp WordVec 64 W8) = 1209-primOpTag (VecWriteScalarByteArrayOp WordVec 32 W16) = 1210-primOpTag (VecWriteScalarByteArrayOp WordVec 16 W32) = 1211-primOpTag (VecWriteScalarByteArrayOp WordVec 8 W64) = 1212-primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W32) = 1213-primOpTag (VecWriteScalarByteArrayOp FloatVec 2 W64) = 1214-primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W32) = 1215-primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W64) = 1216-primOpTag (VecWriteScalarByteArrayOp FloatVec 16 W32) = 1217-primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W64) = 1218-primOpTag (VecIndexScalarOffAddrOp IntVec 16 W8) = 1219-primOpTag (VecIndexScalarOffAddrOp IntVec 8 W16) = 1220-primOpTag (VecIndexScalarOffAddrOp IntVec 4 W32) = 1221-primOpTag (VecIndexScalarOffAddrOp IntVec 2 W64) = 1222-primOpTag (VecIndexScalarOffAddrOp IntVec 32 W8) = 1223-primOpTag (VecIndexScalarOffAddrOp IntVec 16 W16) = 1224-primOpTag (VecIndexScalarOffAddrOp IntVec 8 W32) = 1225-primOpTag (VecIndexScalarOffAddrOp IntVec 4 W64) = 1226-primOpTag (VecIndexScalarOffAddrOp IntVec 64 W8) = 1227-primOpTag (VecIndexScalarOffAddrOp IntVec 32 W16) = 1228-primOpTag (VecIndexScalarOffAddrOp IntVec 16 W32) = 1229-primOpTag (VecIndexScalarOffAddrOp IntVec 8 W64) = 1230-primOpTag (VecIndexScalarOffAddrOp WordVec 16 W8) = 1231-primOpTag (VecIndexScalarOffAddrOp WordVec 8 W16) = 1232-primOpTag (VecIndexScalarOffAddrOp WordVec 4 W32) = 1233-primOpTag (VecIndexScalarOffAddrOp WordVec 2 W64) = 1234-primOpTag (VecIndexScalarOffAddrOp WordVec 32 W8) = 1235-primOpTag (VecIndexScalarOffAddrOp WordVec 16 W16) = 1236-primOpTag (VecIndexScalarOffAddrOp WordVec 8 W32) = 1237-primOpTag (VecIndexScalarOffAddrOp WordVec 4 W64) = 1238-primOpTag (VecIndexScalarOffAddrOp WordVec 64 W8) = 1239-primOpTag (VecIndexScalarOffAddrOp WordVec 32 W16) = 1240-primOpTag (VecIndexScalarOffAddrOp WordVec 16 W32) = 1241-primOpTag (VecIndexScalarOffAddrOp WordVec 8 W64) = 1242-primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W32) = 1243-primOpTag (VecIndexScalarOffAddrOp FloatVec 2 W64) = 1244-primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W32) = 1245-primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W64) = 1246-primOpTag (VecIndexScalarOffAddrOp FloatVec 16 W32) = 1247-primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W64) = 1248-primOpTag (VecReadScalarOffAddrOp IntVec 16 W8) = 1249-primOpTag (VecReadScalarOffAddrOp IntVec 8 W16) = 1250-primOpTag (VecReadScalarOffAddrOp IntVec 4 W32) = 1251-primOpTag (VecReadScalarOffAddrOp IntVec 2 W64) = 1252-primOpTag (VecReadScalarOffAddrOp IntVec 32 W8) = 1253-primOpTag (VecReadScalarOffAddrOp IntVec 16 W16) = 1254-primOpTag (VecReadScalarOffAddrOp IntVec 8 W32) = 1255-primOpTag (VecReadScalarOffAddrOp IntVec 4 W64) = 1256-primOpTag (VecReadScalarOffAddrOp IntVec 64 W8) = 1257-primOpTag (VecReadScalarOffAddrOp IntVec 32 W16) = 1258-primOpTag (VecReadScalarOffAddrOp IntVec 16 W32) = 1259-primOpTag (VecReadScalarOffAddrOp IntVec 8 W64) = 1260-primOpTag (VecReadScalarOffAddrOp WordVec 16 W8) = 1261-primOpTag (VecReadScalarOffAddrOp WordVec 8 W16) = 1262-primOpTag (VecReadScalarOffAddrOp WordVec 4 W32) = 1263-primOpTag (VecReadScalarOffAddrOp WordVec 2 W64) = 1264-primOpTag (VecReadScalarOffAddrOp WordVec 32 W8) = 1265-primOpTag (VecReadScalarOffAddrOp WordVec 16 W16) = 1266-primOpTag (VecReadScalarOffAddrOp WordVec 8 W32) = 1267-primOpTag (VecReadScalarOffAddrOp WordVec 4 W64) = 1268-primOpTag (VecReadScalarOffAddrOp WordVec 64 W8) = 1269-primOpTag (VecReadScalarOffAddrOp WordVec 32 W16) = 1270-primOpTag (VecReadScalarOffAddrOp WordVec 16 W32) = 1271-primOpTag (VecReadScalarOffAddrOp WordVec 8 W64) = 1272-primOpTag (VecReadScalarOffAddrOp FloatVec 4 W32) = 1273-primOpTag (VecReadScalarOffAddrOp FloatVec 2 W64) = 1274-primOpTag (VecReadScalarOffAddrOp FloatVec 8 W32) = 1275-primOpTag (VecReadScalarOffAddrOp FloatVec 4 W64) = 1276-primOpTag (VecReadScalarOffAddrOp FloatVec 16 W32) = 1277-primOpTag (VecReadScalarOffAddrOp FloatVec 8 W64) = 1278-primOpTag (VecWriteScalarOffAddrOp IntVec 16 W8) = 1279-primOpTag (VecWriteScalarOffAddrOp IntVec 8 W16) = 1280-primOpTag (VecWriteScalarOffAddrOp IntVec 4 W32) = 1281-primOpTag (VecWriteScalarOffAddrOp IntVec 2 W64) = 1282-primOpTag (VecWriteScalarOffAddrOp IntVec 32 W8) = 1283-primOpTag (VecWriteScalarOffAddrOp IntVec 16 W16) = 1284-primOpTag (VecWriteScalarOffAddrOp IntVec 8 W32) = 1285-primOpTag (VecWriteScalarOffAddrOp IntVec 4 W64) = 1286-primOpTag (VecWriteScalarOffAddrOp IntVec 64 W8) = 1287-primOpTag (VecWriteScalarOffAddrOp IntVec 32 W16) = 1288-primOpTag (VecWriteScalarOffAddrOp IntVec 16 W32) = 1289-primOpTag (VecWriteScalarOffAddrOp IntVec 8 W64) = 1290-primOpTag (VecWriteScalarOffAddrOp WordVec 16 W8) = 1291-primOpTag (VecWriteScalarOffAddrOp WordVec 8 W16) = 1292-primOpTag (VecWriteScalarOffAddrOp WordVec 4 W32) = 1293-primOpTag (VecWriteScalarOffAddrOp WordVec 2 W64) = 1294-primOpTag (VecWriteScalarOffAddrOp WordVec 32 W8) = 1295-primOpTag (VecWriteScalarOffAddrOp WordVec 16 W16) = 1296-primOpTag (VecWriteScalarOffAddrOp WordVec 8 W32) = 1297-primOpTag (VecWriteScalarOffAddrOp WordVec 4 W64) = 1298-primOpTag (VecWriteScalarOffAddrOp WordVec 64 W8) = 1299-primOpTag (VecWriteScalarOffAddrOp WordVec 32 W16) = 1300-primOpTag (VecWriteScalarOffAddrOp WordVec 16 W32) = 1301-primOpTag (VecWriteScalarOffAddrOp WordVec 8 W64) = 1302-primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W32) = 1303-primOpTag (VecWriteScalarOffAddrOp FloatVec 2 W64) = 1304-primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W32) = 1305-primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W64) = 1306-primOpTag (VecWriteScalarOffAddrOp FloatVec 16 W32) = 1307-primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W64) = 1308-primOpTag PrefetchByteArrayOp3 = 1309-primOpTag PrefetchMutableByteArrayOp3 = 1310-primOpTag PrefetchAddrOp3 = 1311-primOpTag PrefetchValueOp3 = 1312-primOpTag PrefetchByteArrayOp2 = 1313-primOpTag PrefetchMutableByteArrayOp2 = 1314-primOpTag PrefetchAddrOp2 = 1315-primOpTag PrefetchValueOp2 = 1316-primOpTag PrefetchByteArrayOp1 = 1317-primOpTag PrefetchMutableByteArrayOp1 = 1318-primOpTag PrefetchAddrOp1 = 1319-primOpTag PrefetchValueOp1 = 1320-primOpTag PrefetchByteArrayOp0 = 1321-primOpTag PrefetchMutableByteArrayOp0 = 1322-primOpTag PrefetchAddrOp0 = 1323-primOpTag PrefetchValueOp0 = 1324+maxPrimOpTag = 1372+primOpTag :: PrimOp -> Int+primOpTag CharGtOp = 0+primOpTag CharGeOp = 1+primOpTag CharEqOp = 2+primOpTag CharNeOp = 3+primOpTag CharLtOp = 4+primOpTag CharLeOp = 5+primOpTag OrdOp = 6+primOpTag Int8ToIntOp = 7+primOpTag IntToInt8Op = 8+primOpTag Int8NegOp = 9+primOpTag Int8AddOp = 10+primOpTag Int8SubOp = 11+primOpTag Int8MulOp = 12+primOpTag Int8QuotOp = 13+primOpTag Int8RemOp = 14+primOpTag Int8QuotRemOp = 15+primOpTag Int8SllOp = 16+primOpTag Int8SraOp = 17+primOpTag Int8SrlOp = 18+primOpTag Int8ToWord8Op = 19+primOpTag Int8EqOp = 20+primOpTag Int8GeOp = 21+primOpTag Int8GtOp = 22+primOpTag Int8LeOp = 23+primOpTag Int8LtOp = 24+primOpTag Int8NeOp = 25+primOpTag Word8ToWordOp = 26+primOpTag WordToWord8Op = 27+primOpTag Word8AddOp = 28+primOpTag Word8SubOp = 29+primOpTag Word8MulOp = 30+primOpTag Word8QuotOp = 31+primOpTag Word8RemOp = 32+primOpTag Word8QuotRemOp = 33+primOpTag Word8AndOp = 34+primOpTag Word8OrOp = 35+primOpTag Word8XorOp = 36+primOpTag Word8NotOp = 37+primOpTag Word8SllOp = 38+primOpTag Word8SrlOp = 39+primOpTag Word8ToInt8Op = 40+primOpTag Word8EqOp = 41+primOpTag Word8GeOp = 42+primOpTag Word8GtOp = 43+primOpTag Word8LeOp = 44+primOpTag Word8LtOp = 45+primOpTag Word8NeOp = 46+primOpTag Int16ToIntOp = 47+primOpTag IntToInt16Op = 48+primOpTag Int16NegOp = 49+primOpTag Int16AddOp = 50+primOpTag Int16SubOp = 51+primOpTag Int16MulOp = 52+primOpTag Int16QuotOp = 53+primOpTag Int16RemOp = 54+primOpTag Int16QuotRemOp = 55+primOpTag Int16SllOp = 56+primOpTag Int16SraOp = 57+primOpTag Int16SrlOp = 58+primOpTag Int16ToWord16Op = 59+primOpTag Int16EqOp = 60+primOpTag Int16GeOp = 61+primOpTag Int16GtOp = 62+primOpTag Int16LeOp = 63+primOpTag Int16LtOp = 64+primOpTag Int16NeOp = 65+primOpTag Word16ToWordOp = 66+primOpTag WordToWord16Op = 67+primOpTag Word16AddOp = 68+primOpTag Word16SubOp = 69+primOpTag Word16MulOp = 70+primOpTag Word16QuotOp = 71+primOpTag Word16RemOp = 72+primOpTag Word16QuotRemOp = 73+primOpTag Word16AndOp = 74+primOpTag Word16OrOp = 75+primOpTag Word16XorOp = 76+primOpTag Word16NotOp = 77+primOpTag Word16SllOp = 78+primOpTag Word16SrlOp = 79+primOpTag Word16ToInt16Op = 80+primOpTag Word16EqOp = 81+primOpTag Word16GeOp = 82+primOpTag Word16GtOp = 83+primOpTag Word16LeOp = 84+primOpTag Word16LtOp = 85+primOpTag Word16NeOp = 86+primOpTag Int32ToIntOp = 87+primOpTag IntToInt32Op = 88+primOpTag Int32NegOp = 89+primOpTag Int32AddOp = 90+primOpTag Int32SubOp = 91+primOpTag Int32MulOp = 92+primOpTag Int32QuotOp = 93+primOpTag Int32RemOp = 94+primOpTag Int32QuotRemOp = 95+primOpTag Int32SllOp = 96+primOpTag Int32SraOp = 97+primOpTag Int32SrlOp = 98+primOpTag Int32ToWord32Op = 99+primOpTag Int32EqOp = 100+primOpTag Int32GeOp = 101+primOpTag Int32GtOp = 102+primOpTag Int32LeOp = 103+primOpTag Int32LtOp = 104+primOpTag Int32NeOp = 105+primOpTag Word32ToWordOp = 106+primOpTag WordToWord32Op = 107+primOpTag Word32AddOp = 108+primOpTag Word32SubOp = 109+primOpTag Word32MulOp = 110+primOpTag Word32QuotOp = 111+primOpTag Word32RemOp = 112+primOpTag Word32QuotRemOp = 113+primOpTag Word32AndOp = 114+primOpTag Word32OrOp = 115+primOpTag Word32XorOp = 116+primOpTag Word32NotOp = 117+primOpTag Word32SllOp = 118+primOpTag Word32SrlOp = 119+primOpTag Word32ToInt32Op = 120+primOpTag Word32EqOp = 121+primOpTag Word32GeOp = 122+primOpTag Word32GtOp = 123+primOpTag Word32LeOp = 124+primOpTag Word32LtOp = 125+primOpTag Word32NeOp = 126+primOpTag Int64ToIntOp = 127+primOpTag IntToInt64Op = 128+primOpTag Int64NegOp = 129+primOpTag Int64AddOp = 130+primOpTag Int64SubOp = 131+primOpTag Int64MulOp = 132+primOpTag Int64QuotOp = 133+primOpTag Int64RemOp = 134+primOpTag Int64SllOp = 135+primOpTag Int64SraOp = 136+primOpTag Int64SrlOp = 137+primOpTag Int64ToWord64Op = 138+primOpTag Int64EqOp = 139+primOpTag Int64GeOp = 140+primOpTag Int64GtOp = 141+primOpTag Int64LeOp = 142+primOpTag Int64LtOp = 143+primOpTag Int64NeOp = 144+primOpTag Word64ToWordOp = 145+primOpTag WordToWord64Op = 146+primOpTag Word64AddOp = 147+primOpTag Word64SubOp = 148+primOpTag Word64MulOp = 149+primOpTag Word64QuotOp = 150+primOpTag Word64RemOp = 151+primOpTag Word64AndOp = 152+primOpTag Word64OrOp = 153+primOpTag Word64XorOp = 154+primOpTag Word64NotOp = 155+primOpTag Word64SllOp = 156+primOpTag Word64SrlOp = 157+primOpTag Word64ToInt64Op = 158+primOpTag Word64EqOp = 159+primOpTag Word64GeOp = 160+primOpTag Word64GtOp = 161+primOpTag Word64LeOp = 162+primOpTag Word64LtOp = 163+primOpTag Word64NeOp = 164+primOpTag IntAddOp = 165+primOpTag IntSubOp = 166+primOpTag IntMulOp = 167+primOpTag IntMul2Op = 168+primOpTag IntMulMayOfloOp = 169+primOpTag IntQuotOp = 170+primOpTag IntRemOp = 171+primOpTag IntQuotRemOp = 172+primOpTag IntAndOp = 173+primOpTag IntOrOp = 174+primOpTag IntXorOp = 175+primOpTag IntNotOp = 176+primOpTag IntNegOp = 177+primOpTag IntAddCOp = 178+primOpTag IntSubCOp = 179+primOpTag IntGtOp = 180+primOpTag IntGeOp = 181+primOpTag IntEqOp = 182+primOpTag IntNeOp = 183+primOpTag IntLtOp = 184+primOpTag IntLeOp = 185+primOpTag ChrOp = 186+primOpTag IntToWordOp = 187+primOpTag IntToFloatOp = 188+primOpTag IntToDoubleOp = 189+primOpTag WordToFloatOp = 190+primOpTag WordToDoubleOp = 191+primOpTag IntSllOp = 192+primOpTag IntSraOp = 193+primOpTag IntSrlOp = 194+primOpTag WordAddOp = 195+primOpTag WordAddCOp = 196+primOpTag WordSubCOp = 197+primOpTag WordAdd2Op = 198+primOpTag WordSubOp = 199+primOpTag WordMulOp = 200+primOpTag WordMul2Op = 201+primOpTag WordQuotOp = 202+primOpTag WordRemOp = 203+primOpTag WordQuotRemOp = 204+primOpTag WordQuotRem2Op = 205+primOpTag WordAndOp = 206+primOpTag WordOrOp = 207+primOpTag WordXorOp = 208+primOpTag WordNotOp = 209+primOpTag WordSllOp = 210+primOpTag WordSrlOp = 211+primOpTag WordToIntOp = 212+primOpTag WordGtOp = 213+primOpTag WordGeOp = 214+primOpTag WordEqOp = 215+primOpTag WordNeOp = 216+primOpTag WordLtOp = 217+primOpTag WordLeOp = 218+primOpTag PopCnt8Op = 219+primOpTag PopCnt16Op = 220+primOpTag PopCnt32Op = 221+primOpTag PopCnt64Op = 222+primOpTag PopCntOp = 223+primOpTag Pdep8Op = 224+primOpTag Pdep16Op = 225+primOpTag Pdep32Op = 226+primOpTag Pdep64Op = 227+primOpTag PdepOp = 228+primOpTag Pext8Op = 229+primOpTag Pext16Op = 230+primOpTag Pext32Op = 231+primOpTag Pext64Op = 232+primOpTag PextOp = 233+primOpTag Clz8Op = 234+primOpTag Clz16Op = 235+primOpTag Clz32Op = 236+primOpTag Clz64Op = 237+primOpTag ClzOp = 238+primOpTag Ctz8Op = 239+primOpTag Ctz16Op = 240+primOpTag Ctz32Op = 241+primOpTag Ctz64Op = 242+primOpTag CtzOp = 243+primOpTag BSwap16Op = 244+primOpTag BSwap32Op = 245+primOpTag BSwap64Op = 246+primOpTag BSwapOp = 247+primOpTag BRev8Op = 248+primOpTag BRev16Op = 249+primOpTag BRev32Op = 250+primOpTag BRev64Op = 251+primOpTag BRevOp = 252+primOpTag Narrow8IntOp = 253+primOpTag Narrow16IntOp = 254+primOpTag Narrow32IntOp = 255+primOpTag Narrow8WordOp = 256+primOpTag Narrow16WordOp = 257+primOpTag Narrow32WordOp = 258+primOpTag DoubleGtOp = 259+primOpTag DoubleGeOp = 260+primOpTag DoubleEqOp = 261+primOpTag DoubleNeOp = 262+primOpTag DoubleLtOp = 263+primOpTag DoubleLeOp = 264+primOpTag DoubleAddOp = 265+primOpTag DoubleSubOp = 266+primOpTag DoubleMulOp = 267+primOpTag DoubleDivOp = 268+primOpTag DoubleNegOp = 269+primOpTag DoubleFabsOp = 270+primOpTag DoubleToIntOp = 271+primOpTag DoubleToFloatOp = 272+primOpTag DoubleExpOp = 273+primOpTag DoubleExpM1Op = 274+primOpTag DoubleLogOp = 275+primOpTag DoubleLog1POp = 276+primOpTag DoubleSqrtOp = 277+primOpTag DoubleSinOp = 278+primOpTag DoubleCosOp = 279+primOpTag DoubleTanOp = 280+primOpTag DoubleAsinOp = 281+primOpTag DoubleAcosOp = 282+primOpTag DoubleAtanOp = 283+primOpTag DoubleSinhOp = 284+primOpTag DoubleCoshOp = 285+primOpTag DoubleTanhOp = 286+primOpTag DoubleAsinhOp = 287+primOpTag DoubleAcoshOp = 288+primOpTag DoubleAtanhOp = 289+primOpTag DoublePowerOp = 290+primOpTag DoubleDecode_2IntOp = 291+primOpTag DoubleDecode_Int64Op = 292+primOpTag CastDoubleToWord64Op = 293+primOpTag CastWord64ToDoubleOp = 294+primOpTag FloatGtOp = 295+primOpTag FloatGeOp = 296+primOpTag FloatEqOp = 297+primOpTag FloatNeOp = 298+primOpTag FloatLtOp = 299+primOpTag FloatLeOp = 300+primOpTag FloatAddOp = 301+primOpTag FloatSubOp = 302+primOpTag FloatMulOp = 303+primOpTag FloatDivOp = 304+primOpTag FloatNegOp = 305+primOpTag FloatFabsOp = 306+primOpTag FloatToIntOp = 307+primOpTag FloatExpOp = 308+primOpTag FloatExpM1Op = 309+primOpTag FloatLogOp = 310+primOpTag FloatLog1POp = 311+primOpTag FloatSqrtOp = 312+primOpTag FloatSinOp = 313+primOpTag FloatCosOp = 314+primOpTag FloatTanOp = 315+primOpTag FloatAsinOp = 316+primOpTag FloatAcosOp = 317+primOpTag FloatAtanOp = 318+primOpTag FloatSinhOp = 319+primOpTag FloatCoshOp = 320+primOpTag FloatTanhOp = 321+primOpTag FloatAsinhOp = 322+primOpTag FloatAcoshOp = 323+primOpTag FloatAtanhOp = 324+primOpTag FloatPowerOp = 325+primOpTag FloatToDoubleOp = 326+primOpTag FloatDecode_IntOp = 327+primOpTag CastFloatToWord32Op = 328+primOpTag CastWord32ToFloatOp = 329+primOpTag FloatFMAdd = 330+primOpTag FloatFMSub = 331+primOpTag FloatFNMAdd = 332+primOpTag FloatFNMSub = 333+primOpTag DoubleFMAdd = 334+primOpTag DoubleFMSub = 335+primOpTag DoubleFNMAdd = 336+primOpTag DoubleFNMSub = 337+primOpTag NewArrayOp = 338+primOpTag ReadArrayOp = 339+primOpTag WriteArrayOp = 340+primOpTag SizeofArrayOp = 341+primOpTag SizeofMutableArrayOp = 342+primOpTag IndexArrayOp = 343+primOpTag UnsafeFreezeArrayOp = 344+primOpTag UnsafeThawArrayOp = 345+primOpTag CopyArrayOp = 346+primOpTag CopyMutableArrayOp = 347+primOpTag CloneArrayOp = 348+primOpTag CloneMutableArrayOp = 349+primOpTag FreezeArrayOp = 350+primOpTag ThawArrayOp = 351+primOpTag CasArrayOp = 352+primOpTag NewSmallArrayOp = 353+primOpTag ShrinkSmallMutableArrayOp_Char = 354+primOpTag ReadSmallArrayOp = 355+primOpTag WriteSmallArrayOp = 356+primOpTag SizeofSmallArrayOp = 357+primOpTag SizeofSmallMutableArrayOp = 358+primOpTag GetSizeofSmallMutableArrayOp = 359+primOpTag IndexSmallArrayOp = 360+primOpTag UnsafeFreezeSmallArrayOp = 361+primOpTag UnsafeThawSmallArrayOp = 362+primOpTag CopySmallArrayOp = 363+primOpTag CopySmallMutableArrayOp = 364+primOpTag CloneSmallArrayOp = 365+primOpTag CloneSmallMutableArrayOp = 366+primOpTag FreezeSmallArrayOp = 367+primOpTag ThawSmallArrayOp = 368+primOpTag CasSmallArrayOp = 369+primOpTag NewByteArrayOp_Char = 370+primOpTag NewPinnedByteArrayOp_Char = 371+primOpTag NewAlignedPinnedByteArrayOp_Char = 372+primOpTag MutableByteArrayIsPinnedOp = 373+primOpTag ByteArrayIsPinnedOp = 374+primOpTag ByteArrayContents_Char = 375+primOpTag MutableByteArrayContents_Char = 376+primOpTag ShrinkMutableByteArrayOp_Char = 377+primOpTag ResizeMutableByteArrayOp_Char = 378+primOpTag UnsafeFreezeByteArrayOp = 379+primOpTag UnsafeThawByteArrayOp = 380+primOpTag SizeofByteArrayOp = 381+primOpTag SizeofMutableByteArrayOp = 382+primOpTag GetSizeofMutableByteArrayOp = 383+primOpTag IndexByteArrayOp_Char = 384+primOpTag IndexByteArrayOp_WideChar = 385+primOpTag IndexByteArrayOp_Int = 386+primOpTag IndexByteArrayOp_Word = 387+primOpTag IndexByteArrayOp_Addr = 388+primOpTag IndexByteArrayOp_Float = 389+primOpTag IndexByteArrayOp_Double = 390+primOpTag IndexByteArrayOp_StablePtr = 391+primOpTag IndexByteArrayOp_Int8 = 392+primOpTag IndexByteArrayOp_Word8 = 393+primOpTag IndexByteArrayOp_Int16 = 394+primOpTag IndexByteArrayOp_Word16 = 395+primOpTag IndexByteArrayOp_Int32 = 396+primOpTag IndexByteArrayOp_Word32 = 397+primOpTag IndexByteArrayOp_Int64 = 398+primOpTag IndexByteArrayOp_Word64 = 399+primOpTag IndexByteArrayOp_Word8AsChar = 400+primOpTag IndexByteArrayOp_Word8AsWideChar = 401+primOpTag IndexByteArrayOp_Word8AsInt = 402+primOpTag IndexByteArrayOp_Word8AsWord = 403+primOpTag IndexByteArrayOp_Word8AsAddr = 404+primOpTag IndexByteArrayOp_Word8AsFloat = 405+primOpTag IndexByteArrayOp_Word8AsDouble = 406+primOpTag IndexByteArrayOp_Word8AsStablePtr = 407+primOpTag IndexByteArrayOp_Word8AsInt16 = 408+primOpTag IndexByteArrayOp_Word8AsWord16 = 409+primOpTag IndexByteArrayOp_Word8AsInt32 = 410+primOpTag IndexByteArrayOp_Word8AsWord32 = 411+primOpTag IndexByteArrayOp_Word8AsInt64 = 412+primOpTag IndexByteArrayOp_Word8AsWord64 = 413+primOpTag ReadByteArrayOp_Char = 414+primOpTag ReadByteArrayOp_WideChar = 415+primOpTag ReadByteArrayOp_Int = 416+primOpTag ReadByteArrayOp_Word = 417+primOpTag ReadByteArrayOp_Addr = 418+primOpTag ReadByteArrayOp_Float = 419+primOpTag ReadByteArrayOp_Double = 420+primOpTag ReadByteArrayOp_StablePtr = 421+primOpTag ReadByteArrayOp_Int8 = 422+primOpTag ReadByteArrayOp_Word8 = 423+primOpTag ReadByteArrayOp_Int16 = 424+primOpTag ReadByteArrayOp_Word16 = 425+primOpTag ReadByteArrayOp_Int32 = 426+primOpTag ReadByteArrayOp_Word32 = 427+primOpTag ReadByteArrayOp_Int64 = 428+primOpTag ReadByteArrayOp_Word64 = 429+primOpTag ReadByteArrayOp_Word8AsChar = 430+primOpTag ReadByteArrayOp_Word8AsWideChar = 431+primOpTag ReadByteArrayOp_Word8AsInt = 432+primOpTag ReadByteArrayOp_Word8AsWord = 433+primOpTag ReadByteArrayOp_Word8AsAddr = 434+primOpTag ReadByteArrayOp_Word8AsFloat = 435+primOpTag ReadByteArrayOp_Word8AsDouble = 436+primOpTag ReadByteArrayOp_Word8AsStablePtr = 437+primOpTag ReadByteArrayOp_Word8AsInt16 = 438+primOpTag ReadByteArrayOp_Word8AsWord16 = 439+primOpTag ReadByteArrayOp_Word8AsInt32 = 440+primOpTag ReadByteArrayOp_Word8AsWord32 = 441+primOpTag ReadByteArrayOp_Word8AsInt64 = 442+primOpTag ReadByteArrayOp_Word8AsWord64 = 443+primOpTag WriteByteArrayOp_Char = 444+primOpTag WriteByteArrayOp_WideChar = 445+primOpTag WriteByteArrayOp_Int = 446+primOpTag WriteByteArrayOp_Word = 447+primOpTag WriteByteArrayOp_Addr = 448+primOpTag WriteByteArrayOp_Float = 449+primOpTag WriteByteArrayOp_Double = 450+primOpTag WriteByteArrayOp_StablePtr = 451+primOpTag WriteByteArrayOp_Int8 = 452+primOpTag WriteByteArrayOp_Word8 = 453+primOpTag WriteByteArrayOp_Int16 = 454+primOpTag WriteByteArrayOp_Word16 = 455+primOpTag WriteByteArrayOp_Int32 = 456+primOpTag WriteByteArrayOp_Word32 = 457+primOpTag WriteByteArrayOp_Int64 = 458+primOpTag WriteByteArrayOp_Word64 = 459+primOpTag WriteByteArrayOp_Word8AsChar = 460+primOpTag WriteByteArrayOp_Word8AsWideChar = 461+primOpTag WriteByteArrayOp_Word8AsInt = 462+primOpTag WriteByteArrayOp_Word8AsWord = 463+primOpTag WriteByteArrayOp_Word8AsAddr = 464+primOpTag WriteByteArrayOp_Word8AsFloat = 465+primOpTag WriteByteArrayOp_Word8AsDouble = 466+primOpTag WriteByteArrayOp_Word8AsStablePtr = 467+primOpTag WriteByteArrayOp_Word8AsInt16 = 468+primOpTag WriteByteArrayOp_Word8AsWord16 = 469+primOpTag WriteByteArrayOp_Word8AsInt32 = 470+primOpTag WriteByteArrayOp_Word8AsWord32 = 471+primOpTag WriteByteArrayOp_Word8AsInt64 = 472+primOpTag WriteByteArrayOp_Word8AsWord64 = 473+primOpTag CompareByteArraysOp = 474+primOpTag CopyByteArrayOp = 475+primOpTag CopyMutableByteArrayOp = 476+primOpTag CopyMutableByteArrayNonOverlappingOp = 477+primOpTag CopyByteArrayToAddrOp = 478+primOpTag CopyMutableByteArrayToAddrOp = 479+primOpTag CopyAddrToByteArrayOp = 480+primOpTag CopyAddrToAddrOp = 481+primOpTag CopyAddrToAddrNonOverlappingOp = 482+primOpTag SetByteArrayOp = 483+primOpTag SetAddrRangeOp = 484+primOpTag AtomicReadByteArrayOp_Int = 485+primOpTag AtomicWriteByteArrayOp_Int = 486+primOpTag CasByteArrayOp_Int = 487+primOpTag CasByteArrayOp_Int8 = 488+primOpTag CasByteArrayOp_Int16 = 489+primOpTag CasByteArrayOp_Int32 = 490+primOpTag CasByteArrayOp_Int64 = 491+primOpTag FetchAddByteArrayOp_Int = 492+primOpTag FetchSubByteArrayOp_Int = 493+primOpTag FetchAndByteArrayOp_Int = 494+primOpTag FetchNandByteArrayOp_Int = 495+primOpTag FetchOrByteArrayOp_Int = 496+primOpTag FetchXorByteArrayOp_Int = 497+primOpTag AddrAddOp = 498+primOpTag AddrSubOp = 499+primOpTag AddrRemOp = 500+primOpTag AddrToIntOp = 501+primOpTag IntToAddrOp = 502+primOpTag AddrGtOp = 503+primOpTag AddrGeOp = 504+primOpTag AddrEqOp = 505+primOpTag AddrNeOp = 506+primOpTag AddrLtOp = 507+primOpTag AddrLeOp = 508+primOpTag IndexOffAddrOp_Char = 509+primOpTag IndexOffAddrOp_WideChar = 510+primOpTag IndexOffAddrOp_Int = 511+primOpTag IndexOffAddrOp_Word = 512+primOpTag IndexOffAddrOp_Addr = 513+primOpTag IndexOffAddrOp_Float = 514+primOpTag IndexOffAddrOp_Double = 515+primOpTag IndexOffAddrOp_StablePtr = 516+primOpTag IndexOffAddrOp_Int8 = 517+primOpTag IndexOffAddrOp_Word8 = 518+primOpTag IndexOffAddrOp_Int16 = 519+primOpTag IndexOffAddrOp_Word16 = 520+primOpTag IndexOffAddrOp_Int32 = 521+primOpTag IndexOffAddrOp_Word32 = 522+primOpTag IndexOffAddrOp_Int64 = 523+primOpTag IndexOffAddrOp_Word64 = 524+primOpTag IndexOffAddrOp_Word8AsChar = 525+primOpTag IndexOffAddrOp_Word8AsWideChar = 526+primOpTag IndexOffAddrOp_Word8AsInt = 527+primOpTag IndexOffAddrOp_Word8AsWord = 528+primOpTag IndexOffAddrOp_Word8AsAddr = 529+primOpTag IndexOffAddrOp_Word8AsFloat = 530+primOpTag IndexOffAddrOp_Word8AsDouble = 531+primOpTag IndexOffAddrOp_Word8AsStablePtr = 532+primOpTag IndexOffAddrOp_Word8AsInt16 = 533+primOpTag IndexOffAddrOp_Word8AsWord16 = 534+primOpTag IndexOffAddrOp_Word8AsInt32 = 535+primOpTag IndexOffAddrOp_Word8AsWord32 = 536+primOpTag IndexOffAddrOp_Word8AsInt64 = 537+primOpTag IndexOffAddrOp_Word8AsWord64 = 538+primOpTag ReadOffAddrOp_Char = 539+primOpTag ReadOffAddrOp_WideChar = 540+primOpTag ReadOffAddrOp_Int = 541+primOpTag ReadOffAddrOp_Word = 542+primOpTag ReadOffAddrOp_Addr = 543+primOpTag ReadOffAddrOp_Float = 544+primOpTag ReadOffAddrOp_Double = 545+primOpTag ReadOffAddrOp_StablePtr = 546+primOpTag ReadOffAddrOp_Int8 = 547+primOpTag ReadOffAddrOp_Word8 = 548+primOpTag ReadOffAddrOp_Int16 = 549+primOpTag ReadOffAddrOp_Word16 = 550+primOpTag ReadOffAddrOp_Int32 = 551+primOpTag ReadOffAddrOp_Word32 = 552+primOpTag ReadOffAddrOp_Int64 = 553+primOpTag ReadOffAddrOp_Word64 = 554+primOpTag ReadOffAddrOp_Word8AsChar = 555+primOpTag ReadOffAddrOp_Word8AsWideChar = 556+primOpTag ReadOffAddrOp_Word8AsInt = 557+primOpTag ReadOffAddrOp_Word8AsWord = 558+primOpTag ReadOffAddrOp_Word8AsAddr = 559+primOpTag ReadOffAddrOp_Word8AsFloat = 560+primOpTag ReadOffAddrOp_Word8AsDouble = 561+primOpTag ReadOffAddrOp_Word8AsStablePtr = 562+primOpTag ReadOffAddrOp_Word8AsInt16 = 563+primOpTag ReadOffAddrOp_Word8AsWord16 = 564+primOpTag ReadOffAddrOp_Word8AsInt32 = 565+primOpTag ReadOffAddrOp_Word8AsWord32 = 566+primOpTag ReadOffAddrOp_Word8AsInt64 = 567+primOpTag ReadOffAddrOp_Word8AsWord64 = 568+primOpTag WriteOffAddrOp_Char = 569+primOpTag WriteOffAddrOp_WideChar = 570+primOpTag WriteOffAddrOp_Int = 571+primOpTag WriteOffAddrOp_Word = 572+primOpTag WriteOffAddrOp_Addr = 573+primOpTag WriteOffAddrOp_Float = 574+primOpTag WriteOffAddrOp_Double = 575+primOpTag WriteOffAddrOp_StablePtr = 576+primOpTag WriteOffAddrOp_Int8 = 577+primOpTag WriteOffAddrOp_Word8 = 578+primOpTag WriteOffAddrOp_Int16 = 579+primOpTag WriteOffAddrOp_Word16 = 580+primOpTag WriteOffAddrOp_Int32 = 581+primOpTag WriteOffAddrOp_Word32 = 582+primOpTag WriteOffAddrOp_Int64 = 583+primOpTag WriteOffAddrOp_Word64 = 584+primOpTag WriteOffAddrOp_Word8AsChar = 585+primOpTag WriteOffAddrOp_Word8AsWideChar = 586+primOpTag WriteOffAddrOp_Word8AsInt = 587+primOpTag WriteOffAddrOp_Word8AsWord = 588+primOpTag WriteOffAddrOp_Word8AsAddr = 589+primOpTag WriteOffAddrOp_Word8AsFloat = 590+primOpTag WriteOffAddrOp_Word8AsDouble = 591+primOpTag WriteOffAddrOp_Word8AsStablePtr = 592+primOpTag WriteOffAddrOp_Word8AsInt16 = 593+primOpTag WriteOffAddrOp_Word8AsWord16 = 594+primOpTag WriteOffAddrOp_Word8AsInt32 = 595+primOpTag WriteOffAddrOp_Word8AsWord32 = 596+primOpTag WriteOffAddrOp_Word8AsInt64 = 597+primOpTag WriteOffAddrOp_Word8AsWord64 = 598+primOpTag InterlockedExchange_Addr = 599+primOpTag InterlockedExchange_Word = 600+primOpTag CasAddrOp_Addr = 601+primOpTag CasAddrOp_Word = 602+primOpTag CasAddrOp_Word8 = 603+primOpTag CasAddrOp_Word16 = 604+primOpTag CasAddrOp_Word32 = 605+primOpTag CasAddrOp_Word64 = 606+primOpTag FetchAddAddrOp_Word = 607+primOpTag FetchSubAddrOp_Word = 608+primOpTag FetchAndAddrOp_Word = 609+primOpTag FetchNandAddrOp_Word = 610+primOpTag FetchOrAddrOp_Word = 611+primOpTag FetchXorAddrOp_Word = 612+primOpTag AtomicReadAddrOp_Word = 613+primOpTag AtomicWriteAddrOp_Word = 614+primOpTag NewMutVarOp = 615+primOpTag ReadMutVarOp = 616+primOpTag WriteMutVarOp = 617+primOpTag AtomicSwapMutVarOp = 618+primOpTag AtomicModifyMutVar2Op = 619+primOpTag AtomicModifyMutVar_Op = 620+primOpTag CasMutVarOp = 621+primOpTag CatchOp = 622+primOpTag RaiseOp = 623+primOpTag RaiseUnderflowOp = 624+primOpTag RaiseOverflowOp = 625+primOpTag RaiseDivZeroOp = 626+primOpTag RaiseIOOp = 627+primOpTag MaskAsyncExceptionsOp = 628+primOpTag MaskUninterruptibleOp = 629+primOpTag UnmaskAsyncExceptionsOp = 630+primOpTag MaskStatus = 631+primOpTag NewPromptTagOp = 632+primOpTag PromptOp = 633+primOpTag Control0Op = 634+primOpTag AtomicallyOp = 635+primOpTag RetryOp = 636+primOpTag CatchRetryOp = 637+primOpTag CatchSTMOp = 638+primOpTag NewTVarOp = 639+primOpTag ReadTVarOp = 640+primOpTag ReadTVarIOOp = 641+primOpTag WriteTVarOp = 642+primOpTag NewMVarOp = 643+primOpTag TakeMVarOp = 644+primOpTag TryTakeMVarOp = 645+primOpTag PutMVarOp = 646+primOpTag TryPutMVarOp = 647+primOpTag ReadMVarOp = 648+primOpTag TryReadMVarOp = 649+primOpTag IsEmptyMVarOp = 650+primOpTag NewIOPortOp = 651+primOpTag ReadIOPortOp = 652+primOpTag WriteIOPortOp = 653+primOpTag DelayOp = 654+primOpTag WaitReadOp = 655+primOpTag WaitWriteOp = 656+primOpTag ForkOp = 657+primOpTag ForkOnOp = 658+primOpTag KillThreadOp = 659+primOpTag YieldOp = 660+primOpTag MyThreadIdOp = 661+primOpTag LabelThreadOp = 662+primOpTag IsCurrentThreadBoundOp = 663+primOpTag NoDuplicateOp = 664+primOpTag GetThreadLabelOp = 665+primOpTag ThreadStatusOp = 666+primOpTag ListThreadsOp = 667+primOpTag MkWeakOp = 668+primOpTag MkWeakNoFinalizerOp = 669+primOpTag AddCFinalizerToWeakOp = 670+primOpTag DeRefWeakOp = 671+primOpTag FinalizeWeakOp = 672+primOpTag TouchOp = 673+primOpTag MakeStablePtrOp = 674+primOpTag DeRefStablePtrOp = 675+primOpTag EqStablePtrOp = 676+primOpTag MakeStableNameOp = 677+primOpTag StableNameToIntOp = 678+primOpTag CompactNewOp = 679+primOpTag CompactResizeOp = 680+primOpTag CompactContainsOp = 681+primOpTag CompactContainsAnyOp = 682+primOpTag CompactGetFirstBlockOp = 683+primOpTag CompactGetNextBlockOp = 684+primOpTag CompactAllocateBlockOp = 685+primOpTag CompactFixupPointersOp = 686+primOpTag CompactAdd = 687+primOpTag CompactAddWithSharing = 688+primOpTag CompactSize = 689+primOpTag ReallyUnsafePtrEqualityOp = 690+primOpTag ParOp = 691+primOpTag SparkOp = 692+primOpTag SeqOp = 693+primOpTag GetSparkOp = 694+primOpTag NumSparks = 695+primOpTag KeepAliveOp = 696+primOpTag DataToTagSmallOp = 697+primOpTag DataToTagLargeOp = 698+primOpTag TagToEnumOp = 699+primOpTag AddrToAnyOp = 700+primOpTag AnyToAddrOp = 701+primOpTag MkApUpd0_Op = 702+primOpTag NewBCOOp = 703+primOpTag UnpackClosureOp = 704+primOpTag ClosureSizeOp = 705+primOpTag GetApStackValOp = 706+primOpTag GetCCSOfOp = 707+primOpTag GetCurrentCCSOp = 708+primOpTag ClearCCSOp = 709+primOpTag WhereFromOp = 710+primOpTag TraceEventOp = 711+primOpTag TraceEventBinaryOp = 712+primOpTag TraceMarkerOp = 713+primOpTag SetThreadAllocationCounter = 714+primOpTag (VecBroadcastOp IntVec 16 W8) = 715+primOpTag (VecBroadcastOp IntVec 8 W16) = 716+primOpTag (VecBroadcastOp IntVec 4 W32) = 717+primOpTag (VecBroadcastOp IntVec 2 W64) = 718+primOpTag (VecBroadcastOp IntVec 32 W8) = 719+primOpTag (VecBroadcastOp IntVec 16 W16) = 720+primOpTag (VecBroadcastOp IntVec 8 W32) = 721+primOpTag (VecBroadcastOp IntVec 4 W64) = 722+primOpTag (VecBroadcastOp IntVec 64 W8) = 723+primOpTag (VecBroadcastOp IntVec 32 W16) = 724+primOpTag (VecBroadcastOp IntVec 16 W32) = 725+primOpTag (VecBroadcastOp IntVec 8 W64) = 726+primOpTag (VecBroadcastOp WordVec 16 W8) = 727+primOpTag (VecBroadcastOp WordVec 8 W16) = 728+primOpTag (VecBroadcastOp WordVec 4 W32) = 729+primOpTag (VecBroadcastOp WordVec 2 W64) = 730+primOpTag (VecBroadcastOp WordVec 32 W8) = 731+primOpTag (VecBroadcastOp WordVec 16 W16) = 732+primOpTag (VecBroadcastOp WordVec 8 W32) = 733+primOpTag (VecBroadcastOp WordVec 4 W64) = 734+primOpTag (VecBroadcastOp WordVec 64 W8) = 735+primOpTag (VecBroadcastOp WordVec 32 W16) = 736+primOpTag (VecBroadcastOp WordVec 16 W32) = 737+primOpTag (VecBroadcastOp WordVec 8 W64) = 738+primOpTag (VecBroadcastOp FloatVec 4 W32) = 739+primOpTag (VecBroadcastOp FloatVec 2 W64) = 740+primOpTag (VecBroadcastOp FloatVec 8 W32) = 741+primOpTag (VecBroadcastOp FloatVec 4 W64) = 742+primOpTag (VecBroadcastOp FloatVec 16 W32) = 743+primOpTag (VecBroadcastOp FloatVec 8 W64) = 744+primOpTag (VecPackOp IntVec 16 W8) = 745+primOpTag (VecPackOp IntVec 8 W16) = 746+primOpTag (VecPackOp IntVec 4 W32) = 747+primOpTag (VecPackOp IntVec 2 W64) = 748+primOpTag (VecPackOp IntVec 32 W8) = 749+primOpTag (VecPackOp IntVec 16 W16) = 750+primOpTag (VecPackOp IntVec 8 W32) = 751+primOpTag (VecPackOp IntVec 4 W64) = 752+primOpTag (VecPackOp IntVec 64 W8) = 753+primOpTag (VecPackOp IntVec 32 W16) = 754+primOpTag (VecPackOp IntVec 16 W32) = 755+primOpTag (VecPackOp IntVec 8 W64) = 756+primOpTag (VecPackOp WordVec 16 W8) = 757+primOpTag (VecPackOp WordVec 8 W16) = 758+primOpTag (VecPackOp WordVec 4 W32) = 759+primOpTag (VecPackOp WordVec 2 W64) = 760+primOpTag (VecPackOp WordVec 32 W8) = 761+primOpTag (VecPackOp WordVec 16 W16) = 762+primOpTag (VecPackOp WordVec 8 W32) = 763+primOpTag (VecPackOp WordVec 4 W64) = 764+primOpTag (VecPackOp WordVec 64 W8) = 765+primOpTag (VecPackOp WordVec 32 W16) = 766+primOpTag (VecPackOp WordVec 16 W32) = 767+primOpTag (VecPackOp WordVec 8 W64) = 768+primOpTag (VecPackOp FloatVec 4 W32) = 769+primOpTag (VecPackOp FloatVec 2 W64) = 770+primOpTag (VecPackOp FloatVec 8 W32) = 771+primOpTag (VecPackOp FloatVec 4 W64) = 772+primOpTag (VecPackOp FloatVec 16 W32) = 773+primOpTag (VecPackOp FloatVec 8 W64) = 774+primOpTag (VecUnpackOp IntVec 16 W8) = 775+primOpTag (VecUnpackOp IntVec 8 W16) = 776+primOpTag (VecUnpackOp IntVec 4 W32) = 777+primOpTag (VecUnpackOp IntVec 2 W64) = 778+primOpTag (VecUnpackOp IntVec 32 W8) = 779+primOpTag (VecUnpackOp IntVec 16 W16) = 780+primOpTag (VecUnpackOp IntVec 8 W32) = 781+primOpTag (VecUnpackOp IntVec 4 W64) = 782+primOpTag (VecUnpackOp IntVec 64 W8) = 783+primOpTag (VecUnpackOp IntVec 32 W16) = 784+primOpTag (VecUnpackOp IntVec 16 W32) = 785+primOpTag (VecUnpackOp IntVec 8 W64) = 786+primOpTag (VecUnpackOp WordVec 16 W8) = 787+primOpTag (VecUnpackOp WordVec 8 W16) = 788+primOpTag (VecUnpackOp WordVec 4 W32) = 789+primOpTag (VecUnpackOp WordVec 2 W64) = 790+primOpTag (VecUnpackOp WordVec 32 W8) = 791+primOpTag (VecUnpackOp WordVec 16 W16) = 792+primOpTag (VecUnpackOp WordVec 8 W32) = 793+primOpTag (VecUnpackOp WordVec 4 W64) = 794+primOpTag (VecUnpackOp WordVec 64 W8) = 795+primOpTag (VecUnpackOp WordVec 32 W16) = 796+primOpTag (VecUnpackOp WordVec 16 W32) = 797+primOpTag (VecUnpackOp WordVec 8 W64) = 798+primOpTag (VecUnpackOp FloatVec 4 W32) = 799+primOpTag (VecUnpackOp FloatVec 2 W64) = 800+primOpTag (VecUnpackOp FloatVec 8 W32) = 801+primOpTag (VecUnpackOp FloatVec 4 W64) = 802+primOpTag (VecUnpackOp FloatVec 16 W32) = 803+primOpTag (VecUnpackOp FloatVec 8 W64) = 804+primOpTag (VecInsertOp IntVec 16 W8) = 805+primOpTag (VecInsertOp IntVec 8 W16) = 806+primOpTag (VecInsertOp IntVec 4 W32) = 807+primOpTag (VecInsertOp IntVec 2 W64) = 808+primOpTag (VecInsertOp IntVec 32 W8) = 809+primOpTag (VecInsertOp IntVec 16 W16) = 810+primOpTag (VecInsertOp IntVec 8 W32) = 811+primOpTag (VecInsertOp IntVec 4 W64) = 812+primOpTag (VecInsertOp IntVec 64 W8) = 813+primOpTag (VecInsertOp IntVec 32 W16) = 814+primOpTag (VecInsertOp IntVec 16 W32) = 815+primOpTag (VecInsertOp IntVec 8 W64) = 816+primOpTag (VecInsertOp WordVec 16 W8) = 817+primOpTag (VecInsertOp WordVec 8 W16) = 818+primOpTag (VecInsertOp WordVec 4 W32) = 819+primOpTag (VecInsertOp WordVec 2 W64) = 820+primOpTag (VecInsertOp WordVec 32 W8) = 821+primOpTag (VecInsertOp WordVec 16 W16) = 822+primOpTag (VecInsertOp WordVec 8 W32) = 823+primOpTag (VecInsertOp WordVec 4 W64) = 824+primOpTag (VecInsertOp WordVec 64 W8) = 825+primOpTag (VecInsertOp WordVec 32 W16) = 826+primOpTag (VecInsertOp WordVec 16 W32) = 827+primOpTag (VecInsertOp WordVec 8 W64) = 828+primOpTag (VecInsertOp FloatVec 4 W32) = 829+primOpTag (VecInsertOp FloatVec 2 W64) = 830+primOpTag (VecInsertOp FloatVec 8 W32) = 831+primOpTag (VecInsertOp FloatVec 4 W64) = 832+primOpTag (VecInsertOp FloatVec 16 W32) = 833+primOpTag (VecInsertOp FloatVec 8 W64) = 834+primOpTag (VecAddOp IntVec 16 W8) = 835+primOpTag (VecAddOp IntVec 8 W16) = 836+primOpTag (VecAddOp IntVec 4 W32) = 837+primOpTag (VecAddOp IntVec 2 W64) = 838+primOpTag (VecAddOp IntVec 32 W8) = 839+primOpTag (VecAddOp IntVec 16 W16) = 840+primOpTag (VecAddOp IntVec 8 W32) = 841+primOpTag (VecAddOp IntVec 4 W64) = 842+primOpTag (VecAddOp IntVec 64 W8) = 843+primOpTag (VecAddOp IntVec 32 W16) = 844+primOpTag (VecAddOp IntVec 16 W32) = 845+primOpTag (VecAddOp IntVec 8 W64) = 846+primOpTag (VecAddOp WordVec 16 W8) = 847+primOpTag (VecAddOp WordVec 8 W16) = 848+primOpTag (VecAddOp WordVec 4 W32) = 849+primOpTag (VecAddOp WordVec 2 W64) = 850+primOpTag (VecAddOp WordVec 32 W8) = 851+primOpTag (VecAddOp WordVec 16 W16) = 852+primOpTag (VecAddOp WordVec 8 W32) = 853+primOpTag (VecAddOp WordVec 4 W64) = 854+primOpTag (VecAddOp WordVec 64 W8) = 855+primOpTag (VecAddOp WordVec 32 W16) = 856+primOpTag (VecAddOp WordVec 16 W32) = 857+primOpTag (VecAddOp WordVec 8 W64) = 858+primOpTag (VecAddOp FloatVec 4 W32) = 859+primOpTag (VecAddOp FloatVec 2 W64) = 860+primOpTag (VecAddOp FloatVec 8 W32) = 861+primOpTag (VecAddOp FloatVec 4 W64) = 862+primOpTag (VecAddOp FloatVec 16 W32) = 863+primOpTag (VecAddOp FloatVec 8 W64) = 864+primOpTag (VecSubOp IntVec 16 W8) = 865+primOpTag (VecSubOp IntVec 8 W16) = 866+primOpTag (VecSubOp IntVec 4 W32) = 867+primOpTag (VecSubOp IntVec 2 W64) = 868+primOpTag (VecSubOp IntVec 32 W8) = 869+primOpTag (VecSubOp IntVec 16 W16) = 870+primOpTag (VecSubOp IntVec 8 W32) = 871+primOpTag (VecSubOp IntVec 4 W64) = 872+primOpTag (VecSubOp IntVec 64 W8) = 873+primOpTag (VecSubOp IntVec 32 W16) = 874+primOpTag (VecSubOp IntVec 16 W32) = 875+primOpTag (VecSubOp IntVec 8 W64) = 876+primOpTag (VecSubOp WordVec 16 W8) = 877+primOpTag (VecSubOp WordVec 8 W16) = 878+primOpTag (VecSubOp WordVec 4 W32) = 879+primOpTag (VecSubOp WordVec 2 W64) = 880+primOpTag (VecSubOp WordVec 32 W8) = 881+primOpTag (VecSubOp WordVec 16 W16) = 882+primOpTag (VecSubOp WordVec 8 W32) = 883+primOpTag (VecSubOp WordVec 4 W64) = 884+primOpTag (VecSubOp WordVec 64 W8) = 885+primOpTag (VecSubOp WordVec 32 W16) = 886+primOpTag (VecSubOp WordVec 16 W32) = 887+primOpTag (VecSubOp WordVec 8 W64) = 888+primOpTag (VecSubOp FloatVec 4 W32) = 889+primOpTag (VecSubOp FloatVec 2 W64) = 890+primOpTag (VecSubOp FloatVec 8 W32) = 891+primOpTag (VecSubOp FloatVec 4 W64) = 892+primOpTag (VecSubOp FloatVec 16 W32) = 893+primOpTag (VecSubOp FloatVec 8 W64) = 894+primOpTag (VecMulOp IntVec 16 W8) = 895+primOpTag (VecMulOp IntVec 8 W16) = 896+primOpTag (VecMulOp IntVec 4 W32) = 897+primOpTag (VecMulOp IntVec 2 W64) = 898+primOpTag (VecMulOp IntVec 32 W8) = 899+primOpTag (VecMulOp IntVec 16 W16) = 900+primOpTag (VecMulOp IntVec 8 W32) = 901+primOpTag (VecMulOp IntVec 4 W64) = 902+primOpTag (VecMulOp IntVec 64 W8) = 903+primOpTag (VecMulOp IntVec 32 W16) = 904+primOpTag (VecMulOp IntVec 16 W32) = 905+primOpTag (VecMulOp IntVec 8 W64) = 906+primOpTag (VecMulOp WordVec 16 W8) = 907+primOpTag (VecMulOp WordVec 8 W16) = 908+primOpTag (VecMulOp WordVec 4 W32) = 909+primOpTag (VecMulOp WordVec 2 W64) = 910+primOpTag (VecMulOp WordVec 32 W8) = 911+primOpTag (VecMulOp WordVec 16 W16) = 912+primOpTag (VecMulOp WordVec 8 W32) = 913+primOpTag (VecMulOp WordVec 4 W64) = 914+primOpTag (VecMulOp WordVec 64 W8) = 915+primOpTag (VecMulOp WordVec 32 W16) = 916+primOpTag (VecMulOp WordVec 16 W32) = 917+primOpTag (VecMulOp WordVec 8 W64) = 918+primOpTag (VecMulOp FloatVec 4 W32) = 919+primOpTag (VecMulOp FloatVec 2 W64) = 920+primOpTag (VecMulOp FloatVec 8 W32) = 921+primOpTag (VecMulOp FloatVec 4 W64) = 922+primOpTag (VecMulOp FloatVec 16 W32) = 923+primOpTag (VecMulOp FloatVec 8 W64) = 924+primOpTag (VecDivOp FloatVec 4 W32) = 925+primOpTag (VecDivOp FloatVec 2 W64) = 926+primOpTag (VecDivOp FloatVec 8 W32) = 927+primOpTag (VecDivOp FloatVec 4 W64) = 928+primOpTag (VecDivOp FloatVec 16 W32) = 929+primOpTag (VecDivOp FloatVec 8 W64) = 930+primOpTag (VecQuotOp IntVec 16 W8) = 931+primOpTag (VecQuotOp IntVec 8 W16) = 932+primOpTag (VecQuotOp IntVec 4 W32) = 933+primOpTag (VecQuotOp IntVec 2 W64) = 934+primOpTag (VecQuotOp IntVec 32 W8) = 935+primOpTag (VecQuotOp IntVec 16 W16) = 936+primOpTag (VecQuotOp IntVec 8 W32) = 937+primOpTag (VecQuotOp IntVec 4 W64) = 938+primOpTag (VecQuotOp IntVec 64 W8) = 939+primOpTag (VecQuotOp IntVec 32 W16) = 940+primOpTag (VecQuotOp IntVec 16 W32) = 941+primOpTag (VecQuotOp IntVec 8 W64) = 942+primOpTag (VecQuotOp WordVec 16 W8) = 943+primOpTag (VecQuotOp WordVec 8 W16) = 944+primOpTag (VecQuotOp WordVec 4 W32) = 945+primOpTag (VecQuotOp WordVec 2 W64) = 946+primOpTag (VecQuotOp WordVec 32 W8) = 947+primOpTag (VecQuotOp WordVec 16 W16) = 948+primOpTag (VecQuotOp WordVec 8 W32) = 949+primOpTag (VecQuotOp WordVec 4 W64) = 950+primOpTag (VecQuotOp WordVec 64 W8) = 951+primOpTag (VecQuotOp WordVec 32 W16) = 952+primOpTag (VecQuotOp WordVec 16 W32) = 953+primOpTag (VecQuotOp WordVec 8 W64) = 954+primOpTag (VecRemOp IntVec 16 W8) = 955+primOpTag (VecRemOp IntVec 8 W16) = 956+primOpTag (VecRemOp IntVec 4 W32) = 957+primOpTag (VecRemOp IntVec 2 W64) = 958+primOpTag (VecRemOp IntVec 32 W8) = 959+primOpTag (VecRemOp IntVec 16 W16) = 960+primOpTag (VecRemOp IntVec 8 W32) = 961+primOpTag (VecRemOp IntVec 4 W64) = 962+primOpTag (VecRemOp IntVec 64 W8) = 963+primOpTag (VecRemOp IntVec 32 W16) = 964+primOpTag (VecRemOp IntVec 16 W32) = 965+primOpTag (VecRemOp IntVec 8 W64) = 966+primOpTag (VecRemOp WordVec 16 W8) = 967+primOpTag (VecRemOp WordVec 8 W16) = 968+primOpTag (VecRemOp WordVec 4 W32) = 969+primOpTag (VecRemOp WordVec 2 W64) = 970+primOpTag (VecRemOp WordVec 32 W8) = 971+primOpTag (VecRemOp WordVec 16 W16) = 972+primOpTag (VecRemOp WordVec 8 W32) = 973+primOpTag (VecRemOp WordVec 4 W64) = 974+primOpTag (VecRemOp WordVec 64 W8) = 975+primOpTag (VecRemOp WordVec 32 W16) = 976+primOpTag (VecRemOp WordVec 16 W32) = 977+primOpTag (VecRemOp WordVec 8 W64) = 978+primOpTag (VecNegOp IntVec 16 W8) = 979+primOpTag (VecNegOp IntVec 8 W16) = 980+primOpTag (VecNegOp IntVec 4 W32) = 981+primOpTag (VecNegOp IntVec 2 W64) = 982+primOpTag (VecNegOp IntVec 32 W8) = 983+primOpTag (VecNegOp IntVec 16 W16) = 984+primOpTag (VecNegOp IntVec 8 W32) = 985+primOpTag (VecNegOp IntVec 4 W64) = 986+primOpTag (VecNegOp IntVec 64 W8) = 987+primOpTag (VecNegOp IntVec 32 W16) = 988+primOpTag (VecNegOp IntVec 16 W32) = 989+primOpTag (VecNegOp IntVec 8 W64) = 990+primOpTag (VecNegOp FloatVec 4 W32) = 991+primOpTag (VecNegOp FloatVec 2 W64) = 992+primOpTag (VecNegOp FloatVec 8 W32) = 993+primOpTag (VecNegOp FloatVec 4 W64) = 994+primOpTag (VecNegOp FloatVec 16 W32) = 995+primOpTag (VecNegOp FloatVec 8 W64) = 996+primOpTag (VecIndexByteArrayOp IntVec 16 W8) = 997+primOpTag (VecIndexByteArrayOp IntVec 8 W16) = 998+primOpTag (VecIndexByteArrayOp IntVec 4 W32) = 999+primOpTag (VecIndexByteArrayOp IntVec 2 W64) = 1000+primOpTag (VecIndexByteArrayOp IntVec 32 W8) = 1001+primOpTag (VecIndexByteArrayOp IntVec 16 W16) = 1002+primOpTag (VecIndexByteArrayOp IntVec 8 W32) = 1003+primOpTag (VecIndexByteArrayOp IntVec 4 W64) = 1004+primOpTag (VecIndexByteArrayOp IntVec 64 W8) = 1005+primOpTag (VecIndexByteArrayOp IntVec 32 W16) = 1006+primOpTag (VecIndexByteArrayOp IntVec 16 W32) = 1007+primOpTag (VecIndexByteArrayOp IntVec 8 W64) = 1008+primOpTag (VecIndexByteArrayOp WordVec 16 W8) = 1009+primOpTag (VecIndexByteArrayOp WordVec 8 W16) = 1010+primOpTag (VecIndexByteArrayOp WordVec 4 W32) = 1011+primOpTag (VecIndexByteArrayOp WordVec 2 W64) = 1012+primOpTag (VecIndexByteArrayOp WordVec 32 W8) = 1013+primOpTag (VecIndexByteArrayOp WordVec 16 W16) = 1014+primOpTag (VecIndexByteArrayOp WordVec 8 W32) = 1015+primOpTag (VecIndexByteArrayOp WordVec 4 W64) = 1016+primOpTag (VecIndexByteArrayOp WordVec 64 W8) = 1017+primOpTag (VecIndexByteArrayOp WordVec 32 W16) = 1018+primOpTag (VecIndexByteArrayOp WordVec 16 W32) = 1019+primOpTag (VecIndexByteArrayOp WordVec 8 W64) = 1020+primOpTag (VecIndexByteArrayOp FloatVec 4 W32) = 1021+primOpTag (VecIndexByteArrayOp FloatVec 2 W64) = 1022+primOpTag (VecIndexByteArrayOp FloatVec 8 W32) = 1023+primOpTag (VecIndexByteArrayOp FloatVec 4 W64) = 1024+primOpTag (VecIndexByteArrayOp FloatVec 16 W32) = 1025+primOpTag (VecIndexByteArrayOp FloatVec 8 W64) = 1026+primOpTag (VecReadByteArrayOp IntVec 16 W8) = 1027+primOpTag (VecReadByteArrayOp IntVec 8 W16) = 1028+primOpTag (VecReadByteArrayOp IntVec 4 W32) = 1029+primOpTag (VecReadByteArrayOp IntVec 2 W64) = 1030+primOpTag (VecReadByteArrayOp IntVec 32 W8) = 1031+primOpTag (VecReadByteArrayOp IntVec 16 W16) = 1032+primOpTag (VecReadByteArrayOp IntVec 8 W32) = 1033+primOpTag (VecReadByteArrayOp IntVec 4 W64) = 1034+primOpTag (VecReadByteArrayOp IntVec 64 W8) = 1035+primOpTag (VecReadByteArrayOp IntVec 32 W16) = 1036+primOpTag (VecReadByteArrayOp IntVec 16 W32) = 1037+primOpTag (VecReadByteArrayOp IntVec 8 W64) = 1038+primOpTag (VecReadByteArrayOp WordVec 16 W8) = 1039+primOpTag (VecReadByteArrayOp WordVec 8 W16) = 1040+primOpTag (VecReadByteArrayOp WordVec 4 W32) = 1041+primOpTag (VecReadByteArrayOp WordVec 2 W64) = 1042+primOpTag (VecReadByteArrayOp WordVec 32 W8) = 1043+primOpTag (VecReadByteArrayOp WordVec 16 W16) = 1044+primOpTag (VecReadByteArrayOp WordVec 8 W32) = 1045+primOpTag (VecReadByteArrayOp WordVec 4 W64) = 1046+primOpTag (VecReadByteArrayOp WordVec 64 W8) = 1047+primOpTag (VecReadByteArrayOp WordVec 32 W16) = 1048+primOpTag (VecReadByteArrayOp WordVec 16 W32) = 1049+primOpTag (VecReadByteArrayOp WordVec 8 W64) = 1050+primOpTag (VecReadByteArrayOp FloatVec 4 W32) = 1051+primOpTag (VecReadByteArrayOp FloatVec 2 W64) = 1052+primOpTag (VecReadByteArrayOp FloatVec 8 W32) = 1053+primOpTag (VecReadByteArrayOp FloatVec 4 W64) = 1054+primOpTag (VecReadByteArrayOp FloatVec 16 W32) = 1055+primOpTag (VecReadByteArrayOp FloatVec 8 W64) = 1056+primOpTag (VecWriteByteArrayOp IntVec 16 W8) = 1057+primOpTag (VecWriteByteArrayOp IntVec 8 W16) = 1058+primOpTag (VecWriteByteArrayOp IntVec 4 W32) = 1059+primOpTag (VecWriteByteArrayOp IntVec 2 W64) = 1060+primOpTag (VecWriteByteArrayOp IntVec 32 W8) = 1061+primOpTag (VecWriteByteArrayOp IntVec 16 W16) = 1062+primOpTag (VecWriteByteArrayOp IntVec 8 W32) = 1063+primOpTag (VecWriteByteArrayOp IntVec 4 W64) = 1064+primOpTag (VecWriteByteArrayOp IntVec 64 W8) = 1065+primOpTag (VecWriteByteArrayOp IntVec 32 W16) = 1066+primOpTag (VecWriteByteArrayOp IntVec 16 W32) = 1067+primOpTag (VecWriteByteArrayOp IntVec 8 W64) = 1068+primOpTag (VecWriteByteArrayOp WordVec 16 W8) = 1069+primOpTag (VecWriteByteArrayOp WordVec 8 W16) = 1070+primOpTag (VecWriteByteArrayOp WordVec 4 W32) = 1071+primOpTag (VecWriteByteArrayOp WordVec 2 W64) = 1072+primOpTag (VecWriteByteArrayOp WordVec 32 W8) = 1073+primOpTag (VecWriteByteArrayOp WordVec 16 W16) = 1074+primOpTag (VecWriteByteArrayOp WordVec 8 W32) = 1075+primOpTag (VecWriteByteArrayOp WordVec 4 W64) = 1076+primOpTag (VecWriteByteArrayOp WordVec 64 W8) = 1077+primOpTag (VecWriteByteArrayOp WordVec 32 W16) = 1078+primOpTag (VecWriteByteArrayOp WordVec 16 W32) = 1079+primOpTag (VecWriteByteArrayOp WordVec 8 W64) = 1080+primOpTag (VecWriteByteArrayOp FloatVec 4 W32) = 1081+primOpTag (VecWriteByteArrayOp FloatVec 2 W64) = 1082+primOpTag (VecWriteByteArrayOp FloatVec 8 W32) = 1083+primOpTag (VecWriteByteArrayOp FloatVec 4 W64) = 1084+primOpTag (VecWriteByteArrayOp FloatVec 16 W32) = 1085+primOpTag (VecWriteByteArrayOp FloatVec 8 W64) = 1086+primOpTag (VecIndexOffAddrOp IntVec 16 W8) = 1087+primOpTag (VecIndexOffAddrOp IntVec 8 W16) = 1088+primOpTag (VecIndexOffAddrOp IntVec 4 W32) = 1089+primOpTag (VecIndexOffAddrOp IntVec 2 W64) = 1090+primOpTag (VecIndexOffAddrOp IntVec 32 W8) = 1091+primOpTag (VecIndexOffAddrOp IntVec 16 W16) = 1092+primOpTag (VecIndexOffAddrOp IntVec 8 W32) = 1093+primOpTag (VecIndexOffAddrOp IntVec 4 W64) = 1094+primOpTag (VecIndexOffAddrOp IntVec 64 W8) = 1095+primOpTag (VecIndexOffAddrOp IntVec 32 W16) = 1096+primOpTag (VecIndexOffAddrOp IntVec 16 W32) = 1097+primOpTag (VecIndexOffAddrOp IntVec 8 W64) = 1098+primOpTag (VecIndexOffAddrOp WordVec 16 W8) = 1099+primOpTag (VecIndexOffAddrOp WordVec 8 W16) = 1100+primOpTag (VecIndexOffAddrOp WordVec 4 W32) = 1101+primOpTag (VecIndexOffAddrOp WordVec 2 W64) = 1102+primOpTag (VecIndexOffAddrOp WordVec 32 W8) = 1103+primOpTag (VecIndexOffAddrOp WordVec 16 W16) = 1104+primOpTag (VecIndexOffAddrOp WordVec 8 W32) = 1105+primOpTag (VecIndexOffAddrOp WordVec 4 W64) = 1106+primOpTag (VecIndexOffAddrOp WordVec 64 W8) = 1107+primOpTag (VecIndexOffAddrOp WordVec 32 W16) = 1108+primOpTag (VecIndexOffAddrOp WordVec 16 W32) = 1109+primOpTag (VecIndexOffAddrOp WordVec 8 W64) = 1110+primOpTag (VecIndexOffAddrOp FloatVec 4 W32) = 1111+primOpTag (VecIndexOffAddrOp FloatVec 2 W64) = 1112+primOpTag (VecIndexOffAddrOp FloatVec 8 W32) = 1113+primOpTag (VecIndexOffAddrOp FloatVec 4 W64) = 1114+primOpTag (VecIndexOffAddrOp FloatVec 16 W32) = 1115+primOpTag (VecIndexOffAddrOp FloatVec 8 W64) = 1116+primOpTag (VecReadOffAddrOp IntVec 16 W8) = 1117+primOpTag (VecReadOffAddrOp IntVec 8 W16) = 1118+primOpTag (VecReadOffAddrOp IntVec 4 W32) = 1119+primOpTag (VecReadOffAddrOp IntVec 2 W64) = 1120+primOpTag (VecReadOffAddrOp IntVec 32 W8) = 1121+primOpTag (VecReadOffAddrOp IntVec 16 W16) = 1122+primOpTag (VecReadOffAddrOp IntVec 8 W32) = 1123+primOpTag (VecReadOffAddrOp IntVec 4 W64) = 1124+primOpTag (VecReadOffAddrOp IntVec 64 W8) = 1125+primOpTag (VecReadOffAddrOp IntVec 32 W16) = 1126+primOpTag (VecReadOffAddrOp IntVec 16 W32) = 1127+primOpTag (VecReadOffAddrOp IntVec 8 W64) = 1128+primOpTag (VecReadOffAddrOp WordVec 16 W8) = 1129+primOpTag (VecReadOffAddrOp WordVec 8 W16) = 1130+primOpTag (VecReadOffAddrOp WordVec 4 W32) = 1131+primOpTag (VecReadOffAddrOp WordVec 2 W64) = 1132+primOpTag (VecReadOffAddrOp WordVec 32 W8) = 1133+primOpTag (VecReadOffAddrOp WordVec 16 W16) = 1134+primOpTag (VecReadOffAddrOp WordVec 8 W32) = 1135+primOpTag (VecReadOffAddrOp WordVec 4 W64) = 1136+primOpTag (VecReadOffAddrOp WordVec 64 W8) = 1137+primOpTag (VecReadOffAddrOp WordVec 32 W16) = 1138+primOpTag (VecReadOffAddrOp WordVec 16 W32) = 1139+primOpTag (VecReadOffAddrOp WordVec 8 W64) = 1140+primOpTag (VecReadOffAddrOp FloatVec 4 W32) = 1141+primOpTag (VecReadOffAddrOp FloatVec 2 W64) = 1142+primOpTag (VecReadOffAddrOp FloatVec 8 W32) = 1143+primOpTag (VecReadOffAddrOp FloatVec 4 W64) = 1144+primOpTag (VecReadOffAddrOp FloatVec 16 W32) = 1145+primOpTag (VecReadOffAddrOp FloatVec 8 W64) = 1146+primOpTag (VecWriteOffAddrOp IntVec 16 W8) = 1147+primOpTag (VecWriteOffAddrOp IntVec 8 W16) = 1148+primOpTag (VecWriteOffAddrOp IntVec 4 W32) = 1149+primOpTag (VecWriteOffAddrOp IntVec 2 W64) = 1150+primOpTag (VecWriteOffAddrOp IntVec 32 W8) = 1151+primOpTag (VecWriteOffAddrOp IntVec 16 W16) = 1152+primOpTag (VecWriteOffAddrOp IntVec 8 W32) = 1153+primOpTag (VecWriteOffAddrOp IntVec 4 W64) = 1154+primOpTag (VecWriteOffAddrOp IntVec 64 W8) = 1155+primOpTag (VecWriteOffAddrOp IntVec 32 W16) = 1156+primOpTag (VecWriteOffAddrOp IntVec 16 W32) = 1157+primOpTag (VecWriteOffAddrOp IntVec 8 W64) = 1158+primOpTag (VecWriteOffAddrOp WordVec 16 W8) = 1159+primOpTag (VecWriteOffAddrOp WordVec 8 W16) = 1160+primOpTag (VecWriteOffAddrOp WordVec 4 W32) = 1161+primOpTag (VecWriteOffAddrOp WordVec 2 W64) = 1162+primOpTag (VecWriteOffAddrOp WordVec 32 W8) = 1163+primOpTag (VecWriteOffAddrOp WordVec 16 W16) = 1164+primOpTag (VecWriteOffAddrOp WordVec 8 W32) = 1165+primOpTag (VecWriteOffAddrOp WordVec 4 W64) = 1166+primOpTag (VecWriteOffAddrOp WordVec 64 W8) = 1167+primOpTag (VecWriteOffAddrOp WordVec 32 W16) = 1168+primOpTag (VecWriteOffAddrOp WordVec 16 W32) = 1169+primOpTag (VecWriteOffAddrOp WordVec 8 W64) = 1170+primOpTag (VecWriteOffAddrOp FloatVec 4 W32) = 1171+primOpTag (VecWriteOffAddrOp FloatVec 2 W64) = 1172+primOpTag (VecWriteOffAddrOp FloatVec 8 W32) = 1173+primOpTag (VecWriteOffAddrOp FloatVec 4 W64) = 1174+primOpTag (VecWriteOffAddrOp FloatVec 16 W32) = 1175+primOpTag (VecWriteOffAddrOp FloatVec 8 W64) = 1176+primOpTag (VecIndexScalarByteArrayOp IntVec 16 W8) = 1177+primOpTag (VecIndexScalarByteArrayOp IntVec 8 W16) = 1178+primOpTag (VecIndexScalarByteArrayOp IntVec 4 W32) = 1179+primOpTag (VecIndexScalarByteArrayOp IntVec 2 W64) = 1180+primOpTag (VecIndexScalarByteArrayOp IntVec 32 W8) = 1181+primOpTag (VecIndexScalarByteArrayOp IntVec 16 W16) = 1182+primOpTag (VecIndexScalarByteArrayOp IntVec 8 W32) = 1183+primOpTag (VecIndexScalarByteArrayOp IntVec 4 W64) = 1184+primOpTag (VecIndexScalarByteArrayOp IntVec 64 W8) = 1185+primOpTag (VecIndexScalarByteArrayOp IntVec 32 W16) = 1186+primOpTag (VecIndexScalarByteArrayOp IntVec 16 W32) = 1187+primOpTag (VecIndexScalarByteArrayOp IntVec 8 W64) = 1188+primOpTag (VecIndexScalarByteArrayOp WordVec 16 W8) = 1189+primOpTag (VecIndexScalarByteArrayOp WordVec 8 W16) = 1190+primOpTag (VecIndexScalarByteArrayOp WordVec 4 W32) = 1191+primOpTag (VecIndexScalarByteArrayOp WordVec 2 W64) = 1192+primOpTag (VecIndexScalarByteArrayOp WordVec 32 W8) = 1193+primOpTag (VecIndexScalarByteArrayOp WordVec 16 W16) = 1194+primOpTag (VecIndexScalarByteArrayOp WordVec 8 W32) = 1195+primOpTag (VecIndexScalarByteArrayOp WordVec 4 W64) = 1196+primOpTag (VecIndexScalarByteArrayOp WordVec 64 W8) = 1197+primOpTag (VecIndexScalarByteArrayOp WordVec 32 W16) = 1198+primOpTag (VecIndexScalarByteArrayOp WordVec 16 W32) = 1199+primOpTag (VecIndexScalarByteArrayOp WordVec 8 W64) = 1200+primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W32) = 1201+primOpTag (VecIndexScalarByteArrayOp FloatVec 2 W64) = 1202+primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W32) = 1203+primOpTag (VecIndexScalarByteArrayOp FloatVec 4 W64) = 1204+primOpTag (VecIndexScalarByteArrayOp FloatVec 16 W32) = 1205+primOpTag (VecIndexScalarByteArrayOp FloatVec 8 W64) = 1206+primOpTag (VecReadScalarByteArrayOp IntVec 16 W8) = 1207+primOpTag (VecReadScalarByteArrayOp IntVec 8 W16) = 1208+primOpTag (VecReadScalarByteArrayOp IntVec 4 W32) = 1209+primOpTag (VecReadScalarByteArrayOp IntVec 2 W64) = 1210+primOpTag (VecReadScalarByteArrayOp IntVec 32 W8) = 1211+primOpTag (VecReadScalarByteArrayOp IntVec 16 W16) = 1212+primOpTag (VecReadScalarByteArrayOp IntVec 8 W32) = 1213+primOpTag (VecReadScalarByteArrayOp IntVec 4 W64) = 1214+primOpTag (VecReadScalarByteArrayOp IntVec 64 W8) = 1215+primOpTag (VecReadScalarByteArrayOp IntVec 32 W16) = 1216+primOpTag (VecReadScalarByteArrayOp IntVec 16 W32) = 1217+primOpTag (VecReadScalarByteArrayOp IntVec 8 W64) = 1218+primOpTag (VecReadScalarByteArrayOp WordVec 16 W8) = 1219+primOpTag (VecReadScalarByteArrayOp WordVec 8 W16) = 1220+primOpTag (VecReadScalarByteArrayOp WordVec 4 W32) = 1221+primOpTag (VecReadScalarByteArrayOp WordVec 2 W64) = 1222+primOpTag (VecReadScalarByteArrayOp WordVec 32 W8) = 1223+primOpTag (VecReadScalarByteArrayOp WordVec 16 W16) = 1224+primOpTag (VecReadScalarByteArrayOp WordVec 8 W32) = 1225+primOpTag (VecReadScalarByteArrayOp WordVec 4 W64) = 1226+primOpTag (VecReadScalarByteArrayOp WordVec 64 W8) = 1227+primOpTag (VecReadScalarByteArrayOp WordVec 32 W16) = 1228+primOpTag (VecReadScalarByteArrayOp WordVec 16 W32) = 1229+primOpTag (VecReadScalarByteArrayOp WordVec 8 W64) = 1230+primOpTag (VecReadScalarByteArrayOp FloatVec 4 W32) = 1231+primOpTag (VecReadScalarByteArrayOp FloatVec 2 W64) = 1232+primOpTag (VecReadScalarByteArrayOp FloatVec 8 W32) = 1233+primOpTag (VecReadScalarByteArrayOp FloatVec 4 W64) = 1234+primOpTag (VecReadScalarByteArrayOp FloatVec 16 W32) = 1235+primOpTag (VecReadScalarByteArrayOp FloatVec 8 W64) = 1236+primOpTag (VecWriteScalarByteArrayOp IntVec 16 W8) = 1237+primOpTag (VecWriteScalarByteArrayOp IntVec 8 W16) = 1238+primOpTag (VecWriteScalarByteArrayOp IntVec 4 W32) = 1239+primOpTag (VecWriteScalarByteArrayOp IntVec 2 W64) = 1240+primOpTag (VecWriteScalarByteArrayOp IntVec 32 W8) = 1241+primOpTag (VecWriteScalarByteArrayOp IntVec 16 W16) = 1242+primOpTag (VecWriteScalarByteArrayOp IntVec 8 W32) = 1243+primOpTag (VecWriteScalarByteArrayOp IntVec 4 W64) = 1244+primOpTag (VecWriteScalarByteArrayOp IntVec 64 W8) = 1245+primOpTag (VecWriteScalarByteArrayOp IntVec 32 W16) = 1246+primOpTag (VecWriteScalarByteArrayOp IntVec 16 W32) = 1247+primOpTag (VecWriteScalarByteArrayOp IntVec 8 W64) = 1248+primOpTag (VecWriteScalarByteArrayOp WordVec 16 W8) = 1249+primOpTag (VecWriteScalarByteArrayOp WordVec 8 W16) = 1250+primOpTag (VecWriteScalarByteArrayOp WordVec 4 W32) = 1251+primOpTag (VecWriteScalarByteArrayOp WordVec 2 W64) = 1252+primOpTag (VecWriteScalarByteArrayOp WordVec 32 W8) = 1253+primOpTag (VecWriteScalarByteArrayOp WordVec 16 W16) = 1254+primOpTag (VecWriteScalarByteArrayOp WordVec 8 W32) = 1255+primOpTag (VecWriteScalarByteArrayOp WordVec 4 W64) = 1256+primOpTag (VecWriteScalarByteArrayOp WordVec 64 W8) = 1257+primOpTag (VecWriteScalarByteArrayOp WordVec 32 W16) = 1258+primOpTag (VecWriteScalarByteArrayOp WordVec 16 W32) = 1259+primOpTag (VecWriteScalarByteArrayOp WordVec 8 W64) = 1260+primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W32) = 1261+primOpTag (VecWriteScalarByteArrayOp FloatVec 2 W64) = 1262+primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W32) = 1263+primOpTag (VecWriteScalarByteArrayOp FloatVec 4 W64) = 1264+primOpTag (VecWriteScalarByteArrayOp FloatVec 16 W32) = 1265+primOpTag (VecWriteScalarByteArrayOp FloatVec 8 W64) = 1266+primOpTag (VecIndexScalarOffAddrOp IntVec 16 W8) = 1267+primOpTag (VecIndexScalarOffAddrOp IntVec 8 W16) = 1268+primOpTag (VecIndexScalarOffAddrOp IntVec 4 W32) = 1269+primOpTag (VecIndexScalarOffAddrOp IntVec 2 W64) = 1270+primOpTag (VecIndexScalarOffAddrOp IntVec 32 W8) = 1271+primOpTag (VecIndexScalarOffAddrOp IntVec 16 W16) = 1272+primOpTag (VecIndexScalarOffAddrOp IntVec 8 W32) = 1273+primOpTag (VecIndexScalarOffAddrOp IntVec 4 W64) = 1274+primOpTag (VecIndexScalarOffAddrOp IntVec 64 W8) = 1275+primOpTag (VecIndexScalarOffAddrOp IntVec 32 W16) = 1276+primOpTag (VecIndexScalarOffAddrOp IntVec 16 W32) = 1277+primOpTag (VecIndexScalarOffAddrOp IntVec 8 W64) = 1278+primOpTag (VecIndexScalarOffAddrOp WordVec 16 W8) = 1279+primOpTag (VecIndexScalarOffAddrOp WordVec 8 W16) = 1280+primOpTag (VecIndexScalarOffAddrOp WordVec 4 W32) = 1281+primOpTag (VecIndexScalarOffAddrOp WordVec 2 W64) = 1282+primOpTag (VecIndexScalarOffAddrOp WordVec 32 W8) = 1283+primOpTag (VecIndexScalarOffAddrOp WordVec 16 W16) = 1284+primOpTag (VecIndexScalarOffAddrOp WordVec 8 W32) = 1285+primOpTag (VecIndexScalarOffAddrOp WordVec 4 W64) = 1286+primOpTag (VecIndexScalarOffAddrOp WordVec 64 W8) = 1287+primOpTag (VecIndexScalarOffAddrOp WordVec 32 W16) = 1288+primOpTag (VecIndexScalarOffAddrOp WordVec 16 W32) = 1289+primOpTag (VecIndexScalarOffAddrOp WordVec 8 W64) = 1290+primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W32) = 1291+primOpTag (VecIndexScalarOffAddrOp FloatVec 2 W64) = 1292+primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W32) = 1293+primOpTag (VecIndexScalarOffAddrOp FloatVec 4 W64) = 1294+primOpTag (VecIndexScalarOffAddrOp FloatVec 16 W32) = 1295+primOpTag (VecIndexScalarOffAddrOp FloatVec 8 W64) = 1296+primOpTag (VecReadScalarOffAddrOp IntVec 16 W8) = 1297+primOpTag (VecReadScalarOffAddrOp IntVec 8 W16) = 1298+primOpTag (VecReadScalarOffAddrOp IntVec 4 W32) = 1299+primOpTag (VecReadScalarOffAddrOp IntVec 2 W64) = 1300+primOpTag (VecReadScalarOffAddrOp IntVec 32 W8) = 1301+primOpTag (VecReadScalarOffAddrOp IntVec 16 W16) = 1302+primOpTag (VecReadScalarOffAddrOp IntVec 8 W32) = 1303+primOpTag (VecReadScalarOffAddrOp IntVec 4 W64) = 1304+primOpTag (VecReadScalarOffAddrOp IntVec 64 W8) = 1305+primOpTag (VecReadScalarOffAddrOp IntVec 32 W16) = 1306+primOpTag (VecReadScalarOffAddrOp IntVec 16 W32) = 1307+primOpTag (VecReadScalarOffAddrOp IntVec 8 W64) = 1308+primOpTag (VecReadScalarOffAddrOp WordVec 16 W8) = 1309+primOpTag (VecReadScalarOffAddrOp WordVec 8 W16) = 1310+primOpTag (VecReadScalarOffAddrOp WordVec 4 W32) = 1311+primOpTag (VecReadScalarOffAddrOp WordVec 2 W64) = 1312+primOpTag (VecReadScalarOffAddrOp WordVec 32 W8) = 1313+primOpTag (VecReadScalarOffAddrOp WordVec 16 W16) = 1314+primOpTag (VecReadScalarOffAddrOp WordVec 8 W32) = 1315+primOpTag (VecReadScalarOffAddrOp WordVec 4 W64) = 1316+primOpTag (VecReadScalarOffAddrOp WordVec 64 W8) = 1317+primOpTag (VecReadScalarOffAddrOp WordVec 32 W16) = 1318+primOpTag (VecReadScalarOffAddrOp WordVec 16 W32) = 1319+primOpTag (VecReadScalarOffAddrOp WordVec 8 W64) = 1320+primOpTag (VecReadScalarOffAddrOp FloatVec 4 W32) = 1321+primOpTag (VecReadScalarOffAddrOp FloatVec 2 W64) = 1322+primOpTag (VecReadScalarOffAddrOp FloatVec 8 W32) = 1323+primOpTag (VecReadScalarOffAddrOp FloatVec 4 W64) = 1324+primOpTag (VecReadScalarOffAddrOp FloatVec 16 W32) = 1325+primOpTag (VecReadScalarOffAddrOp FloatVec 8 W64) = 1326+primOpTag (VecWriteScalarOffAddrOp IntVec 16 W8) = 1327+primOpTag (VecWriteScalarOffAddrOp IntVec 8 W16) = 1328+primOpTag (VecWriteScalarOffAddrOp IntVec 4 W32) = 1329+primOpTag (VecWriteScalarOffAddrOp IntVec 2 W64) = 1330+primOpTag (VecWriteScalarOffAddrOp IntVec 32 W8) = 1331+primOpTag (VecWriteScalarOffAddrOp IntVec 16 W16) = 1332+primOpTag (VecWriteScalarOffAddrOp IntVec 8 W32) = 1333+primOpTag (VecWriteScalarOffAddrOp IntVec 4 W64) = 1334+primOpTag (VecWriteScalarOffAddrOp IntVec 64 W8) = 1335+primOpTag (VecWriteScalarOffAddrOp IntVec 32 W16) = 1336+primOpTag (VecWriteScalarOffAddrOp IntVec 16 W32) = 1337+primOpTag (VecWriteScalarOffAddrOp IntVec 8 W64) = 1338+primOpTag (VecWriteScalarOffAddrOp WordVec 16 W8) = 1339+primOpTag (VecWriteScalarOffAddrOp WordVec 8 W16) = 1340+primOpTag (VecWriteScalarOffAddrOp WordVec 4 W32) = 1341+primOpTag (VecWriteScalarOffAddrOp WordVec 2 W64) = 1342+primOpTag (VecWriteScalarOffAddrOp WordVec 32 W8) = 1343+primOpTag (VecWriteScalarOffAddrOp WordVec 16 W16) = 1344+primOpTag (VecWriteScalarOffAddrOp WordVec 8 W32) = 1345+primOpTag (VecWriteScalarOffAddrOp WordVec 4 W64) = 1346+primOpTag (VecWriteScalarOffAddrOp WordVec 64 W8) = 1347+primOpTag (VecWriteScalarOffAddrOp WordVec 32 W16) = 1348+primOpTag (VecWriteScalarOffAddrOp WordVec 16 W32) = 1349+primOpTag (VecWriteScalarOffAddrOp WordVec 8 W64) = 1350+primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W32) = 1351+primOpTag (VecWriteScalarOffAddrOp FloatVec 2 W64) = 1352+primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W32) = 1353+primOpTag (VecWriteScalarOffAddrOp FloatVec 4 W64) = 1354+primOpTag (VecWriteScalarOffAddrOp FloatVec 16 W32) = 1355+primOpTag (VecWriteScalarOffAddrOp FloatVec 8 W64) = 1356+primOpTag PrefetchByteArrayOp3 = 1357+primOpTag PrefetchMutableByteArrayOp3 = 1358+primOpTag PrefetchAddrOp3 = 1359+primOpTag PrefetchValueOp3 = 1360+primOpTag PrefetchByteArrayOp2 = 1361+primOpTag PrefetchMutableByteArrayOp2 = 1362+primOpTag PrefetchAddrOp2 = 1363+primOpTag PrefetchValueOp2 = 1364+primOpTag PrefetchByteArrayOp1 = 1365+primOpTag PrefetchMutableByteArrayOp1 = 1366+primOpTag PrefetchAddrOp1 = 1367+primOpTag PrefetchValueOp1 = 1368+primOpTag PrefetchByteArrayOp0 = 1369+primOpTag PrefetchMutableByteArrayOp0 = 1370+primOpTag PrefetchAddrOp0 = 1371+primOpTag PrefetchValueOp0 = 1372
ghc-lib/stage0/lib/llvm-passes view
@@ -1,5 +1,5 @@ [-(0, "-enable-new-pm=0 -mem2reg -globalopt -lower-expect"),-(1, "-enable-new-pm=0 -O1 -globalopt"),-(2, "-enable-new-pm=0 -O2")+(0, "-passes=function(require<tbaa>),function(mem2reg),globalopt,function(lower-expect)"),+(1, "-passes=default<O1>"),+(2, "-passes=default<O2>") ]
ghc-lib/stage0/lib/settings view
@@ -1,20 +1,20 @@-[("C compiler command", "/usr/local/opt/ccache/libexec/gcc")-,("C compiler flags", "--target=x86_64-apple-darwin  -Qunused-arguments")-,("C++ compiler command", "/usr/local/opt/ccache/libexec/g++")-,("C++ compiler flags", "--target=x86_64-apple-darwin ")-,("C compiler link flags", "--target=x86_64-apple-darwin   -Wl,-no_fixup_chains -Wl,-no_warn_duplicate_libraries")+[("C compiler command", "/usr/bin/gcc")+,("C compiler flags", "--target=x86_64-apple-darwin -Qunused-arguments")+,("C++ compiler command", "/usr/bin/g++")+,("C++ compiler flags", "--target=x86_64-apple-darwin")+,("C compiler link flags", "--target=x86_64-apple-darwin -Wl,-no_fixup_chains -Wl,-no_warn_duplicate_libraries") ,("C compiler supports -no-pie", "NO")-,("Haskell CPP command", "/usr/local/opt/ccache/libexec/gcc")+,("CPP command", "/usr/bin/gcc")+,("CPP flags", "-E")+,("Haskell CPP command", "/usr/bin/gcc") ,("Haskell CPP flags", "-E -undef -traditional -Wno-invalid-pp-token -Wno-unicode -Wno-trigraphs")-,("ld command", "ld")-,("ld flags", "") ,("ld supports compact unwind", "YES") ,("ld supports filelist", "YES")-,("ld supports response files", "YES")-,("ld is GNU ld", "NO") ,("ld supports single module", "NO")-,("Merge objects command", "ld")+,("ld is GNU ld", "NO")+,("Merge objects command", "/usr/bin/ld") ,("Merge objects flags", "-r")+,("Merge objects supports response files", "YES") ,("ar command", "/usr/bin/ar") ,("ar flags", "qcls") ,("ar supports at file", "NO")@@ -22,10 +22,8 @@ ,("ranlib command", "/usr/bin/ranlib") ,("otool command", "otool") ,("install_name_tool command", "install_name_tool")-,("touch command", "touch")-,("dllwrap command", "/bin/false") ,("windres command", "/bin/false")-,("unlit command", "$topdir/bin/unlit")+,("unlit command", "$topdir/../bin/unlit") ,("cross compiling", "NO") ,("target platform string", "x86_64-apple-darwin") ,("target os", "OSDarwin")@@ -40,7 +38,7 @@ ,("LLVM target", "x86_64-apple-darwin") ,("LLVM llc command", "llc") ,("LLVM opt command", "opt")-,("LLVM clang command", "clang")+,("LLVM llvm-as command", "clang") ,("Use inplace MinGW toolchain", "NO") ,("Use interpreter", "YES") ,("Support SMP", "YES")
ghc-lib/stage0/libraries/ghc-boot/build/GHC/Version.hs view
@@ -3,19 +3,19 @@ import Prelude -- See Note [Why do we import Prelude here?]  cProjectGitCommitId   :: String-cProjectGitCommitId   = "189a368ba74dbfe8a6e832fe0f9ffe56cd565824"+cProjectGitCommitId   = "6d779c0fab30c39475aef50d39064ed67ce839d7"  cProjectVersion       :: String-cProjectVersion       = "9.8.4.20250206"+cProjectVersion       = "9.10.1"  cProjectVersionInt    :: String-cProjectVersionInt    = "908"+cProjectVersionInt    = "910"  cProjectPatchLevel    :: String-cProjectPatchLevel    = "420250206"+cProjectPatchLevel    = "1"  cProjectPatchLevel1   :: String-cProjectPatchLevel1   = "4"+cProjectPatchLevel1   = "1"  cProjectPatchLevel2   :: String-cProjectPatchLevel2   = "20250206"+cProjectPatchLevel2   = "0"
ghc-lib/stage0/rts/build/include/GhclibDerivedConstants.h view
@@ -7,7 +7,7 @@ // WORD_SIZE 8 // BITMAP_BITS_SHIFT 6 // TAG_BITS 3-#define HS_CONSTANTS "291,1,2,4096,252,9,0,8,16,24,32,40,48,56,64,72,80,84,88,92,96,100,104,112,120,128,136,144,152,168,184,200,216,232,248,280,312,344,376,408,440,504,568,632,696,760,824,832,840,848,856,864,872,888,904,-24,-16,-8,24,0,8,48,46,96,72,8,48,8,8,16,8,64,8,16,8,0,72,56,8,16,0,8,8,0,8,0,104,120,16,8,16,0,4,4,24,20,4,15,7,1,-16,255,0,255,7,10,6,6,1,6,6,6,6,6,0,16384,21,1024,8,4,8,8,6,3,30,1152921503533105152,0,1152921504606846976,1"+#define HS_CONSTANTS "291,1,2,4096,252,9,0,8,16,24,32,40,48,56,64,72,80,84,88,92,96,100,104,112,120,128,136,144,152,168,184,200,216,232,248,280,312,344,376,408,440,504,568,632,696,760,824,832,840,848,856,864,872,888,904,-24,-16,-8,24,0,8,48,46,96,72,8,48,8,8,16,8,64,8,16,8,0,72,56,8,8,16,0,8,8,0,8,0,112,128,16,8,16,0,0,4,4,24,20,4,15,7,1,-16,255,0,255,7,10,6,6,1,6,6,6,6,6,0,16384,21,1024,8,4,8,8,6,3,30,1152921503533105152,0,1152921504606846976,1" #define CONTROL_GROUP_CONST_291 291 #define STD_HDR_SIZE 1 #define PROF_HDR_SIZE 2@@ -100,6 +100,9 @@ #define OFFSET_Capability_weak_ptr_list_tl 1184 #define REP_Capability_weak_ptr_list_tl b64 #define Capability_weak_ptr_list_tl(__ptr__) REP_Capability_weak_ptr_list_tl[__ptr__+OFFSET_Capability_weak_ptr_list_tl]+#define OFFSET_Capability_n_run_queue 992+#define REP_Capability_n_run_queue b32+#define Capability_n_run_queue(__ptr__) REP_Capability_n_run_queue[__ptr__+OFFSET_Capability_n_run_queue] #define OFFSET_bdescr_start 0 #define REP_bdescr_start b64 #define bdescr_start(__ptr__) REP_bdescr_start[__ptr__+OFFSET_bdescr_start]@@ -173,6 +176,8 @@ #define StgEntCounter_entry_count(__ptr__) REP_StgEntCounter_entry_count[__ptr__+OFFSET_StgEntCounter_entry_count] #define SIZEOF_StgUpdateFrame_NoHdr 8 #define SIZEOF_StgUpdateFrame (SIZEOF_StgHeader+8)+#define SIZEOF_StgOrigThunkInfoFrame_NoHdr 8+#define SIZEOF_StgOrigThunkInfoFrame (SIZEOF_StgHeader+8) #define SIZEOF_StgCatchFrame_NoHdr 8 #define SIZEOF_StgCatchFrame (SIZEOF_StgHeader+8) #define SIZEOF_StgStopFrame_NoHdr 0@@ -211,43 +216,46 @@ #define OFFSET_StgTSO_what_next 24 #define REP_StgTSO_what_next b16 #define StgTSO_what_next(__ptr__) REP_StgTSO_what_next[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_what_next]-#define OFFSET_StgTSO_why_blocked 26-#define REP_StgTSO_why_blocked b16+#define OFFSET_StgTSO_why_blocked 32+#define REP_StgTSO_why_blocked b32 #define StgTSO_why_blocked(__ptr__) REP_StgTSO_why_blocked[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_why_blocked]-#define OFFSET_StgTSO_block_info 32+#define OFFSET_StgTSO_block_info 40 #define REP_StgTSO_block_info b64 #define StgTSO_block_info(__ptr__) REP_StgTSO_block_info[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_block_info]-#define OFFSET_StgTSO_blocked_exceptions 88+#define OFFSET_StgTSO_blocked_exceptions 96 #define REP_StgTSO_blocked_exceptions b64 #define StgTSO_blocked_exceptions(__ptr__) REP_StgTSO_blocked_exceptions[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_blocked_exceptions]-#define OFFSET_StgTSO_id 40+#define OFFSET_StgTSO_id 48 #define REP_StgTSO_id b64 #define StgTSO_id(__ptr__) REP_StgTSO_id[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_id]-#define OFFSET_StgTSO_cap 64+#define OFFSET_StgTSO_cap 72 #define REP_StgTSO_cap b64 #define StgTSO_cap(__ptr__) REP_StgTSO_cap[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_cap]-#define OFFSET_StgTSO_saved_errno 48+#define OFFSET_StgTSO_saved_errno 56 #define REP_StgTSO_saved_errno b32 #define StgTSO_saved_errno(__ptr__) REP_StgTSO_saved_errno[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_saved_errno]-#define OFFSET_StgTSO_trec 72+#define OFFSET_StgTSO_trec 80 #define REP_StgTSO_trec b64 #define StgTSO_trec(__ptr__) REP_StgTSO_trec[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_trec] #define OFFSET_StgTSO_flags 28 #define REP_StgTSO_flags b32 #define StgTSO_flags(__ptr__) REP_StgTSO_flags[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_flags]-#define OFFSET_StgTSO_dirty 52+#define OFFSET_StgTSO_dirty 60 #define REP_StgTSO_dirty b32 #define StgTSO_dirty(__ptr__) REP_StgTSO_dirty[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_dirty]-#define OFFSET_StgTSO_bq 96+#define OFFSET_StgTSO_bq 104 #define REP_StgTSO_bq b64 #define StgTSO_bq(__ptr__) REP_StgTSO_bq[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_bq]-#define OFFSET_StgTSO_label 80+#define OFFSET_StgTSO_label 88 #define REP_StgTSO_label b64 #define StgTSO_label(__ptr__) REP_StgTSO_label[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_label]-#define OFFSET_StgTSO_alloc_limit 104+#define OFFSET_StgTSO_bound 64+#define REP_StgTSO_bound b64+#define StgTSO_bound(__ptr__) REP_StgTSO_bound[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_bound]+#define OFFSET_StgTSO_alloc_limit 112 #define REP_StgTSO_alloc_limit b64 #define StgTSO_alloc_limit(__ptr__) REP_StgTSO_alloc_limit[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_alloc_limit]-#define OFFSET_StgTSO_cccs 120+#define OFFSET_StgTSO_cccs 128 #define REP_StgTSO_cccs b64 #define StgTSO_cccs(__ptr__) REP_StgTSO_cccs[__ptr__+SIZEOF_StgHeader+OFFSET_StgTSO_cccs] #define OFFSET_StgTSO_stackobj 16@@ -263,13 +271,23 @@ #define OFFSET_StgStack_dirty 4 #define REP_StgStack_dirty b8 #define StgStack_dirty(__ptr__) REP_StgStack_dirty[__ptr__+SIZEOF_StgHeader+OFFSET_StgStack_dirty]+#define OFFSET_StgStack_marking 5+#define REP_StgStack_marking b8+#define StgStack_marking(__ptr__) REP_StgStack_marking[__ptr__+SIZEOF_StgHeader+OFFSET_StgStack_marking] #define SIZEOF_StgTSOProfInfo 8 #define OFFSET_StgUpdateFrame_updatee 0 #define REP_StgUpdateFrame_updatee b64 #define StgUpdateFrame_updatee(__ptr__) REP_StgUpdateFrame_updatee[__ptr__+SIZEOF_StgHeader+OFFSET_StgUpdateFrame_updatee]+#define OFFSET_StgOrigThunkInfoFrame_info_ptr 0+#define REP_StgOrigThunkInfoFrame_info_ptr b64+#define StgOrigThunkInfoFrame_info_ptr(__ptr__) REP_StgOrigThunkInfoFrame_info_ptr[__ptr__+SIZEOF_StgHeader+OFFSET_StgOrigThunkInfoFrame_info_ptr] #define OFFSET_StgCatchFrame_handler 0 #define REP_StgCatchFrame_handler b64 #define StgCatchFrame_handler(__ptr__) REP_StgCatchFrame_handler[__ptr__+SIZEOF_StgHeader+OFFSET_StgCatchFrame_handler]+#define SIZEOF_StgRetFun 24+#define OFFSET_StgRetFun_size 8+#define OFFSET_StgRetFun_fun 16+#define OFFSET_StgRetFun_payload 24 #define SIZEOF_StgPAP_NoHdr 16 #define SIZEOF_StgPAP (SIZEOF_StgHeader+16) #define OFFSET_StgPAP_n_args 4@@ -517,25 +535,25 @@ #define OFFSET_StgCompactNFDataBlock_next 16 #define REP_StgCompactNFDataBlock_next b64 #define StgCompactNFDataBlock_next(__ptr__) REP_StgCompactNFDataBlock_next[__ptr__+OFFSET_StgCompactNFDataBlock_next]-#define OFFSET_RtsFlags_ProfFlags_doHeapProfile 280+#define OFFSET_RtsFlags_ProfFlags_doHeapProfile 288 #define REP_RtsFlags_ProfFlags_doHeapProfile b32 #define RtsFlags_ProfFlags_doHeapProfile(__ptr__) REP_RtsFlags_ProfFlags_doHeapProfile[__ptr__+OFFSET_RtsFlags_ProfFlags_doHeapProfile]-#define OFFSET_RtsFlags_ProfFlags_showCCSOnException 301+#define OFFSET_RtsFlags_ProfFlags_showCCSOnException 311 #define REP_RtsFlags_ProfFlags_showCCSOnException b8 #define RtsFlags_ProfFlags_showCCSOnException(__ptr__) REP_RtsFlags_ProfFlags_showCCSOnException[__ptr__+OFFSET_RtsFlags_ProfFlags_showCCSOnException]-#define OFFSET_RtsFlags_DebugFlags_apply 245+#define OFFSET_RtsFlags_DebugFlags_apply 253 #define REP_RtsFlags_DebugFlags_apply b8 #define RtsFlags_DebugFlags_apply(__ptr__) REP_RtsFlags_DebugFlags_apply[__ptr__+OFFSET_RtsFlags_DebugFlags_apply]-#define OFFSET_RtsFlags_DebugFlags_sanity 239+#define OFFSET_RtsFlags_DebugFlags_sanity 247 #define REP_RtsFlags_DebugFlags_sanity b8 #define RtsFlags_DebugFlags_sanity(__ptr__) REP_RtsFlags_DebugFlags_sanity[__ptr__+OFFSET_RtsFlags_DebugFlags_sanity]-#define OFFSET_RtsFlags_DebugFlags_weak 234+#define OFFSET_RtsFlags_DebugFlags_weak 242 #define REP_RtsFlags_DebugFlags_weak b8 #define RtsFlags_DebugFlags_weak(__ptr__) REP_RtsFlags_DebugFlags_weak[__ptr__+OFFSET_RtsFlags_DebugFlags_weak] #define OFFSET_RtsFlags_GcFlags_initialStkSize 16 #define REP_RtsFlags_GcFlags_initialStkSize b32 #define RtsFlags_GcFlags_initialStkSize(__ptr__) REP_RtsFlags_GcFlags_initialStkSize[__ptr__+OFFSET_RtsFlags_GcFlags_initialStkSize]-#define OFFSET_RtsFlags_MiscFlags_tickInterval 200+#define OFFSET_RtsFlags_MiscFlags_tickInterval 208 #define REP_RtsFlags_MiscFlags_tickInterval b64 #define RtsFlags_MiscFlags_tickInterval(__ptr__) REP_RtsFlags_MiscFlags_tickInterval[__ptr__+OFFSET_RtsFlags_MiscFlags_tickInterval] #define SIZEOF_StgFunInfoExtraFwd 32
ghc-lib/stage0/rts/build/include/ghcautoconf.h view
@@ -1,7 +1,7 @@ #if !defined(__GHCAUTOCONF_H__) #define __GHCAUTOCONF_H__-/* mk/config.h.  Generated from config.h.in by configure.  */-/* mk/config.h.in.  Generated from configure.ac by autoheader.  */+/* ghcautoconf.h.autoconf.  Generated from ghcautoconf.h.autoconf.in by configure.  */+/* ghcautoconf.h.autoconf.in.  Generated from configure.ac by autoheader.  */  /* Define if building universal (internal helper macro) */ /* #undef AC_APPLE_UNIVERSAL_BUILD */@@ -103,9 +103,6 @@ /* Define to 1 if you have the <bfd.h> header file. */ /* #undef HAVE_BFD_H */ -/* Does C compiler support __atomic primitives? */-#define HAVE_C11_ATOMICS 1- /* Define to 1 if you have the 'clock_gettime' function. */ #define HAVE_CLOCK_GETTIME 1 @@ -125,15 +122,15 @@  /* Define to 1 if you have the declaration of 'MADV_DONTNEED', and to 0 if you    don't. */-/* #undef HAVE_DECL_MADV_DONTNEED */+#define HAVE_DECL_MADV_DONTNEED 1  /* Define to 1 if you have the declaration of 'MADV_FREE', and to 0 if you    don't. */-/* #undef HAVE_DECL_MADV_FREE */+#define HAVE_DECL_MADV_FREE 1  /* Define to 1 if you have the declaration of 'MAP_NORESERVE', and to 0 if you    don't. */-/* #undef HAVE_DECL_MAP_NORESERVE */+#define HAVE_DECL_MAP_NORESERVE 1  /* Define to 1 if you have the declaration of 'program_invocation_short_name',    and to 0 if you don't. */@@ -148,9 +145,6 @@ /* Define to 1 if you have the 'dlinfo' function. */ /* #undef HAVE_DLINFO */ -/* Define to 1 if you have the <elfutils/libdw.h> header file. */-/* #undef HAVE_ELFUTILS_LIBDW_H */- /* Define to 1 if you have the <errno.h> header file. */ #define HAVE_ERRNO_H 1 @@ -160,9 +154,6 @@ /* Define to 1 if you have the <fcntl.h> header file. */ #define HAVE_FCNTL_H 1 -/* Define to 1 if you have the <ffi.h> header file. */-/* #undef HAVE_FFI_H */- /* Define to 1 if you have the 'fork' function. */ #define HAVE_FORK 1 @@ -202,18 +193,12 @@ /* Define to 1 if you need to link with libm */ #define HAVE_LIBM 1 -/* Define to 1 if you have the 'mingwex' library (-lmingwex). */-/* #undef HAVE_LIBMINGWEX */- /* Define to 1 if you have libnuma */ #define HAVE_LIBNUMA 0  /* Define to 1 if you have the 'pthread' library (-lpthread). */ #define HAVE_LIBPTHREAD 1 -/* Define to 1 if you have the 'rt' library (-lrt). */-/* #undef HAVE_LIBRT */- /* Define to 1 if you wish to compress IPE data in compiler results (requires    libzstd) */ #define HAVE_LIBZSTD 0@@ -311,9 +296,6 @@ /* Define to 1 if you have the 'sysconf' function. */ #define HAVE_SYSCONF 1 -/* Define to 1 if you have libffi. */-/* #undef HAVE_SYSTEM_LIBFFI */- /* Define to 1 if you have the <sys/cpuset.h> header file. */ /* #undef HAVE_SYS_CPUSET_H */ @@ -401,19 +383,13 @@ /* Define to 1 if 'vfork' works. */ #define HAVE_WORKING_VFORK 1 -/* Define to 1 if you have the <zstd.h> header file. */-/* #undef HAVE_ZSTD_H */- /* Define to 1 if C symbols have a leading underscore added by the compiler.    */ #define LEADING_UNDERSCORE 1 -/* Define to 1 if we need -latomic. */+/* Define to 1 if we need -latomic for sub-word atomic operations. */ #define NEED_ATOMIC_LIB 0 -/* Define 1 if we need to link code using pthreads with -lpthread */-#define NEED_PTHREAD_LIB 0- /* Define to the address where bug reports for this package should be sent. */ /* #undef PACKAGE_BUGREPORT */ @@ -658,41 +634,9 @@ /* Define as a signed integer type capable of holding a process identifier. */ /* #undef pid_t */ -/* The maximum supported LLVM version number */-#define sUPPORTED_LLVM_VERSION_MAX (16)--/* The minimum supported LLVM version number */-#define sUPPORTED_LLVM_VERSION_MIN (11)- /* Define as 'unsigned int' if <stddef.h> doesn't define. */ /* #undef size_t */  /* Define as 'fork' if 'vfork' does not work. */ /* #undef vfork */-/* ghcautoconf.h.autoconf.  Generated from ghcautoconf.h.autoconf.in by configure.  */-/* ghcautoconf.h.autoconf.in.  Generated from configure.ac by autoheader.  */--/* Define to the address where bug reports for this package should be sent. */-/* #undef PACKAGE_BUGREPORT */--/* Define to the full name of this package. */-/* #undef PACKAGE_NAME */--/* Define to the full name and version of this package. */-/* #undef PACKAGE_STRING */--/* Define to the one symbol short name of this package. */-/* #undef PACKAGE_TARNAME */--/* Define to the home page for this package. */-/* #undef PACKAGE_URL */--/* Define to the version of this package. */-/* #undef PACKAGE_VERSION */--/* ARM pre v6 */-/* #undef arm_HOST_ARCH_PRE_ARMv6 */--/* ARM pre v7 */-/* #undef arm_HOST_ARCH_PRE_ARMv7 */ #endif /* __GHCAUTOCONF_H__ */
ghc-lib/stage0/rts/build/include/ghcplatform.h view
@@ -4,23 +4,22 @@ #define BuildPlatform_TYPE  x86_64_apple_darwin #define HostPlatform_TYPE   x86_64_apple_darwin -#define x86_64_apple_darwin_BUILD 1-#define x86_64_apple_darwin_HOST 1--#define x86_64_BUILD_ARCH 1-#define x86_64_HOST_ARCH 1-#define BUILD_ARCH "x86_64"-#define HOST_ARCH "x86_64"+#define x86_64_apple_darwin_BUILD  1+#define x86_64_apple_darwin_HOST  1 -#define darwin_BUILD_OS 1-#define darwin_HOST_OS 1-#define BUILD_OS "darwin"-#define HOST_OS "darwin"+#define x86_64_BUILD_ARCH  1+#define x86_64_HOST_ARCH  1+#define BUILD_ARCH  "x86_64"+#define HOST_ARCH  "x86_64" -#define apple_BUILD_VENDOR 1-#define apple_HOST_VENDOR 1-#define BUILD_VENDOR "apple"-#define HOST_VENDOR "apple"+#define darwin_BUILD_OS  1+#define darwin_HOST_OS  1+#define BUILD_OS  "darwin"+#define HOST_OS  "darwin" +#define apple_BUILD_VENDOR  1+#define apple_HOST_VENDOR  1+#define BUILD_VENDOR  "apple"+#define HOST_VENDOR  "apple"  #endif /* __GHCPLATFORM_H__ */
ghc/ghc-bin.cabal view
@@ -2,7 +2,7 @@ -- ./configure.  Make sure you are editing ghc-bin.cabal.in, not ghc-bin.cabal.  Name: ghc-bin-Version: 9.8.4.20250206+Version: 9.10.1 Copyright: XXX -- License: XXX -- License-File: XXX@@ -28,7 +28,7 @@     Manual: True  Executable ghc-    Default-Language: Haskell2010+    Default-Language: GHC2021      Main-Is: Main.hs     Build-Depends: base       >= 4   && < 5,@@ -36,14 +36,14 @@                    bytestring >= 0.9 && < 0.13,                    directory  >= 1   && < 1.4,                    process    >= 1   && < 1.7,-                   filepath   >= 1   && < 1.5,-                   containers >= 0.5 && < 0.7,+                   filepath   >= 1   && < 1.6,+                   containers >= 0.5 && < 0.8,                    transformers >= 0.5 && < 0.7,-                   ghc-boot      == 9.8.4.20250206,-                   ghc           == 9.8.4.20250206+                   ghc-boot      == 9.10.1,+                   ghc           == 9.10.1      if os(windows)-        Build-Depends: Win32  >= 2.3 && < 2.14+        Build-Depends: Win32  >= 2.3 && < 2.15     else         Build-Depends: unix   >= 2.7 && < 2.9 @@ -58,7 +58,7 @@         Build-depends:             deepseq        >= 1.4 && < 1.6,             ghc-prim       >= 0.5.0 && < 0.12,-            ghci           == 9.8.4.20250206,+            ghci           == 9.10.1,             haskeline      == 0.8.*,             exceptions     == 0.10.*,             time           >= 1.8 && < 1.13
libraries/ghc-boot-th/GHC/LanguageExtensions/Type.hs view
@@ -77,6 +77,7 @@    | InstanceSigs    | ApplicativeDo    | LinearTypes+   | RequiredTypeArguments    -- Visible forall (VDQ) in types of terms     | StandaloneDeriving    | DeriveDataTypeable@@ -153,6 +154,7 @@    | OverloadedRecordUpdate    | TypeAbstractions    | ExtendedLiterals+   | ListTuplePuns    deriving (Eq, Enum, Show, Generic, Bounded) -- 'Ord' and 'Bounded' are provided for GHC API users (see discussions -- in https://gitlab.haskell.org/ghc/ghc/merge_requests/2707 and
libraries/ghc-boot-th/ghc-boot-th.cabal view
@@ -3,7 +3,7 @@ -- ghc-boot-th.cabal.in, not ghc-boot-th.cabal.  name:           ghc-boot-th-version:        9.8.4.20250206+version:        9.10.1 license:        BSD3 license-file:   LICENSE category:       GHC@@ -36,4 +36,4 @@             GHC.ForeignSrcLang.Type             GHC.Lexeme -    build-depends: base       >= 4.7 && < 4.20+    build-depends: base       >= 4.7 && < 4.21
− libraries/ghc-boot/GHC/Platform/ArchOS.hs 
@@ -1,161 +0,0 @@-{-# LANGUAGE LambdaCase, ScopedTypeVariables #-}---- | Platform architecture and OS------ We need it in ghc-boot because ghc-pkg needs it.-module GHC.Platform.ArchOS-   ( ArchOS(..)-   , Arch(..)-   , OS(..)-   , ArmISA(..)-   , ArmISAExt(..)-   , ArmABI(..)-   , PPC_64ABI(..)-   , stringEncodeArch-   , stringEncodeOS-   )-where--import Prelude -- See Note [Why do we import Prelude here?]---- | Platform architecture and OS.-data ArchOS-   = ArchOS-      { archOS_arch :: Arch-      , archOS_OS   :: OS-      }-   deriving (Read, Show, Eq, Ord)---- | Architectures------ TODO: It might be nice to extend these constructors with information about--- what instruction set extensions an architecture might support.----data Arch-   = ArchUnknown-   | ArchX86-   | ArchX86_64-   | ArchPPC-   | ArchPPC_64 PPC_64ABI-   | ArchS390X-   | ArchARM ArmISA [ArmISAExt] ArmABI-   | ArchAArch64-   | ArchAlpha-   | ArchMipseb-   | ArchMipsel-   | ArchRISCV64-   | ArchLoongArch64-   | ArchJavaScript-   | ArchWasm32-   deriving (Read, Show, Eq, Ord)---- | ARM Instruction Set Architecture-data ArmISA-   = ARMv5-   | ARMv6-   | ARMv7-   deriving (Read, Show, Eq, Ord)---- | ARM extensions-data ArmISAExt-   = VFPv2-   | VFPv3-   | VFPv3D16-   | NEON-   | IWMMX2-   deriving (Read, Show, Eq, Ord)---- | ARM ABI-data ArmABI-   = SOFT-   | SOFTFP-   | HARD-   deriving (Read, Show, Eq, Ord)---- | PowerPC 64-bit ABI-data PPC_64ABI-   = ELF_V1 -- ^ PowerPC64-   | ELF_V2 -- ^ PowerPC64 LE-   deriving (Read, Show, Eq, Ord)---- | Operating systems.------ Using OSUnknown to generate code should produce a sensible default, but no--- promises.-data OS-   = OSUnknown-   | OSLinux-   | OSDarwin-   | OSSolaris2-   | OSMinGW32-   | OSFreeBSD-   | OSDragonFly-   | OSOpenBSD-   | OSNetBSD-   | OSKFreeBSD-   | OSHaiku-   | OSQNXNTO-   | OSAIX-   | OSHurd-   | OSWasi-   | OSGhcjs-   deriving (Read, Show, Eq, Ord)----- Note [Platform Syntax]--- ~~~~~~~~~~~~~~~~~~~~~~------ There is a very loose encoding of platforms shared by many tools we are--- encoding to here. GNU Config (http://git.savannah.gnu.org/cgit/config.git),--- and LLVM's http://llvm.org/doxygen/classllvm_1_1Triple.html are perhaps the--- most definitional parsers. The basic syntax is a list of '-'-separated--- components. The Unix 'uname' command syntax is related but briefer.------ Those two parsers are quite forgiving, and even the 'config.sub'--- normalization is forgiving too. The "best" way to encode a platform is--- therefore somewhat a matter of taste.------ The 'stringEncode*' functions here convert each part of GHC's structured--- notion of a platform into one dash-separated component.---- | See Note [Platform Syntax].-stringEncodeArch :: Arch -> String-stringEncodeArch = \case-  ArchUnknown       -> "unknown"-  ArchX86           -> "i386"-  ArchX86_64        -> "x86_64"-  ArchPPC           -> "powerpc"-  ArchPPC_64 ELF_V1 -> "powerpc64"-  ArchPPC_64 ELF_V2 -> "powerpc64le"-  ArchS390X         -> "s390x"-  ArchARM ARMv5 _ _ -> "armv5"-  ArchARM ARMv6 _ _ -> "armv6"-  ArchARM ARMv7 _ _ -> "armv7"-  ArchAArch64       -> "aarch64"-  ArchAlpha         -> "alpha"-  ArchMipseb        -> "mipseb"-  ArchMipsel        -> "mipsel"-  ArchRISCV64       -> "riscv64"-  ArchLoongArch64   -> "loongarch64"-  ArchJavaScript    -> "javascript"-  ArchWasm32        -> "wasm32"---- | See Note [Platform Syntax].-stringEncodeOS :: OS -> String-stringEncodeOS = \case-  OSUnknown   -> "unknown"-  OSLinux     -> "linux"-  OSDarwin    -> "darwin"-  OSSolaris2  -> "solaris2"-  OSMinGW32   -> "mingw32"-  OSFreeBSD   -> "freebsd"-  OSDragonFly -> "dragonfly"-  OSOpenBSD   -> "openbsd"-  OSNetBSD    -> "netbsd"-  OSKFreeBSD  -> "kfreebsdgnu"-  OSHaiku     -> "haiku"-  OSQNXNTO    -> "nto-qnx"-  OSAIX       -> "aix"-  OSHurd      -> "hurd"-  OSWasi      -> "wasi"-  OSGhcjs     -> "ghcjs"
libraries/ghc-boot/GHC/Utils/Encoding.hs view
@@ -81,7 +81,6 @@         (,,,,)          Z5T     5-tuple         (# #)           Z1H     unboxed 1-tuple (note the space)         (#,,,,#)        Z5H     unboxed 5-tuple-                (NB: There is no Z1T nor Z0H.) -}  type UserString = String        -- As the user typed it@@ -223,15 +222,15 @@ for 3-tuples or unboxed 3-tuples respectively.  No other encoding starts         Z<digit> -* "(# #)" is the tycon for an unboxed 1-tuple (not 0-tuple)-  There are no unboxed 0-tuples.+* "(##)" is the tycon for an unboxed 0-tuple+* "(# #)" is the tycon for an unboxed 1-tuple  * "()" is the tycon for a boxed 0-tuple.-  There are no boxed 1-tuples. -}  maybe_tuple :: UserString -> Maybe EncodedString +maybe_tuple "(##)" = Just("Z0H") maybe_tuple "(# #)" = Just("Z1H") maybe_tuple ('(' : '#' : cs) = case count_commas (0::Int) cs of                                  (n, '#' : ')' : _) -> Just ('Z' : shows (n+1) "H")
libraries/ghc-boot/ghc-boot.cabal view
@@ -5,7 +5,7 @@ -- ghc-boot.cabal.  name:           ghc-boot-version:        9.8.4.20250206+version:        9.10.1 license:        BSD-3-Clause license-file:   LICENSE category:       GHC@@ -51,7 +51,6 @@             GHC.Serialized             GHC.ForeignSrcLang             GHC.HandleEncoding-            GHC.Platform.ArchOS             GHC.Platform.Host             GHC.Settings.Utils             GHC.UniqueSubdir@@ -65,19 +64,24 @@             , GHC.ForeignSrcLang.Type             , GHC.Lexeme +    -- reexport platform modules from ghc-platform+    reexported-modules:+              GHC.Platform.ArchOS+     -- but done by Hadrian     autogen-modules:             GHC.Version             GHC.Platform.Host -    build-depends: base       >= 4.7 && < 4.20,+    build-depends: base       >= 4.7 && < 4.21,                    binary     == 0.8.*,                    bytestring >= 0.10 && < 0.13,-                   containers >= 0.5 && < 0.7,+                   containers >= 0.5 && < 0.8,                    directory  >= 1.2 && < 1.4,-                   filepath   >= 1.3 && < 1.5,+                   filepath   >= 1.3 && < 1.6,                    deepseq    >= 1.4 && < 1.6,-                   ghc-boot-th == 9.8.4.20250206+                   ghc-platform >= 0.1,+                   ghc-boot-th == 9.10.1     if !os(windows)         build-depends:                    unix       >= 2.7 && < 2.9
libraries/ghc-heap/GHC/Exts/Heap.hs view
@@ -317,8 +317,9 @@             _ -> fail $ "Expected at least 3 ptrs to MVAR, found "                         ++ show (length pts) -        BLOCKING_QUEUE ->-            pure $ OtherClosure itbl pts rawHeapWords+        BLOCKING_QUEUE+          | [_link, bh, _owner, msg] <- pts ->+            pure $ BlockingQueueClosure itbl _link bh _owner msg          WEAK -> case pts of             pts0 : pts1 : pts2 : pts3 : rest -> pure $ WeakClosure
libraries/ghc-heap/GHC/Exts/Heap/ClosureTypes.hs view
@@ -7,6 +7,9 @@     ) where  import Prelude -- See note [Why do we import Prelude here?]+#if __GLASGOW_HASKELL__ >= 909+import GHC.Internal.ClosureTypes+#else import GHC.Generics  {- ---------------------------------------------@@ -83,6 +86,7 @@     | CONTINUATION     | N_CLOSURE_TYPES  deriving (Enum, Eq, Ord, Show, Generic)+#endif  -- | Return the size of the closures header in words closureTypeHeaderSize :: ClosureType -> Int
libraries/ghc-heap/GHC/Exts/Heap/Closures.hs view
@@ -18,6 +18,14 @@     , allClosures     , closureSize +    -- * Stack+    , StgStackClosure+    , GenStgStackClosure(..)+    , StackFrame+    , GenStackFrame(..)+    , StackField+    , GenStackField(..)+     -- * Boxes     , Box(..)     , areBoxesEqual@@ -95,7 +103,6 @@  ------------------------------------------------------------------------ -- Closures- type Closure = GenClosure Box  -- | This is the representation of a Haskell value on the heap. It reflects@@ -354,8 +361,110 @@   | UnsupportedClosure         { info       :: !StgInfoTable         }++    -- | A primitive word from a bitmap encoded stack frame payload+    --+    -- The type itself cannot be restored (i.e. it might represent a Word8#+    -- or an Int#).+  |  UnknownTypeWordSizedPrimitive+        { wordVal :: !Word }   deriving (Show, Generic, Functor, Foldable, Traversable) +type StgStackClosure = GenStgStackClosure Box++-- | A decoded @StgStack@ with `StackFrame`s+--+-- Stack related data structures (`GenStgStackClosure`, `GenStackField`,+-- `GenStackFrame`) are defined separately from `GenClosure` as their related+-- functions are very different. Though, both are closures in the sense of RTS+-- structures, their decoding logic differs: While it's safe to keep a reference+-- to a heap closure, the garbage collector does not update references to stack+-- located closures.+--+-- Additionally, stack frames don't appear outside of the stack. Thus, keeping+-- `GenStackFrame` and `GenClosure` separated, makes these types more precise+-- (in the sense what values to expect.)+data GenStgStackClosure b = GenStgStackClosure+      { ssc_info            :: !StgInfoTable+      , ssc_stack_size      :: !Word32 -- ^ stack size in *words*+      , ssc_stack           :: ![GenStackFrame b]+      }+  deriving (Foldable, Functor, Generic, Show, Traversable)++type StackField = GenStackField Box++-- | Bitmap-encoded payload on the stack+data GenStackField b+    -- | A non-pointer field+    = StackWord !Word+    -- | A pointer field+    | StackBox  !b+  deriving (Foldable, Functor, Generic, Show, Traversable)++type StackFrame = GenStackFrame Box++-- | A single stack frame+data GenStackFrame b =+   UpdateFrame+      { info_tbl           :: !StgInfoTable+      , updatee            :: !b+      }++  | CatchFrame+      { info_tbl            :: !StgInfoTable+      , handler             :: !b+      }++  | CatchStmFrame+      { info_tbl            :: !StgInfoTable+      , catchFrameCode      :: !b+      , handler             :: !b+      }++  | CatchRetryFrame+      { info_tbl            :: !StgInfoTable+      , running_alt_code    :: !Word+      , first_code          :: !b+      , alt_code            :: !b+      }++  | AtomicallyFrame+      { info_tbl            :: !StgInfoTable+      , atomicallyFrameCode :: !b+      , result              :: !b+      }++  | UnderflowFrame+      { info_tbl            :: !StgInfoTable+      , nextChunk           :: !(GenStgStackClosure b)+      }++  | StopFrame+      { info_tbl            :: !StgInfoTable }++  | RetSmall+      { info_tbl            :: !StgInfoTable+      , stack_payload       :: ![GenStackField b]+      }++  | RetBig+      { info_tbl            :: !StgInfoTable+      , stack_payload       :: ![GenStackField b]+      }++  | RetFun+      { info_tbl            :: !StgInfoTable+      , retFunSize          :: !Word+      , retFunFun           :: !b+      , retFunPayload       :: ![GenStackField b]+      }++  |  RetBCO+      { info_tbl            :: !StgInfoTable+      , bco                 :: !b -- ^ always a BCOClosure+      , bcoArgs             :: ![GenStackField b]+      }+  deriving (Foldable, Functor, Generic, Show, Traversable)  data PrimType   = PInt
libraries/ghc-heap/GHC/Exts/Heap/InfoTable/Types.hsc view
@@ -37,4 +37,4 @@    tipe   :: ClosureType,    srtlen :: HalfWord,    code   :: Maybe ItblCodes -- Just <=> TABLES_NEXT_TO_CODE-  } deriving (Show, Generic)+  } deriving (Eq, Show, Generic)
libraries/ghc-heap/ghc-heap.cabal view
@@ -1,6 +1,6 @@ cabal-version:  3.0 name:           ghc-heap-version:        9.8.4.20250206+version:        9.10.1 license:        BSD-3-Clause license-file:   LICENSE maintainer:     libraries@haskell.org@@ -25,11 +25,16 @@   build-depends:    base             >= 4.9.0 && < 5.0                   , ghc-prim         > 0.2 && < 0.12                   , rts              == 1.0.*-                  , containers       >= 0.6.2.1 && < 0.7+                  , containers       >= 0.6.2.1 && < 0.8 +  if impl(ghc >= 9.9)+    build-depends:  ghc-internal     >= 9.1001 && < 9.1002+   ghc-options:      -Wall   if !os(ghcjs)     cmm-sources:      cbits/HeapPrim.cmm+                      cbits/Stack.cmm+  c-sources:        cbits/Stack_c.c    default-extensions: NoImplicitPrelude @@ -48,3 +53,6 @@                     GHC.Exts.Heap.ProfInfo.PeekProfInfo                     GHC.Exts.Heap.ProfInfo.PeekProfInfo_ProfilingDisabled                     GHC.Exts.Heap.ProfInfo.PeekProfInfo_ProfilingEnabled+                    GHC.Exts.Stack.Constants+                    GHC.Exts.Stack+                    GHC.Exts.Stack.Decode
+ libraries/ghc-platform/ghc-platform.cabal view
@@ -0,0 +1,20 @@+cabal-version:      3.0+name:               ghc-platform+version:            0.1.0.0+synopsis:           Platform information used by GHC and friends+license:            BSD-3-Clause+license-file:       LICENSE+author:             Rodrigo Mesquita+maintainer:         ghc-devs@haskell.org+build-type:         Simple+extra-doc-files:    CHANGELOG.md++common warnings+    ghc-options: -Wall++library+    import:           warnings+    exposed-modules:  GHC.Platform.ArchOS+    build-depends:    base >=4.15.0.0 && <5+    hs-source-dirs:   src+    default-language: Haskell2010
+ libraries/ghc-platform/src/GHC/Platform/ArchOS.hs view
@@ -0,0 +1,195 @@+{-# LANGUAGE LambdaCase, ScopedTypeVariables #-}++-- | Platform architecture and OS+module GHC.Platform.ArchOS+   ( ArchOS(..)++     -- * Architectures+   , Arch(..)+   , ArmISA(..)+   , ArmISAExt(..)+   , ArmABI(..)+   , PPC_64ABI(..)+   , isARM+   , stringEncodeArch++     -- * Operating systems+   , OS(..)+   , osElfTarget+   , osMachOTarget+   , stringEncodeOS+   )+where++import Prelude -- See Note [Why do we import Prelude here?]++-- | Platform architecture and OS.+data ArchOS+   = ArchOS+      { archOS_arch :: Arch+      , archOS_OS   :: OS+      }+   deriving (Read, Show, Eq, Ord)++-- | Architectures+data Arch+   = ArchUnknown+   | ArchX86+   | ArchX86_64+   | ArchPPC+   | ArchPPC_64 PPC_64ABI+   | ArchS390X+   | ArchARM ArmISA [ArmISAExt] ArmABI+   | ArchAArch64+   | ArchAlpha+   | ArchMipseb+   | ArchMipsel+   | ArchRISCV64+   | ArchLoongArch64+   | ArchJavaScript+   | ArchWasm32+   deriving (Read, Show, Eq, Ord)++-- | ARM Instruction Set Architecture+data ArmISA+   = ARMv5+   | ARMv6+   | ARMv7+   deriving (Read, Show, Eq, Ord)++-- | ARM extensions+data ArmISAExt+   = VFPv2+   | VFPv3+   | VFPv3D16+   | NEON+   | IWMMX2+   deriving (Read, Show, Eq, Ord)++-- | ARM ABI+data ArmABI+   = SOFT+   | SOFTFP+   | HARD+   deriving (Read, Show, Eq, Ord)++-- | PowerPC 64-bit ABI+data PPC_64ABI+   = ELF_V1 -- ^ PowerPC64+   | ELF_V2 -- ^ PowerPC64 LE+   deriving (Read, Show, Eq, Ord)++-- | Operating systems.+--+-- Using OSUnknown to generate code should produce a sensible default, but no+-- promises.+data OS+   = OSUnknown+   | OSLinux+   | OSDarwin+   | OSSolaris2+   | OSMinGW32+   | OSFreeBSD+   | OSDragonFly+   | OSOpenBSD+   | OSNetBSD+   | OSKFreeBSD+   | OSHaiku+   | OSQNXNTO+   | OSAIX+   | OSHurd+   | OSWasi+   | OSGhcjs+   deriving (Read, Show, Eq, Ord)+++-- Note [Platform Syntax]+-- ~~~~~~~~~~~~~~~~~~~~~~+--+-- There is a very loose encoding of platforms shared by many tools we are+-- encoding to here. GNU Config (http://git.savannah.gnu.org/cgit/config.git),+-- and LLVM's http://llvm.org/doxygen/classllvm_1_1Triple.html are perhaps the+-- most definitional parsers. The basic syntax is a list of '-'-separated+-- components. The Unix 'uname' command syntax is related but briefer.+--+-- Those two parsers are quite forgiving, and even the 'config.sub'+-- normalization is forgiving too. The "best" way to encode a platform is+-- therefore somewhat a matter of taste.+--+-- The 'stringEncode*' functions here convert each part of GHC's structured+-- notion of a platform into one dash-separated component.++-- | See Note [Platform Syntax].+stringEncodeArch :: Arch -> String+stringEncodeArch = \case+  ArchUnknown       -> "unknown"+  ArchX86           -> "i386"+  ArchX86_64        -> "x86_64"+  ArchPPC           -> "powerpc"+  ArchPPC_64 ELF_V1 -> "powerpc64"+  ArchPPC_64 ELF_V2 -> "powerpc64le"+  ArchS390X         -> "s390x"+  ArchARM ARMv5 _ _ -> "armv5"+  ArchARM ARMv6 _ _ -> "armv6"+  ArchARM ARMv7 _ _ -> "armv7"+  ArchAArch64       -> "aarch64"+  ArchAlpha         -> "alpha"+  ArchMipseb        -> "mipseb"+  ArchMipsel        -> "mipsel"+  ArchRISCV64       -> "riscv64"+  ArchLoongArch64   -> "loongarch64"+  ArchJavaScript    -> "javascript"+  ArchWasm32        -> "wasm32"++-- | See Note [Platform Syntax].+stringEncodeOS :: OS -> String+stringEncodeOS = \case+  OSUnknown   -> "unknown"+  OSLinux     -> "linux"+  OSDarwin    -> "darwin"+  OSSolaris2  -> "solaris2"+  OSMinGW32   -> "mingw32"+  OSFreeBSD   -> "freebsd"+  OSDragonFly -> "dragonfly"+  OSOpenBSD   -> "openbsd"+  OSNetBSD    -> "netbsd"+  OSKFreeBSD  -> "kfreebsdgnu"+  OSHaiku     -> "haiku"+  OSQNXNTO    -> "nto-qnx"+  OSAIX       -> "aix"+  OSHurd      -> "hurd"+  OSWasi      -> "wasi"+  OSGhcjs     -> "ghcjs"++-- | This predicate tells us whether the OS uses the ELF as its primary object format.+osElfTarget :: OS -> Bool+osElfTarget OSLinux     = True+osElfTarget OSFreeBSD   = True+osElfTarget OSDragonFly = True+osElfTarget OSOpenBSD   = True+osElfTarget OSNetBSD    = True+osElfTarget OSSolaris2  = True+osElfTarget OSDarwin    = False+osElfTarget OSMinGW32   = False+osElfTarget OSKFreeBSD  = True+osElfTarget OSHaiku     = True+osElfTarget OSQNXNTO    = False+osElfTarget OSAIX       = False+osElfTarget OSHurd      = True+osElfTarget OSWasi      = False+osElfTarget OSGhcjs     = False+osElfTarget OSUnknown   = False+ -- Defaulting to False is safe; it means don't rely on any+ -- ELF-specific functionality.  It is important to have a default for+ -- portability, otherwise we have to answer this question for every+ -- new platform we compile on (even unreg).++isARM :: Arch -> Bool+isARM (ArchARM {}) = True+isARM ArchAArch64  = True+isARM _ = False++-- | This predicate tells us whether the OS support Mach-O shared libraries.+osMachOTarget :: OS -> Bool+osMachOTarget OSDarwin = True+osMachOTarget _ = False
+ libraries/ghci/GHCi/BinaryArray.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE BangPatterns, MagicHash, UnboxedTuples, FlexibleContexts #-}+-- | Efficient serialisation for GHCi Instruction arrays+--+-- Author: Ben Gamari+--+module GHCi.BinaryArray(putArray, getArray) where++import Prelude+import Foreign.Ptr+import Data.Binary+import Data.Binary.Put (putBuilder)+import qualified Data.Binary.Get.Internal as Binary+import qualified Data.ByteString.Builder as BB+import qualified Data.ByteString.Builder.Internal as BB+import qualified Data.Array.Base as A+import qualified Data.Array.IO.Internals as A+import qualified Data.Array.Unboxed as A+import GHC.Exts+import GHC.IO++-- | An efficient serialiser of 'A.UArray'.+putArray :: Binary i => A.UArray i a -> Put+putArray (A.UArray l u _ arr#) = do+    put l+    put u+    putBuilder $ byteArrayBuilder arr#++byteArrayBuilder :: ByteArray# -> BB.Builder+byteArrayBuilder arr# = BB.builder $ go 0 (I# (sizeofByteArray# arr#))+  where+    go :: Int -> Int -> BB.BuildStep a -> BB.BuildStep a+    go !inStart !inEnd k (BB.BufferRange outStart outEnd)+      -- There is enough room in this output buffer to write all remaining array+      -- contents+      | inRemaining <= outRemaining = do+          copyByteArrayToAddr arr# inStart outStart inRemaining+          k (BB.BufferRange (outStart `plusPtr` inRemaining) outEnd)+      -- There is only enough space for a fraction of the remaining contents+      | otherwise = do+          copyByteArrayToAddr arr# inStart outStart outRemaining+          let !inStart' = inStart + outRemaining+          return $! BB.bufferFull 1 outEnd (go inStart' inEnd k)+      where+        inRemaining  = inEnd - inStart+        outRemaining = outEnd `minusPtr` outStart++    copyByteArrayToAddr :: ByteArray# -> Int -> Ptr a -> Int -> IO ()+    copyByteArrayToAddr src# (I# src_off#) (Ptr dst#) (I# len#) =+        IO $ \s -> case copyByteArrayToAddr# src# src_off# dst# len# s of+                     s' -> (# s', () #)++-- | An efficient deserialiser of 'A.UArray'.+getArray :: (Binary i, A.Ix i, A.MArray A.IOUArray a IO) => Get (A.UArray i a)+getArray = do+    l <- get+    u <- get+    arr@(A.IOUArray (A.STUArray _ _ _ arr#)) <-+        return $ unsafeDupablePerformIO $ A.newArray_ (l,u)+    let go 0 _ = return ()+        go !remaining !off = do+            Binary.readNWith n $ \ptr ->+              copyAddrToByteArray ptr arr# off n+            go (remaining - n) (off + n)+          where n = min chunkSize remaining+    go (I# (sizeofMutableByteArray# arr#)) 0+    return $! unsafeDupablePerformIO $ unsafeFreezeIOUArray arr+  where+    chunkSize = 10*1024++    copyAddrToByteArray :: Ptr a -> MutableByteArray# RealWorld+                        -> Int -> Int -> IO ()+    copyAddrToByteArray (Ptr src#) dst# (I# dst_off#) (I# len#) =+        IO $ \s -> case copyAddrToByteArray# src# dst# dst_off# len# s of+                     s' -> (# s', () #)++-- this is inexplicably not exported in currently released array versions+unsafeFreezeIOUArray :: A.IOUArray ix e -> IO (A.UArray ix e)+unsafeFreezeIOUArray (A.IOUArray marr) = stToIO (A.unsafeFreezeSTUArray marr)
libraries/ghci/GHCi/BreakArray.hs view
@@ -8,7 +8,7 @@ -- | Break Arrays -- -- An array of words, indexed by a breakpoint number (breakpointId in Tickish)--- containing the ignore count for every breakpopint.+-- containing the ignore count for every breakpoint. -- There is one of these arrays per module. -- -- For each word with value n:
libraries/ghci/GHCi/Message.hs view
@@ -14,6 +14,7 @@   , THMessage(..), THMsg(..)   , QResult(..)   , EvalStatus_(..), EvalStatus, EvalResult(..), EvalOpts(..), EvalExpr(..)+  , EvalBreakpoint (..)   , SerializableException(..)   , toSerializableException, fromSerializableException   , THResult(..), THResultType(..)@@ -21,7 +22,6 @@   , QState(..)   , getMessage, putMessage, getTHMessage, putTHMessage   , Pipe(..), remoteCall, remoteTHCall, readPipe, writePipe-  , LoadedDLL   , BreakModule   ) where @@ -30,11 +30,13 @@ import GHCi.FFI import GHCi.TH.Binary () -- For Binary instances import GHCi.BreakArray+import GHCi.ResolvedBCO  import GHC.LanguageExtensions import qualified GHC.Exts.Heap as Heap import GHC.ForeignSrcLang import GHC.Fingerprint+import GHC.Conc (pseq, par) import Control.Concurrent import Control.Exception import Data.Binary@@ -71,9 +73,8 @@   -- These all invoke the corresponding functions in the RTS Linker API.   InitLinker :: Message ()   LookupSymbol :: String -> Message (Maybe (RemotePtr ()))-  LookupSymbolInDLL :: RemotePtr LoadedDLL -> String -> Message (Maybe (RemotePtr ()))   LookupClosure :: String -> Message (Maybe HValueRef)-  LoadDLL :: String -> Message (Either String (RemotePtr LoadedDLL))+  LoadDLL :: String -> Message (Maybe String)   LoadArchive :: String -> Message () -- error?   LoadObj :: String -> Message () -- error?   UnloadObj :: String -> Message () -- error?@@ -85,10 +86,10 @@   -- Interpreter -------------------------------------------    -- | Create a set of BCO objects, and return HValueRefs to them-  -- Note: Each ByteString contains a Binary-encoded [ResolvedBCO], not-  -- a ResolvedBCO. The list is to allow us to serialise the ResolvedBCOs-  -- in parallel. See @createBCOs@ in compiler/GHC/Runtime/Interpreter.hs.-  CreateBCOs :: [LB.ByteString] -> Message [HValueRef]+  -- See @createBCOs@ in compiler/GHC/Runtime/Interpreter.hs.+  -- NB: this has a custom Binary behavior,+  -- see Note [Parallelize CreateBCOs serialization]+  CreateBCOs :: [ResolvedBCO] -> Message [HValueRef]    -- | Release 'HValueRef's   FreeHValueRefs :: [HValueRef] -> Message ()@@ -386,16 +387,23 @@  data EvalStatus_ a b   = EvalComplete Word64 (EvalResult a)-  | EvalBreak Bool+  | EvalBreak        HValueRef{- AP_STACK -}-       Int {- break index -}-       String {- module name -}+       (Maybe EvalBreakpoint)        (RemoteRef (ResumeContext b))        (RemotePtr CostCentreStack) -- Cost centre stack   deriving (Generic, Show)  instance Binary a => Binary (EvalStatus_ a b) +data EvalBreakpoint =+  EvalBreakpoint+    Int -- ^ break index+    String -- ^ ModuleName+  deriving (Generic, Show)++instance Binary EvalBreakpoint+ data EvalResult a   = EvalException SerializableException   | EvalSuccess a@@ -407,9 +415,6 @@ -- that type isn't available here. data BreakModule --- | A dummy type that tags pointers returned by 'LoadDLL'.-data LoadedDLL- -- SomeException can't be serialized because it contains dynamic -- types.  However, we do very limited things with the exceptions that -- are thrown by interpreted computations:@@ -480,8 +485,8 @@ #ifndef MIN_VERSION_ghc_heap #define MIN_VERSION_ghc_heap(major1,major2,minor) (\   (major1) <  9 || \-  (major1) == 9 && (major2) <  8 || \-  (major1) == 9 && (major2) == 8 && (minor) <= 4)+  (major1) == 9 && (major2) <  10 || \+  (major1) == 9 && (major2) == 10 && (minor) <= 1) #endif /* MIN_VERSION_ghc_heap */ #if MIN_VERSION_ghc_heap(8,11,0) instance Binary Heap.StgTSOProfInfo@@ -516,7 +521,8 @@       9  -> Msg <$> RemoveLibrarySearchPath <$> get       10 -> Msg <$> return ResolveObjs       11 -> Msg <$> FindSystemLibrary <$> get-      12 -> Msg <$> CreateBCOs <$> get+      12 -> Msg <$> (CreateBCOs . concatMap (runGet get)) <$> (get :: Get [LB.ByteString])+                    -- See Note [Parallelize CreateBCOs serialization]       13 -> Msg <$> FreeHValueRefs <$> get       14 -> Msg <$> MallocData <$> get       15 -> Msg <$> MallocStrings <$> get@@ -544,7 +550,6 @@       37 -> Msg <$> return RtsRevertCAFs       38 -> Msg <$> (ResumeSeq <$> get)       39 -> Msg <$> (NewBreakModule <$> get)-      40 -> Msg <$> (LookupSymbolInDLL <$> get <*> get)       _  -> error $ "Unknown Message code " ++ (show b)  putMessage :: Message a -> Put@@ -561,7 +566,8 @@   RemoveLibrarySearchPath ptr -> putWord8 9  >> put ptr   ResolveObjs                 -> putWord8 10   FindSystemLibrary str       -> putWord8 11 >> put str-  CreateBCOs bco              -> putWord8 12 >> put bco+  CreateBCOs bco              -> putWord8 12 >> put (serializeBCOs bco)+                              -- See Note [Parallelize CreateBCOs serialization]   FreeHValueRefs val          -> putWord8 13 >> put val   MallocData bs               -> putWord8 14 >> put bs   MallocStrings bss           -> putWord8 15 >> put bss@@ -577,7 +583,7 @@   MkCostCentres mod ccs       -> putWord8 25 >> put mod >> put ccs   CostCentreStackInfo ptr     -> putWord8 26 >> put ptr   NewBreakArray sz            -> putWord8 27 >> put sz-  SetupBreakpoint arr ix cnt    -> putWord8 28 >> put arr >> put ix >> put cnt+  SetupBreakpoint arr ix cnt  -> putWord8 28 >> put arr >> put ix >> put cnt   BreakpointStatus arr ix     -> putWord8 29 >> put arr >> put ix   GetBreakpointVar a b        -> putWord8 30 >> put a >> put b   StartTH                     -> putWord8 31@@ -588,8 +594,35 @@   Seq a                       -> putWord8 36 >> put a   RtsRevertCAFs               -> putWord8 37   ResumeSeq a                 -> putWord8 38 >> put a-  NewBreakModule name         -> putWord8 39 >> put name-  LookupSymbolInDLL dll str   -> putWord8 40 >> put dll >> put str+  NewBreakModule name          -> putWord8 39 >> put name++{-+Note [Parallelize CreateBCOs serialization]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Serializing ResolvedBCO is expensive, so we do it in parallel.+We split the list [ResolvedBCO] into chunks of length <= 100,+and serialize every chunk in parallel, getting a [LB.ByteString]+where every bytestring corresponds to a single chunk (multiple ResolvedBCOs).++Previously, we stored [LB.ByteString] in the Message object, but that+incurs unneccessary serialization with the internal interpreter (#23919).+-}++serializeBCOs :: [ResolvedBCO] -> [LB.ByteString]+serializeBCOs rbcos = parMap doChunk (chunkList 100 rbcos)+ where+  -- make sure we force the whole lazy ByteString+  doChunk c = pseq (LB.length bs) bs+    where bs = runPut (put c)++  -- We don't have the parallel package, so roll our own simple parMap+  parMap _ [] = []+  parMap f (x:xs) = fx `par` (fxs `pseq` (fx : fxs))+    where fx = f x; fxs = parMap f xs++  chunkList :: Int -> [a] -> [[a]]+  chunkList _ [] = []+  chunkList n xs = as : chunkList n bs where (as,bs) = splitAt n xs  -- ----------------------------------------------------------------------------- -- Reading/writing messages
+ libraries/ghci/GHCi/ResolvedBCO.hs view
@@ -0,0 +1,77 @@+{-# LANGUAGE RecordWildCards, DeriveGeneric, GeneralizedNewtypeDeriving,+    BangPatterns, CPP #-}+module GHCi.ResolvedBCO+  ( ResolvedBCO(..)+  , ResolvedBCOPtr(..)+  , isLittleEndian+  ) where++import Prelude -- See note [Why do we import Prelude here?]+import GHC.Data.SizedSeq+import GHCi.RemoteTypes+import GHCi.BreakArray++import Data.Array.Unboxed+import Data.Binary+import GHC.Generics+import GHCi.BinaryArray+++#include "MachDeps.h"++isLittleEndian :: Bool+#if defined(WORDS_BIGENDIAN)+isLittleEndian = False+#else+isLittleEndian = True+#endif++-- -----------------------------------------------------------------------------+-- ResolvedBCO++-- | A 'ResolvedBCO' is one in which all the 'Name' references have been+-- resolved to actual addresses or 'RemoteHValues'.+--+-- Note, all arrays are zero-indexed (we assume this when+-- serializing/deserializing)+data ResolvedBCO+   = ResolvedBCO {+        resolvedBCOIsLE   :: Bool,+        resolvedBCOArity  :: {-# UNPACK #-} !Int,+        resolvedBCOInstrs :: UArray Int Word16,         -- insns+        resolvedBCOBitmap :: UArray Int Word64,         -- bitmap+        resolvedBCOLits   :: UArray Int Word64,         -- non-ptrs+        resolvedBCOPtrs   :: (SizedSeq ResolvedBCOPtr)  -- ptrs+   }+   deriving (Generic, Show)++-- | The Binary instance for ResolvedBCOs.+--+-- Note, that we do encode the endianness, however there is no support for mixed+-- endianness setups.  This is primarily to ensure that ghc and iserv share the+-- same endianness.+instance Binary ResolvedBCO where+  put ResolvedBCO{..} = do+    put resolvedBCOIsLE+    put resolvedBCOArity+    putArray resolvedBCOInstrs+    putArray resolvedBCOBitmap+    putArray resolvedBCOLits+    put resolvedBCOPtrs+  get = ResolvedBCO+        <$> get <*> get <*> getArray <*> getArray <*> getArray <*> get++data ResolvedBCOPtr+  = ResolvedBCORef {-# UNPACK #-} !Int+      -- ^ reference to the Nth BCO in the current set+  | ResolvedBCOPtr {-# UNPACK #-} !(RemoteRef HValue)+      -- ^ reference to a previously created BCO+  | ResolvedBCOStaticPtr {-# UNPACK #-} !(RemotePtr ())+      -- ^ reference to a static ptr+  | ResolvedBCOPtrBCO ResolvedBCO+      -- ^ a nested BCO+  | ResolvedBCOPtrBreakArray {-# UNPACK #-} !(RemoteRef BreakArray)+      -- ^ Resolves to the MutableArray# inside the BreakArray+  deriving (Generic, Show)++instance Binary ResolvedBCOPtr
libraries/ghci/GHCi/TH/Binary.hs view
@@ -36,6 +36,7 @@ instance Binary TH.Pat instance Binary TH.Exp instance Binary TH.Dec+instance Binary TH.NamespaceSpecifier instance Binary TH.Overlap instance Binary TH.DerivClause instance Binary TH.DerivStrategy
libraries/ghci/ghci.cabal view
@@ -2,7 +2,7 @@ -- ../../configure.  Make sure you are editing ghci.cabal.in, not ghci.cabal.  name:           ghci-version:        9.8.4.20250206+version:        9.10.1 license:        BSD3 license-file:   LICENSE category:       GHC@@ -75,16 +75,16 @@     Build-Depends:         rts,         array            == 0.5.*,-        base             >= 4.8 && < 4.20,+        base             >= 4.8 && < 4.21,         ghc-prim         >= 0.5.0 && < 0.12,         binary           == 0.8.*,         bytestring       >= 0.10 && < 0.13,-        containers       >= 0.5 && < 0.7,+        containers       >= 0.5 && < 0.8,         deepseq          >= 1.4 && < 1.6,-        filepath         == 1.4.*,-        ghc-boot         == 9.8.4.20250206,-        ghc-heap         == 9.8.4.20250206,-        template-haskell == 2.21.*,+        filepath         >= 1.4 && < 1.6,+        ghc-boot         == 9.10.1,+        ghc-heap         == 9.10.1,+        template-haskell == 2.22.*,         transformers     >= 0.5 && < 0.7      if !os(windows)
libraries/template-haskell/Language/Haskell/TH.hs view
@@ -80,7 +80,8 @@         Bang(..), Strict, Foreign(..), Callconv(..), Safety(..), Pragma(..),         Inline(..), RuleMatch(..), Phases(..), RuleBndr(..), AnnTarget(..),         FunDep(..), TySynEqn(..), TypeFamilyHead(..),-        Fixity(..), FixityDirection(..), defaultFixity, maxPrecedence,+        Fixity(..), FixityDirection(..), NamespaceSpecifier(..), defaultFixity,+        maxPrecedence,         PatSynDir(..), PatSynArgs(..),     -- ** Expressions         Exp(..), Match(..), Body(..), Guard(..), Stmt(..), Range(..), Lit(..),
libraries/template-haskell/Language/Haskell/TH/Lib.hs view
@@ -33,7 +33,7 @@     -- *** Patterns         litP, varP, tupP, unboxedTupP, unboxedSumP, conP, uInfixP, parensP,         infixP, tildeP, bangP, asP, wildP, recP,-        listP, sigP, viewP,+        listP, sigP, viewP, typeP, invisP,         fieldPat,      -- *** Pattern Guards@@ -44,7 +44,7 @@         appE, appTypeE, uInfixE, parensE, infixE, infixApp, sectionL, sectionR,         lamE, lam1E, lamCaseE, lamCasesE, tupE, unboxedTupE, unboxedSumE, condE,         multiIfE, letE, caseE, appsE, listE, sigE, recConE, recUpdE, stringE,-        fieldExp, getFieldE, projectionE, typedSpliceE, typedBracketE,+        fieldExp, getFieldE, projectionE, typedSpliceE, typedBracketE, typeE,     -- **** Ranges     fromE, fromThenE, fromToE, fromThenToE, 
libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_HADDOCK not-home #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE StandaloneKindSignatures #-} {-# LANGUAGE Trustworthy #-}@@ -160,11 +161,18 @@ sigP p t = do p' <- p               t' <- t               pure (SigP p' t')+typeP :: Quote m => m Type -> m Pat+typeP t = do t' <- t+             pure (TypeP t')+invisP :: Quote m => m Type -> m Pat+invisP t = do t' <- t+              pure (InvisP t') viewP :: Quote m => m Exp -> m Pat -> m Pat viewP e p = do e' <- e                p' <- p                pure (ViewP e' p') + fieldPat :: Quote m => Name -> m Pat -> m FieldPat fieldPat n p = do p' <- p                   pure (n, p')@@ -246,11 +254,10 @@                       ds' <- sequenceA ds;                       pure (Clause ps' r' ds') } - --------------------------------------------------------------------------- -- *   Exp --- | Dynamically binding a variable (unhygenic)+-- | Dynamically binding a variable (unhygienic) dyn :: Quote m => String -> m Exp dyn s = pure (VarE (mkName s)) @@ -401,6 +408,8 @@ fromThenToE x y z = do { a <- x; b <- y; c <- z;                          pure (ArithSeqE (FromThenToR a b c)) } +typeE :: Quote m => m Type -> m Exp+typeE = fmap TypeE  ------------------------------------------------------------------------------- -- *   Dec@@ -490,14 +499,23 @@       pure $ ForeignD (ImportF cc s str n ty')  infixLD :: Quote m => Int -> Name -> m Dec-infixLD prec nm = pure (InfixD (Fixity prec InfixL) nm)+infixLD prec = infixLWithSpecD prec NoNamespaceSpecifier  infixRD :: Quote m => Int -> Name -> m Dec-infixRD prec nm = pure (InfixD (Fixity prec InfixR) nm)+infixRD prec = infixRWithSpecD prec NoNamespaceSpecifier  infixND :: Quote m => Int -> Name -> m Dec-infixND prec nm = pure (InfixD (Fixity prec InfixN) nm)+infixND prec = infixNWithSpecD prec NoNamespaceSpecifier +infixLWithSpecD :: Quote m => Int -> NamespaceSpecifier -> Name -> m Dec+infixLWithSpecD prec ns_spec nm = pure (InfixD (Fixity prec InfixL) ns_spec nm)++infixRWithSpecD :: Quote m => Int -> NamespaceSpecifier -> Name -> m Dec+infixRWithSpecD prec ns_spec nm = pure (InfixD (Fixity prec InfixR) ns_spec nm)++infixNWithSpecD :: Quote m => Int -> NamespaceSpecifier -> Name -> m Dec+infixNWithSpecD prec ns_spec nm = pure (InfixD (Fixity prec InfixN) ns_spec nm)+ defaultD :: Quote m => [m Type] -> m Dec defaultD tys = DefaultD <$> sequenceA tys @@ -548,6 +566,12 @@ pragCompleteD :: Quote m => [Name] -> Maybe Name -> m Dec pragCompleteD cls mty = pure $ PragmaD $ CompleteP cls mty +pragSCCFunD :: Quote m => Name -> m Dec+pragSCCFunD nm = pure $ PragmaD $ SCCP nm Nothing++pragSCCFunNamedD :: Quote m => Name -> String -> m Dec+pragSCCFunNamedD nm str = pure $ PragmaD $ SCCP nm (Just str)+ dataInstD :: Quote m => m Cxt -> (Maybe [m (TyVarBndr ())]) -> m Type -> Maybe (m Kind) -> [m Con]           -> [m DerivClause] -> m Dec dataInstD ctxt mb_bndrs ty ksig cons derivs =@@ -1067,7 +1091,7 @@     doc_loc (SigD n _)                                     = Just $ DeclDoc n     doc_loc (ForeignD (ImportF _ _ _ n _))                 = Just $ DeclDoc n     doc_loc (ForeignD (ExportF _ _ n _))                   = Just $ DeclDoc n-    doc_loc (InfixD _ n)                                   = Just $ DeclDoc n+    doc_loc (InfixD _ _ n)                                 = Just $ DeclDoc n     doc_loc (DataFamilyD n _ _)                            = Just $ DeclDoc n     doc_loc (OpenTypeFamilyD (TypeFamilyHead n _ _ _))     = Just $ DeclDoc n     doc_loc (ClosedTypeFamilyD (TypeFamilyHead n _ _ _) _) = Just $ DeclDoc n
libraries/template-haskell/Language/Haskell/TH/Ppr.hs view
@@ -14,7 +14,7 @@ import Data.Word ( Word8 ) import Data.Char ( toLower, chr) import GHC.Show  ( showMultiLineString )-import GHC.Lexeme( startsVarSym )+import GHC.Lexeme( isVarSymChar ) import Data.Ratio ( numerator, denominator ) import Data.Foldable ( toList ) import Prelude hiding ((<>))@@ -77,13 +77,19 @@ ppr_sig :: Name -> Type -> Doc ppr_sig v ty = pprName' Applied v <+> dcolon <+> ppr ty -pprFixity :: Name -> Fixity -> Doc-pprFixity _ f | f == defaultFixity = empty-pprFixity v (Fixity i d) = ppr_fix d <+> int i <+> pprName' Infix v+pprFixity :: Name -> Fixity -> NamespaceSpecifier -> Doc+pprFixity _ f _ | f == defaultFixity = empty+pprFixity v (Fixity i d) ns_spec+  = ppr_fix d <+> int i <+> pprNamespaceSpecifier ns_spec <+> pprName' Infix v     where ppr_fix InfixR = text "infixr"           ppr_fix InfixL = text "infixl"           ppr_fix InfixN = text "infix" +pprNamespaceSpecifier :: NamespaceSpecifier -> Doc+pprNamespaceSpecifier NoNamespaceSpecifier = empty+pprNamespaceSpecifier TypeNamespaceSpecifier = text "type"+pprNamespaceSpecifier DataNamespaceSpecifier = text "data"+ -- | Pretty prints a pattern synonym type signature pprPatSynSig :: Name -> PatSynType -> Doc pprPatSynSig nm ty@@ -122,8 +128,8 @@ isSymOcc n   = case nameBase n of       []    -> True  -- Empty name; weird-      (c:_) -> startsVarSym c-                   -- c.f. OccName.startsVarSym in GHC itself+      (c:_) -> isVarSymChar c+                   -- c.f. isVarSymChar in GHC itself  pprInfixExp :: Exp -> Doc pprInfixExp (VarE v) = pprName' Infix v@@ -234,6 +240,7 @@ pprExp _ (ProjectionE xs) = parens $ hcat $ map ((char '.'<>) . text) $ toList xs pprExp _ (TypedBracketE e) = text "[||" <> ppr e <> text "||]" pprExp _ (TypedSpliceE e) = text "$$" <> pprExp appPrec e+pprExp i (TypeE t) = parensIf (i > noPrec) $ text "type" <+> ppr t  pprFields :: [(Name,Exp)] -> Doc pprFields = sep . punctuate comma . map (\(s,e) -> pprName' Applied s <+> equals <+> ppr e)@@ -385,27 +392,32 @@ pprPat _ (ListP ps) = brackets (commaSep ps) pprPat i (SigP p t) = parensIf (i > noPrec) $ ppr p <+> dcolon <+> ppr t pprPat _ (ViewP e p) = parens $ pprExp noPrec e <+> text "->" <+> pprPat noPrec p+pprPat _ (TypeP t) = parens $ text "type" <+> ppr t+pprPat _ (InvisP t) = parens $ text "@" <+> ppr t  ------------------------------ instance Ppr Dec where     ppr = ppr_dec True -ppr_dec :: Bool     -- declaration on the toplevel?+ppr_dec :: Bool     -- ^ declaration on the toplevel?         -> Dec         -> Doc-ppr_dec _ (FunD f cs)   = vcat $ map (\c -> pprPrefixOcc f <+> ppr c) cs+ppr_dec isTop (FunD f cs)   = layout $ map (\c -> pprPrefixOcc f <+> ppr c) cs+  where+    layout :: [Doc] -> Doc+    layout = if isTop then vcat else semiSepWith id ppr_dec _ (ValD p r ds) = ppr p <+> pprBody True r                           $$ where_clause ds ppr_dec _ (TySynD t xs rhs)   = ppr_tySyn empty (Just t) (hsep (map ppr xs)) rhs-ppr_dec _ (DataD ctxt t xs ksig cs decs)-  = ppr_data empty ctxt (Just t) (hsep (map ppr xs)) ksig cs decs-ppr_dec _ (NewtypeD ctxt t xs ksig c decs)-  = ppr_newtype empty ctxt (Just t) (sep (map ppr xs)) ksig c decs-ppr_dec _ (TypeDataD t xs ksig cs)-  = ppr_type_data empty [] (Just t) (hsep (map ppr xs)) ksig cs []+ppr_dec isTop (DataD ctxt t xs ksig cs decs)+  = ppr_data isTop empty ctxt (Just t) (hsep (map ppr xs)) ksig cs decs+ppr_dec isTop (NewtypeD ctxt t xs ksig c decs)+  = ppr_newtype isTop empty ctxt (Just t) (sep (map ppr xs)) ksig c decs+ppr_dec isTop (TypeDataD t xs ksig cs)+  = ppr_type_data isTop empty [] (Just t) (hsep (map ppr xs)) ksig cs [] ppr_dec _  (ClassD ctxt c xs fds ds)-  = text "class" <+> pprCxt ctxt <+> ppr c <+> hsep (map ppr xs) <+> ppr fds+  = text "class" <+> pprCxt ctxt <+> pprName' Applied c <+> hsep (map ppr xs) <+> ppr fds     $$ where_clause ds ppr_dec _ (InstanceD o ctxt i ds) =         text "instance" <+> maybe empty ppr_overlap o <+> pprCxt ctxt <+> ppr i@@ -413,25 +425,25 @@ ppr_dec _ (SigD f t)    = pprPrefixOcc f <+> dcolon <+> ppr t ppr_dec _ (KiSigD f k)  = text "type" <+> pprPrefixOcc f <+> dcolon <+> ppr k ppr_dec _ (ForeignD f)  = ppr f-ppr_dec _ (InfixD fx n) = pprFixity n fx+ppr_dec _ (InfixD fx ns_spec n) = pprFixity n fx ns_spec ppr_dec _ (DefaultD tys) =         text "default" <+> parens (sep $ punctuate comma $ map ppr tys) ppr_dec _ (PragmaD p)   = ppr p ppr_dec isTop (DataFamilyD tc tvs kind)-  = text "data" <+> maybeFamily <+> ppr tc <+> hsep (map ppr tvs) <+> maybeKind+  = text "data" <+> maybeFamily <+> pprName' Applied tc <+> hsep (map ppr tvs) <+> maybeKind   where     maybeFamily | isTop     = text "family"                 | otherwise = empty     maybeKind | (Just k') <- kind = dcolon <+> ppr k'               | otherwise = empty ppr_dec isTop (DataInstD ctxt bndrs ty ksig cs decs)-  = ppr_data (maybeInst <+> ppr_bndrs bndrs)+  = ppr_data isTop (maybeInst <+> ppr_bndrs bndrs)              ctxt Nothing (ppr ty) ksig cs decs   where     maybeInst | isTop     = text "instance"               | otherwise = empty ppr_dec isTop (NewtypeInstD ctxt bndrs ty ksig c decs)-  = ppr_newtype (maybeInst <+> ppr_bndrs bndrs)+  = ppr_newtype isTop (maybeInst <+> ppr_bndrs bndrs)                 ctxt Nothing (ppr ty) ksig c decs   where     maybeInst | isTop     = text "instance"@@ -454,7 +466,7 @@     ppr_eqn (TySynEqn mb_bndrs lhs rhs)       = ppr_bndrs mb_bndrs <+> ppr lhs <+> text "=" <+> ppr rhs ppr_dec _ (RoleAnnotD name roles)-  = hsep [ text "type role", ppr name ] <+> hsep (map ppr roles)+  = hsep [ text "type role", pprName' Applied name ] <+> hsep (map ppr roles) ppr_dec _ (StandaloneDerivD ds cxt ty)   = hsep [ text "deriving"          , maybe empty ppr_deriv_strategy ds@@ -469,7 +481,8 @@     pprNameArgs | InfixPatSyn a1 a2 <- args = ppr a1 <+> pprName' Infix name <+> ppr a2                 | otherwise                 = pprName' Applied name <+> ppr args     pprPatRHS   | ExplBidir cls <- dir = hang (ppr pat <+> text "where")-                                           nestDepth (pprName' Applied name <+> ppr cls)+                                              nestDepth+                                              (vcat $ (pprName' Applied name <+>) . ppr <$> cls)                 | otherwise            = ppr pat ppr_dec _ (PatSynSigD name ty)   = pprPatSynSig name ty@@ -492,27 +505,31 @@     Overlapping   -> "{-# OVERLAPPING #-}"     Incoherent    -> "{-# INCOHERENT #-}" -ppr_data :: Doc -> Cxt -> Maybe Name -> Doc -> Maybe Kind -> [Con] -> [DerivClause]+ppr_data :: Bool     -- ^ declaration on the toplevel?+         -> Doc -> Cxt -> Maybe Name -> Doc -> Maybe Kind -> [Con] -> [DerivClause]          -> Doc ppr_data = ppr_typedef "data" -ppr_newtype :: Doc -> Cxt -> Maybe Name -> Doc -> Maybe Kind -> Con -> [DerivClause]+ppr_newtype :: Bool     -- ^ declaration on the toplevel?+            -> Doc -> Cxt -> Maybe Name -> Doc -> Maybe Kind -> Con -> [DerivClause]             -> Doc-ppr_newtype maybeInst ctxt t argsDoc ksig c decs = ppr_typedef "newtype" maybeInst ctxt t argsDoc ksig [c] decs+ppr_newtype isTop maybeInst ctxt t argsDoc ksig c decs+  = ppr_typedef "newtype" isTop maybeInst ctxt t argsDoc ksig [c] decs -ppr_type_data :: Doc -> Cxt -> Maybe Name -> Doc -> Maybe Kind -> [Con] -> [DerivClause]-         -> Doc+ppr_type_data :: Bool     -- ^ declaration on the toplevel?+              -> Doc -> Cxt -> Maybe Name -> Doc -> Maybe Kind -> [Con] -> [DerivClause]+              -> Doc ppr_type_data = ppr_typedef "type data" -ppr_typedef :: String -> Doc -> Cxt -> Maybe Name -> Doc -> Maybe Kind -> [Con] -> [DerivClause] -> Doc-ppr_typedef data_or_newtype maybeInst ctxt t argsDoc ksig cs decs+ppr_typedef :: String -> Bool -> Doc -> Cxt -> Maybe Name -> Doc -> Maybe Kind -> [Con] -> [DerivClause] -> Doc+ppr_typedef data_or_newtype isTop maybeInst ctxt t argsDoc ksig cs decs   = sep [text data_or_newtype <+> maybeInst             <+> pprCxt ctxt             <+> case t of                  Just n -> pprName' Applied n <+> argsDoc                  Nothing -> argsDoc             <+> ksigDoc <+> maybeWhere,-         nest nestDepth (vcat (pref $ map ppr cs)),+         nest nestDepth (layout (pref $ map ppr cs)),          if null decs            then empty            else nest nestDepth@@ -523,6 +540,10 @@     pref []              = []      -- No constructors; can't happen in H98     pref (d:ds)          = (char '=' <+> d):map (bar <+>) ds +    layout :: [Doc] -> Doc+    layout | isGadtDecl && not isTop = braces . semiSepWith id+           | otherwise = vcat+     maybeWhere :: Doc     maybeWhere | isGadtDecl = text "where"                | otherwise  = empty@@ -542,7 +563,7 @@ ppr_deriv_clause :: DerivClause -> Doc ppr_deriv_clause (DerivClause ds ctxt)   = text "deriving" <+> pp_strat_before-                    <+> ppr_cxt_preds ctxt+                    <+> ppr_cxt_preds appPrec ctxt                     <+> pp_strat_after   where     -- @via@ is unique in that in comes /after/ the class being derived,@@ -647,6 +668,8 @@     ppr (CompleteP cls mty)        = text "{-# COMPLETE" <+> (fsep $ punctuate comma $ map (pprName' Applied) cls)                 <+> maybe empty (\ty -> dcolon <+> pprName' Applied ty) mty <+> text "#-}"+    ppr (SCCP nm str)+       = text "{-# SCC" <+> pprName' Applied nm <+> maybe empty pprString str <+> text "#-}"  ------------------------------ instance Ppr Inline where@@ -861,11 +884,11 @@ instance Ppr Type where     ppr = pprType noPrec instance Ppr TypeArg where-    ppr (TANormal ty) = parensIf (isStarT ty) (ppr ty)+    ppr (TANormal ty) = ppr ty     ppr (TyArg ki) = char '@' <> parensIf (isStarT ki) (ppr ki)  pprParendTypeArg :: TypeArg -> Doc-pprParendTypeArg (TANormal ty) = parensIf (isStarT ty) (pprParendType ty)+pprParendTypeArg (TANormal ty) = pprParendType ty pprParendTypeArg (TyArg ki) = char '@' <> parensIf (isStarT ki) (pprParendType ki)  isStarT :: Type -> Bool@@ -970,14 +993,12 @@ ------------------------------ pprCxt :: Cxt -> Doc pprCxt [] = empty-pprCxt ts = ppr_cxt_preds ts <+> text "=>"+pprCxt ts = ppr_cxt_preds funPrec ts <+> text "=>" -ppr_cxt_preds :: Cxt -> Doc-ppr_cxt_preds [] = empty-ppr_cxt_preds [t@ImplicitParamT{}] = parens (ppr t)-ppr_cxt_preds [t@ForallT{}] = parens (ppr t)-ppr_cxt_preds [t] = ppr t-ppr_cxt_preds ts = parens (commaSep ts)+ppr_cxt_preds :: Precedence -> Cxt -> Doc+ppr_cxt_preds _ [] = text "()"+ppr_cxt_preds p [t] = pprType p t+ppr_cxt_preds _ ts = parens (commaSep ts)  ------------------------------ instance Ppr Range where
libraries/template-haskell/Language/Haskell/TH/Syntax.hs view
@@ -57,7 +57,7 @@ import GHC.CString      ( unpackCString# ) import GHC.Generics     ( Generic ) import GHC.Types        ( Int(..), Word(..), Char(..), Double(..), Float(..),-                          TYPE, RuntimeRep(..) )+                          TYPE, RuntimeRep(..), Levity(..), Multiplicity (..) ) import qualified Data.Kind as Kind (Type) import GHC.Prim         ( Int#, Word#, Char#, Double#, Float#, Addr# ) import GHC.Ptr          ( Ptr, plusPtr )@@ -72,11 +72,6 @@ import GHC.Stack  -#if __GLASGOW_HASKELL__ >= 901-import GHC.Types ( Levity(..) )-#endif--#if __GLASGOW_HASKELL__ >= 903 import Data.Array.Byte (ByteArray(..)) import GHC.Exts   ( ByteArray#, unsafeFreezeByteArray#, copyAddrToByteArray#, newByteArray#@@ -84,7 +79,6 @@   , copyByteArray#, newPinnedByteArray#) import GHC.ForeignPtr (ForeignPtr(..), ForeignPtrContents(..)) import GHC.ST (ST(..), runST)-#endif  ----------------------------------------------------- --@@ -380,8 +374,12 @@ 4::Int. So you can't coerce a (Code Q Age) to a (Code Q Int). -}  -- Code constructor-+#if __GLASGOW_HASKELL__ >= 909+type Code :: (Kind.Type -> Kind.Type) -> forall r. TYPE r -> Kind.Type+  -- See Note [Foralls to the right in Code]+#else type Code :: (Kind.Type -> Kind.Type) -> TYPE r -> Kind.Type+#endif type role Code representational nominal   -- See Note [Role of TExp] newtype Code m a = Code   { examineCode :: m (TExp a) -- ^ Underlying monadic value@@ -421,6 +419,23 @@ --       In the Template Haskell splice $$([|| "foo" ||])  +{- Note [Foralls to the right in Code]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Code has the following type signature:+   type Code :: (Kind.Type -> Kind.Type) -> forall r. TYPE r -> Kind.Type++This allows us to write+   data T (f :: forall r . (TYPE r) -> Type) = MkT (f Int) (f Int#)++   tcodeq :: T (Code Q)+   tcodeq = MkT [||5||] [||5#||]++If we used the slightly more straightforward signature+   type Code :: foral r. (Kind.Type -> Kind.Type) -> TYPE r -> Kind.Type++then the example above would become ill-typed.  (See #23592 for some discussion.)+-}+ -- | Unsafely convert an untyped code representation into a typed code -- representation. unsafeCodeCoerce :: forall (r :: RuntimeRep) (a :: TYPE r) m .@@ -668,7 +683,7 @@     @B@ themselves implement 'Eq'    - @reifyInstances ''Show [ 'VarT' ('mkName' "a") ]@ produces every available-    instance of 'Eq'+    instance of 'Show'  There is one edge case: @reifyInstances ''Typeable tys@ currently always produces an empty list (no matter what @tys@ are given).@@ -770,7 +785,7 @@ -- assumption from splices that they will be executed in the directory where the -- cabal file resides. Projects such as haskell-language-server can't and don't -- change directory when compiling files but instead set the -package-root flag--- appropiately.+-- appropriately. getPackageRoot :: Q FilePath getPackageRoot = Q qGetPackageRoot @@ -910,7 +925,7 @@ putDoc :: DocLoc -> String -> Q () putDoc t s = Q (qPutDoc t s) --- | Retreives the Haddock documentation at the specified location, if one+-- | Retrieves the Haddock documentation at the specified location, if one -- exists. -- It can be used to read documentation on things defined outside of the current -- module, provided that those modules were compiled with the @-haddock@ flag.@@ -995,11 +1010,7 @@   -- | Turn a value into a Template Haskell expression, suitable for use in   -- a splice.   lift :: Quote m => t -> m Exp-#if __GLASGOW_HASKELL__ >= 901   default lift :: (r ~ ('BoxedRep 'Lifted), Quote m) => t -> m Exp-#else-  default lift :: (r ~ 'LiftedRep, Quote m) => t -> m Exp-#endif   lift = unTypeCode . liftTyped    -- | Turn a value into a Template Haskell typed expression, suitable for use@@ -1122,8 +1133,6 @@   lift x     = return (LitE (StringPrimL (map (fromIntegral . ord) (unpackCString# x)))) -#if __GLASGOW_HASKELL__ >= 903- -- | -- @since 2.19.0.0 instance Lift ByteArray where@@ -1162,8 +1171,6 @@       s'' -> case unsafeFreezeByteArray# mb s'' of         (# s''', ret #) -> (# s''', ByteArray ret #) -#endif- instance Lift a => Lift (Maybe a) where   liftTyped x = unsafeCodeCoerce (lift x) @@ -1433,7 +1440,7 @@                       con@('(':_) -> Name (mkOccName con)                                           (NameG DataName                                                 (mkPkgName "ghc-prim")-                                                (mkModName "GHC.Tuple.Prim"))+                                                (mkModName "GHC.Tuple"))                        -- Tricky case: see Note [Data for non-algebraic types]                       fun@(x:_)   | startsVarSym x || startsVarId x@@ -1925,14 +1932,20 @@     withParens thing       | boxed     = "("  ++ thing ++ ")"       | otherwise = "(#" ++ thing ++ "#)"-    tup_occ | n == 1    = if boxed then solo else "Solo#"+    tup_occ | n == 0, space == TcClsName = if boxed then "Unit" else "Unit#"+            | n == 1 = if boxed then solo else unboxed_solo+            | space == TcClsName = "Tuple" ++ show n ++ if boxed then "" else "#"             | otherwise = withParens (replicate n_commas ',')     n_commas = n - 1-    tup_mod  = mkModName "GHC.Tuple.Prim"+    tup_mod  = mkModName (if boxed then "GHC.Tuple" else "GHC.Types")     solo       | space == DataName = "MkSolo"       | otherwise = "Solo" +    unboxed_solo+      | space == DataName = "(# #)"+      | otherwise = "Solo#"+ -- Unboxed sum data and type constructors -- | Unboxed sum data constructor unboxedSumDataName :: SumAlt -> SumArity -> Name@@ -1951,7 +1964,7 @@    | otherwise   = Name (mkOccName sum_occ)-         (NameG DataName (mkPkgName "ghc-prim") (mkModName "GHC.Prim"))+         (NameG DataName (mkPkgName "ghc-prim") (mkModName "GHC.Types"))    where     prefix     = "unboxedSumDataName: "@@ -1970,11 +1983,11 @@    | otherwise   = Name (mkOccName sum_occ)-         (NameG TcClsName (mkPkgName "ghc-prim") (mkModName "GHC.Prim"))+         (NameG TcClsName (mkPkgName "ghc-prim") (mkModName "GHC.Types"))    where     -- Synced with the definition of mkSumTyConOcc in GHC.Builtin.Types-    sum_occ = '(' : '#' : replicate (arity - 1) '|' ++ "#)"+    sum_occ = "Sum" ++ show arity ++ "#"  ----------------------------------------------------- --              Locations@@ -2295,6 +2308,8 @@   | ListP [ Pat ]                   -- ^ @{ [1,2,3] }@   | SigP Pat Type                   -- ^ @{ p :: t }@   | ViewP Exp Pat                   -- ^ @{ e -> p }@+  | TypeP Type                      -- ^ @{ type p }@+  | InvisP Type                     -- ^ @{ @p }@   deriving( Show, Eq, Ord, Data, Generic )  type FieldPat = (Name,Pat)@@ -2394,6 +2409,7 @@   | ProjectionE (NonEmpty String)      -- ^ @(.x)@ or @(.x.y)@ (Record projections)   | TypedBracketE Exp                  -- ^ @[|| e ||]@   | TypedSpliceE Exp                   -- ^ @$$e@+  | TypeE Type                         -- ^ @{ type t }@   deriving( Show, Eq, Ord, Data, Generic )  type FieldExp = (Name,Exp)@@ -2452,7 +2468,8 @@   | ForeignD Foreign              -- ^ @{ foreign import ... }                                   --{ foreign export ... }@ -  | InfixD Fixity Name            -- ^ @{ infix 3 foo }@+  | InfixD Fixity NamespaceSpecifier Name+                                  -- ^ @{ infix 3 data foo }@   | DefaultD [Type]               -- ^ @{ default (Integer, Double) }@    -- | pragmas@@ -2509,6 +2526,18 @@       -- and where clauses which consist entirely of implicit bindings.   deriving( Show, Eq, Ord, Data, Generic ) +-- | A way to specify a namespace to look in when GHC needs to find+--   a name's source+data NamespaceSpecifier+  = NoNamespaceSpecifier   -- ^ Name may be everything; If there are two+                           --   names in different namespaces, then consider both+  | TypeNamespaceSpecifier -- ^ Name should be a type-level entity, such as a+                           --   data type, type alias, type family, type class,+                           --   or type variable+  | DataNamespaceSpecifier -- ^ Name should be a term-level entity, such as a+                           --   function, data constructor, or pattern synonym+  deriving( Show, Eq, Ord, Data, Generic )+ -- | Varieties of allowed instance overlap. data Overlap = Overlappable   -- ^ May be overlapped by more specific instances              | Overlapping    -- ^ May overlap a more general instance@@ -2629,6 +2658,8 @@             | LineP           Int String             | CompleteP       [Name] (Maybe Name)                 -- ^ @{ {\-\# COMPLETE C_1, ..., C_i [ :: T ] \#-} }@+            | SCCP            Name (Maybe String)+                -- ^ @{ {\-\# SCC fun "optional_name" \#-} }@         deriving( Show, Eq, Ord, Data, Generic )  data Inline = NoInline
libraries/template-haskell/template-haskell.cabal view
@@ -3,7 +3,7 @@ -- template-haskell.cabal.  name:           template-haskell-version:        2.21.0.0+version:        2.22.0.0 -- NOTE: Don't forget to update ./changelog.md license:        BSD3 license-file:   LICENSE@@ -55,8 +55,8 @@         Language.Haskell.TH.Lib.Map      build-depends:-        base        >= 4.11 && < 4.20,-        ghc-boot-th == 9.8.4.20250206,+        base        >= 4.11 && < 4.21,+        ghc-boot-th == 9.10.1,         ghc-prim,         pretty      == 1.1.* 
+ rts/include/stg/MachRegs/arm32.h view
@@ -0,0 +1,60 @@+#pragma once++/* -----------------------------------------------------------------------------+   The ARM EABI register mapping++   Here we consider ARM mode (i.e. 32bit isns)+   and also CPU with full VFPv3 implementation++   ARM registers (see Chapter 5.1 in ARM IHI 0042D and+   Section 9.2.2 in ARM Software Development Toolkit Reference Guide)++   r15  PC         The Program Counter.+   r14  LR         The Link Register.+   r13  SP         The Stack Pointer.+   r12  IP         The Intra-Procedure-call scratch register.+   r11  v8/fp      Variable-register 8.+   r10  v7/sl      Variable-register 7.+   r9   v6/SB/TR   Platform register. The meaning of this register is+                   defined by the platform standard.+   r8   v5         Variable-register 5.+   r7   v4         Variable register 4.+   r6   v3         Variable register 3.+   r5   v2         Variable register 2.+   r4   v1         Variable register 1.+   r3   a4         Argument / scratch register 4.+   r2   a3         Argument / scratch register 3.+   r1   a2         Argument / result / scratch register 2.+   r0   a1         Argument / result / scratch register 1.++   VFPv2/VFPv3/NEON registers+   s0-s15/d0-d7/q0-q3    Argument / result/ scratch registers+   s16-s31/d8-d15/q4-q7  callee-saved registers (must be preserved across+                         subroutine calls)++   VFPv3/NEON registers (added to the VFPv2 registers set)+   d16-d31/q8-q15        Argument / result/ scratch registers+   ----------------------------------------------------------------------------- */++#define REG(x) __asm__(#x)++#define REG_Base        r4+#define REG_Sp          r5+#define REG_Hp          r6+#define REG_R1          r7+#define REG_R2          r8+#define REG_R3          r9+#define REG_R4          r10+#define REG_SpLim       r11++#if !defined(arm_HOST_ARCH_PRE_ARMv6)+/* d8 */+#define REG_F1    s16+#define REG_F2    s17+/* d9 */+#define REG_F3    s18+#define REG_F4    s19++#define REG_D1    d10+#define REG_D2    d11+#endif
+ rts/include/stg/MachRegs/arm64.h view
@@ -0,0 +1,64 @@+#pragma once+++/* -----------------------------------------------------------------------------+   The ARMv8/AArch64 ABI register mapping++   The AArch64 provides 31 64-bit general purpose registers+   and 32 128-bit SIMD/floating point registers.++   General purpose registers (see Chapter 5.1.1 in ARM IHI 0055B)++   Register | Special | Role in the procedure call standard+   ---------+---------+------------------------------------+     SP     |         | The Stack Pointer+     r30    |  LR     | The Link Register+     r29    |  FP     | The Frame Pointer+   r19-r28  |         | Callee-saved registers+     r18    |         | The Platform Register, if needed;+            |         | or temporary register+     r17    |  IP1    | The second intra-procedure-call temporary register+     r16    |  IP0    | The first intra-procedure-call scratch register+    r9-r15  |         | Temporary registers+     r8     |         | Indirect result location register+    r0-r7   |         | Parameter/result registers+++   FPU/SIMD registers++   s/d/q/v0-v7    Argument / result/ scratch registers+   s/d/q/v8-v15   callee-saved registers (must be preserved across subroutine calls,+                  but only bottom 64-bit value needs to be preserved)+   s/d/q/v16-v31  temporary registers++   ----------------------------------------------------------------------------- */++#define REG(x) __asm__(#x)++#define REG_Base        r19+#define REG_Sp          r20+#define REG_Hp          r21+#define REG_R1          r22+#define REG_R2          r23+#define REG_R3          r24+#define REG_R4          r25+#define REG_R5          r26+#define REG_R6          r27+#define REG_SpLim       r28++#define REG_F1          s8+#define REG_F2          s9+#define REG_F3          s10+#define REG_F4          s11++#define REG_D1          d12+#define REG_D2          d13+#define REG_D3          d14+#define REG_D4          d15++#define REG_XMM1        q4+#define REG_XMM2        q5++#define CALLER_SAVES_XMM1+#define CALLER_SAVES_XMM2+
+ rts/include/stg/MachRegs/loongarch64.h view
@@ -0,0 +1,51 @@+#pragma once++/* -----------------------------------------------------------------------------+   The loongarch64 register mapping++   Register    | Role(s)                                 | Call effect+   ------------+-----------------------------------------+-------------+   zero        | Hard-wired zero                         | -+   ra          | Return address                          | caller-saved+   tp          | Thread pointer                          | -+   sp          | Stack pointer                           | callee-saved+   a0,a1       | Arguments / return values               | caller-saved+   a2..a7      | Arguments                               | caller-saved+   t0..t8      | -                                       | caller-saved+   u0          | Reserve                                 | -+   fp          | Frame pointer                           | callee-saved+   s0..s8      | -                                       | callee-saved+   fa0,fa1     | Arguments / return values               | caller-saved+   fa2..fa7    | Arguments                               | caller-saved+   ft0..ft15   | -                                       | caller-saved+   fs0..fs7    | -                                       | callee-saved++   Each general purpose register as well as each floating-point+   register is 64 bits wide, also, the u0 register is called r21 in some cases.++   -------------------------------------------------------------------------- */++#define REG(x) __asm__("$" #x)++#define REG_Base        s0+#define REG_Sp          s1+#define REG_Hp          s2+#define REG_R1          s3+#define REG_R2          s4+#define REG_R3          s5+#define REG_R4          s6+#define REG_R5          s7+#define REG_SpLim       s8++#define REG_F1          fs0+#define REG_F2          fs1+#define REG_F3          fs2+#define REG_F4          fs3++#define REG_D1          fs4+#define REG_D2          fs5+#define REG_D3          fs6+#define REG_D4          fs7++#define MAX_REAL_FLOAT_REG   4+#define MAX_REAL_DOUBLE_REG  4
+ rts/include/stg/MachRegs/ppc.h view
@@ -0,0 +1,65 @@+#pragma once++/* -----------------------------------------------------------------------------+   The PowerPC register mapping++   0            system glue?    (caller-save, volatile)+   1            SP              (callee-save, non-volatile)+   2            AIX, powerpc64-linux:+                    RTOC        (a strange special case)+                powerpc32-linux:+                                reserved for use by system++   3-10         args/return     (caller-save, volatile)+   11,12        system glue?    (caller-save, volatile)+   13           on 64-bit:      reserved for thread state pointer+                on 32-bit:      (callee-save, non-volatile)+   14-31                        (callee-save, non-volatile)++   f0                           (caller-save, volatile)+   f1-f13       args/return     (caller-save, volatile)+   f14-f31                      (callee-save, non-volatile)++   \tr{14}--\tr{31} are wonderful callee-save registers on all ppc OSes.+   \tr{0}--\tr{12} are caller-save registers.++   \tr{%f14}--\tr{%f31} are callee-save floating-point registers.++   We can do the Whole Business with callee-save registers only!+   -------------------------------------------------------------------------- */+++#define REG(x) __asm__(#x)++#define REG_R1          r14+#define REG_R2          r15+#define REG_R3          r16+#define REG_R4          r17+#define REG_R5          r18+#define REG_R6          r19+#define REG_R7          r20+#define REG_R8          r21+#define REG_R9          r22+#define REG_R10         r23++#define REG_F1          fr14+#define REG_F2          fr15+#define REG_F3          fr16+#define REG_F4          fr17+#define REG_F5          fr18+#define REG_F6          fr19++#define REG_D1          fr20+#define REG_D2          fr21+#define REG_D3          fr22+#define REG_D4          fr23+#define REG_D5          fr24+#define REG_D6          fr25++#define REG_Sp          r24+#define REG_SpLim       r25+#define REG_Hp          r26+#define REG_Base        r27++#define MAX_REAL_FLOAT_REG   6+#define MAX_REAL_DOUBLE_REG  6
+ rts/include/stg/MachRegs/riscv64.h view
@@ -0,0 +1,61 @@+#pragma once++/* -----------------------------------------------------------------------------+   The riscv64 register mapping++   Register    | Role(s)                                 | Call effect+   ------------+-----------------------------------------+-------------+   zero        | Hard-wired zero                         | -+   ra          | Return address                          | caller-saved+   sp          | Stack pointer                           | callee-saved+   gp          | Global pointer                          | callee-saved+   tp          | Thread pointer                          | callee-saved+   t0,t1,t2    | -                                       | caller-saved+   s0          | Frame pointer                           | callee-saved+   s1          | -                                       | callee-saved+   a0,a1       | Arguments / return values               | caller-saved+   a2..a7      | Arguments                               | caller-saved+   s2..s11     | -                                       | callee-saved+   t3..t6      | -                                       | caller-saved+   ft0..ft7    | -                                       | caller-saved+   fs0,fs1     | -                                       | callee-saved+   fa0,fa1     | Arguments / return values               | caller-saved+   fa2..fa7    | Arguments                               | caller-saved+   fs2..fs11   | -                                       | callee-saved+   ft8..ft11   | -                                       | caller-saved++   Each general purpose register as well as each floating-point+   register is 64 bits wide.++   -------------------------------------------------------------------------- */++#define REG(x) __asm__(#x)++#define REG_Base        s1+#define REG_Sp          s2+#define REG_Hp          s3+#define REG_R1          s4+#define REG_R2          s5+#define REG_R3          s6+#define REG_R4          s7+#define REG_R5          s8+#define REG_R6          s9+#define REG_R7          s10+#define REG_SpLim       s11++#define REG_F1          fs0+#define REG_F2          fs1+#define REG_F3          fs2+#define REG_F4          fs3+#define REG_F5          fs4+#define REG_F6          fs5++#define REG_D1          fs6+#define REG_D2          fs7+#define REG_D3          fs8+#define REG_D4          fs9+#define REG_D5          fs10+#define REG_D6          fs11++#define MAX_REAL_FLOAT_REG   6+#define MAX_REAL_DOUBLE_REG  6
+ rts/include/stg/MachRegs/s390x.h view
@@ -0,0 +1,72 @@+#pragma once++/* -----------------------------------------------------------------------------+   The s390x register mapping++   Register    | Role(s)                                 | Call effect+   ------------+-------------------------------------+-----------------+   r0,r1       | -                                       | caller-saved+   r2          | Argument / return value                 | caller-saved+   r3,r4,r5    | Arguments                               | caller-saved+   r6          | Argument                                | callee-saved+   r7...r11    | -                                       | callee-saved+   r12         | (Commonly used as GOT pointer)          | callee-saved+   r13         | (Commonly used as literal pool pointer) | callee-saved+   r14         | Return address                          | caller-saved+   r15         | Stack pointer                           | callee-saved+   f0          | Argument / return value                 | caller-saved+   f2,f4,f6    | Arguments                               | caller-saved+   f1,f3,f5,f7 | -                                       | caller-saved+   f8...f15    | -                                       | callee-saved+   v0...v31    | -                                       | caller-saved++   Each general purpose register r0 through r15 as well as each floating-point+   register f0 through f15 is 64 bits wide. Each vector register v0 through v31+   is 128 bits wide.++   Note, the vector registers v0 through v15 overlap with the floating-point+   registers f0 through f15.++   -------------------------------------------------------------------------- */+++#define REG(x) __asm__("%" #x)++#define REG_Base        r7+#define REG_Sp          r8+#define REG_Hp          r10+#define REG_R1          r11+#define REG_R2          r12+#define REG_R3          r13+#define REG_R4          r6+#define REG_R5          r2+#define REG_R6          r3+#define REG_R7          r4+#define REG_R8          r5+#define REG_SpLim       r9+#define REG_MachSp      r15++#define REG_F1          f8+#define REG_F2          f9+#define REG_F3          f10+#define REG_F4          f11+#define REG_F5          f0+#define REG_F6          f1++#define REG_D1          f12+#define REG_D2          f13+#define REG_D3          f14+#define REG_D4          f15+#define REG_D5          f2+#define REG_D6          f3++#define CALLER_SAVES_R5+#define CALLER_SAVES_R6+#define CALLER_SAVES_R7+#define CALLER_SAVES_R8++#define CALLER_SAVES_F5+#define CALLER_SAVES_F6++#define CALLER_SAVES_D5+#define CALLER_SAVES_D6
+ rts/include/stg/MachRegs/wasm32.h view
@@ -0,0 +1,35 @@+#pragma once++#define REG_Base           0++#define REG_R1             1+#define REG_R2             2+#define REG_R3             3+#define REG_R4             4+#define REG_R5             5+#define REG_R6             6+#define REG_R7             7+#define REG_R8             8+#define REG_R9             9+#define REG_R10            10++#define REG_F1             11+#define REG_F2             12+#define REG_F3             13+#define REG_F4             14+#define REG_F5             15+#define REG_F6             16++#define REG_D1             17+#define REG_D2             18+#define REG_D3             19+#define REG_D4             20+#define REG_D5             21+#define REG_D6             22++#define REG_L1             23++#define REG_Sp             24+#define REG_SpLim          25+#define REG_Hp             26+#define REG_HpLim          27
+ rts/include/stg/MachRegs/x86.h view
@@ -0,0 +1,210 @@+/* -----------------------------------------------------------------------------+   The x86 register mapping++   Ok, we've only got 6 general purpose registers, a frame pointer and a+   stack pointer.  \tr{%eax} and \tr{%edx} are return values from C functions,+   hence they get trashed across ccalls and are caller saves. \tr{%ebx},+   \tr{%esi}, \tr{%edi}, \tr{%ebp} are all callee-saves.++   Reg     STG-Reg+   ---------------+   ebx     Base+   ebp     Sp+   esi     R1+   edi     Hp++   Leaving SpLim out of the picture.+   -------------------------------------------------------------------------- */++#if defined(MACHREGS_i386)++#define REG(x) __asm__("%" #x)++#if !defined(not_doing_dynamic_linking)+#define REG_Base    ebx+#endif+#define REG_Sp      ebp++#if !defined(STOLEN_X86_REGS)+#define STOLEN_X86_REGS 4+#endif++#if STOLEN_X86_REGS >= 3+# define REG_R1     esi+#endif++#if STOLEN_X86_REGS >= 4+# define REG_Hp     edi+#endif+#define REG_MachSp  esp++#define REG_XMM1    xmm0+#define REG_XMM2    xmm1+#define REG_XMM3    xmm2+#define REG_XMM4    xmm3++#define REG_YMM1    ymm0+#define REG_YMM2    ymm1+#define REG_YMM3    ymm2+#define REG_YMM4    ymm3++#define REG_ZMM1    zmm0+#define REG_ZMM2    zmm1+#define REG_ZMM3    zmm2+#define REG_ZMM4    zmm3++#define MAX_REAL_VANILLA_REG 1  /* always, since it defines the entry conv */+#define MAX_REAL_FLOAT_REG   0+#define MAX_REAL_DOUBLE_REG  0+#define MAX_REAL_LONG_REG    0+#define MAX_REAL_XMM_REG     4+#define MAX_REAL_YMM_REG     4+#define MAX_REAL_ZMM_REG     4++/* -----------------------------------------------------------------------------+  The x86-64 register mapping++  %rax          caller-saves, don't steal this one+  %rbx          YES+  %rcx          arg reg, caller-saves+  %rdx          arg reg, caller-saves+  %rsi          arg reg, caller-saves+  %rdi          arg reg, caller-saves+  %rbp          YES (our *prime* register)+  %rsp          (unavailable - stack pointer)+  %r8           arg reg, caller-saves+  %r9           arg reg, caller-saves+  %r10          caller-saves+  %r11          caller-saves+  %r12          YES+  %r13          YES+  %r14          YES+  %r15          YES++  %xmm0-7       arg regs, caller-saves+  %xmm8-15      caller-saves++  Use the caller-saves regs for Rn, because we don't always have to+  save those (as opposed to Sp/Hp/SpLim etc. which always have to be+  saved).++  --------------------------------------------------------------------------- */++#elif defined(MACHREGS_x86_64)++#define REG(x) __asm__("%" #x)++#define REG_Base  r13+#define REG_Sp    rbp+#define REG_Hp    r12+#define REG_R1    rbx+#define REG_R2    r14+#define REG_R3    rsi+#define REG_R4    rdi+#define REG_R5    r8+#define REG_R6    r9+#define REG_SpLim r15+#define REG_MachSp  rsp++/*+Map both Fn and Dn to register xmmn so that we can pass a function any+combination of up to six Float# or Double# arguments without touching+the stack. See Note [Overlapping global registers] for implications.+*/++#define REG_F1    xmm1+#define REG_F2    xmm2+#define REG_F3    xmm3+#define REG_F4    xmm4+#define REG_F5    xmm5+#define REG_F6    xmm6++#define REG_D1    xmm1+#define REG_D2    xmm2+#define REG_D3    xmm3+#define REG_D4    xmm4+#define REG_D5    xmm5+#define REG_D6    xmm6++#define REG_XMM1    xmm1+#define REG_XMM2    xmm2+#define REG_XMM3    xmm3+#define REG_XMM4    xmm4+#define REG_XMM5    xmm5+#define REG_XMM6    xmm6++#define REG_YMM1    ymm1+#define REG_YMM2    ymm2+#define REG_YMM3    ymm3+#define REG_YMM4    ymm4+#define REG_YMM5    ymm5+#define REG_YMM6    ymm6++#define REG_ZMM1    zmm1+#define REG_ZMM2    zmm2+#define REG_ZMM3    zmm3+#define REG_ZMM4    zmm4+#define REG_ZMM5    zmm5+#define REG_ZMM6    zmm6++#if !defined(mingw32_HOST_OS)+#define CALLER_SAVES_R3+#define CALLER_SAVES_R4+#endif+#define CALLER_SAVES_R5+#define CALLER_SAVES_R6++#define CALLER_SAVES_F1+#define CALLER_SAVES_F2+#define CALLER_SAVES_F3+#define CALLER_SAVES_F4+#define CALLER_SAVES_F5+#if !defined(mingw32_HOST_OS)+#define CALLER_SAVES_F6+#endif++#define CALLER_SAVES_D1+#define CALLER_SAVES_D2+#define CALLER_SAVES_D3+#define CALLER_SAVES_D4+#define CALLER_SAVES_D5+#if !defined(mingw32_HOST_OS)+#define CALLER_SAVES_D6+#endif++#define CALLER_SAVES_XMM1+#define CALLER_SAVES_XMM2+#define CALLER_SAVES_XMM3+#define CALLER_SAVES_XMM4+#define CALLER_SAVES_XMM5+#if !defined(mingw32_HOST_OS)+#define CALLER_SAVES_XMM6+#endif++#define CALLER_SAVES_YMM1+#define CALLER_SAVES_YMM2+#define CALLER_SAVES_YMM3+#define CALLER_SAVES_YMM4+#define CALLER_SAVES_YMM5+#if !defined(mingw32_HOST_OS)+#define CALLER_SAVES_YMM6+#endif++#define CALLER_SAVES_ZMM1+#define CALLER_SAVES_ZMM2+#define CALLER_SAVES_ZMM3+#define CALLER_SAVES_ZMM4+#define CALLER_SAVES_ZMM5+#if !defined(mingw32_HOST_OS)+#define CALLER_SAVES_ZMM6+#endif++#define MAX_REAL_VANILLA_REG 6+#define MAX_REAL_FLOAT_REG   6+#define MAX_REAL_DOUBLE_REG  6+#define MAX_REAL_LONG_REG    0+#define MAX_REAL_XMM_REG     6+#define MAX_REAL_YMM_REG     6+#define MAX_REAL_ZMM_REG     6++#endif  /* MACHREGS_i386 || MACHREGS_x86_64 */