[Git][ghc/ghc][wip/T25281] More record selector elimination
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Thu Oct 3 13:54:47 UTC 2024
Simon Peyton Jones pushed to branch wip/T25281 at Glasgow Haskell Compiler / GHC
Commits:
487faf51 by Simon Peyton Jones at 2024-10-03T14:54:11+01:00
More record selector elimination
- - - - -
5 changed files:
- compiler/GHC/Hs/Decls.hs
- compiler/Language/Haskell/Syntax/Decls.hs
- utils/haddock/haddock-api/src/Haddock/Backends/Hoogle.hs
- utils/haddock/haddock-api/src/Haddock/GhcUtils.hs
- utils/haddock/haddock-api/src/Haddock/Interface/Create.hs
Changes:
=====================================
compiler/GHC/Hs/Decls.hs
=====================================
@@ -131,6 +131,7 @@ import GHC.Unit.Module.Warnings
import GHC.Data.Maybe
import Data.Data (Data)
+import Data.List (concatMap)
import Data.Foldable (toList)
{-
@@ -222,6 +223,21 @@ hsGroupTopLevelFixitySigs (HsGroup{ hs_fixds = fixds, hs_tyclds = tyclds }) =
, L loc (FixSig _ sig) <- sigs
]
+hsGroupInstDecls :: HsGroup (GhcPass p) -> [LInstDecl (GhcPass p)]
+hsGroupInstDecls = (=<<) group_instds . hs_tyclds
+
+tyClGroupTyClDecls :: [TyClGroup (GhcPass p)] -> [LTyClDecl (GhcPass p)]
+tyClGroupTyClDecls = Data.List.concatMap group_tyclds
+
+tyClGroupInstDecls :: [TyClGroup (GhcPass p)] -> [LInstDecl (GhcPass p)]
+tyClGroupInstDecls = Data.List.concatMap group_instds
+
+tyClGroupRoleDecls :: [TyClGroup (GhcPass p)] -> [LRoleAnnotDecl (GhcPass p)]
+tyClGroupRoleDecls = Data.List.concatMap group_roles
+
+tyClGroupKindSigs :: [TyClGroup (GhcPass p)] -> [LStandaloneKindSig (GhcPass p)]
+tyClGroupKindSigs = Data.List.concatMap group_kisigs
+
appendGroups :: HsGroup (GhcPass p) -> HsGroup (GhcPass p)
-> HsGroup (GhcPass p)
appendGroups
@@ -393,6 +409,10 @@ tyClDeclLName (SynDecl { tcdLName = ln }) = ln
tyClDeclLName (DataDecl { tcdLName = ln }) = ln
tyClDeclLName (ClassDecl { tcdLName = ln }) = ln
+tyClDeclTyVars :: TyClDecl (GhcPass p) -> LHsQTyVars (GhcPass p)
+tyClDeclTyVars (FamDecl { tcdFam = FamilyDecl { fdTyVars = tvs } }) = tvs
+tyClDeclTyVars d = tcdTyVars d
+
countTyClDecls :: [TyClDecl pass] -> (Int, Int, Int, Int, Int)
-- class, synonym decls, data, newtype, family decls
countTyClDecls decls
=====================================
compiler/Language/Haskell/Syntax/Decls.hs
=====================================
@@ -36,12 +36,9 @@ module Language.Haskell.Syntax.Decls (
-- ** Class or type declarations
TyClDecl(..), LTyClDecl,
TyClGroup(..),
- tyClGroupTyClDecls, tyClGroupInstDecls, tyClGroupRoleDecls,
- tyClGroupKindSigs,
isClassDecl, isDataDecl, isSynDecl,
isFamilyDecl, isTypeFamilyDecl, isDataFamilyDecl,
isOpenTypeFamilyInfo, isClosedTypeFamilyInfo,
- tyClDeclTyVars,
FamilyDecl(..), LFamilyDecl,
-- ** Instance declarations
@@ -86,7 +83,7 @@ module Language.Haskell.Syntax.Decls (
FamilyResultSig(..), LFamilyResultSig, InjectivityAnn(..), LInjectivityAnn,
-- * Grouping
- HsGroup(..), hsGroupInstDecls,
+ HsGroup(..)
) where
-- friends:
@@ -115,12 +112,10 @@ import Data.Data hiding (TyCon, Fixity, Infix)
import Data.Void
import Data.Maybe
import Data.String
-import Data.Function
import Data.Eq
import Data.Int
import Data.Bool
import Prelude (Show)
-import qualified Data.List
import Data.Foldable
import Data.Traversable
import Data.List.NonEmpty (NonEmpty (..))
@@ -240,9 +235,6 @@ data HsGroup p
| XHsGroup !(XXHsGroup p)
-hsGroupInstDecls :: HsGroup id -> [LInstDecl id]
-hsGroupInstDecls = (=<<) group_instds . hs_tyclds
-
-- | Located Splice Declaration
type LSpliceDecl pass = XRec pass (SpliceDecl pass)
@@ -567,11 +559,6 @@ isDataFamilyDecl _other = False
-- Dealing with names
-tyClDeclTyVars :: TyClDecl pass -> LHsQTyVars pass
-tyClDeclTyVars (FamDecl { tcdFam = FamilyDecl { fdTyVars = tvs } }) = tvs
-tyClDeclTyVars d = tcdTyVars d
-
-
{- Note [CUSKs: complete user-supplied kind signatures]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We kind-check declarations differently if they have a complete, user-supplied
@@ -702,19 +689,6 @@ data TyClGroup pass -- See Note [TyClGroups and dependency analysis]
| XTyClGroup !(XXTyClGroup pass)
-tyClGroupTyClDecls :: [TyClGroup pass] -> [LTyClDecl pass]
-tyClGroupTyClDecls = Data.List.concatMap group_tyclds
-
-tyClGroupInstDecls :: [TyClGroup pass] -> [LInstDecl pass]
-tyClGroupInstDecls = Data.List.concatMap group_instds
-
-tyClGroupRoleDecls :: [TyClGroup pass] -> [LRoleAnnotDecl pass]
-tyClGroupRoleDecls = Data.List.concatMap group_roles
-
-tyClGroupKindSigs :: [TyClGroup pass] -> [LStandaloneKindSig pass]
-tyClGroupKindSigs = Data.List.concatMap group_kisigs
-
-
{- *********************************************************************
* *
Data and type family declarations
=====================================
utils/haddock/haddock-api/src/Haddock/Backends/Hoogle.hs
=====================================
@@ -215,7 +215,7 @@ ppClass sDocContext decl@(ClassDecl{}) subdocs =
ppSig' = flip (ppSigWithDoc sDocContext) subdocs
- add_ctxt = addClassContext (tcdName decl) (tyClDeclTyVars decl)
+ add_ctxt = addClassContext (tcdName decl) (tyClDeclTyVarsI decl)
ppTyFams :: String
ppTyFams
@@ -331,7 +331,7 @@ ppCtor sDocContext dat subdocs con at ConDeclH98{con_args = con_args'} =
apps $
map reL $
(HsTyVar noAnn NotPromoted (reL (tcdName dat)))
- : map (tyVarArg . unLoc) (hsQTvExplicit $ tyClDeclTyVars dat)
+ : map (tyVarArg . unLoc) (hsQTvExplicit $ tyClDeclTyVarsI dat)
ppCtor
sDocContext
_dat
=====================================
utils/haddock/haddock-api/src/Haddock/GhcUtils.hs
=====================================
@@ -248,6 +248,10 @@ tyClDeclLNameI (SynDecl{tcdLName = ln}) = ln
tyClDeclLNameI (DataDecl{tcdLName = ln}) = ln
tyClDeclLNameI (ClassDecl{tcdLName = ln}) = ln
+tyClDeclTyVarsI :: TyClDecl DocNameI -> LHsQTyVars DocNameI
+tyClDeclTyVarsI (FamDecl { tcdFam = FamilyDecl { fdTyVars = tvs } }) = tvs
+tyClDeclTyVarsI d = tcdTyVars d
+
tcdNameI :: TyClDecl DocNameI -> DocName
tcdNameI = unLoc . tyClDeclLNameI
=====================================
utils/haddock/haddock-api/src/Haddock/Interface/Create.hs
=====================================
@@ -847,7 +847,7 @@ extractDecl prr dflags sDocContext name decl
-- TODO: document fixity
case (matchesMethod, matchesAssociatedType) of
([s0], _) ->
- let tyvar_names = tyClDeclTyVars d
+ let tyvar_names = tyClDeclTyVarsI d
L pos sig = addClassContext clsNm tyvar_names s0
in pure (Right $ L pos (SigD noExtField sig))
(_, [L pos fam_decl]) -> pure (Right $ L pos (TyClD noExtField (FamDecl noExtField fam_decl)))
@@ -881,7 +881,7 @@ extractDecl prr dflags sDocContext name decl
{ tcdLName = L _ dataNm
, tcdDataDefn = HsDataDefn{dd_cons = dataCons}
} -> pure $ do
- let ty_args = lHsQTyVarsToTypes (tyClDeclTyVars d)
+ let ty_args = lHsQTyVarsToTypes (tyClDeclTyVarsI d)
lsig <-
if isDataConName name
then extractPatternSyn name dataNm ty_args (toList dataCons)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/487faf515075969df88cde8c27354f3b305533ac
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/487faf515075969df88cde8c27354f3b305533ac
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/20241003/2fb3561b/attachment-0001.html>
More information about the ghc-commits
mailing list