diff options
29 files changed, 403 insertions, 329 deletions
diff --git a/compiler/GHC/Hs/Binds.hs b/compiler/GHC/Hs/Binds.hs index 686d9e6b25..c08031c223 100644 --- a/compiler/GHC/Hs/Binds.hs +++ b/compiler/GHC/Hs/Binds.hs @@ -600,6 +600,10 @@ pprTicks pp_no_debug pp_when_debug then pp_when_debug else pp_no_debug +instance Outputable (XRec a RdrName) => Outputable (RecordPatSynField a) where + ppr (RecordPatSynField { recordPatSynField = v }) = ppr v + + {- ************************************************************************ * * @@ -651,20 +655,28 @@ instance OutputableBndrId p => Outputable (IPBind (GhcPass p)) where type instance XTypeSig (GhcPass p) = EpAnn AnnSig type instance XPatSynSig (GhcPass p) = EpAnn AnnSig type instance XClassOpSig (GhcPass p) = EpAnn AnnSig -type instance XIdSig (GhcPass p) = NoExtField -- No anns, generated 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] -type instance XMinimalSig (GhcPass p) = EpAnn [AddEpAnn] -type instance XSCCFunSig (GhcPass p) = EpAnn [AddEpAnn] -type instance XCompleteMatchSig (GhcPass p) = EpAnn [AddEpAnn] - -type instance XXSig (GhcPass p) = DataConCantHappen +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) + -- 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 XXFixitySig (GhcPass p) = DataConCantHappen +-- | 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 +-- just like a type signature: there should be an accompanying binding +newtype IdSig = IdSig { unIdSig :: Id } + deriving Data + data AnnSig = AnnSig { asDcolon :: AddEpAnn, -- Not an EpaAnchor to capture unicode option @@ -714,7 +726,6 @@ ppr_sig (TypeSig _ vars ty) = pprVarSig (map unLoc vars) (ppr ty) ppr_sig (ClassOpSig _ is_deflt vars ty) | is_deflt = text "default" <+> pprVarSig (map unLoc vars) (ppr ty) | otherwise = pprVarSig (map unLoc vars) (ppr ty) -ppr_sig (IdSig _ id) = pprVarSig [id] (ppr (varType id)) ppr_sig (FixSig _ fix_sig) = ppr fix_sig ppr_sig (SpecSig _ var ty inl@(InlinePragma { inl_inline = spec })) = pragSrcBrackets (inlinePragmaSource inl) pragmaSrc (pprSpec (unLoc var) @@ -729,20 +740,20 @@ ppr_sig (InlineSig _ var inl) ppr_pfx = case inlinePragmaSource inl of SourceText src -> text src NoSourceText -> text "{-#" <+> inlinePragmaName (inl_inline inl) -ppr_sig (SpecInstSig _ src ty) +ppr_sig (SpecInstSig (_, src) ty) = pragSrcBrackets src "{-# pragma" (text "instance" <+> ppr ty) -ppr_sig (MinimalSig _ src bf) +ppr_sig (MinimalSig (_, src) bf) = pragSrcBrackets src "{-# MINIMAL" (pprMinimalSig bf) ppr_sig (PatSynSig _ names sig_ty) = text "pattern" <+> pprVarSig (map unLoc names) (ppr sig_ty) -ppr_sig (SCCFunSig _ src fn mlabel) +ppr_sig (SCCFunSig (_, src) fn mlabel) = pragSrcBrackets src "{-# SCC" (ppr_fn <+> maybe empty ppr mlabel ) where ppr_fn = case ghcPass @p of GhcPs -> ppr fn GhcRn -> ppr fn GhcTc -> ppr fn -ppr_sig (CompleteMatchSig _ src cs mty) +ppr_sig (CompleteMatchSig (_, src) cs mty) = pragSrcBrackets src "{-# COMPLETE" ((hsep (punctuate comma (map ppr_n (unLoc cs)))) <+> opt_sig) @@ -752,6 +763,40 @@ ppr_sig (CompleteMatchSig _ src cs mty) GhcPs -> ppr n GhcRn -> ppr n GhcTc -> ppr n +ppr_sig (XSig x) = case ghcPass @p of + GhcRn | IdSig id <- x -> pprVarSig [id] (ppr (varType id)) + GhcTc | IdSig id <- x -> pprVarSig [id] (ppr (varType id)) + +hsSigDoc :: forall p. IsPass p => Sig (GhcPass p) -> SDoc +hsSigDoc (TypeSig {}) = text "type signature" +hsSigDoc (PatSynSig {}) = text "pattern synonym signature" +hsSigDoc (ClassOpSig _ is_deflt _ _) + | is_deflt = text "default type signature" + | otherwise = text "class method signature" +hsSigDoc (SpecSig _ _ _ inl) = (inlinePragmaName . inl_inline $ inl) <+> text "pragma" +hsSigDoc (InlineSig _ _ prag) = (inlinePragmaName . inl_inline $ prag) <+> text "pragma" +-- Using the 'inlinePragmaName' function ensures that the pragma name for any +-- one of the INLINE/INLINABLE/NOINLINE pragmas are printed after being extracted +-- from the InlineSpec field of the pragma. +hsSigDoc (SpecInstSig (_, src) _) = text (extractSpecPragName src) <+> text "instance pragma" +hsSigDoc (FixSig {}) = text "fixity declaration" +hsSigDoc (MinimalSig {}) = text "MINIMAL pragma" +hsSigDoc (SCCFunSig {}) = text "SCC pragma" +hsSigDoc (CompleteMatchSig {}) = text "COMPLETE pragma" +hsSigDoc (XSig _) = case ghcPass @p of + GhcRn -> text "id signature" + GhcTc -> text "id signature" + +-- | Extracts the name for a SPECIALIZE instance pragma. In 'hsSigDoc', the src +-- field of 'SpecInstSig' signature contains the SourceText for a SPECIALIZE +-- instance pragma of the form: "SourceText {-# SPECIALIZE" +-- +-- Extraction ensures that all variants of the pragma name (with a 'Z' or an +-- 'S') are output exactly as used in the pragma. +extractSpecPragName :: SourceText -> String +extractSpecPragName srcTxt = case (words $ show srcTxt) of + (_:_:pragName:_) -> filter (/= '\"') pragName + _ -> pprPanic "hsSigDoc: Misformed SPECIALISE instance pragma:" (ppr srcTxt) instance OutputableBndrId p => Outputable (FixitySig (GhcPass p)) where diff --git a/compiler/GHC/Hs/Lit.hs b/compiler/GHC/Hs/Lit.hs index 3b9b6948c6..838e3348dd 100644 --- a/compiler/GHC/Hs/Lit.hs +++ b/compiler/GHC/Hs/Lit.hs @@ -25,14 +25,15 @@ import GHC.Prelude import {-# SOURCE #-} GHC.Hs.Expr( pprExpr ) -import Language.Haskell.Syntax.Lit - +import GHC.Types.Basic (PprPrec(..), topPrec ) +import GHC.Core.Ppr ( {- instance OutputableBndr TyVar -} ) import GHC.Types.SourceText import GHC.Core.Type import GHC.Utils.Outputable +import GHC.Hs.Extension import Language.Haskell.Syntax.Expr ( HsExpr ) import Language.Haskell.Syntax.Extension -import GHC.Hs.Extension +import Language.Haskell.Syntax.Lit {- ************************************************************************ @@ -103,6 +104,37 @@ type instance XXOverLit (GhcPass _) = DataConCantHappen overLitType :: HsOverLit GhcTc -> Type overLitType (OverLit OverLitTc{ ol_type = ty } _) = ty +-- | @'hsOverLitNeedsParens' p ol@ returns 'True' if an overloaded literal +-- @ol@ needs to be parenthesized under precedence @p@. +hsOverLitNeedsParens :: PprPrec -> HsOverLit x -> Bool +hsOverLitNeedsParens p (OverLit { ol_val = olv }) = go olv + where + go :: OverLitVal -> Bool + go (HsIntegral x) = p > topPrec && il_neg x + go (HsFractional x) = p > topPrec && fl_neg x + go (HsIsString {}) = False +hsOverLitNeedsParens _ (XOverLit { }) = False + +-- | @'hsLitNeedsParens' p l@ returns 'True' if a literal @l@ needs +-- to be parenthesized under precedence @p@. +hsLitNeedsParens :: PprPrec -> HsLit x -> Bool +hsLitNeedsParens p = go + where + go (HsChar {}) = False + go (HsCharPrim {}) = False + go (HsString {}) = False + go (HsStringPrim {}) = False + go (HsInt _ x) = p > topPrec && il_neg x + go (HsIntPrim _ x) = p > topPrec && x < 0 + go (HsWordPrim {}) = False + go (HsInt64Prim _ x) = p > topPrec && x < 0 + go (HsWord64Prim {}) = False + go (HsInteger _ x _) = p > topPrec && x < 0 + go (HsRat _ x _) = p > topPrec && fl_neg x + go (HsFloatPrim _ x) = p > topPrec && fl_neg x + go (HsDoublePrim _ x) = p > topPrec && fl_neg x + go (XLit _) = False + -- | Convert a literal from one index type to another convertLit :: HsLit (GhcPass p1) -> HsLit (GhcPass p2) convertLit (HsChar a x) = HsChar a x @@ -161,6 +193,11 @@ instance OutputableBndrId p ppr (OverLit {ol_val=val, ol_ext=ext}) = ppr val <+> (whenPprDebug (parens (pprXOverLit (ghcPass @p) ext))) +instance Outputable OverLitVal where + ppr (HsIntegral i) = pprWithSourceText (il_text i) (integer (il_value i)) + ppr (HsFractional f) = ppr f + ppr (HsIsString st s) = pprWithSourceText st (pprHsString s) + -- | pmPprHsLit pretty prints literals and is used when pretty printing pattern -- match warnings. All are printed the same (i.e., without hashes if they are -- primitive and not wrapped in constructors if they are boxed). This happens @@ -181,3 +218,4 @@ pmPprHsLit (HsInteger _ i _) = integer i pmPprHsLit (HsRat _ f _) = ppr f pmPprHsLit (HsFloatPrim _ f) = ppr f pmPprHsLit (HsDoublePrim _ d) = ppr d + diff --git a/compiler/GHC/Hs/Pat.hs b/compiler/GHC/Hs/Pat.hs index 102587026e..2b8eb269bb 100644 --- a/compiler/GHC/Hs/Pat.hs +++ b/compiler/GHC/Hs/Pat.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} @@ -260,6 +261,24 @@ hsRecUpdFieldOcc = fmap unambiguousFieldOcc . hfbLHS ************************************************************************ -} +instance Outputable (HsPatSigType 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) + => Outputable (HsRecFields p arg) where + ppr (HsRecFields { rec_flds = flds, rec_dotdot = Nothing }) + = braces (fsep (punctuate comma (map ppr flds))) + ppr (HsRecFields { rec_flds = flds, rec_dotdot = Just (unLoc -> n) }) + = braces (fsep (punctuate comma (map ppr (take n flds) ++ [dotdot]))) + where + dotdot = text ".." <+> whenPprDebug (ppr (drop n flds)) + +instance (Outputable p, OutputableBndr p, Outputable arg) + => Outputable (HsFieldBind p arg) where + ppr (HsFieldBind { hfbLHS = f, hfbRHS = arg, + hfbPun = pun }) + = pprPrefixOcc f <+> (ppUnless pun $ equals <+> ppr arg) + instance OutputableBndrId p => Outputable (Pat (GhcPass p)) where ppr = pprPat @@ -734,3 +753,4 @@ type instance Anno (Pat (GhcPass p)) = SrcSpanAnnA type instance Anno (HsOverLit (GhcPass p)) = SrcAnn NoEpAnns type instance Anno ConLike = SrcSpanAnnN type instance Anno (HsFieldBind lhs rhs) = SrcSpanAnnA +type instance Anno RecFieldsDotDot = SrcSpan diff --git a/compiler/GHC/Hs/Type.hs b/compiler/GHC/Hs/Type.hs index 1635019dbe..73709e2849 100644 --- a/compiler/GHC/Hs/Type.hs +++ b/compiler/GHC/Hs/Type.hs @@ -2,6 +2,7 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -112,8 +113,10 @@ import GHC.Hs.Doc import GHC.Types.Basic import GHC.Types.SrcLoc import GHC.Utils.Outputable +import GHC.Utils.Misc (count) import Data.Maybe +import Data.Data (Data) import qualified Data.Semigroup as S @@ -207,6 +210,14 @@ type instance XHsPS GhcPs = EpAnnCO type instance XHsPS GhcRn = HsPSRn type instance XHsPS GhcTc = HsPSRn +-- | The extension field for 'HsPatSigType', which is only used in the +-- renamer onwards. See @Note [Pattern signature binders and scoping]@. +data HsPSRn = HsPSRn + { hsps_nwcs :: [Name] -- ^ Wildcard names + , hsps_imp_tvs :: [Name] -- ^ Implicitly bound variable names + } + deriving Data + type instance XXHsPatSigType (GhcPass _) = DataConCantHappen type instance XHsSig (GhcPass _) = NoExtField @@ -533,6 +544,66 @@ lhsTypeArgSrcSpan arg = case arg of -------------------------------- +numVisibleArgs :: [HsArg tm ty] -> Arity +numVisibleArgs = count is_vis + where is_vis (HsValArg _) = True + is_vis _ = False + +-------------------------------- + +-- | @'pprHsArgsApp' id fixity args@ pretty-prints an application of @id@ +-- to @args@, using the @fixity@ to tell whether @id@ should be printed prefix +-- or infix. Examples: +-- +-- @ +-- pprHsArgsApp T Prefix [HsTypeArg Bool, HsValArg Int] = T \@Bool Int +-- pprHsArgsApp T Prefix [HsTypeArg Bool, HsArgPar, HsValArg Int] = (T \@Bool) Int +-- pprHsArgsApp (++) Infix [HsValArg Char, HsValArg Double] = Char ++ Double +-- pprHsArgsApp (++) Infix [HsValArg Char, HsValArg Double, HsVarArg Ordering] = (Char ++ Double) Ordering +-- @ +pprHsArgsApp :: (OutputableBndr id, Outputable tm, Outputable ty) + => id -> LexicalFixity -> [HsArg tm ty] -> SDoc +pprHsArgsApp thing fixity (argl:argr:args) + | Infix <- fixity + = let pp_op_app = hsep [ ppr_single_hs_arg argl + , pprInfixOcc thing + , ppr_single_hs_arg argr ] in + case args of + [] -> pp_op_app + _ -> ppr_hs_args_prefix_app (parens pp_op_app) args + +pprHsArgsApp thing _fixity args + = ppr_hs_args_prefix_app (pprPrefixOcc thing) args + +-- | Pretty-print a prefix identifier to a list of 'HsArg's. +ppr_hs_args_prefix_app :: (Outputable tm, Outputable ty) + => SDoc -> [HsArg tm ty] -> SDoc +ppr_hs_args_prefix_app acc [] = acc +ppr_hs_args_prefix_app acc (arg:args) = + case arg of + HsValArg{} -> ppr_hs_args_prefix_app (acc <+> ppr_single_hs_arg arg) args + HsTypeArg{} -> ppr_hs_args_prefix_app (acc <+> ppr_single_hs_arg arg) args + HsArgPar{} -> ppr_hs_args_prefix_app (parens acc) args + +-- | Pretty-print an 'HsArg' in isolation. +ppr_single_hs_arg :: (Outputable tm, Outputable ty) + => HsArg 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 +-- allows this to be reachable, so don't fail here. +ppr_single_hs_arg (HsArgPar{}) = empty + +-- | 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 tm ty) where + ppr (HsValArg tm) = text "HsValArg" <+> ppr tm + ppr (HsTypeArg sp ty) = text "HsTypeArg" <+> ppr sp <+> ppr ty + ppr (HsArgPar sp) = text "HsArgPar" <+> ppr sp + +-------------------------------- + -- | Decompose a pattern synonym type signature into its constituent parts. -- -- Note that this function looks through parentheses, so it will work on types @@ -919,6 +990,41 @@ instance (OutputableBndrId p) => Outputable (HsPatSigType (GhcPass p)) where ppr (HsPS { hsps_body = ty }) = ppr ty + +instance Outputable HsTyLit where + ppr = ppr_tylit + +instance Outputable HsIPName where + ppr (HsIPName n) = char '?' <> ftext n -- Ordinary implicit parameters + +instance OutputableBndr HsIPName where + pprBndr _ n = ppr n -- Simple for now + pprInfixOcc n = ppr n + pprPrefixOcc n = ppr n + +instance (Outputable tyarg, Outputable arg, Outputable rec) + => Outputable (HsConDetails tyarg arg rec) where + ppr (PrefixCon tyargs args) = text "PrefixCon:" <+> hsep (map (\t -> text "@" <> ppr t) tyargs) <+> ppr args + ppr (RecCon rec) = text "RecCon:" <+> ppr rec + ppr (InfixCon l r) = text "InfixCon:" <+> ppr [l, r] + +instance Outputable (XRec pass RdrName) => Outputable (FieldOcc pass) where + ppr = ppr . foLabel + +instance (UnXRec pass, OutputableBndr (XRec pass RdrName)) => OutputableBndr (FieldOcc pass) where + pprInfixOcc = pprInfixOcc . unXRec @pass . foLabel + pprPrefixOcc = pprPrefixOcc . unXRec @pass . foLabel + +instance (UnXRec pass, OutputableBndr (XRec pass RdrName)) => OutputableBndr (GenLocated SrcSpan (FieldOcc pass)) where + pprInfixOcc = pprInfixOcc . unLoc + pprPrefixOcc = pprPrefixOcc . unLoc + + +ppr_tylit :: HsTyLit -> SDoc +ppr_tylit (HsNumTy source i) = pprWithSourceText source (integer i) +ppr_tylit (HsStrTy source s) = pprWithSourceText source (text (show s)) +ppr_tylit (HsCharTy source c) = pprWithSourceText source (text (show c)) + pprAnonWildCard :: SDoc pprAnonWildCard = char '_' diff --git a/compiler/GHC/HsToCore/Match.hs b/compiler/GHC/HsToCore/Match.hs index 0cc5907c2b..86b6347e09 100644 --- a/compiler/GHC/HsToCore/Match.hs +++ b/compiler/GHC/HsToCore/Match.hs @@ -27,7 +27,7 @@ import GHC.Platform import {-#SOURCE#-} GHC.HsToCore.Expr (dsExpr) -import GHC.Types.Basic ( Origin(..), isGenerated, Boxity(..) ) +import GHC.Types.Basic ( Origin(..), isGenerated ) import GHC.Types.SourceText import GHC.Driver.Session import GHC.Hs diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs index 015ecb56f6..57292e47f2 100644 --- a/compiler/GHC/HsToCore/Quote.hs +++ b/compiler/GHC/HsToCore/Quote.hs @@ -989,16 +989,16 @@ rep_sig (L loc (PatSynSig _ nms ty)) rep_sig (L loc (ClassOpSig _ is_deflt nms ty)) | is_deflt = mapM (rep_ty_sig defaultSigDName (locA loc) ty) nms | otherwise = mapM (rep_ty_sig sigDName (locA loc) ty) nms -rep_sig d@(L _ (IdSig {})) = pprPanic "rep_sig IdSig" (ppr d) rep_sig (L loc (FixSig _ fix_sig)) = rep_fix_d (locA loc) fix_sig rep_sig (L loc (InlineSig _ nm ispec))= rep_inline nm ispec (locA loc) rep_sig (L loc (SpecSig _ nm tys ispec)) = concatMapM (\t -> rep_specialise nm t ispec (locA loc)) tys -rep_sig (L loc (SpecInstSig _ _ ty)) = rep_specialiseInst ty (locA loc) +rep_sig (L loc (SpecInstSig _ ty)) = rep_specialiseInst ty (locA loc) rep_sig (L _ (MinimalSig {})) = notHandled ThMinimalPragmas rep_sig (L _ (SCCFunSig {})) = notHandled ThSCCPragmas -rep_sig (L loc (CompleteMatchSig _ _st cls mty)) +rep_sig (L loc (CompleteMatchSig _ cls mty)) = rep_complete_sig cls mty (locA loc) +rep_sig d@(L _ (XSig {})) = pprPanic "rep_sig IdSig" (ppr d) -- Desugar the explicit type variable binders in an 'LHsSigType', making -- sure not to gensym them. diff --git a/compiler/GHC/HsToCore/Utils.hs b/compiler/GHC/HsToCore/Utils.hs index e3c6ef1333..083c59b3cf 100644 --- a/compiler/GHC/HsToCore/Utils.hs +++ b/compiler/GHC/HsToCore/Utils.hs @@ -66,7 +66,6 @@ import GHC.Core.PatSyn import GHC.Core.Type import GHC.Core.Coercion import GHC.Builtin.Types -import GHC.Types.Basic import GHC.Core.ConLike import GHC.Types.Unique.Set import GHC.Types.Unique.Supply diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs index dab2a7e7ad..c1465bf0bc 100644 --- a/compiler/GHC/Iface/Ext/Ast.hs +++ b/compiler/GHC/Iface/Ext/Ast.hs @@ -1698,7 +1698,6 @@ instance HiePass p => ToHie (SigContext (LocatedA (Sig (GhcPass p)))) where _ -> toHie $ map (C $ TyDecl) names , toHie $ TS (UnresolvedScope (map unLoc names) msp) typ ] - IdSig _ _ -> [] FixSig _ fsig -> [ toHie $ L sp fsig ] @@ -1709,21 +1708,22 @@ instance HiePass p => ToHie (SigContext (LocatedA (Sig (GhcPass p)))) where [ toHie $ (C Use) name , toHie $ map (TS (ResolvedScopes [])) typs ] - SpecInstSig _ _ typ -> + SpecInstSig _ typ -> [ toHie $ TS (ResolvedScopes []) typ ] - MinimalSig _ _ form -> + MinimalSig _ form -> [ toHie form ] - SCCFunSig _ _ name mtxt -> + SCCFunSig _ name mtxt -> [ toHie $ (C Use) name , maybe (pure []) (locOnly . getLocA) mtxt ] - CompleteMatchSig _ _ (L ispan names) typ -> + CompleteMatchSig _ (L ispan names) typ -> [ locOnly ispan , toHie $ map (C Use) names , toHie $ fmap (C Use) typ ] + XSig _ -> [] instance ToHie (TScoped (LocatedA (HsSigType GhcRn))) where toHie (TS tsc (L span t@HsSig{sig_bndrs=bndrs,sig_body=body})) = concatM $ makeNodeA t span : diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y index be897a1d14..2731c6abd2 100644 --- a/compiler/GHC/Parser.y +++ b/compiler/GHC/Parser.y @@ -2580,7 +2580,7 @@ sigdecl :: { LHsDecl GhcPs } {% 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))) } + (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 '#-}' @@ -2591,12 +2591,12 @@ sigdecl :: { LHsDecl GhcPs } {% 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))) } + {% 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))))) }} + ; 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 -> @@ -2611,11 +2611,11 @@ sigdecl :: { LHsDecl GhcPs } | '{-# 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)) } + $ 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)) } + {% 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 -}] diff --git a/compiler/GHC/Rename/Bind.hs b/compiler/GHC/Rename/Bind.hs index 70489c0048..5ade2db117 100644 --- a/compiler/GHC/Rename/Bind.hs +++ b/compiler/GHC/Rename/Bind.hs @@ -970,9 +970,6 @@ renameSigs ctxt sigs -- Doesn't seem worth much trouble to sort this. renameSig :: HsSigCtxt -> Sig GhcPs -> RnM (Sig GhcRn, FreeVars) -renameSig _ (IdSig _ x) - = return (IdSig noExtField x, emptyFVs) -- Actually this never occurs - renameSig ctxt sig@(TypeSig _ vs ty) = do { new_vs <- mapM (lookupSigOccRnN ctxt sig) vs ; let doc = TypeSigCtx (ppr_sig_bndrs vs) @@ -992,7 +989,7 @@ renameSig ctxt sig@(ClassOpSig _ is_deflt vs ty) ty_ctxt = GenericCtx (text "a class method signature for" <+> quotes (ppr v1)) -renameSig _ (SpecInstSig _ src ty) +renameSig _ (SpecInstSig (_, src) ty) = do { checkInferredVars doc inf_msg ty ; (new_ty, fvs) <- rnHsSigType doc TypeLevel ty -- Check if there are any nested `forall`s or contexts, which are @@ -1001,7 +998,7 @@ renameSig _ (SpecInstSig _ src ty) -- GHC.Hs.Type). ; addNoNestedForallsContextsErr doc (text "SPECIALISE instance type") (getLHsInstDeclHead new_ty) - ; return (SpecInstSig noAnn src new_ty,fvs) } + ; return (SpecInstSig (noAnn, src) new_ty,fvs) } where doc = SpecInstSigCtx inf_msg = Just (text "Inferred type variables are not allowed") @@ -1031,9 +1028,9 @@ renameSig ctxt (FixSig _ fsig) = do { new_fsig <- rnSrcFixityDecl ctxt fsig ; return (FixSig noAnn new_fsig, emptyFVs) } -renameSig ctxt sig@(MinimalSig _ s (L l bf)) +renameSig ctxt sig@(MinimalSig (_, s) (L l bf)) = do new_bf <- traverse (lookupSigOccRnN ctxt sig) bf - return (MinimalSig noAnn s (L l new_bf), emptyFVs) + return (MinimalSig (noAnn, s) (L l new_bf), emptyFVs) renameSig ctxt sig@(PatSynSig _ vs ty) = do { new_vs <- mapM (lookupSigOccRnN ctxt sig) vs @@ -1043,13 +1040,13 @@ renameSig ctxt sig@(PatSynSig _ vs ty) ty_ctxt = GenericCtx (text "a pattern synonym signature for" <+> ppr_sig_bndrs vs) -renameSig ctxt sig@(SCCFunSig _ st v s) +renameSig ctxt sig@(SCCFunSig (_, st) v s) = do { new_v <- lookupSigOccRnN ctxt sig v - ; return (SCCFunSig noAnn st new_v s, emptyFVs) } + ; return (SCCFunSig (noAnn, st) new_v s, emptyFVs) } -- COMPLETE Sigs can refer to imported IDs which is why we use -- lookupLocatedOccRn rather than lookupSigOccRn -renameSig _ctxt sig@(CompleteMatchSig _ s (L l bf) mty) +renameSig _ctxt sig@(CompleteMatchSig (_, s) (L l bf) mty) = do new_bf <- traverse lookupLocatedOccRn bf new_mty <- traverse lookupLocatedOccRn mty @@ -1058,7 +1055,7 @@ renameSig _ctxt sig@(CompleteMatchSig _ s (L l bf) mty) -- Why 'any'? See Note [Orphan COMPLETE pragmas] addErrCtxt (text "In" <+> ppr sig) $ failWithTc orphanError - return (CompleteMatchSig noAnn s (L l new_bf) new_mty, emptyFVs) + return (CompleteMatchSig (noAnn, s) (L l new_bf) new_mty, emptyFVs) where orphanError :: TcRnMessage orphanError = TcRnUnknownMessage $ mkPlainError noHints $ @@ -1108,10 +1105,6 @@ okHsSig ctxt (L _ sig) (FixSig {}, InstDeclCtxt {}) -> False (FixSig {}, _) -> True - (IdSig {}, TopSigCtxt {}) -> True - (IdSig {}, InstDeclCtxt {}) -> True - (IdSig {}, _) -> False - (InlineSig {}, HsBootCtxt {}) -> False (InlineSig {}, _) -> True @@ -1132,6 +1125,11 @@ okHsSig ctxt (L _ sig) (CompleteMatchSig {}, TopSigCtxt {} ) -> True (CompleteMatchSig {}, _) -> False + (XSig {}, TopSigCtxt {}) -> True + (XSig {}, InstDeclCtxt {}) -> True + (XSig {}, _) -> False + + ------------------- findDupSigs :: [LSig GhcPs] -> [NonEmpty (LocatedN RdrName, Sig GhcPs)] -- Check for duplicates on RdrName version, @@ -1151,7 +1149,7 @@ findDupSigs sigs expand_sig sig@(TypeSig _ ns _) = [(n,sig) | n <- ns] expand_sig sig@(ClassOpSig _ _ ns _) = [(n,sig) | n <- ns] expand_sig sig@(PatSynSig _ ns _ ) = [(n,sig) | n <- ns] - expand_sig sig@(SCCFunSig _ _ n _) = [(n,sig)] + expand_sig sig@(SCCFunSig (_, _) n _) = [(n,sig)] expand_sig _ = [] matching_sig :: (LocatedN RdrName, Sig GhcPs) -> (LocatedN RdrName, Sig GhcPs) -> Bool --AZ diff --git a/compiler/GHC/Rename/HsType.hs b/compiler/GHC/Rename/HsType.hs index bbcd5244af..eacfe233dc 100644 --- a/compiler/GHC/Rename/HsType.hs +++ b/compiler/GHC/Rename/HsType.hs @@ -71,7 +71,7 @@ import GHC.Types.Error import GHC.Utils.Misc import GHC.Types.Fixity ( compareFixity, negateFixity , Fixity(..), FixityDirection(..), LexicalFixity(..) ) -import GHC.Types.Basic ( PromotionFlag(..), isPromoted, TypeOrKind(..) ) +import GHC.Types.Basic ( TypeOrKind(..) ) import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Panic.Plain diff --git a/compiler/GHC/Tc/Gen/Bind.hs b/compiler/GHC/Tc/Gen/Bind.hs index 08c4ca664c..3db286e3e5 100644 --- a/compiler/GHC/Tc/Gen/Bind.hs +++ b/compiler/GHC/Tc/Gen/Bind.hs @@ -208,7 +208,7 @@ tcCompleteSigs sigs = -- combinations are invalid it will be found so at match sites. -- There it is also where we consider if the type of the pattern match is -- compatible with the result type constructor 'mb_tc'. - doOne (L loc c@(CompleteMatchSig _ext _src_txt (L _ ns) mb_tc_nm)) + doOne (L loc c@(CompleteMatchSig (_ext, _src_txt) (L _ ns) mb_tc_nm)) = fmap Just $ setSrcSpanA loc $ addErrCtxt (text "In" <+> ppr c) $ do cls <- mkUniqDSet <$> mapM (addLocMA tcLookupConLike) ns mb_tc <- traverse @Maybe tcLookupLocatedTyCon mb_tc_nm @@ -658,7 +658,7 @@ tcPolyCheck _prag_fn sig bind funBindTicks :: SrcSpan -> TcId -> Module -> [LSig GhcRn] -> TcM [CoreTickish] funBindTicks loc fun_id mod sigs - | (mb_cc_str : _) <- [ cc_name | L _ (SCCFunSig _ _ _ cc_name) <- sigs ] + | (mb_cc_str : _) <- [ cc_name | L _ (SCCFunSig _ _ cc_name) <- sigs ] -- this can only be a singleton list, as duplicate pragmas are rejected -- by the renamer , let cc_str diff --git a/compiler/GHC/Tc/Gen/Expr.hs b/compiler/GHC/Tc/Gen/Expr.hs index e26fee1f98..cb7f5cfb56 100644 --- a/compiler/GHC/Tc/Gen/Expr.hs +++ b/compiler/GHC/Tc/Gen/Expr.hs @@ -1376,7 +1376,7 @@ desugarRecordUpd record_expr rbnds res_ty upd_ids_lhs = [ (NonRecursive, unitBag $ genSimpleFunBind (idName id) [] rhs) | (_, (id, rhs)) <- upd_ids ] mk_idSig :: (Name, (Id, LHsExpr GhcRn)) -> LSig GhcRn - mk_idSig (_, (id, _)) = L gen $ IdSig noExtField id + mk_idSig (_, (id, _)) = L gen $ XSig $ IdSig id -- We let-bind variables using 'IdSig' in order to accept -- record updates involving higher-rank types. -- See Wrinkle [Using IdSig] in Note [Record Updates]. diff --git a/compiler/GHC/Tc/Gen/Sig.hs b/compiler/GHC/Tc/Gen/Sig.hs index 69e65ce2d1..ce5e3bd394 100644 --- a/compiler/GHC/Tc/Gen/Sig.hs +++ b/compiler/GHC/Tc/Gen/Sig.hs @@ -189,7 +189,7 @@ tcTySigs hs_sigs ; return (poly_ids, lookupNameEnv env) } tcTySig :: LSig GhcRn -> TcM [TcSigInfo] -tcTySig (L _ (IdSig _ id)) +tcTySig (L _ (XSig (IdSig id))) = do { let ctxt = FunSigCtxt (idName id) NoRRC -- NoRRC: do not report redundant constraints -- The user has no control over the signature! @@ -581,7 +581,7 @@ mkPragEnv sigs binds get_sig :: LSig GhcRn -> Maybe (Name, LSig GhcRn) get_sig sig@(L _ (SpecSig _ (L _ nm) _ _)) = Just (nm, add_arity nm sig) get_sig sig@(L _ (InlineSig _ (L _ nm) _)) = Just (nm, add_arity nm sig) - get_sig sig@(L _ (SCCFunSig _ _ (L _ nm) _)) = Just (nm, sig) + get_sig sig@(L _ (SCCFunSig _ (L _ nm) _)) = Just (nm, sig) get_sig _ = Nothing add_arity n sig -- Adjust inl_sat field to match visible arity of function diff --git a/compiler/GHC/Tc/Instance/Typeable.hs b/compiler/GHC/Tc/Instance/Typeable.hs index 3dc6154c84..f1a576dcbc 100644 --- a/compiler/GHC/Tc/Instance/Typeable.hs +++ b/compiler/GHC/Tc/Instance/Typeable.hs @@ -13,7 +13,7 @@ module GHC.Tc.Instance.Typeable(mkTypeableBinds, tyConIsTypeable) where import GHC.Prelude import GHC.Platform -import GHC.Types.Basic ( Boxity(..), neverInlinePragma ) +import GHC.Types.Basic ( neverInlinePragma ) import GHC.Types.SourceText ( SourceText(..) ) import GHC.Iface.Env( newGlobalBinder ) import GHC.Core.TyCo.Rep( Type(..), TyLit(..) ) diff --git a/compiler/GHC/Tc/TyCl/Class.hs b/compiler/GHC/Tc/TyCl/Class.hs index ee41b3e0aa..dee46e9189 100644 --- a/compiler/GHC/Tc/TyCl/Class.hs +++ b/compiler/GHC/Tc/TyCl/Class.hs @@ -403,7 +403,7 @@ findMinimalDef :: [LSig GhcRn] -> Maybe ClassMinimalDef findMinimalDef = firstJusts . map toMinimalDef where toMinimalDef :: LSig GhcRn -> Maybe ClassMinimalDef - toMinimalDef (L _ (MinimalSig _ _ (L _ bf))) = Just (fmap unLoc bf) + toMinimalDef (L _ (MinimalSig _ (L _ bf))) = Just (fmap unLoc bf) toMinimalDef _ = Nothing {- diff --git a/compiler/GHC/Tc/TyCl/Instance.hs b/compiler/GHC/Tc/TyCl/Instance.hs index 160d8ceae9..c99beb861e 100644 --- a/compiler/GHC/Tc/TyCl/Instance.hs +++ b/compiler/GHC/Tc/TyCl/Instance.hs @@ -2346,7 +2346,7 @@ tcSpecInstPrags dfun_id (InstBindings { ib_binds = binds, ib_pragmas = uprags }) ------------------------------ tcSpecInst :: Id -> Sig GhcRn -> TcM TcSpecPrag -tcSpecInst dfun_id prag@(SpecInstSig _ _ hs_ty) +tcSpecInst dfun_id prag@(SpecInstSig _ hs_ty) = addErrCtxt (spec_ctxt prag) $ do { spec_dfun_ty <- tcHsClsInstType SpecInstCtxt hs_ty ; co_fn <- tcSpecWrapper SpecInstCtxt (idType dfun_id) spec_dfun_ty diff --git a/compiler/GHC/Tc/TyCl/Utils.hs b/compiler/GHC/Tc/TyCl/Utils.hs index e102507d63..a77d6be317 100644 --- a/compiler/GHC/Tc/TyCl/Utils.hs +++ b/compiler/GHC/Tc/TyCl/Utils.hs @@ -853,14 +853,14 @@ when typechecking the [d| .. |] quote, and typecheck them later. tcRecSelBinds :: [(Id, LHsBind GhcRn)] -> TcM TcGblEnv tcRecSelBinds sel_bind_prs - = tcExtendGlobalValEnv [sel_id | (L _ (IdSig _ sel_id)) <- sigs] $ + = tcExtendGlobalValEnv [sel_id | (L _ (XSig (IdSig sel_id))) <- sigs] $ do { (rec_sel_binds, tcg_env) <- discardWarnings $ -- See Note [Impredicative record selectors] setXOptM LangExt.ImpredicativeTypes $ tcValBinds TopLevel binds sigs getGblEnv ; return (tcg_env `addTypecheckedBinds` map snd rec_sel_binds) } where - sigs = [ L (noAnnSrcSpan loc) (IdSig noExtField sel_id) + sigs = [ L (noAnnSrcSpan loc) (XSig $ IdSig sel_id) | (sel_id, _) <- sel_bind_prs , let loc = getSrcSpan sel_id ] binds = [(NonRecursive, unitBag bind) | (_, bind) <- sel_bind_prs] diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs index 441c84bad7..0432de43fa 100644 --- a/compiler/GHC/ThToHs.hs +++ b/compiler/GHC/ThToHs.hs @@ -857,7 +857,7 @@ cvtPragmaD (SpecialiseP nm ty inline phases) cvtPragmaD (SpecialiseInstP ty) = do { ty' <- cvtSigType ty ; returnJustLA $ Hs.SigD noExtField $ - SpecInstSig noAnn (SourceText "{-# SPECIALISE") ty' } + SpecInstSig (noAnn, (SourceText "{-# SPECIALISE")) ty' } cvtPragmaD (RuleP nm ty_bndrs tm_bndrs lhs rhs phases) = do { let nm' = mkFastString nm @@ -906,7 +906,7 @@ cvtPragmaD (CompleteP cls mty) = do { cls' <- wrapL $ mapM cNameN cls ; mty' <- traverse tconNameN mty ; returnJustLA $ Hs.SigD noExtField - $ CompleteMatchSig noAnn NoSourceText cls' mty' } + $ CompleteMatchSig (noAnn, NoSourceText) cls' mty' } dfltActivation :: TH.Inline -> Activation dfltActivation TH.NoInline = NeverActive diff --git a/compiler/GHC/Types/Basic.hs b/compiler/GHC/Types/Basic.hs index a2decc2ba4..d5eba8c4ad 100644 --- a/compiler/GHC/Types/Basic.hs +++ b/compiler/GHC/Types/Basic.hs @@ -122,6 +122,8 @@ import GHC.Types.SourceText import qualified GHC.LanguageExtensions as LangExt import Data.Data import qualified Data.Semigroup as Semi +import {-# SOURCE #-} Language.Haskell.Syntax.Type (PromotionFlag(..), isPromoted) +import Language.Haskell.Syntax.Basic (Boxity(..), isBoxed, ConTag) {- ************************************************************************ @@ -195,12 +197,6 @@ type FullArgCount = Int ************************************************************************ -} --- | A *one-index* constructor tag --- --- Type of the tags associated with each constructor possibility or superclass --- selector -type ConTag = Int - -- | A *zero-indexed* constructor tag type ConTagZ = Int @@ -401,16 +397,6 @@ unSwap IsSwapped f a b = f b a * * ********************************************************************* -} --- | Is a TyCon a promoted data constructor or just a normal type constructor? -data PromotionFlag - = NotPromoted - | IsPromoted - deriving ( Eq, Data ) - -isPromoted :: PromotionFlag -> Bool -isPromoted IsPromoted = True -isPromoted NotPromoted = False - instance Outputable PromotionFlag where ppr NotPromoted = text "NotPromoted" ppr IsPromoted = text "IsPromoted" @@ -498,15 +484,6 @@ instance Outputable TopLevelFlag where ************************************************************************ -} -data Boxity - = Boxed - | Unboxed - deriving( Eq, Data ) - -isBoxed :: Boxity -> Bool -isBoxed Boxed = True -isBoxed Unboxed = False - instance Outputable Boxity where ppr Boxed = text "Boxed" ppr Unboxed = text "Unboxed" diff --git a/compiler/Language/Haskell/Syntax/Basic.hs b/compiler/Language/Haskell/Syntax/Basic.hs new file mode 100644 index 0000000000..ad3e0e94ba --- /dev/null +++ b/compiler/Language/Haskell/Syntax/Basic.hs @@ -0,0 +1,45 @@ +{-# LANGUAGE DeriveDataTypeable #-} +module Language.Haskell.Syntax.Basic where + +import Data.Int (Int) + +import Data.Eq +import Data.Bool +import Data.Data + + +{- +************************************************************************ +* * +Boxity +* * +************************************************************************ +-} + +data Boxity + = Boxed + | Unboxed + deriving( Eq, Data ) + +isBoxed :: Boxity -> Bool +isBoxed Boxed = True +isBoxed Unboxed = False + +{- +************************************************************************ +* * +Counts and indices +* * +************************************************************************ +-} + +-- | The width of an unboxed sum +type SumWidth = Int + +-- | A *one-index* constructor tag +-- +-- Type of the tags associated with each constructor possibility or superclass +-- selector +type ConTag = Int + + diff --git a/compiler/Language/Haskell/Syntax/Binds.hs b/compiler/Language/Haskell/Syntax/Binds.hs index c50eb7e833..467304af53 100644 --- a/compiler/Language/Haskell/Syntax/Binds.hs +++ b/compiler/Language/Haskell/Syntax/Binds.hs @@ -21,8 +21,6 @@ Datatype for: @BindGroup@, @Bind@, @Sig@, @Bind@. -- See Note [Language.Haskell.Syntax.* Hierarchy] for why not GHC.Hs.* module Language.Haskell.Syntax.Binds where -import GHC.Prelude - import {-# SOURCE #-} Language.Haskell.Syntax.Expr ( LHsExpr , MatchGroup @@ -32,19 +30,18 @@ import {-# SOURCE #-} Language.Haskell.Syntax.Pat import Language.Haskell.Syntax.Extension import Language.Haskell.Syntax.Type -import GHC.Types.Name.Reader(RdrName) + import GHC.Types.Basic -import GHC.Types.SourceText import GHC.Types.Tickish -import GHC.Types.Var import GHC.Types.Fixity import GHC.Data.Bag -import GHC.Data.BooleanFormula (LBooleanFormula) -import GHC.Utils.Outputable -import GHC.Utils.Panic (pprPanic) +import GHC.Data.BooleanFormula (LBooleanFormula) +import GHC.Types.SourceText (StringLiteral) import Data.Void +import Data.Bool +import Data.Maybe {- ************************************************************************ @@ -372,13 +369,6 @@ data Sig pass -- 'GHC.Parser.Annotation.AnnDcolon' | ClassOpSig (XClassOpSig pass) Bool [LIdP pass] (LHsSigType pass) - -- | 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 just like a type - -- signature: there should be an accompanying binding - | IdSig (XIdSig pass) Id - -- | An ordinary fixity declaration -- -- > infixl 8 *** @@ -435,8 +425,7 @@ data Sig pass -- 'GHC.Parser.Annotation.AnnInstance','GHC.Parser.Annotation.AnnClose' -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation - | SpecInstSig (XSpecInstSig pass) SourceText (LHsSigType pass) - -- Note [Pragma source text] in GHC.Types.SourceText + | SpecInstSig (XSpecInstSig pass) (LHsSigType pass) -- | A minimal complete definition pragma -- @@ -447,9 +436,7 @@ data Sig pass -- 'GHC.Parser.Annotation.AnnClose' -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation - | MinimalSig (XMinimalSig pass) - SourceText (LBooleanFormula (LIdP pass)) - -- Note [Pragma source text] in GHC.Types.SourceText + | MinimalSig (XMinimalSig pass) (LBooleanFormula (LIdP pass)) -- | A "set cost centre" pragma for declarations -- @@ -460,7 +447,6 @@ data Sig pass -- > {-# SCC funName "cost_centre_name" #-} | SCCFunSig (XSCCFunSig pass) - SourceText -- Note [Pragma source text] in GHC.Types.SourceText (LIdP pass) -- Function name (Maybe (XRec pass StringLiteral)) -- | A complete match pragma @@ -471,7 +457,6 @@ data Sig pass -- complete matchings which, for example, arise from pattern -- synonym definitions. | CompleteMatchSig (XCompleteMatchSig pass) - SourceText (XRec pass [LIdP pass]) (Maybe (LIdP pass)) | XSig !(XXSig pass) @@ -490,7 +475,7 @@ isFixityLSig _ = False isTypeLSig :: forall p. UnXRec p => LSig p -> Bool -- Type signatures isTypeLSig (unXRec @p -> TypeSig {}) = True isTypeLSig (unXRec @p -> ClassOpSig {}) = True -isTypeLSig (unXRec @p -> IdSig {}) = True +isTypeLSig (unXRec @p -> XSig {}) = True isTypeLSig _ = False isSpecLSig :: forall p. UnXRec p => LSig p -> Bool @@ -526,36 +511,6 @@ isCompleteMatchSig :: forall p. UnXRec p => LSig p -> Bool isCompleteMatchSig (unXRec @p -> CompleteMatchSig {} ) = True isCompleteMatchSig _ = False -hsSigDoc :: Sig name -> SDoc -hsSigDoc (TypeSig {}) = text "type signature" -hsSigDoc (PatSynSig {}) = text "pattern synonym signature" -hsSigDoc (ClassOpSig _ is_deflt _ _) - | is_deflt = text "default type signature" - | otherwise = text "class method signature" -hsSigDoc (IdSig {}) = text "id signature" -hsSigDoc (SpecSig _ _ _ inl) = (inlinePragmaName . inl_inline $ inl) <+> text "pragma" -hsSigDoc (InlineSig _ _ prag) = (inlinePragmaName . inl_inline $ prag) <+> text "pragma" --- Using the 'inlinePragmaName' function ensures that the pragma name for any --- one of the INLINE/INLINABLE/NOINLINE pragmas are printed after being extracted --- from the InlineSpec field of the pragma. -hsSigDoc (SpecInstSig _ src _) = text (extractSpecPragName src) <+> text "instance pragma" -hsSigDoc (FixSig {}) = text "fixity declaration" -hsSigDoc (MinimalSig {}) = text "MINIMAL pragma" -hsSigDoc (SCCFunSig {}) = text "SCC pragma" -hsSigDoc (CompleteMatchSig {}) = text "COMPLETE pragma" -hsSigDoc (XSig {}) = text "XSIG TTG extension" - --- | Extracts the name for a SPECIALIZE instance pragma. In 'hsSigDoc', the src --- field of 'SpecInstSig' signature contains the SourceText for a SPECIALIZE --- instance pragma of the form: "SourceText {-# SPECIALIZE" --- --- Extraction ensures that all variants of the pragma name (with a 'Z' or an --- 'S') are output exactly as used in the pragma. -extractSpecPragName :: SourceText -> String -extractSpecPragName srcTxt = case (words $ show srcTxt) of - (_:_:pragName:_) -> filter (/= '\"') pragName - _ -> pprPanic "hsSigDoc: Misformed SPECIALISE instance pragma:" (ppr srcTxt) - {- ************************************************************************ * * @@ -605,9 +560,6 @@ when we have a different name for the local and top-level binder, making the distinction between the two names clear. -} -instance Outputable (XRec a RdrName) => Outputable (RecordPatSynField a) where - ppr (RecordPatSynField { recordPatSynField = v }) = ppr v - -- | Haskell Pattern Synonym Direction data HsPatSynDir id diff --git a/compiler/Language/Haskell/Syntax/Decls.hs b/compiler/Language/Haskell/Syntax/Decls.hs index da5265a144..0e0f0ff94c 100644 --- a/compiler/Language/Haskell/Syntax/Decls.hs +++ b/compiler/Language/Haskell/Syntax/Decls.hs @@ -100,11 +100,13 @@ import {-# SOURCE #-} Language.Haskell.Syntax.Expr import Language.Haskell.Syntax.Binds import Language.Haskell.Syntax.Type +import Language.Haskell.Syntax.Extension + import GHC.Hs.Doc -- ROMES:TODO Discuss in #21592 whether this is parsed AST or base AST + import GHC.Core.TyCon import GHC.Types.Basic import GHC.Types.ForeignCall -import Language.Haskell.Syntax.Extension import GHC.Types.Name.Set import GHC.Types.Fixity @@ -116,7 +118,7 @@ import GHC.Types.SourceText import GHC.Core.Type import GHC.Unit.Module.Warnings -import GHC.Data.Maybe +import Data.Maybe import Data.Data hiding (TyCon,Fixity, Infix) import Data.Void diff --git a/compiler/Language/Haskell/Syntax/Expr.hs b/compiler/Language/Haskell/Syntax/Expr.hs index 8d2a365a8c..6d57489eb5 100644 --- a/compiler/Language/Haskell/Syntax/Expr.hs +++ b/compiler/Language/Haskell/Syntax/Expr.hs @@ -25,6 +25,7 @@ module Language.Haskell.Syntax.Expr where import GHC.Prelude +import Language.Haskell.Syntax.Basic import Language.Haskell.Syntax.Decls import Language.Haskell.Syntax.Pat import Language.Haskell.Syntax.Lit @@ -35,7 +36,6 @@ import Language.Haskell.Syntax.Binds -- others: import GHC.Core.DataCon (FieldLabelString) import GHC.Types.Name -import GHC.Types.Basic import GHC.Types.Fixity import GHC.Types.SourceText import GHC.Types.SrcLoc @@ -437,8 +437,8 @@ data HsExpr p -- the expression, (arity - alternative) after it | ExplicitSum (XExplicitSum p) - ConTag -- Alternative (one-based) - Arity -- Sum arity + ConTag -- Alternative (one-based) + SumWidth -- Sum arity (LHsExpr p) -- | - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnCase', diff --git a/compiler/Language/Haskell/Syntax/Lit.hs b/compiler/Language/Haskell/Syntax/Lit.hs index 3000aa345c..a6f3e015b7 100644 --- a/compiler/Language/Haskell/Syntax/Lit.hs +++ b/compiler/Language/Haskell/Syntax/Lit.hs @@ -18,18 +18,21 @@ -- | Source-language literals module Language.Haskell.Syntax.Lit where -import GHC.Prelude +import Language.Haskell.Syntax.Extension -import GHC.Types.Basic (PprPrec(..), topPrec ) +import GHC.Utils.Panic import GHC.Types.SourceText import GHC.Core.Type -import GHC.Utils.Outputable -import GHC.Utils.Panic + import GHC.Data.FastString -import Language.Haskell.Syntax.Extension import Data.ByteString (ByteString) import Data.Data hiding ( Fixity ) +import Data.Bool +import Data.Ord +import Data.Eq +import Data.Char +import GHC.Integer (Integer) -- ROMES:TODO where is integer {- ************************************************************************ @@ -147,38 +150,3 @@ instance Ord OverLitVal where compare (HsIsString _ _) (HsIntegral _) = GT compare (HsIsString _ _) (HsFractional _) = GT -instance Outputable OverLitVal where - ppr (HsIntegral i) = pprWithSourceText (il_text i) (integer (il_value i)) - ppr (HsFractional f) = ppr f - ppr (HsIsString st s) = pprWithSourceText st (pprHsString s) - --- | @'hsLitNeedsParens' p l@ returns 'True' if a literal @l@ needs --- to be parenthesized under precedence @p@. -hsLitNeedsParens :: PprPrec -> HsLit x -> Bool -hsLitNeedsParens p = go - where - go (HsChar {}) = False - go (HsCharPrim {}) = False - go (HsString {}) = False - go (HsStringPrim {}) = False - go (HsInt _ x) = p > topPrec && il_neg x - go (HsIntPrim _ x) = p > topPrec && x < 0 - go (HsWordPrim {}) = False - go (HsInt64Prim _ x) = p > topPrec && x < 0 - go (HsWord64Prim {}) = False - go (HsInteger _ x _) = p > topPrec && x < 0 - go (HsRat _ x _) = p > topPrec && fl_neg x - go (HsFloatPrim _ x) = p > topPrec && fl_neg x - go (HsDoublePrim _ x) = p > topPrec && fl_neg x - go (XLit _) = False - --- | @'hsOverLitNeedsParens' p ol@ returns 'True' if an overloaded literal --- @ol@ needs to be parenthesized under precedence @p@. -hsOverLitNeedsParens :: PprPrec -> HsOverLit x -> Bool -hsOverLitNeedsParens p (OverLit { ol_val = olv }) = go olv - where - go :: OverLitVal -> Bool - go (HsIntegral x) = p > topPrec && il_neg x - go (HsFractional x) = p > topPrec && fl_neg x - go (HsIsString {}) = False -hsOverLitNeedsParens _ (XOverLit { }) = False diff --git a/compiler/Language/Haskell/Syntax/Pat.hs b/compiler/Language/Haskell/Syntax/Pat.hs index 12ef7ae98a..5846796de4 100644 --- a/compiler/Language/Haskell/Syntax/Pat.hs +++ b/compiler/Language/Haskell/Syntax/Pat.hs @@ -27,23 +27,27 @@ module Language.Haskell.Syntax.Pat ( HsRecFields(..), HsFieldBind(..), LHsFieldBind, HsRecField, LHsRecField, HsRecUpdField, LHsRecUpdField, + RecFieldsDotDot, hsRecFields, hsRecFieldSel, hsRecFieldsArgs, ) where -import GHC.Prelude - import {-# SOURCE #-} Language.Haskell.Syntax.Expr (SyntaxExpr, LHsExpr, HsUntypedSplice) -- friends: +import Language.Haskell.Syntax.Basic import Language.Haskell.Syntax.Lit import Language.Haskell.Syntax.Extension import Language.Haskell.Syntax.Type -import GHC.Types.Basic --- others: -import GHC.Core.Ppr ( {- instance OutputableBndr TyVar -} ) -import GHC.Utils.Outputable -import GHC.Types.SrcLoc + -- libraries: +import Data.Maybe +import Data.Functor +import Data.Foldable +import Data.Traversable +import Data.Bool +import Data.Int +import Data.Function +import Data.List type LPat p = XRec p (Pat p) @@ -132,7 +136,7 @@ data Pat p | SumPat (XSumPat p) -- after typechecker, types of the alternative (LPat p) -- Sum sub-pattern ConTag -- Alternative (one-based) - Arity -- Arity (INVARIANT: ≥ 2) + SumWidth -- Arity (INVARIANT: ≥ 2) -- ^ Anonymous sum pattern -- -- - 'GHC.Parser.Annotation.AnnKeywordId' : @@ -243,10 +247,12 @@ data HsRecFields p arg -- A bunch of record fields -- { x = 3, y = True } -- Used for both expressions and patterns = HsRecFields { rec_flds :: [LHsRecField p arg], - rec_dotdot :: Maybe (Located Int) } -- Note [DotDot fields] + rec_dotdot :: Maybe (XRec p RecFieldsDotDot) } -- Note [DotDot fields] -- AZ:The XRec for LHsRecField makes the derivings fail. -- deriving (Functor, Foldable, Traversable) +-- Type synonym to be able to have a specific XRec instance for the Int in `rec_dotdot` +type RecFieldsDotDot = Int -- Note [DotDot fields] -- ~~~~~~~~~~~~~~~~~~~~ @@ -353,29 +359,3 @@ hsRecFieldsArgs rbinds = map (hfbRHS . unXRec @p) (rec_flds rbinds) hsRecFieldSel :: forall p arg. UnXRec p => HsRecField p arg -> XCFieldOcc p hsRecFieldSel = foExt . unXRec @p . hfbLHS - -{- -************************************************************************ -* * -* Printing patterns -* * -************************************************************************ --} - -instance Outputable (HsPatSigType p) => Outputable (HsConPatTyArg p) where - ppr (HsConPatTyArg _ ty) = char '@' <> ppr ty - -instance (Outputable arg, Outputable (XRec p (HsRecField p arg))) - => Outputable (HsRecFields p arg) where - ppr (HsRecFields { rec_flds = flds, rec_dotdot = Nothing }) - = braces (fsep (punctuate comma (map ppr flds))) - ppr (HsRecFields { rec_flds = flds, rec_dotdot = Just (unLoc -> n) }) - = braces (fsep (punctuate comma (map ppr (take n flds) ++ [dotdot]))) - where - dotdot = text ".." <+> whenPprDebug (ppr (drop n flds)) - -instance (Outputable p, OutputableBndr p, Outputable arg) - => Outputable (HsFieldBind p arg) where - ppr (HsFieldBind { hfbLHS = f, hfbRHS = arg, - hfbPun = pun }) - = pprPrefixOcc f <+> (ppUnless pun $ equals <+> ppr arg) diff --git a/compiler/Language/Haskell/Syntax/Type.hs b/compiler/Language/Haskell/Syntax/Type.hs index e394628f25..9bd8aa90e2 100644 --- a/compiler/Language/Haskell/Syntax/Type.hs +++ b/compiler/Language/Haskell/Syntax/Type.hs @@ -30,18 +30,20 @@ module Language.Haskell.Syntax.Type ( LHsQTyVars(..), HsOuterTyVarBndrs(..), HsOuterFamEqnTyVarBndrs, HsOuterSigTyVarBndrs, HsWildCardBndrs(..), - HsPatSigType(..), HsPSRn(..), + HsPatSigType(..), HsSigType(..), LHsSigType, LHsSigWcType, LHsWcType, HsTupleSort(..), HsContext, LHsContext, HsTyLit(..), HsIPName(..), hsIPNameFS, - HsArg(..), numVisibleArgs, pprHsArgsApp, + HsArg(..), LHsTypeArg, LBangType, BangType, HsSrcBang(..), HsImplBang(..), SrcStrictness(..), SrcUnpackedness(..), + Boxity(..), PromotionFlag(..), + isBoxed, isPromoted, ConDeclField(..), LConDeclField, @@ -56,29 +58,47 @@ module Language.Haskell.Syntax.Type ( hsPatSigType, ) where -import GHC.Prelude - import {-# SOURCE #-} Language.Haskell.Syntax.Expr ( HsUntypedSplice ) import Language.Haskell.Syntax.Extension +import Language.Haskell.Syntax.Basic import GHC.Types.SourceText -import GHC.Types.Name( Name ) import GHC.Types.Name.Reader ( RdrName ) import GHC.Core.DataCon( HsSrcBang(..), HsImplBang(..), SrcStrictness(..), SrcUnpackedness(..) ) import GHC.Core.Type -import GHC.Hs.Doc -import GHC.Types.Basic -import GHC.Types.Fixity import GHC.Types.SrcLoc -import GHC.Utils.Outputable -import GHC.Data.FastString -import GHC.Utils.Misc ( count ) import GHC.Parser.Annotation +import GHC.Hs.Doc +import GHC.Data.FastString + import Data.Data hiding ( Fixity, Prefix, Infix ) import Data.Void +import Data.Maybe +import Data.Eq +import Data.Bool +import Data.Char +import GHC.Num (Integer) + +{- +************************************************************************ +* * +\subsection{Promotion flag} +* * +************************************************************************ +-} + +-- | Is a TyCon a promoted data constructor or just a normal type constructor? +data PromotionFlag + = NotPromoted + | IsPromoted + deriving ( Eq, Data ) + +isPromoted :: PromotionFlag -> Bool +isPromoted IsPromoted = True +isPromoted NotPromoted = False {- ************************************************************************ @@ -422,14 +442,6 @@ data HsPatSigType pass } | XHsPatSigType !(XXHsPatSigType pass) --- | The extension field for 'HsPatSigType', which is only used in the --- renamer onwards. See @Note [Pattern signature binders and scoping]@. -data HsPSRn = HsPSRn - { hsps_nwcs :: [Name] -- ^ Wildcard names - , hsps_imp_tvs :: [Name] -- ^ Implicitly bound variable names - } - deriving Data - -- | Located Haskell Signature Type type LHsSigType pass = XRec pass (HsSigType pass) -- Implicit only @@ -680,14 +692,6 @@ newtype HsIPName = HsIPName FastString hsIPNameFS :: HsIPName -> FastString hsIPNameFS (HsIPName n) = n -instance Outputable HsIPName where - ppr (HsIPName n) = char '?' <> ftext n -- Ordinary implicit parameters - -instance OutputableBndr HsIPName where - pprBndr _ n = ppr n -- Simple for now - pprInfixOcc n = ppr n - pprPrefixOcc n = ppr n - -------------------------------------------------- -- | Haskell Type Variable Binder @@ -1081,12 +1085,6 @@ data HsConDetails tyarg arg rec noTypeArgs :: [Void] noTypeArgs = [] -instance (Outputable tyarg, Outputable arg, Outputable rec) - => Outputable (HsConDetails tyarg arg rec) where - ppr (PrefixCon tyargs args) = text "PrefixCon:" <+> hsep (map (\t -> text "@" <> ppr t) tyargs) <+> ppr args - ppr (RecCon rec) = text "RecCon:" <+> ppr rec - ppr (InfixCon l r) = text "InfixCon:" <+> ppr [l, r] - {- Note [ConDeclField passs] ~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1203,64 +1201,9 @@ data HsArg tm ty -- SrcSpan is location of the `@` | HsArgPar SrcSpan -- See Note [HsArgPar] -numVisibleArgs :: [HsArg tm ty] -> Arity -numVisibleArgs = count is_vis - where is_vis (HsValArg _) = True - is_vis _ = False - -- type level equivalent type LHsTypeArg p = HsArg (LHsType p) (LHsKind p) --- | @'pprHsArgsApp' id fixity args@ pretty-prints an application of @id@ --- to @args@, using the @fixity@ to tell whether @id@ should be printed prefix --- or infix. Examples: --- --- @ --- pprHsArgsApp T Prefix [HsTypeArg Bool, HsValArg Int] = T \@Bool Int --- pprHsArgsApp T Prefix [HsTypeArg Bool, HsArgPar, HsValArg Int] = (T \@Bool) Int --- pprHsArgsApp (++) Infix [HsValArg Char, HsValArg Double] = Char ++ Double --- pprHsArgsApp (++) Infix [HsValArg Char, HsValArg Double, HsVarArg Ordering] = (Char ++ Double) Ordering --- @ -pprHsArgsApp :: (OutputableBndr id, Outputable tm, Outputable ty) - => id -> LexicalFixity -> [HsArg tm ty] -> SDoc -pprHsArgsApp thing fixity (argl:argr:args) - | Infix <- fixity - = let pp_op_app = hsep [ ppr_single_hs_arg argl - , pprInfixOcc thing - , ppr_single_hs_arg argr ] in - case args of - [] -> pp_op_app - _ -> ppr_hs_args_prefix_app (parens pp_op_app) args - -pprHsArgsApp thing _fixity args - = ppr_hs_args_prefix_app (pprPrefixOcc thing) args - --- | Pretty-print a prefix identifier to a list of 'HsArg's. -ppr_hs_args_prefix_app :: (Outputable tm, Outputable ty) - => SDoc -> [HsArg tm ty] -> SDoc -ppr_hs_args_prefix_app acc [] = acc -ppr_hs_args_prefix_app acc (arg:args) = - case arg of - HsValArg{} -> ppr_hs_args_prefix_app (acc <+> ppr_single_hs_arg arg) args - HsTypeArg{} -> ppr_hs_args_prefix_app (acc <+> ppr_single_hs_arg arg) args - HsArgPar{} -> ppr_hs_args_prefix_app (parens acc) args - --- | Pretty-print an 'HsArg' in isolation. -ppr_single_hs_arg :: (Outputable tm, Outputable ty) - => HsArg 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 --- allows this to be reachable, so don't fail here. -ppr_single_hs_arg (HsArgPar{}) = empty - --- | 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 tm ty) where - ppr (HsValArg tm) = text "HsValArg" <+> ppr tm - ppr (HsTypeArg sp ty) = text "HsTypeArg" <+> ppr sp <+> ppr ty - ppr (HsArgPar sp) = text "HsArgPar" <+> ppr sp {- Note [HsArgPar] ~~~~~~~~~~~~~~~ @@ -1276,8 +1219,6 @@ The SrcSpan is the span of the original HsPar -} --------------------------------- - {- ************************************************************************ @@ -1312,17 +1253,6 @@ deriving instance ( , Eq (XXFieldOcc pass) ) => Eq (FieldOcc pass) -instance Outputable (XRec pass RdrName) => Outputable (FieldOcc pass) where - ppr = ppr . foLabel - -instance (UnXRec pass, OutputableBndr (XRec pass RdrName)) => OutputableBndr (FieldOcc pass) where - pprInfixOcc = pprInfixOcc . unXRec @pass . foLabel - pprPrefixOcc = pprPrefixOcc . unXRec @pass . foLabel - -instance (UnXRec pass, OutputableBndr (XRec pass RdrName)) => OutputableBndr (GenLocated SrcSpan (FieldOcc pass)) where - pprInfixOcc = pprInfixOcc . unLoc - pprPrefixOcc = pprPrefixOcc . unLoc - -- | Located Ambiguous Field Occurence type LAmbiguousFieldOcc pass = XRec pass (AmbiguousFieldOcc pass) @@ -1350,11 +1280,3 @@ data AmbiguousFieldOcc pass * * ************************************************************************ -} - -instance Outputable HsTyLit where - ppr = ppr_tylit --------------------------- -ppr_tylit :: HsTyLit -> SDoc -ppr_tylit (HsNumTy source i) = pprWithSourceText source (integer i) -ppr_tylit (HsStrTy source s) = pprWithSourceText source (text (show s)) -ppr_tylit (HsCharTy source c) = pprWithSourceText source (text (show c)) diff --git a/compiler/Language/Haskell/Syntax/Type.hs-boot b/compiler/Language/Haskell/Syntax/Type.hs-boot new file mode 100644 index 0000000000..126355528a --- /dev/null +++ b/compiler/Language/Haskell/Syntax/Type.hs-boot @@ -0,0 +1,21 @@ +module Language.Haskell.Syntax.Type where + +import Data.Bool +import Data.Eq + +{- +************************************************************************ +* * +\subsection{Promotion flag} +* * +************************************************************************ +-} + +-- | Is a TyCon a promoted data constructor or just a normal type constructor? +data PromotionFlag + = NotPromoted + | IsPromoted + +instance Eq PromotionFlag + +isPromoted :: PromotionFlag -> Bool diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 92b70c9ff8..452b34cce6 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -799,6 +799,7 @@ Library GHC.Utils.Trace Language.Haskell.Syntax + Language.Haskell.Syntax.Basic Language.Haskell.Syntax.Binds Language.Haskell.Syntax.Decls Language.Haskell.Syntax.Expr |