recursion-ninja pushed to branch wip/26699 at Glasgow Haskell Compiler / GHC Commits: 76bbbe23 by Recursion Ninja at 2026-01-29T16:01:16-05:00 Add TTG extension point to 'OverlapMode' Migrate OverlapMode to new module Language.Haskell.Syntax.Overlap Migrate OverlapFlag to new module GHC.Hs.Decls.Overlap - - - - - 26 changed files: - compiler/GHC/Core/InstEnv.hs - compiler/GHC/Hs/Decls.hs - + compiler/GHC/Hs/Decls/Overlap.hs - compiler/GHC/Hs/Instances.hs - compiler/GHC/HsToCore/Quote.hs - compiler/GHC/Iface/Ext/Ast.hs - compiler/GHC/Iface/Syntax.hs - compiler/GHC/Parser.y - compiler/GHC/Rename/Module.hs - compiler/GHC/Tc/Deriv.hs - compiler/GHC/Tc/Deriv/Utils.hs - compiler/GHC/Tc/Errors/Ppr.hs - compiler/GHC/Tc/Utils/Instantiate.hs - compiler/GHC/ThToHs.hs - compiler/GHC/Types/Basic.hs - compiler/GHC/Types/Name.hs - compiler/GHC/Unit/Types.hs - compiler/GHC/Utils/Outputable.hs - compiler/Language/Haskell/Syntax/Basic.hs - compiler/Language/Haskell/Syntax/Decls.hs - + compiler/Language/Haskell/Syntax/Decls/Overlap.hs - compiler/Language/Haskell/Syntax/Extension.hs - compiler/ghc.cabal.in - utils/check-exact/ExactPrint.hs - utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs - utils/haddock/haddock-api/src/Haddock/Types.hs Changes: ===================================== compiler/GHC/Core/InstEnv.hs ===================================== @@ -10,7 +10,7 @@ The bits common to GHC.Tc.TyCl.Instance and GHC.Tc.Deriv. module GHC.Core.InstEnv ( DFunId, InstMatch, ClsInstLookupResult, CanonicalEvidence(..), PotentialUnifiers(..), getCoherentUnifiers, nullUnifiers, - OverlapFlag(..), OverlapMode(..), setOverlapModeMaybe, + OverlapFlag(..), OverlapMode(..), ClsInst(..), DFunInstType, pprInstance, pprInstanceHdr, pprDFunId, pprInstances, instanceWarning, instanceHead, instanceSig, mkLocalClsInst, mkImportedClsInst, instanceDFunId, updateClsInstDFuns, updateClsInstDFun, @@ -40,6 +40,7 @@ import GHC.Core.RoughMap import GHC.Core.Class import GHC.Core.Unify import GHC.Core.FVs( orphNamesOfTypes, orphNamesOfType ) +import GHC.Hs.Decls.Overlap import GHC.Hs.Extension import GHC.Unit.Module.Env @@ -50,7 +51,6 @@ import GHC.Types.Unique.DSet import GHC.Types.Var.Set import GHC.Types.Name import GHC.Types.Name.Set -import GHC.Types.Basic import GHC.Types.Id import GHC.Generics (Generic) import Data.List.NonEmpty ( NonEmpty (..), nonEmpty ) ===================================== compiler/GHC/Hs/Decls.hs ===================================== @@ -100,13 +100,17 @@ module GHC.Hs.Decls ( -- friends: import GHC.Prelude +import Language.Haskell.Syntax.Binds import Language.Haskell.Syntax.Decls +import Language.Haskell.Syntax.Decls.Overlap (OverlapMode(..)) import Language.Haskell.Syntax.Extension -import {-# SOURCE #-} GHC.Hs.Expr ( pprExpr, pprUntypedSplice ) +import {-# SOURCE #-} GHC.Hs.Expr (pprExpr, pprUntypedSplice) -- Because Expr imports Decls via HsBracket -import GHC.Hs.Binds +import GHC.Hs.Binds (ActivationAnn(..), + emptyValBindsIn, emptyValBindsOut, isEmptyValBinds, + plusHsValBinds, pprDeclList, pprLHsBindsForUser) import GHC.Hs.Type import GHC.Hs.Doc import GHC.Types.Basic @@ -1061,7 +1065,7 @@ ppDerivStrategy mb = Nothing -> empty Just (L _ ds) -> ppr ds -ppOverlapPragma :: Maybe (LocatedP OverlapMode) -> SDoc +ppOverlapPragma :: Maybe (LocatedP (OverlapMode (GhcPass p))) -> SDoc ppOverlapPragma mb = case mb of Nothing -> empty @@ -1489,7 +1493,7 @@ type instance Anno (ClsInstDecl (GhcPass p)) = SrcSpanAnnA type instance Anno (InstDecl (GhcPass p)) = SrcSpanAnnA type instance Anno (DocDecl (GhcPass p)) = SrcSpanAnnA type instance Anno (DerivDecl (GhcPass p)) = SrcSpanAnnA -type instance Anno OverlapMode = SrcSpanAnnP +type instance Anno (OverlapMode (GhcPass p)) = SrcSpanAnnP type instance Anno (DerivStrategy (GhcPass p)) = EpAnnCO type instance Anno (DefaultDecl (GhcPass p)) = SrcSpanAnnA type instance Anno (ForeignDecl (GhcPass p)) = SrcSpanAnnA ===================================== compiler/GHC/Hs/Decls/Overlap.hs ===================================== @@ -0,0 +1,108 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} -- XOverlapMode, XXOverlapMode + +{-# OPTIONS_GHC -fno-warn-orphans #-} +{- Necessary for the following instances: + * (type class): Binary OverlapMode + * (type family): XOverlapMode (GhcPass p) + * (type family): XXOverlapMode (GhcPass p) +-} + +{- | +Data-types describing the overlap annotations for instances as well as +interpreting the instances usage within the Safe Haskell context. +-} +module GHC.Hs.Decls.Overlap ( + -- * OverlapFlag + -- ** Data-type + OverlapFlag(..), + + -- * OverlapMode + -- ** Data-type + OverlapMode(..), + -- ** Queries + hasOverlappableFlag, + hasOverlappingFlag, + hasIncoherentFlag, + hasNonCanonicalFlag, + ) where + +import GHC.Prelude + +import GHC.Hs.Extension + +import Language.Haskell.Syntax.Decls.Overlap +import Language.Haskell.Syntax.Extension + +import GHC.Types.SourceText +import GHC.Utils.Binary +import GHC.Utils.Outputable + +import Control.DeepSeq (NFData(..)) + +{- +************************************************************************ +* * + Instance overlap flag +* * +************************************************************************ +-} + +-- | The semantics allowed for overlapping instances for a particular +-- instance. See Note [Safe Haskell isSafeOverlap] in GHC.Core.InstEnv for a +-- explanation of the `isSafeOverlap` field. +data OverlapFlag = OverlapFlag + { isSafeOverlap :: Bool + , overlapMode :: OverlapMode GhcTc + } deriving (Eq) + +instance Binary OverlapFlag where + put_ bh flag = do put_ bh (overlapMode flag) + put_ bh (isSafeOverlap flag) + get bh = do + h <- get bh + b <- get bh + return OverlapFlag { isSafeOverlap = b, overlapMode = h } + +instance NFData OverlapFlag where + rnf (OverlapFlag mode safe) = rnf mode `seq` rnf safe + +instance Outputable OverlapFlag where + ppr flag = ppr (overlapMode flag) <+> pprSafeOverlap (isSafeOverlap flag) + +type instance XOverlapMode (GhcPass _) = SourceText + +type instance XXOverlapMode (GhcPass _) = DataConCantHappen + +instance NFData (OverlapMode (GhcPass p)) where + rnf = \case + NoOverlap s -> rnf s + Overlappable s -> rnf s + Overlapping s -> rnf s + Overlaps s -> rnf s + Incoherent s -> rnf s + NonCanonical s -> rnf s + +instance Binary (OverlapMode (GhcPass p)) where + put_ bh = \case + NoOverlap s -> putByte bh 0 >> put_ bh s + Overlaps s -> putByte bh 1 >> put_ bh s + Incoherent s -> putByte bh 2 >> put_ bh s + Overlapping s -> putByte bh 3 >> put_ bh s + Overlappable s -> putByte bh 4 >> put_ bh s + NonCanonical s -> putByte bh 5 >> put_ bh s + + get bh = do + h <- getByte bh + case h of + 0 -> get bh >>= \s -> return $ NoOverlap s + 1 -> get bh >>= \s -> return $ Overlaps s + 2 -> get bh >>= \s -> return $ Incoherent s + 3 -> get bh >>= \s -> return $ Overlapping s + 4 -> get bh >>= \s -> return $ Overlappable s + _ -> get bh >>= \s -> return $ NonCanonical s + +pprSafeOverlap :: Bool -> SDoc +pprSafeOverlap True = text "[safe]" +pprSafeOverlap False = empty ===================================== compiler/GHC/Hs/Instances.hs ===================================== @@ -33,6 +33,7 @@ import GHC.Types.Name.Reader (WithUserRdr(..)) import GHC.Types.InlinePragma (ActivationGhc) import GHC.Data.BooleanFormula (BooleanFormula(..)) import Language.Haskell.Syntax.Decls +import Language.Haskell.Syntax.Decls.Overlap (OverlapMode(..)) import Language.Haskell.Syntax.Extension (Anno) import Language.Haskell.Syntax.Binds.InlinePragma (ActivationX(..), InlinePragma(..)) @@ -642,3 +643,8 @@ deriving instance Data ActivationGhc deriving instance Data (InlinePragma GhcPs) deriving instance Data (InlinePragma GhcRn) deriving instance Data (InlinePragma GhcTc) + +-- deriving instance Data (OverlapMode p) +deriving instance Data (OverlapMode GhcPs) +deriving instance Data (OverlapMode GhcRn) +deriving instance Data (OverlapMode GhcTc) ===================================== compiler/GHC/HsToCore/Quote.hs ===================================== @@ -37,6 +37,7 @@ import GHC.HsToCore.Binds import qualified GHC.Boot.TH.Syntax as TH import GHC.Hs +import GHC.Hs.Decls.Overlap ( OverlapMode(..) ) import GHC.Tc.Utils.TcType import GHC.Tc.Types.Evidence @@ -68,7 +69,6 @@ import qualified GHC.Data.List.NonEmpty as NE import GHC.Types.SrcLoc as SrcLoc import GHC.Types.Unique -import GHC.Types.Basic import GHC.Types.ForeignCall import GHC.Types.Var import GHC.Types.Id @@ -2731,7 +2731,7 @@ repNewtypeStrategy = rep2 newtypeStrategyName [] repViaStrategy :: Core (M TH.Type) -> MetaM (Core (M TH.DerivStrategy)) repViaStrategy (MkC t) = rep2 viaStrategyName [t] -repOverlap :: Maybe OverlapMode -> MetaM (Core (Maybe TH.Overlap)) +repOverlap :: Maybe (OverlapMode GhcRn) -> MetaM (Core (Maybe TH.Overlap)) repOverlap mb = case mb of Nothing -> nothing ===================================== compiler/GHC/Iface/Ext/Ast.hs ===================================== @@ -1718,7 +1718,7 @@ instance ToHie (RScoped (LocatedAn NoEpAnns (DerivStrategy GhcRn))) where NewtypeStrategy _ -> [] ViaStrategy s -> [ toHie (TS (ResolvedScopes [sc]) s) ] -instance ToHie (LocatedP OverlapMode) where +instance ToHie (LocatedP (OverlapMode GhcRn)) where toHie (L span _) = locOnly (locA span) instance ToHie (LocatedA (ConDecl GhcRn)) where ===================================== compiler/GHC/Iface/Syntax.hs ===================================== @@ -85,6 +85,7 @@ import GHC.Builtin.Types ( constraintKindTyConName ) import GHC.Stg.EnforceEpt.TagSig import GHC.Parser.Annotation (noLocA) import GHC.Hs.Extension ( GhcRn ) +import GHC.Hs.Decls.Overlap ( OverlapFlag ) import GHC.Hs.Doc ( WithHsDocIdentifiers(..) ) import GHC.Utils.Lexeme (isLexSym) ===================================== compiler/GHC/Parser.y ===================================== @@ -43,6 +43,7 @@ import qualified Data.List.NonEmpty as NE import qualified Prelude -- for happy-generated code import GHC.Hs +import GHC.Hs.Decls.Overlap ( OverlapMode(..) ) import GHC.Driver.Backpack.Syntax @@ -1443,7 +1444,7 @@ inst_decl :: { LInstDecl GhcPs } (fmap reverse $7) (AnnDataDefn [] [] NoEpTok tnewtype tdata (epTok $2) dcolon twhere oc cc NoEpTok)}} -overlap_pragma :: { Maybe (LocatedP OverlapMode) } +overlap_pragma :: { Maybe (LocatedP (OverlapMode GhcPs)) } : '{-# OVERLAPPABLE' '#-}' {% fmap Just $ amsr (sLL $1 $> (Overlappable (getOVERLAPPABLE_PRAGs $1))) (AnnPragma (glR $1) (epTok $2) noAnn noAnn noAnn noAnn noAnn) } | '{-# OVERLAPPING' '#-}' {% fmap Just $ amsr (sLL $1 $> (Overlapping (getOVERLAPPING_PRAGs $1))) ===================================== compiler/GHC/Rename/Module.hs ===================================== @@ -1,3 +1,4 @@ +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE RecursiveDo #-} {-# LANGUAGE TypeFamilies #-} @@ -21,6 +22,7 @@ import {-# SOURCE #-} GHC.Rename.Expr( rnLExpr ) import {-# SOURCE #-} GHC.Rename.Splice ( rnSpliceDecl, rnTopSpliceDecls ) import GHC.Hs +import GHC.Hs.Decls.Overlap ( OverlapMode(..) ) import GHC.Rename.HsType import GHC.Rename.Bind @@ -582,7 +584,7 @@ rnClsInstDecl :: ClsInstDecl GhcPs -> RnM (ClsInstDecl GhcRn, FreeVars) rnClsInstDecl (ClsInstDecl { cid_ext = (inst_warn_ps, _, _) , cid_poly_ty = inst_ty, cid_binds = mbinds , cid_sigs = uprags, cid_tyfam_insts = ats - , cid_overlap_mode = oflag + , cid_overlap_mode = omode , cid_datafam_insts = adts }) = do { rec { let ctxt = ClassInstanceCtx head_ty' ; checkInferredVars ctxt inst_ty @@ -656,13 +658,14 @@ rnClsInstDecl (ClsInstDecl { cid_ext = (inst_warn_ps, _, _) ; (adts', adt_fvs) <- rnATInstDecls rnDataFamInstDecl cls ktv_names adts ; return ( (ats', adts'), at_fvs `plusFV` adt_fvs) } + ; let omode' = rnOverlapMode omode ; let all_fvs = meth_fvs `plusFV` more_fvs `plusFV` inst_fvs ; inst_warn_rn <- mapM rnLWarningTxt inst_warn_ps ; return (ClsInstDecl { cid_ext = inst_warn_rn , cid_poly_ty = inst_ty', cid_binds = mbinds' , cid_sigs = uprags', cid_tyfam_insts = ats' - , cid_overlap_mode = oflag + , cid_overlap_mode = omode' , cid_datafam_insts = adts' }, all_fvs) } -- We return the renamed associated data type declarations so @@ -685,6 +688,18 @@ rnClsInstDecl (ClsInstDecl { cid_ext = (inst_warn_ps, _, _) addErrAt l $ TcRnWithHsDocContext ctxt err_msg pure $ mkUnboundName (mkTcOccFS (fsLit "<class>")) +rnOverlapMode :: Maybe (XRec GhcPs (OverlapMode GhcPs)) + -> Maybe (XRec GhcRn (OverlapMode GhcRn)) +rnOverlapMode = + let advancePass = \case + NoOverlap s -> NoOverlap s + Overlappable s -> Overlappable s + Overlapping s -> Overlapping s + Overlaps s -> Overlaps s + Incoherent s -> Incoherent s + NonCanonical s -> NonCanonical s + in fmap (fmap advancePass) + rnFamEqn :: HsDocContext -> AssocTyFamInfo -> FamEqn GhcPs rhs @@ -1167,7 +1182,8 @@ rnSrcDerivDecl (DerivDecl (inst_warn_ps, ann) ty mds overlap) NFC_StandaloneDerivedInstanceHead (getLHsInstDeclHead $ dropWildCards ty') ; inst_warn_rn <- mapM rnLWarningTxt inst_warn_ps - ; return (DerivDecl (inst_warn_rn, ann) ty' mds' overlap, fvs) } + ; let overlap' = rnOverlapMode overlap + ; return (DerivDecl (inst_warn_rn, ann) ty' mds' overlap', fvs) } where ctxt = DerivDeclCtx nowc_ty = dropWildCards ty ===================================== compiler/GHC/Tc/Deriv.hs ===================================== @@ -763,7 +763,7 @@ deriveStandalone (L loc (DerivDecl (warn, _) deriv_ty mb_lderiv_strat overlap_mo then do warnUselessTypeable return Nothing else do early_deriv_spec <- - mkEqnHelp (fmap unLoc overlap_mode) + mkEqnHelp (fmap (tcOverlapMode . unLoc) overlap_mode) tvs' cls inst_tys' deriv_ctxt' mb_deriv_strat' (fmap unLoc warn) @@ -773,6 +773,16 @@ deriveStandalone (L loc (DerivDecl (warn, _) deriv_ty mb_lderiv_strat overlap_mo early_deriv_spec pure (Just early_deriv_spec) } + +tcOverlapMode :: OverlapMode GhcRn -> OverlapMode GhcTc +tcOverlapMode = \case + NoOverlap s -> NoOverlap s + Overlappable s -> Overlappable s + Overlapping s -> Overlapping s + Overlaps s -> Overlaps s + Incoherent s -> Incoherent s + NonCanonical s -> NonCanonical s + -- Typecheck the type in a standalone deriving declaration. -- -- This may appear dense, but it's mostly huffing and puffing to recognize @@ -1218,7 +1228,7 @@ instance (at least from the user's perspective), the amount of engineering required to obtain the latter instance just isn't worth it. -} -mkEqnHelp :: Maybe OverlapMode +mkEqnHelp :: Maybe (OverlapMode GhcTc) -> [TyVar] -> Class -> [Type] -> DerivContext ===================================== compiler/GHC/Tc/Deriv/Utils.hs ===================================== @@ -112,7 +112,7 @@ mkDerivOrigin standalone = DerivOrigin standalone -- determining what its @EarlyDerivSpec@ should be. -- See @Note [DerivEnv and DerivSpecMechanism]@. data DerivEnv = DerivEnv - { denv_overlap_mode :: Maybe OverlapMode + { denv_overlap_mode :: Maybe (OverlapMode GhcTc) -- ^ Is this an overlapping instance? , denv_tvs :: [TyVar] -- ^ Universally quantified type variables in the instance. If the @@ -167,7 +167,7 @@ data DerivSpec theta = DS { ds_loc :: SrcSpan , ds_tys :: [Type] , ds_skol_info :: SkolemInfo , ds_user_ctxt :: UserTypeCtxt - , ds_overlap :: Maybe OverlapMode + , ds_overlap :: Maybe (OverlapMode GhcTc) , ds_standalone_wildcard :: Maybe SrcSpan -- See Note [Inferring the instance context] -- in GHC.Tc.Deriv.Infer ===================================== compiler/GHC/Tc/Errors/Ppr.hs ===================================== @@ -70,6 +70,7 @@ import GHC.CoreToIface import GHC.Driver.Flags import GHC.Driver.Backend import GHC.Hs hiding (HoleError) +import GHC.Hs.Decls.Overlap import GHC.Tc.Errors.Types import GHC.Tc.Errors.Types.PromotionErr (pprTermLevelUseCtxt) ===================================== compiler/GHC/Tc/Utils/Instantiate.hs ===================================== @@ -912,7 +912,7 @@ hasFixedRuntimeRepRes std_nm user_expr ty = mapM_ do_check mb_arity ************************************************************************ -} -getOverlapFlag :: Maybe OverlapMode -- User pragma if any +getOverlapFlag :: Maybe (OverlapMode (GhcPass p)) -- User pragma if any -> TcM OverlapFlag -- Construct the OverlapFlag from the global module flags, -- but if the overlap_mode argument is (Just m), @@ -946,18 +946,25 @@ getOverlapFlag overlap_mode_prag -- See GHC.Core.InstEnv Note [Coherence and specialisation: overview] final_overlap_mode | Incoherent s <- overlap_mode - , noncanonical_incoherence = NonCanonical s - | otherwise = overlap_mode + , noncanonical_incoherence = NonCanonical s + | otherwise = overlap_mode - ; return (OverlapFlag { isSafeOverlap = safeLanguageOn dflags - , overlapMode = final_overlap_mode }) } + final_overlap_flag = OverlapFlag (safeLanguageOn dflags) $ + case final_overlap_mode of + NoOverlap s -> NoOverlap s + Overlappable s -> Overlappable s + Overlapping s -> Overlapping s + Overlaps s -> Overlaps s + Incoherent s -> Incoherent s + NonCanonical s -> NonCanonical s + ; return $ final_overlap_flag } tcGetInsts :: TcM [ClsInst] -- Gets the local class instances. tcGetInsts = fmap tcg_insts getGblEnv -newClsInst :: Maybe OverlapMode -- User pragma +newClsInst :: Maybe (OverlapMode (GhcPass p)) -- User pragma -> Name -> [TyVar] -> ThetaType -> Class -> [Type] -> Maybe (WarningTxt GhcRn) -> TcM ClsInst newClsInst overlap_mode dfun_name tvs theta clas tys warn ===================================== compiler/GHC/ThToHs.hs ===================================== @@ -38,6 +38,7 @@ import GHC.Core.Type as Hs import qualified GHC.Core.Coercion as Coercion ( Role(..) ) import GHC.Builtin.Types import GHC.Builtin.Types.Prim( fUNTyCon ) +import GHC.Hs.Decls.Overlap as Hs import GHC.Types.Basic as Hs import GHC.Types.InlinePragma as Hs import GHC.Types.ForeignCall ===================================== compiler/GHC/Types/Basic.hs ===================================== @@ -14,7 +14,14 @@ types that \end{itemize} -} -{-# OPTIONS_GHC -Wno-orphans #-} -- Outputable PromotionFlag, Binary PromotionFlag, Outputable Boxity, Binay Boxity +{-# OPTIONS_GHC -Wno-orphans #-} +{- +Above flag is necessary for these instances: + * Binary Boxity + * Binary PromotionFlag + * Outputable Boxity + * Outputable PromotionFlag +-} {-# LANGUAGE DerivingVia #-} module GHC.Types.Basic ( @@ -40,9 +47,6 @@ module GHC.Types.Basic ( TopLevelFlag(..), isTopLevel, isNotTopLevel, - OverlapFlag(..), OverlapMode(..), setOverlapModeMaybe, - hasOverlappingFlag, hasOverlappableFlag, hasIncoherentFlag, hasNonCanonicalFlag, - Boxity(..), isBoxed, CbvMark(..), isMarkedCbv, @@ -107,13 +111,13 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Binary import GHC.Types.Arity -import GHC.Types.SourceText + import qualified GHC.LanguageExtensions as LangExt import {-# SOURCE #-} Language.Haskell.Syntax.Type (PromotionFlag(..), isPromoted) import {-# SOURCE #-} Language.Haskell.Syntax.Expr (HsDoFlavour) import Language.Haskell.Syntax.Basic -import Language.Haskell.Syntax.ImpExp +import Language.Haskell.Syntax.ImpExp (ImportDeclLevel(..), ImportDeclLevelStyle(..)) import Control.DeepSeq ( NFData(..) ) import Data.Data @@ -592,178 +596,6 @@ of whether we should do pattern-match checks; see the calls of the requiresPMC function (e.g. isMatchContextPmChecked and needToRunPmCheck in GHC.HsToCore.Pmc.Utils). -} -{- -************************************************************************ -* * - Instance overlap flag -* * -************************************************************************ --} - --- | The semantics allowed for overlapping instances for a particular --- instance. See Note [Safe Haskell isSafeOverlap] in GHC.Core.InstEnv for a --- explanation of the `isSafeOverlap` field. --- - -data OverlapFlag = OverlapFlag - { overlapMode :: OverlapMode - , isSafeOverlap :: Bool - } deriving (Eq, Data) - -setOverlapModeMaybe :: OverlapFlag -> Maybe OverlapMode -> OverlapFlag -setOverlapModeMaybe f Nothing = f -setOverlapModeMaybe f (Just m) = f { overlapMode = m } - -hasIncoherentFlag :: OverlapMode -> Bool -hasIncoherentFlag mode = - case mode of - Incoherent _ -> True - NonCanonical _ -> True - _ -> False - -hasOverlappableFlag :: OverlapMode -> Bool -hasOverlappableFlag mode = - case mode of - Overlappable _ -> True - Overlaps _ -> True - Incoherent _ -> True - NonCanonical _ -> True - _ -> False - -hasOverlappingFlag :: OverlapMode -> Bool -hasOverlappingFlag mode = - case mode of - Overlapping _ -> True - Overlaps _ -> True - Incoherent _ -> True - NonCanonical _ -> True - _ -> False - -hasNonCanonicalFlag :: OverlapMode -> Bool -hasNonCanonicalFlag = \case - NonCanonical{} -> True - _ -> False - -data OverlapMode -- See Note [Rules for instance lookup] in GHC.Core.InstEnv - = NoOverlap SourceText - -- See Note [Pragma source text] - -- ^ This instance must not overlap another `NoOverlap` instance. - -- However, it may be overlapped by `Overlapping` instances, - -- and it may overlap `Overlappable` instances. - - - | Overlappable SourceText - -- See Note [Pragma source text] - -- ^ Silently ignore this instance if you find a - -- more specific one that matches the constraint - -- you are trying to resolve - -- - -- Example: constraint (Foo [Int]) - -- instance Foo [Int] - -- instance {-# OVERLAPPABLE #-} Foo [a] - -- - -- Since the second instance has the Overlappable flag, - -- the first instance will be chosen (otherwise - -- its ambiguous which to choose) - - - | Overlapping SourceText - -- See Note [Pragma source text] - -- ^ Silently ignore any more general instances that may be - -- used to solve the constraint. - -- - -- Example: constraint (Foo [Int]) - -- instance {-# OVERLAPPING #-} Foo [Int] - -- instance Foo [a] - -- - -- Since the first instance has the Overlapping flag, - -- the second---more general---instance will be ignored (otherwise - -- it is ambiguous which to choose) - - - | Overlaps SourceText - -- See Note [Pragma source text] - -- ^ Equivalent to having both `Overlapping` and `Overlappable` flags. - - | Incoherent SourceText - -- See Note [Pragma source text] - -- ^ Behave like Overlappable and Overlapping, and in addition pick - -- an arbitrary one if there are multiple matching candidates, and - -- don't worry about later instantiation - -- - -- Example: constraint (Foo [b]) - -- instance {-# INCOHERENT -} Foo [Int] - -- instance Foo [a] - -- Without the Incoherent flag, we'd complain that - -- instantiating 'b' would change which instance - -- was chosen. See also Note [Incoherent instances] in "GHC.Core.InstEnv" - - | NonCanonical SourceText - -- ^ Behave like Incoherent, but the instance choice is observable - -- by the program behaviour. See Note [Coherence and specialisation: overview]. - -- - -- We don't have surface syntax for the distinction between - -- Incoherent and NonCanonical instances; instead, the flag - -- `-f{no-}specialise-incoherents` (on by default) controls - -- whether `INCOHERENT` instances are regarded as Incoherent or - -- NonCanonical. - - deriving (Eq, Data) - - -instance Outputable OverlapFlag where - ppr flag = ppr (overlapMode flag) <+> pprSafeOverlap (isSafeOverlap flag) - -instance NFData OverlapFlag where - rnf (OverlapFlag mode safe) = rnf mode `seq` rnf safe - -instance Outputable OverlapMode where - ppr (NoOverlap _) = empty - ppr (Overlappable _) = text "[overlappable]" - ppr (Overlapping _) = text "[overlapping]" - ppr (Overlaps _) = text "[overlap ok]" - ppr (Incoherent _) = text "[incoherent]" - ppr (NonCanonical _) = text "[noncanonical]" - -instance NFData OverlapMode where - rnf (NoOverlap s) = rnf s - rnf (Overlappable s) = rnf s - rnf (Overlapping s) = rnf s - rnf (Overlaps s) = rnf s - rnf (Incoherent s) = rnf s - rnf (NonCanonical s) = rnf s - -instance Binary OverlapMode where - put_ bh (NoOverlap s) = putByte bh 0 >> put_ bh s - put_ bh (Overlaps s) = putByte bh 1 >> put_ bh s - put_ bh (Incoherent s) = putByte bh 2 >> put_ bh s - put_ bh (Overlapping s) = putByte bh 3 >> put_ bh s - put_ bh (Overlappable s) = putByte bh 4 >> put_ bh s - put_ bh (NonCanonical s) = putByte bh 5 >> put_ bh s - get bh = do - h <- getByte bh - case h of - 0 -> (get bh) >>= \s -> return $ NoOverlap s - 1 -> (get bh) >>= \s -> return $ Overlaps s - 2 -> (get bh) >>= \s -> return $ Incoherent s - 3 -> (get bh) >>= \s -> return $ Overlapping s - 4 -> (get bh) >>= \s -> return $ Overlappable s - 5 -> (get bh) >>= \s -> return $ NonCanonical s - _ -> panic ("get OverlapMode" ++ show h) - - -instance Binary OverlapFlag where - put_ bh flag = do put_ bh (overlapMode flag) - put_ bh (isSafeOverlap flag) - get bh = do - h <- get bh - b <- get bh - return OverlapFlag { overlapMode = h, isSafeOverlap = b } - -pprSafeOverlap :: Bool -> SDoc -pprSafeOverlap True = text "[safe]" -pprSafeOverlap False = empty - {- ************************************************************************ * * ===================================== compiler/GHC/Types/Name.hs ===================================== @@ -105,10 +105,11 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.OldList (intersperse) +import Language.Haskell.Syntax.Basic (Boxity(Boxed, Unboxed)) + import Control.DeepSeq import Data.Data import qualified Data.Semigroup as S -import GHC.Types.Basic (Boxity(Boxed, Unboxed)) import GHC.Builtin.Uniques ( isTupleTyConUnique, isCTupleTyConUnique, isSumTyConUnique, isTupleDataConLikeUnique ) ===================================== compiler/GHC/Unit/Types.hs ===================================== @@ -99,7 +99,7 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BS.Char8 import Language.Haskell.Syntax.Module.Name -import Language.Haskell.Syntax.ImpExp (IsBootInterface(..)) +import Language.Haskell.Syntax.ImpExp.IsBoot (IsBootInterface(..)) --------------------------------------------------------------------- -- MODULES ===================================== compiler/GHC/Utils/Outputable.hs ===================================== @@ -114,6 +114,7 @@ import {-# SOURCE #-} GHC.Types.Name.Occurrence( OccName ) import Language.Haskell.Syntax.Basic import Language.Haskell.Syntax.Binds.InlinePragma +import Language.Haskell.Syntax.Decls.Overlap ( OverlapMode(..) ) import Language.Haskell.Syntax.Module.Name ( ModuleName(..) ) import GHC.Prelude.Basic @@ -2026,3 +2027,12 @@ instance Outputable RuleMatchInfo where instance Outputable TopLevelFlag where ppr TopLevel = text "<TopLevel>" ppr NotTopLevel = text "<NotTopLevel>" + +instance Outputable (OverlapMode p) where + ppr (NoOverlap _) = empty + ppr (Overlappable _) = text "[overlappable]" + ppr (Overlapping _) = text "[overlapping]" + ppr (Overlaps _) = text "[overlap ok]" + ppr (Incoherent _) = text "[incoherent]" + ppr (NonCanonical _) = text "[noncanonical]" + ppr (XOverlapMode _) = text "[user TTG extension]" ===================================== compiler/Language/Haskell/Syntax/Basic.hs ===================================== @@ -1,6 +1,8 @@ {-# LANGUAGE GeneralisedNewtypeDeriving #-} + module Language.Haskell.Syntax.Basic where +import Control.DeepSeq import Data.Data (Data) import Data.Eq import Data.Ord @@ -8,7 +10,6 @@ import Data.Bool import Prelude import GHC.Data.FastString (FastString) -import Control.DeepSeq {- ************************************************************************ ===================================== compiler/Language/Haskell/Syntax/Decls.hs ===================================== @@ -88,18 +88,18 @@ module Language.Haskell.Syntax.Decls ( -- friends: import {-# SOURCE #-} Language.Haskell.Syntax.Expr - ( HsExpr, HsUntypedSplice ) + (HsExpr, HsUntypedSplice) -- Because Expr imports Decls via HsBracket -import Language.Haskell.Syntax.Basic (TopLevelFlag, RuleName) +import Language.Haskell.Syntax.Basic + (LexicalFixity, Role, RuleName, TopLevelFlag) import Language.Haskell.Syntax.Binds import Language.Haskell.Syntax.Binds.InlinePragma (Activation) +import Language.Haskell.Syntax.Decls.Overlap (OverlapMode) import Language.Haskell.Syntax.Extension -import Language.Haskell.Syntax.Type -import Language.Haskell.Syntax.Basic (Role, LexicalFixity) import Language.Haskell.Syntax.Specificity (Specificity) +import Language.Haskell.Syntax.Type -import GHC.Types.Basic (OverlapMode) import GHC.Types.ForeignCall (CType, CCallConv, Safety, Header, CLabelString, CCallTarget, CExportSpec) import GHC.Data.FastString (FastString) @@ -119,7 +119,7 @@ import Prelude (Show) import Data.Foldable import Data.Traversable import Data.List.NonEmpty (NonEmpty (..)) -import GHC.Generics ( Generic ) +import GHC.Generics (Generic) {- @@ -1261,7 +1261,7 @@ data ClsInstDecl pass , cid_sigs :: [LSig pass] -- User-supplied pragmatic info , cid_tyfam_insts :: [LTyFamInstDecl pass] -- Type family instances , cid_datafam_insts :: [LDataFamInstDecl pass] -- Data family instances - , cid_overlap_mode :: Maybe (XRec pass OverlapMode) + , cid_overlap_mode :: Maybe (XRec pass (OverlapMode pass)) } | XClsInstDecl !(XXClsInstDecl pass) @@ -1310,7 +1310,7 @@ data DerivDecl pass = DerivDecl -- See Note [Inferring the instance context] in GHC.Tc.Deriv.Infer. , deriv_strategy :: Maybe (LDerivStrategy pass) - , deriv_overlap_mode :: Maybe (XRec pass OverlapMode) + , deriv_overlap_mode :: Maybe (XRec pass (OverlapMode pass)) } | XDerivDecl !(XXDerivDecl pass) ===================================== compiler/Language/Haskell/Syntax/Decls/Overlap.hs ===================================== @@ -0,0 +1,123 @@ +{-# LANGUAGE GeneralisedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverlappingInstances #-} +{-# LANGUAGE UndecidableInstances #-} -- Eq XOverlapMode, NFData OverlapMode + +{- | +Data-type describing the overlap annotations for instances. +-} +module Language.Haskell.Syntax.Decls.Overlap where + +import Control.DeepSeq +import Data.Eq +import Prelude + +import Language.Haskell.Syntax.Extension + +-- | The status of overlapping instances /(including no overlap)/ for a type. +data OverlapMode pass -- See Note [Rules for instance lookup] in GHC.Core.InstEnv + = NoOverlap (XOverlapMode pass) + -- ^ This instance must not overlap another `NoOverlap` instance. + -- However, it may be overlapped by `Overlapping` instances, + -- and it may overlap `Overlappable` instances. + + + | Overlappable (XOverlapMode pass) + -- ^ Silently ignore this instance if you find a + -- more specific one that matches the constraint + -- you are trying to resolve + -- + -- Example: constraint (Foo [Int]) + -- instance Foo [Int] + -- instance {-# OVERLAPPABLE #-} Foo [a] + -- + -- Since the second instance has the Overlappable flag, + -- the first instance will be chosen (otherwise + -- its ambiguous which to choose) + + | Overlapping (XOverlapMode pass) + -- ^ Silently ignore any more general instances that may be + -- used to solve the constraint. + -- + -- Example: constraint (Foo [Int]) + -- instance {-# OVERLAPPING #-} Foo [Int] + -- instance Foo [a] + -- + -- Since the first instance has the Overlapping flag, + -- the second---more general---instance will be ignored (otherwise + -- it is ambiguous which to choose) + + | Overlaps (XOverlapMode pass) + -- ^ Equivalent to having both `Overlapping` and `Overlappable` flags. + + | Incoherent (XOverlapMode pass) + -- ^ Behave like Overlappable and Overlapping, and in addition pick + -- an arbitrary one if there are multiple matching candidates, and + -- don't worry about later instantiation + -- + -- Example: constraint (Foo [b]) + -- instance {-# INCOHERENT -} Foo [Int] + -- instance Foo [a] + -- Without the Incoherent flag, we'd complain that + -- instantiating 'b' would change which instance + -- was chosen. See also Note [Incoherent instances] in "GHC.Core.InstEnv" + + | NonCanonical (XOverlapMode pass) + -- ^ Behave like Incoherent, but the instance choice is observable + -- by the program behaviour. See Note [Coherence and specialisation: overview]. + -- + -- We don't have surface syntax for the distinction between + -- Incoherent and NonCanonical instances; instead, the flag + -- `-f{no-}specialise-incoherents` (on by default) controls + -- whether `INCOHERENT` instances are regarded as Incoherent or + -- NonCanonical. + + | XOverlapMode !(XXOverlapMode pass) + -- ^ The /Trees That Grow/ extension point constructor. + +deriving instance ( Eq (XOverlapMode pass) + , Eq (XXOverlapMode pass) + ) => Eq (OverlapMode pass) + +instance ( NFData (XOverlapMode pass) + , NFData (XXOverlapMode pass) + ) => NFData (OverlapMode pass) where + rnf = \case + NoOverlap s -> rnf s + Overlappable s -> rnf s + Overlapping s -> rnf s + Overlaps s -> rnf s + Incoherent s -> rnf s + NonCanonical s -> rnf s + XOverlapMode s -> rnf s + + +hasIncoherentFlag :: OverlapMode p -> Bool +hasIncoherentFlag mode = + case mode of + Incoherent _ -> True + NonCanonical _ -> True + _ -> False + +hasOverlappableFlag :: OverlapMode p -> Bool +hasOverlappableFlag mode = + case mode of + Overlappable _ -> True + Overlaps _ -> True + Incoherent _ -> True + NonCanonical _ -> True + _ -> False + +hasOverlappingFlag :: OverlapMode p -> Bool +hasOverlappingFlag mode = + case mode of + Overlapping _ -> True + Overlaps _ -> True + Incoherent _ -> True + NonCanonical _ -> True + _ -> False + +hasNonCanonicalFlag :: OverlapMode p -> Bool +hasNonCanonicalFlag = \case + NonCanonical{} -> True + _ -> False ===================================== compiler/Language/Haskell/Syntax/Extension.hs ===================================== @@ -359,6 +359,11 @@ type family XDataFamInstD x type family XTyFamInstD x type family XXInstDecl x +-- ------------------------------------- +-- OverlapMode type families +type family XOverlapMode x +type family XXOverlapMode x + -- ------------------------------------- -- DerivDecl type families type family XCDerivDecl x ===================================== compiler/ghc.cabal.in ===================================== @@ -546,6 +546,7 @@ Library GHC.Hs.Basic GHC.Hs.Binds GHC.Hs.Decls + GHC.Hs.Decls.Overlap GHC.Hs.Doc GHC.Hs.DocString GHC.Hs.Dump @@ -1024,6 +1025,7 @@ Library Language.Haskell.Syntax.Binds.InlinePragma Language.Haskell.Syntax.BooleanFormula Language.Haskell.Syntax.Decls + Language.Haskell.Syntax.Decls.Overlap Language.Haskell.Syntax.Expr Language.Haskell.Syntax.Extension Language.Haskell.Syntax.ImpExp ===================================== utils/check-exact/ExactPrint.hs ===================================== @@ -45,8 +45,8 @@ import GHC.Base (NonEmpty(..)) import qualified GHC.Data.BooleanFormula as BF import GHC.Data.FastString import qualified GHC.Data.Strict as Strict +import GHC.Hs.Decls.Overlap (OverlapMode(..)) import GHC.TypeLits -import GHC.Types.Basic hiding (EP) import GHC.Types.ForeignCall import GHC.Types.InlinePragma (ActivationGhc, inlinePragmaActivation, inlinePragmaSource) import GHC.Types.Name.Reader @@ -2263,7 +2263,7 @@ instance ExactPrint (TyFamInstDecl GhcPs) where -- --------------------------------------------------------------------- -instance ExactPrint (LocatedP OverlapMode) where +instance Typeable p => ExactPrint (LocatedP (OverlapMode (GhcPass p))) where getAnnotationEntry = entryFromLocatedA setAnnotationAnchor = setAnchorAn ===================================== utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs ===================================== @@ -37,6 +37,7 @@ import GHC hiding (NoLink, HsTypeGhcPsExt (..)) import GHC.Builtin.Types (eqTyCon_RDR, tupleDataConName, tupleTyConName) import GHC.Core.TyCon (tyConResKind) import GHC.Driver.DynFlags (getDynFlags) +import GHC.Hs.Decls.Overlap (OverlapMode(..)) import GHC.Types.Basic (TupleSort (..)) import GHC.Types.Name import GHC.Types.Name.Reader (RdrName (Exact)) @@ -860,10 +861,19 @@ renameDerivD { deriv_ext = noExtField , deriv_type = ty' , deriv_strategy = strat' - , deriv_overlap_mode = omode + , deriv_overlap_mode = fmap convertOverlapMode <$> omode } ) +convertOverlapMode :: OverlapMode GhcRn -> OverlapMode DocNameI +convertOverlapMode = \case + NoOverlap _ -> NoOverlap NoExtField + Overlappable _ -> Overlappable NoExtField + Overlapping _ -> Overlapping NoExtField + Overlaps _ -> Overlaps NoExtField + Incoherent _ -> Incoherent NoExtField + NonCanonical _ -> NonCanonical NoExtField + renameDerivStrategy :: DerivStrategy GhcRn -> RnM (DerivStrategy DocNameI) renameDerivStrategy (StockStrategy a) = pure (StockStrategy a) renameDerivStrategy (AnyclassStrategy a) = pure (AnyclassStrategy a) @@ -885,7 +895,7 @@ renameClsInstD return ( ClsInstDecl { cid_ext = noExtField - , cid_overlap_mode = omode + , cid_overlap_mode = fmap convertOverlapMode <$> omode , cid_poly_ty = ltype' , cid_binds = [] , cid_sigs = [] ===================================== utils/haddock/haddock-api/src/Haddock/Types.hs ===================================== @@ -56,6 +56,7 @@ import GHC.Data.BooleanFormula (BooleanFormula) import GHC.Driver.Session (Language) import qualified GHC.LanguageExtensions as LangExt import GHC.Core.InstEnv (is_dfun_name) +import GHC.Hs.Decls.Overlap (OverlapMode) import GHC.Types.Name (stableNameCmp) import GHC.Types.Name.Occurrence import GHC.Types.Name.Reader (RdrName (..)) @@ -829,6 +830,7 @@ type instance Anno (FamilyResultSig DocNameI) = EpAnn NoEpAnns type instance Anno (HsOuterTyVarBndrs Specificity DocNameI) = SrcSpanAnnA type instance Anno (HsSigType DocNameI) = SrcSpanAnnA type instance Anno (BooleanFormula DocNameI) = SrcSpanAnnL +type instance Anno (OverlapMode DocNameI) = EpAnn AnnPragma type XRecCond a = ( XParTy a ~ (EpToken "(", EpToken ")") @@ -960,8 +962,10 @@ type instance XClassDecl DocNameI = NoExtField type instance XDataDecl DocNameI = NoExtField type instance XSynDecl DocNameI = NoExtField type instance XFamDecl DocNameI = NoExtField +type instance XOverlapMode DocNameI = NoExtField type instance XXHsDataDefn DocNameI = DataConCantHappen type instance XXFamilyDecl DocNameI = DataConCantHappen +type instance XXOverlapMode DocNameI = DataConCantHappen type instance XXTyClDecl DocNameI = DataConCantHappen type instance XHsWC DocNameI _ = NoExtField View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/76bbbe232482d9808d6c83185f50b166... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/76bbbe232482d9808d6c83185f50b166... You're receiving this email because of your account on gitlab.haskell.org.