[Git][ghc/ghc][wip/az/T12842-ttg-fixity] TTG: Move SourceText from `Fixity` to `FixitySig`
Alan Zimmerman (@alanz)
gitlab at gitlab.haskell.org
Sun Jun 16 22:01:06 UTC 2024
Alan Zimmerman pushed to branch wip/az/T12842-ttg-fixity at Glasgow Haskell Compiler / GHC
Commits:
bdae6b9e by Alan Zimmerman at 2024-06-16T23:00:44+01:00
TTG: Move SourceText from `Fixity` to `FixitySig`
It is only used there, simplifies the use of `Fixity` in the rest of
the code, and is moved into a TTG extension point.
Supersedes !12842
- - - - -
25 changed files:
- compiler/GHC/Builtin/PrimOps.hs
- compiler/GHC/Hs/Binds.hs
- compiler/GHC/Hs/Dump.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/Iface/Load.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Annotation.hs
- compiler/GHC/Rename/Expr.hs
- compiler/GHC/Rename/Fixity.hs
- compiler/GHC/Rename/HsType.hs
- compiler/GHC/Tc/Deriv/Generate.hs
- compiler/GHC/Tc/Deriv/Generics.hs
- compiler/GHC/Tc/Gen/Splice.hs
- compiler/GHC/ThToHs.hs
- compiler/GHC/Types/Fixity.hs
- testsuite/tests/parser/should_compile/T20846.stderr
- utils/check-exact/ExactPrint.hs
- utils/genprimopcode/Main.hs
- utils/genprimopcode/Parser.y
- utils/genprimopcode/Syntax.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
- utils/haddock/haddock-api/src/Haddock/Interface/Create.hs
- utils/haddock/haddock-api/src/Haddock/Interface/Json.hs
- utils/haddock/haddock-api/src/Haddock/InterfaceFile.hs
- utils/haddock/haddock-api/src/Haddock/Types.hs
Changes:
=====================================
compiler/GHC/Builtin/PrimOps.hs
=====================================
@@ -49,7 +49,6 @@ import GHC.Types.Basic
import GHC.Types.Fixity ( Fixity(..), FixityDirection(..) )
import GHC.Types.SrcLoc ( wiredInSrcSpan )
import GHC.Types.ForeignCall ( CLabelString )
-import GHC.Types.SourceText ( SourceText(..) )
import GHC.Types.Unique ( Unique )
import GHC.Unit.Types ( Unit )
=====================================
compiler/GHC/Hs/Binds.hs
=====================================
@@ -708,7 +708,7 @@ instance OutputableBndrId p => Outputable (IPBind (GhcPass p)) where
type instance XTypeSig (GhcPass p) = AnnSig
type instance XPatSynSig (GhcPass p) = AnnSig
type instance XClassOpSig (GhcPass p) = AnnSig
-type instance XFixSig (GhcPass p) = [AddEpAnn]
+type instance XFixSig (GhcPass p) = ([AddEpAnn], SourceText)
type instance XInlineSig (GhcPass p) = [AddEpAnn]
type instance XSpecSig (GhcPass p) = [AddEpAnn]
type instance XSpecInstSig (GhcPass p) = ([AddEpAnn], SourceText)
=====================================
compiler/GHC/Hs/Dump.hs
=====================================
@@ -74,7 +74,6 @@ showAstData bs ba a0 = blankLine $$ showAstData' a0
`extQ` name `extQ` occName `extQ` moduleName `extQ` var
`extQ` dataCon
`extQ` bagName `extQ` bagRdrName `extQ` bagVar `extQ` nameSet
- `extQ` fixity
`ext2Q` located
`extQ` srcSpanAnnA
`extQ` srcSpanAnnL
@@ -139,11 +138,12 @@ showAstData bs ba a0 = blankLine $$ showAstData' a0
, generic s ]
sourceText :: SourceText -> SDoc
- sourceText NoSourceText = parens $ text "NoSourceText"
+ sourceText NoSourceText = case bs of
+ BlankSrcSpan -> parens $ text "SourceText" <+> text "blanked"
+ _ -> parens $ text "NoSourceText"
sourceText (SourceText src) = case bs of
- NoBlankSrcSpan -> parens $ text "SourceText" <+> ftext src
- BlankSrcSpanFile -> parens $ text "SourceText" <+> ftext src
- _ -> parens $ text "SourceText" <+> text "blanked"
+ BlankSrcSpan -> parens $ text "SourceText" <+> text "blanked"
+ _ -> parens $ text "SourceText" <+> ftext src
epaAnchor :: EpaLocation -> SDoc
epaAnchor (EpaSpan s) = parens $ text "EpaSpan" <+> srcSpan s
@@ -216,11 +216,6 @@ showAstData bs ba a0 = blankLine $$ showAstData' a0
text "NameSet:"
$$ (list . nameSetElemsStable $ ns)
- fixity :: Fixity -> SDoc
- fixity fx = braces $
- text "Fixity:"
- <+> ppr fx
-
located :: (Data a, Data b) => GenLocated a b -> SDoc
located (L ss a)
= parens (text "L"
=====================================
compiler/GHC/HsToCore/Quote.hs
=====================================
@@ -780,7 +780,7 @@ repLFixD :: LFixitySig GhcRn -> MetaM [(SrcSpan, Core (M TH.Dec))]
repLFixD (L loc fix_sig) = rep_fix_d (locA loc) fix_sig
rep_fix_d :: SrcSpan -> FixitySig GhcRn -> MetaM [(SrcSpan, Core (M TH.Dec))]
-rep_fix_d loc (FixitySig ns_spec names (Fixity _ prec dir))
+rep_fix_d loc (FixitySig ns_spec names (Fixity prec dir))
= do { MkC prec' <- coreIntLit prec
; let rep_fn = case dir of
InfixL -> infixLWithSpecDName
=====================================
compiler/GHC/Iface/Load.hs
=====================================
@@ -90,7 +90,6 @@ import GHC.Types.Avail
import GHC.Types.Fixity
import GHC.Types.Fixity.Env
import GHC.Types.SourceError
-import GHC.Types.SourceText
import GHC.Types.SourceFile
import GHC.Types.SafeHaskell
import GHC.Types.TypeEnv
@@ -1030,7 +1029,7 @@ ghcPrimIface
-- The fixity listed here for @`seq`@ should match
-- those in primops.txt.pp (from which Haddock docs are generated).
- fixities = (getOccName seqId, Fixity NoSourceText 0 InfixR)
+ fixities = (getOccName seqId, Fixity 0 InfixR)
: mapMaybe mkFixity allThePrimOps
mkFixity op = (,) (primOpOcc op) <$> primOpFixity op
@@ -1235,5 +1234,3 @@ instance Outputable WhereFrom where
ppr (ImportByUser NotBoot) = empty
ppr ImportBySystem = text "{- SYSTEM -}"
ppr ImportByPlugin = text "{- PLUGIN -}"
-
-
=====================================
compiler/GHC/Parser.y
=====================================
@@ -2679,8 +2679,8 @@ sigdecl :: { LHsDecl GhcPs }
Nothing -> (NoSourceText, maxPrecedence)
Just l2 -> (fst $ unLoc l2, snd $ unLoc l2)
; amsA' (sLL $1 $> $ SigD noExtField
- (FixSig (mj AnnInfix $1 : maybeToList mbPrecAnn) (FixitySig (unLoc $3) (fromOL $ unLoc $4)
- (Fixity fixText fixPrec (unLoc $1)))))
+ (FixSig (mj AnnInfix $1 : maybeToList mbPrecAnn, fixText) (FixitySig (unLoc $3) (fromOL $ unLoc $4)
+ (Fixity fixPrec (unLoc $1)))))
}}
| pattern_synonym_sig { L (getLoc $1) . SigD noExtField . unLoc $ $1 }
=====================================
compiler/GHC/Parser/Annotation.hs
=====================================
@@ -111,6 +111,7 @@ import GHC.Hs.DocString
import GHC.Utils.Outputable hiding ( (<>) )
import GHC.Utils.Panic
import qualified GHC.Data.Strict as Strict
+import GHC.Types.SourceText (SourceText (NoSourceText))
{-
Note [exact print annotations]
@@ -1353,6 +1354,9 @@ instance NoAnn (EpToken s) where
instance NoAnn (EpUniToken s t) where
noAnn = NoEpUniTok
+instance NoAnn SourceText where
+ noAnn = NoSourceText
+
-- ---------------------------------------------------------------------
instance (Outputable a) => Outputable (EpAnn a) where
=====================================
compiler/GHC/Rename/Expr.hs
=====================================
@@ -411,7 +411,7 @@ rnExpr (OpApp _ e1 op e2)
; fixity <- case op' of
L _ (HsVar _ (L _ n)) -> lookupFixityRn n
L _ (HsRecSel _ f) -> lookupFieldFixityRn f
- _ -> return (Fixity NoSourceText minPrecedence InfixL)
+ _ -> return (Fixity minPrecedence InfixL)
-- c.f. lookupFixity for unbound
; lexical_negation <- xoptM LangExt.LexicalNegation
=====================================
compiler/GHC/Rename/Fixity.hs
=====================================
@@ -27,7 +27,6 @@ import GHC.Types.Fixity.Env
import GHC.Types.Name
import GHC.Types.Name.Env
import GHC.Types.Fixity
-import GHC.Types.SourceText
import GHC.Types.SrcLoc
import GHC.Utils.Outputable
@@ -147,7 +146,7 @@ lookupFixityRn_help :: Name
-> RnM (Bool, Fixity)
lookupFixityRn_help name
| isUnboundName name
- = return (False, Fixity NoSourceText minPrecedence InfixL)
+ = return (False, Fixity minPrecedence InfixL)
-- Minimise errors from unbound names; eg
-- a>0 `foo` b>0
-- where 'foo' is not in scope, should not give an error (#7937)
=====================================
compiler/GHC/Rename/HsType.hs
=====================================
@@ -1557,8 +1557,8 @@ checkPrecMatch op (MG { mg_alts = (L _ ms) })
checkPrec :: Name -> Pat GhcRn -> Bool -> IOEnv (Env TcGblEnv TcLclEnv) ()
checkPrec op (ConPat NoExtField op1 (InfixCon _ _)) right = do
- op_fix@(Fixity _ op_prec op_dir) <- lookupFixityRn op
- op1_fix@(Fixity _ op1_prec op1_dir) <- lookupFixityRn (unLoc op1)
+ op_fix@(Fixity op_prec op_dir) <- lookupFixityRn op
+ op1_fix@(Fixity op1_prec op1_dir) <- lookupFixityRn (unLoc op1)
let
inf_ok = op1_prec > op_prec ||
(op1_prec == op_prec &&
@@ -1586,8 +1586,8 @@ checkSectionPrec direction section op arg
_ -> return ()
where
op_name = get_op op
- go_for_it arg_op arg_fix@(Fixity _ arg_prec assoc) = do
- op_fix@(Fixity _ op_prec _) <- lookupFixityOp op_name
+ go_for_it arg_op arg_fix@(Fixity arg_prec assoc) = do
+ op_fix@(Fixity op_prec _) <- lookupFixityOp op_name
unless (op_prec < arg_prec
|| (op_prec == arg_prec && direction == assoc))
(sectionPrecErr (get_op op, op_fix)
=====================================
compiler/GHC/Tc/Deriv/Generate.hs
=====================================
@@ -1336,7 +1336,7 @@ appPrecedence = fromIntegral maxPrecedence + 1
getPrecedence :: (Name -> Fixity) -> Name -> Integer
getPrecedence get_fixity nm
= case get_fixity nm of
- Fixity _ x _assoc -> fromIntegral x
+ Fixity x _assoc -> fromIntegral x
-- NB: the Report says that associativity is not taken
-- into account for either Read or Show; hence we
-- ignore associativity here
=====================================
compiler/GHC/Tc/Deriv/Generics.hs
=====================================
@@ -654,9 +654,9 @@ tc_mkRepTy gk get_fixity dit@(DerivInstTys{ dit_rep_tc = tycon
ctFix c
| dataConIsInfix c
= case get_fixity (dataConName c) of
- Fixity _ n InfixL -> buildFix n pLA
- Fixity _ n InfixR -> buildFix n pRA
- Fixity _ n InfixN -> buildFix n pNA
+ Fixity n InfixL -> buildFix n pLA
+ Fixity n InfixR -> buildFix n pRA
+ Fixity n InfixN -> buildFix n pNA
| otherwise = mkTyConTy pPrefix
buildFix n assoc = mkTyConApp pInfix [ mkTyConTy assoc
, mkNumLitTy (fromIntegral n)]
=====================================
compiler/GHC/Tc/Gen/Splice.hs
=====================================
@@ -2814,7 +2814,7 @@ reifyFixity name
= do { (found, fix) <- lookupFixityRn_help name
; return (if found then Just (conv_fix fix) else Nothing) }
where
- conv_fix (Hs.Fixity _ i d) = TH.Fixity i (conv_dir d)
+ conv_fix (Hs.Fixity i d) = TH.Fixity i (conv_dir d)
conv_dir Hs.InfixR = TH.InfixR
conv_dir Hs.InfixL = TH.InfixL
conv_dir Hs.InfixN = TH.InfixN
=====================================
compiler/GHC/ThToHs.hs
=====================================
@@ -1984,7 +1984,7 @@ cvtPatSynSigTy ty = cvtSigType ty
-----------------------------------------------------------
cvtFixity :: TH.Fixity -> Hs.Fixity
-cvtFixity (TH.Fixity prec dir) = Hs.Fixity NoSourceText prec (cvt_dir dir)
+cvtFixity (TH.Fixity prec dir) = Hs.Fixity prec (cvt_dir dir)
where
cvt_dir TH.InfixL = Hs.InfixL
cvt_dir TH.InfixR = Hs.InfixR
=====================================
compiler/GHC/Types/Fixity.hs
=====================================
@@ -16,33 +16,28 @@ where
import GHC.Prelude
-import GHC.Types.SourceText
-
import GHC.Utils.Outputable
import GHC.Utils.Binary
import Data.Data hiding (Fixity, Prefix, Infix)
-data Fixity = Fixity SourceText Int FixityDirection
- -- Note [Pragma source text] in "GHC.Types.SourceText"
+data Fixity = Fixity Int FixityDirection
deriving Data
instance Outputable Fixity where
- ppr (Fixity _ prec dir) = hcat [ppr dir, space, int prec]
+ ppr (Fixity prec dir) = hcat [ppr dir, space, int prec]
instance Eq Fixity where -- Used to determine if two fixities conflict
- (Fixity _ p1 dir1) == (Fixity _ p2 dir2) = p1==p2 && dir1 == dir2
+ (Fixity p1 dir1) == (Fixity p2 dir2) = p1==p2 && dir1 == dir2
instance Binary Fixity where
- put_ bh (Fixity src aa ab) = do
- put_ bh src
+ put_ bh (Fixity aa ab) = do
put_ bh aa
put_ bh ab
get bh = do
- src <- get bh
aa <- get bh
ab <- get bh
- return (Fixity src aa ab)
+ return (Fixity aa ab)
------------------------
data FixityDirection
@@ -76,12 +71,12 @@ maxPrecedence = 9
minPrecedence = 0
defaultFixity :: Fixity
-defaultFixity = Fixity NoSourceText maxPrecedence InfixL
+defaultFixity = Fixity maxPrecedence InfixL
negateFixity, funTyFixity :: Fixity
-- Wired-in fixities
-negateFixity = Fixity NoSourceText 6 InfixL -- Fixity of unary negate
-funTyFixity = Fixity NoSourceText (-1) InfixR -- Fixity of '->', see #15235
+negateFixity = Fixity 6 InfixL -- Fixity of unary negate
+funTyFixity = Fixity (-1) InfixR -- Fixity of '->', see #15235
{-
Consider
@@ -96,7 +91,7 @@ whether there's an error.
compareFixity :: Fixity -> Fixity
-> (Bool, -- Error please
Bool) -- Associate to the right: a op1 (b op2 c)
-compareFixity (Fixity _ prec1 dir1) (Fixity _ prec2 dir2)
+compareFixity (Fixity prec1 dir1) (Fixity prec2 dir2)
= case prec1 `compare` prec2 of
GT -> left
LT -> right
=====================================
testsuite/tests/parser/should_compile/T20846.stderr
=====================================
@@ -44,7 +44,9 @@
(SigD
(NoExtField)
(FixSig
- [(AddEpAnn AnnInfix (EpaSpan { T20846.hs:3:1-6 }))]
+ ((,)
+ [(AddEpAnn AnnInfix (EpaSpan { T20846.hs:3:1-6 }))]
+ (NoSourceText))
(FixitySig
(NoNamespaceSpecifier)
[(L
@@ -56,7 +58,9 @@
[]))
(Unqual
{OccName: ++++}))]
- {Fixity: infixr 9}))))
+ (Fixity
+ (9)
+ (InfixR))))))
,(L
(EpAnn
(EpaSpan { T20846.hs:4:1-18 })
=====================================
utils/check-exact/ExactPrint.hs
=====================================
@@ -2761,7 +2761,7 @@ instance ExactPrint (Sig GhcPs) where
(an0, vars',ty') <- exactVarSig an vars ty
return (ClassOpSig an0 is_deflt vars' ty')
- exact (FixSig an (FixitySig x names (Fixity src v fdir))) = do
+ exact (FixSig (an,src) (FixitySig x names (Fixity v fdir))) = do
let fixstr = case fdir of
InfixL -> "infixl"
InfixR -> "infixr"
@@ -2769,7 +2769,7 @@ instance ExactPrint (Sig GhcPs) where
an0 <- markEpAnnLMS'' an lidl AnnInfix (Just fixstr)
an1 <- markEpAnnLMS'' an0 lidl AnnVal (Just (sourceTextToString src (show v)))
names' <- markAnnotated names
- return (FixSig an1 (FixitySig x names' (Fixity src v fdir)))
+ return (FixSig (an1,src) (FixitySig x names' (Fixity v fdir)))
exact (InlineSig an ln inl) = do
an0 <- markAnnOpen an (inl_src inl) "{-# INLINE"
=====================================
utils/genprimopcode/Main.hs
=====================================
@@ -364,7 +364,7 @@ gen_hs_source (Info defaults entries) =
prim_fixity options n
= [ pprFixityDir d ++ " " ++ show i ++ " " ++ asInfix n
- | OptionFixity (Just (Fixity _ i d)) <- options ]
+ | OptionFixity (Just (Fixity i d)) <- options ]
prim_func n t = [ wrapOp n ++ " :: " ++ pprTy t,
wrapOp n ++ " = " ++ funcRhs n ]
=====================================
utils/genprimopcode/Parser.y
=====================================
@@ -90,9 +90,9 @@ pOption : lowerName '=' false { OptionFalse $1 }
| can_fail_warning '=' pPrimOpCanFailWarnFlag { OptionCanFailWarnFlag $3 }
pInfix :: { Maybe Fixity }
-pInfix : infix integer { Just $ Fixity NoSourceText $2 InfixN }
- | infixl integer { Just $ Fixity NoSourceText $2 InfixL }
- | infixr integer { Just $ Fixity NoSourceText $2 InfixR }
+pInfix : infix integer { Just $ Fixity $2 InfixN }
+ | infixl integer { Just $ Fixity $2 InfixL }
+ | infixr integer { Just $ Fixity $2 InfixR }
| nothing { Nothing }
pEffect :: { PrimOpEffect }
=====================================
utils/genprimopcode/Syntax.hs
=====================================
@@ -101,16 +101,12 @@ instance Show TyCon where
-- The SourceText exists so that it matches the SourceText field in
-- BasicTypes.Fixity
-data Fixity = Fixity SourceText Int FixityDirection
+data Fixity = Fixity Int FixityDirection
deriving (Eq, Show)
data FixityDirection = InfixN | InfixL | InfixR
deriving (Eq, Show)
-data SourceText = SourceText String
- | NoSourceText
- deriving (Eq,Show)
-
data PrimOpEffect
= NoEffect
| CanFail
=====================================
utils/haddock/haddock-api/src/Haddock/Backends/Xhtml/Decl.hs
=====================================
@@ -372,7 +372,7 @@ ppFixities fs qual = foldr1 (+++) (map ppFix uniq_fs) +++ rightEdge
uniq_fs =
[ (n, the p, the d')
- | (n, Fixity _ p d) <- fs
+ | (n, Fixity p d) <- fs
, let d' = ppDir d
, then group by
Down (p, d')
=====================================
utils/haddock/haddock-api/src/Haddock/Interface/Create.hs
=====================================
@@ -57,7 +57,6 @@ import Data.Traversable (for)
import Control.Arrow (first, (&&&))
import GHC hiding (lookupName)
import GHC.Builtin.Names
-import GHC.Builtin.Types
import GHC.Builtin.Types.Prim
import GHC.Core.ConLike (ConLike (..))
import GHC.Data.FastString (FastString, bytesFS, unpackFS)
@@ -65,7 +64,6 @@ import GHC.Driver.Ppr
import GHC.HsToCore.Docs hiding (mkMaps)
import GHC.Iface.Syntax
import GHC.Types.Avail
-import GHC.Types.Basic
import GHC.Types.Name
import GHC.Types.Name.Set
import GHC.Types.SafeHaskell
=====================================
utils/haddock/haddock-api/src/Haddock/Interface/Json.hs
=====================================
@@ -241,7 +241,7 @@ jsonName :: Name -> JsonDoc
jsonName = JSString . nameStableString
jsonFixity :: Fixity -> JsonDoc
-jsonFixity (Fixity _ prec dir) =
+jsonFixity (Fixity prec dir) =
jsonObject
[ ("prec", jsonInt prec)
, ("direction", jsonFixityDirection dir)
=====================================
utils/haddock/haddock-api/src/Haddock/InterfaceFile.hs
=====================================
@@ -56,7 +56,7 @@ import GHC.Types.Unique.FM
import GHC.Unit.State
import GHC.Utils.Binary
-import GHC.Iface.Type (IfaceType, getIfaceType, putIfaceType)
+import GHC.Iface.Type (IfaceType, putIfaceType)
import Haddock.Options (Visibility (..))
=====================================
utils/haddock/haddock-api/src/Haddock/Types.hs
=====================================
@@ -978,8 +978,8 @@ instance NFData FixityDirection where
rnf InfixN = ()
instance NFData Fixity where
- rnf (Fixity sourceText n dir) =
- sourceText `deepseq` n `deepseq` dir `deepseq` ()
+ rnf (Fixity n dir) =
+ n `deepseq` dir `deepseq` ()
instance NFData (EpAnn NameAnn) where
rnf (EpAnn en ann cs) = en `deepseq` ann `deepseq` cs `deepseq` ()
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bdae6b9e457b43003ce8e645386ab19b6e1b88b2
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bdae6b9e457b43003ce8e645386ab19b6e1b88b2
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20240616/7e247e00/attachment-0001.html>
More information about the ghc-commits
mailing list