[Git][ghc/ghc][wip/kirchner/ttg-zurich] TTG HsCmdArrForm: use GHC Fixity via extension point
Alan Zimmerman (@alanz)
gitlab at gitlab.haskell.org
Mon Jun 17 21:22:47 UTC 2024
Alan Zimmerman pushed to branch wip/kirchner/ttg-zurich at Glasgow Haskell Compiler / GHC
Commits:
80083341 by Alan Zimmerman at 2024-06-17T22:21:21+01:00
TTG HsCmdArrForm: use GHC Fixity via extension point
And simplify, stripping Fixity out of the Hs Syntax zone
- - - - -
19 changed files:
- compiler/GHC/Hs/Basic.hs
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Hs/Instances.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/Parser.y
- compiler/GHC/Rename/Bind.hs
- compiler/GHC/Rename/Expr.hs
- compiler/GHC/ThToHs.hs
- compiler/GHC/Types/Fixity.hs
- compiler/GHC/Types/Fixity/Env.hs
- compiler/Language/Haskell/Syntax/Basic.hs
- compiler/Language/Haskell/Syntax/Binds.hs
- compiler/Language/Haskell/Syntax/Decls.hs
- compiler/Language/Haskell/Syntax/Extension.hs
- testsuite/tests/parser/should_compile/T20846.stderr
- utils/check-exact/ExactPrint.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Hoogle.hs
- utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs
- utils/haddock/haddock-api/src/Haddock/Types.hs
Changes:
=====================================
compiler/GHC/Hs/Basic.hs
=====================================
@@ -8,52 +8,12 @@ module GHC.Hs.Basic
( module Language.Haskell.Syntax.Basic
) where
-import GHC.Prelude
-
-import GHC.Hs.Extension
-
import GHC.Utils.Outputable
-import GHC.Utils.Binary
import Data.Data ()
-import Language.Haskell.Syntax.Extension
import Language.Haskell.Syntax.Basic
-type instance XFixity (GhcPass _) = NoExtField
-type instance XXFixity (GhcPass _) = DataConCantHappen
-
-instance Outputable FixityDirection where
- ppr InfixL = text "infixl"
- ppr InfixR = text "infixr"
- ppr InfixN = text "infix"
-
-instance Binary FixityDirection where
- put_ bh InfixL =
- putByte bh 0
- put_ bh InfixR =
- putByte bh 1
- put_ bh InfixN =
- putByte bh 2
- get bh = do
- h <- getByte bh
- case h of
- 0 -> return InfixL
- 1 -> return InfixR
- _ -> return InfixN
-
instance Outputable LexicalFixity where
ppr Prefix = text "Prefix"
ppr Infix = text "Infix"
-
-instance Outputable (Fixity (GhcPass p)) where
- ppr (Fixity _ prec dir) = hcat [ppr dir, space, int prec]
-
-instance Binary (Fixity (GhcPass p)) where
- put_ bh (Fixity _src aa ab) = do
- put_ bh aa
- put_ bh ab
- get bh = do
- aa <- get bh
- ab <- get bh
- return (Fixity noExtField aa ab)
=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -32,6 +32,7 @@ import Language.Haskell.Syntax.Expr
-- friends:
import GHC.Prelude
+import GHC.Hs.Basic() -- import instances
import GHC.Hs.Decls() -- import instances
import GHC.Hs.Pat
import GHC.Hs.Lit
=====================================
compiler/GHC/Hs/Instances.hs
=====================================
@@ -33,7 +33,6 @@ import GHC.Hs.Type
import GHC.Hs.Pat
import GHC.Hs.ImpExp
import GHC.Parser.Annotation
-import Language.Haskell.Syntax.Basic (Fixity(..))
-- ---------------------------------------------------------------------
-- Data derivations from GHC.Hs-----------------------------------------
@@ -574,12 +573,6 @@ deriving instance Data XXExprGhcRn
-- ---------------------------------------------------------------------
-deriving instance Data (Fixity GhcPs)
-deriving instance Data (Fixity GhcRn)
-deriving instance Data (Fixity GhcTc)
-
--- ---------------------------------------------------------------------
-
deriving instance Data XXExprGhcTc
deriving instance Data XXPatGhcTc
=====================================
compiler/GHC/HsToCore/Quote.hs
=====================================
@@ -90,7 +90,6 @@ import Data.Kind (Constraint)
import qualified GHC.LanguageExtensions as LangExt
import Language.Haskell.Syntax.Basic (FieldLabelString(..))
-import qualified Language.Haskell.Syntax.Basic as H
import Data.ByteString ( unpack )
import Control.Monad
@@ -781,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 (H.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/Parser.y
=====================================
@@ -71,7 +71,7 @@ import GHC.Types.Name.Occurrence ( varName, dataName, tcClsName, tvName, occName
import GHC.Types.SrcLoc
import GHC.Types.Basic
import GHC.Types.Error ( GhcHint(..) )
-import GHC.Types.Fixity hiding (Fixity(..))
+import GHC.Types.Fixity
import GHC.Types.ForeignCall
import GHC.Types.SourceFile
import GHC.Types.SourceText
@@ -98,8 +98,6 @@ import GHC.Builtin.Types ( unitTyCon, unitDataCon, sumTyCon,
import Language.Haskell.Syntax.Basic (FieldLabelString(..))
import qualified Data.Semigroup as Semi
-
-import Language.Haskell.Syntax.Basic (Fixity(..))
}
%expect 0 -- shift/reduce conflicts
@@ -2682,7 +2680,7 @@ sigdecl :: { LHsDecl GhcPs }
Just l2 -> (fst $ unLoc l2, snd $ unLoc l2)
; amsA' (sLL $1 $> $ SigD noExtField
(FixSig (mj AnnInfix $1 : maybeToList mbPrecAnn, fixText) (FixitySig (unLoc $3) (fromOL $ unLoc $4)
- (Fixity noExtField fixPrec (unLoc $1)))))
+ (Fixity fixPrec (unLoc $1)))))
}}
| pattern_synonym_sig { L (getLoc $1) . SigD noExtField . unLoc $ $1 }
=====================================
compiler/GHC/Rename/Bind.hs
=====================================
@@ -52,7 +52,6 @@ import GHC.Driver.DynFlags
import GHC.Unit.Module
import GHC.Types.Error
import GHC.Types.FieldLabel
-import GHC.Types.Fixity
import GHC.Types.Name
import GHC.Types.Name.Env
import GHC.Types.Name.Set
@@ -72,7 +71,6 @@ import GHC.Data.OrdList
import qualified GHC.LanguageExtensions as LangExt
import Language.Haskell.Syntax.Basic (FieldLabelString(..))
-import qualified Language.Haskell.Syntax.Basic as H
import Control.Monad
import Data.List ( partition )
@@ -695,7 +693,7 @@ makeMiniFixityEnv decls = foldlM add_one_sig emptyMiniFixityEnv decls
where
add_one_sig :: MiniFixityEnv -> LFixitySig GhcPs -> RnM MiniFixityEnv
add_one_sig env (L loc (FixitySig ns_spec names fixity)) =
- foldlM add_one env [ (locA loc, locA name_loc, name, fixityFromSyntax fixity, ns_spec)
+ foldlM add_one env [ (locA loc,locA name_loc,name,fixity, ns_spec)
| L name_loc name <- names ]
add_one env (loc, name_loc, name, fixity, ns_spec) = do
@@ -1403,12 +1401,12 @@ rnSrcFixityDecl sig_ctxt = rn_decl
-- for con-like things; hence returning a list
-- If neither are in scope, report an error; otherwise
-- return a fixity sig for each (slightly odd)
- rn_decl sig@(FixitySig ns_spec fnames (H.Fixity x a b))
+ rn_decl sig@(FixitySig ns_spec fnames fixity)
= do unlessXOptM LangExt.ExplicitNamespaces $
when (ns_spec /= NoNamespaceSpecifier) $
addErr (TcRnNamespacedFixitySigWithoutFlag sig)
names <- concatMapM (lookup_one ns_spec) fnames
- return (FixitySig ns_spec names $ H.Fixity x a b)
+ return (FixitySig ns_spec names fixity)
lookup_one :: NamespaceSpecifier -> LocatedN RdrName -> RnM [LocatedN Name]
lookup_one ns_spec (L name_loc rdr_name)
=====================================
compiler/GHC/Rename/Expr.hs
=====================================
@@ -77,10 +77,10 @@ import qualified GHC.LanguageExtensions as LangExt
import Language.Haskell.Syntax.Basic (FieldLabelString(..))
-import Control.Arrow (first)
import Control.Monad
import Data.List (unzip4, minimumBy)
import Data.List.NonEmpty ( NonEmpty(..), nonEmpty )
+import Control.Arrow (first)
import Data.Ord
import Data.Array
import qualified Data.List.NonEmpty as NE
=====================================
compiler/GHC/ThToHs.hs
=====================================
@@ -64,7 +64,6 @@ import Foreign.ForeignPtr
import Foreign.Ptr
import System.IO.Unsafe
-import qualified Language.Haskell.Syntax.Basic as HSyn (Fixity(..))
-------------------------------------------------------------------
-- The external interface
@@ -1984,8 +1983,8 @@ cvtPatSynSigTy (ForallT univs reqs (ForallT exis provs ty))
cvtPatSynSigTy ty = cvtSigType ty
-----------------------------------------------------------
-cvtFixity :: TH.Fixity -> HSyn.Fixity (GhcPass p)
-cvtFixity (TH.Fixity prec dir) = HSyn.Fixity noExtField prec (cvt_dir dir)
+cvtFixity :: TH.Fixity -> Hs.Fixity
+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
=====================================
@@ -1,6 +1,3 @@
-{-# OPTIONS_GHC -Wno-orphans #-} -- Outputable, Binary, Eq
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DeriveDataTypeable #-}
-- | Fixity
@@ -14,36 +11,26 @@ module GHC.Types.Fixity
, negateFixity
, funTyFixity
, compareFixity
- , fixityFromSyntax
- , fixityToSyntax
)
where
import GHC.Prelude
-import GHC.Hs.Extension
-import qualified GHC.Hs.Basic as H
-
import GHC.Utils.Outputable
import GHC.Utils.Binary
-import Data.Data hiding (Fixity(..))
-
-import Language.Haskell.Syntax.Extension
-import Language.Haskell.Syntax.Basic (FixityDirection(..), LexicalFixity(..))
+import Data.Data hiding (Fixity, Prefix, Infix)
+import Language.Haskell.Syntax.Basic (LexicalFixity(..))
--- | Fixity used internally in GHC, so that we don't have to take `GhcPass p`
--- everywhere.
---
--- The Fixity defined in the AST is converted to this Fixity
---
--- See `fixityFromSyntax`
data Fixity = Fixity Int FixityDirection
- deriving (Eq, Data)
+ deriving Data
instance Outputable Fixity where
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
+
instance Binary Fixity where
put_ bh (Fixity aa ab) = do
put_ bh aa
@@ -53,6 +40,32 @@ instance Binary Fixity where
ab <- get bh
return (Fixity aa ab)
+------------------------
+data FixityDirection
+ = InfixL
+ | InfixR
+ | InfixN
+ deriving (Eq, Data)
+
+instance Outputable FixityDirection where
+ ppr InfixL = text "infixl"
+ ppr InfixR = text "infixr"
+ ppr InfixN = text "infix"
+
+instance Binary FixityDirection where
+ put_ bh InfixL =
+ putByte bh 0
+ put_ bh InfixR =
+ putByte bh 1
+ put_ bh InfixN =
+ putByte bh 2
+ get bh = do
+ h <- getByte bh
+ case h of
+ 0 -> return InfixL
+ 1 -> return InfixR
+ _ -> return InfixN
+
------------------------
maxPrecedence, minPrecedence :: Int
maxPrecedence = 9
@@ -91,9 +104,3 @@ compareFixity (Fixity prec1 dir1) (Fixity prec2 dir2)
right = (False, True)
left = (False, False)
error_please = (True, False)
-
-fixityFromSyntax :: H.Fixity (GhcPass p) -> Fixity
-fixityFromSyntax (H.Fixity _ i d) = Fixity i d
-
-fixityToSyntax :: Fixity -> H.Fixity (GhcPass p)
-fixityToSyntax (Fixity i d) = H.Fixity noExtField i d
=====================================
compiler/GHC/Types/Fixity/Env.hs
=====================================
@@ -1,5 +1,3 @@
-{-# LANGUAGE ExistentialQuantification #-}
-{-# LANGUAGE FlexibleInstances #-}
module GHC.Types.Fixity.Env
( FixityEnv
, FixItem (..)
@@ -33,7 +31,7 @@ emptyFixityEnv = emptyNameEnv
lookupFixity :: FixityEnv -> Name -> Fixity
lookupFixity env n = case lookupNameEnv env n of
- Just (FixItem _ (Fixity a b)) -> Fixity a b
+ Just (FixItem _ fix) -> fix
Nothing -> defaultFixity
-- | Creates cached lookup for the 'mi_fix_fn' field of 'ModIface'
@@ -45,4 +43,3 @@ mkIfaceFixCache pairs
emptyIfaceFixCache :: OccName -> Maybe Fixity
emptyIfaceFixCache _ = Nothing
-
=====================================
compiler/Language/Haskell/Syntax/Basic.hs
=====================================
@@ -2,8 +2,6 @@
{-# LANGUAGE GeneralisedNewtypeDeriving #-}
module Language.Haskell.Syntax.Basic where
-import Language.Haskell.Syntax.Extension
-
import Data.Data
import Data.Eq
import Data.Ord
@@ -99,23 +97,6 @@ data SrcUnpackedness = SrcUnpack -- ^ {-# UNPACK #-} specified
| NoSrcUnpack -- ^ no unpack pragma
deriving (Eq, Data)
-{-
-************************************************************************
-* *
-Fixity
-* *
-************************************************************************
--}
-
-data Fixity pass = Fixity (XFixity pass) Int FixityDirection
- | XFixity !(XXFixity pass)
-
-data FixityDirection
- = InfixL
- | InfixR
- | InfixN
- deriving (Eq, Data)
-
-- | Captures the fixity of declarations as they are parsed. This is not
-- necessarily the same as the fixity declaration, as the normal fixity may be
-- overridden using parens or backticks.
=====================================
compiler/Language/Haskell/Syntax/Binds.hs
=====================================
@@ -30,9 +30,9 @@ import {-# SOURCE #-} Language.Haskell.Syntax.Pat
( LPat )
import Language.Haskell.Syntax.Extension
-import Language.Haskell.Syntax.Basic (Fixity)
import Language.Haskell.Syntax.Type
+import GHC.Types.Fixity (Fixity)
import GHC.Data.Bag (Bag)
import GHC.Types.Basic (InlinePragma)
@@ -495,7 +495,7 @@ data Sig pass
type LFixitySig pass = XRec pass (FixitySig pass)
-- | Fixity Signature
-data FixitySig pass = FixitySig (XFixitySig pass) [LIdP pass] (Fixity pass)
+data FixitySig pass = FixitySig (XFixitySig pass) [LIdP pass] Fixity
| XFixitySig !(XXFixitySig pass)
isFixityLSig :: forall p. UnXRec p => LSig p -> Bool
=====================================
compiler/Language/Haskell/Syntax/Decls.hs
=====================================
@@ -97,11 +97,12 @@ import {-# SOURCE #-} Language.Haskell.Syntax.Expr
import Language.Haskell.Syntax.Binds
import Language.Haskell.Syntax.Extension
import Language.Haskell.Syntax.Type
-import Language.Haskell.Syntax.Basic (Role, LexicalFixity)
+import Language.Haskell.Syntax.Basic (Role)
import GHC.Types.Basic (TopLevelFlag, OverlapMode, RuleName, Activation
,TyConFlavour(..), TypeOrData(..))
import GHC.Types.ForeignCall (CType, CCallConv, Safety, Header, CLabelString, CCallTarget, CExportSpec)
+import GHC.Types.Fixity (LexicalFixity)
import GHC.Core.Type (Specificity)
import GHC.Unit.Module.Warnings (WarningTxt)
=====================================
compiler/Language/Haskell/Syntax/Extension.hs
=====================================
@@ -722,12 +722,6 @@ type family XXIEWrappedName p
--- =====================================================================
--- Type families for the type families in L.H.S.Basic
-
-type family XFixity x
-type family XXFixity x
-
-- =====================================================================
-- Misc
=====================================
testsuite/tests/parser/should_compile/T20846.stderr
=====================================
@@ -59,7 +59,6 @@
(Unqual
{OccName: ++++}))]
(Fixity
- (NoExtField)
(9)
(InfixR))))))
,(L
=====================================
utils/check-exact/ExactPrint.hs
=====================================
@@ -39,6 +39,7 @@ import qualified GHC.Data.BooleanFormula as BF
import GHC.Data.FastString
import GHC.TypeLits
import GHC.Types.Basic hiding (EP)
+import GHC.Types.Fixity
import GHC.Types.ForeignCall
import GHC.Types.Name.Reader
import GHC.Types.PkgQual
@@ -49,7 +50,7 @@ import GHC.Unit.Module.Warnings
import GHC.Utils.Misc
import GHC.Utils.Panic
-import Language.Haskell.Syntax.Basic (FieldLabelString(..), Fixity(..))
+import Language.Haskell.Syntax.Basic (FieldLabelString(..))
import Control.Monad (forM, when, unless)
import Control.Monad.Identity (Identity(..))
@@ -2760,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,src) (FixitySig x names (Fixity xf v fdir))) = do
+ exact (FixSig (an,src) (FixitySig x names (Fixity v fdir))) = do
let fixstr = case fdir of
InfixL -> "infixl"
InfixR -> "infixr"
@@ -2768,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,src) (FixitySig x names' (Fixity xf 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/haddock/haddock-api/src/Haddock/Backends/Hoogle.hs
=====================================
@@ -33,7 +33,6 @@ import GHC
import GHC.Core.InstEnv
import GHC.Driver.Ppr
import GHC.Plugins (TopLevelFlag (..))
-import GHC.Types.Fixity (fixityToSyntax)
import GHC.Types.SourceText
import GHC.Unit.State
import GHC.Utils.Outputable as Outputable
@@ -360,7 +359,7 @@ ppCtor
mkFunTy a b = noLocA (HsFunTy noExtField (HsUnrestrictedArrow noExtField) a b)
ppFixity :: DynFlags -> (Name, Fixity) -> [String]
-ppFixity dflags (name, fixity) = [out dflags ((FixitySig NoNamespaceSpecifier [noLocA name] (fixityToSyntax fixity)) :: FixitySig GhcRn)]
+ppFixity dflags (name, fixity) = [out dflags ((FixitySig NoNamespaceSpecifier [noLocA name] fixity) :: FixitySig GhcRn)]
---------------------------------------------------------------------
-- DOCUMENTATION
=====================================
utils/haddock/haddock-api/src/Haddock/Interface/Rename.hs
=====================================
@@ -23,14 +23,13 @@ import Data.Traversable (mapM)
import Haddock.Backends.Hoogle (ppExportD)
import Haddock.GhcUtils
-import Haddock.Types hiding (Fixity)
+import Haddock.Types
-import GHC hiding (Fixity, NoLink)
+import GHC hiding (NoLink)
import GHC.Builtin.Types (eqTyCon_RDR, tupleDataConName, tupleTyConName)
import GHC.Data.Bag (emptyBag)
import GHC.Types.Name
import GHC.Types.Name.Reader (RdrName (Exact))
-import Language.Haskell.Syntax.Basic (Fixity(..))
import Control.Applicative
import Control.DeepSeq (force)
@@ -764,9 +763,9 @@ renameSig sig = case sig of
lnames' <- mapM renameNameL lnames
sig_ty' <- renameLSigType sig_ty
return $ PatSynSig noExtField lnames' sig_ty'
- FixSig _ (FixitySig _ lnames (Fixity _ i d)) -> do
+ FixSig _ (FixitySig _ lnames fixity) -> do
lnames' <- mapM renameNameL lnames
- return $ FixSig noExtField (FixitySig noExtField lnames' (Fixity noExtField i d))
+ return $ FixSig noExtField (FixitySig noExtField lnames' fixity)
MinimalSig _ (L l s) -> do
s' <- traverse (traverse lookupRn) s
return $ MinimalSig noExtField (L l s')
=====================================
utils/haddock/haddock-api/src/Haddock/Types.hs
=====================================
@@ -880,14 +880,12 @@ type instance XXTyVarBndr DocNameI = DataConCantHappen
type instance XCFieldOcc DocNameI = DocName
type instance XXFieldOcc DocNameI = NoExtField
-type instance XFixity DocNameI = NoExtField
type instance XFixitySig DocNameI = NoExtField
type instance XFixSig DocNameI = NoExtField
type instance XPatSynSig DocNameI = NoExtField
type instance XClassOpSig DocNameI = NoExtField
type instance XTypeSig DocNameI = NoExtField
type instance XMinimalSig DocNameI = NoExtField
-type instance XXFixity DocNameI = DataConCantHappen
type instance XForeignExport DocNameI = NoExtField
type instance XForeignImport DocNameI = NoExtField
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8008334174728e39b4aacf21158a6dd7bf8f524e
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8008334174728e39b4aacf21158a6dd7bf8f524e
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/20240617/0fcf7f5d/attachment-0001.html>
More information about the ghc-commits
mailing list