[Git][ghc/ghc][wip/az/epa-hasannotation-class] EPA: Introduce HasAnnotation class
Alan Zimmerman (@alanz)
gitlab at gitlab.haskell.org
Sun Oct 1 11:54:32 UTC 2023
Alan Zimmerman pushed to branch wip/az/epa-hasannotation-class at Glasgow Haskell Compiler / GHC
Commits:
db83b0c1 by Alan Zimmerman at 2023-10-01T12:54:10+01:00
EPA: Introduce HasAnnotation class
The class is defined as
class HasAnnotation e where
noAnnSrcSpan :: SrcSpan -> e
This generalises noAnnSrcSpan, and allows
noLocA :: (HasAnnotation e) => a -> GenLocated e a
noLocA = L (noAnnSrcSpan noSrcSpan)
- - - - -
9 changed files:
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Hs/Extension.hs
- compiler/GHC/Hs/Utils.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Annotation.hs
- compiler/GHC/Rename/Utils.hs
- compiler/GHC/ThToHs.hs
- utils/check-exact/Orphans.hs
- utils/check-exact/Utils.hs
Changes:
=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -2187,6 +2187,6 @@ type instance Anno FastString = SrcAnn NoEpAnns
type instance Anno (DotFieldOcc (GhcPass p)) = SrcAnn NoEpAnns
-instance (Anno a ~ SrcSpanAnn' (EpAnn an))
+instance (Anno a ~ SrcSpanAnn' (EpAnn an), NoAnn an)
=> WrapXRec (GhcPass p) a where
wrapXRec = noLocA
=====================================
compiler/GHC/Hs/Extension.hs
=====================================
@@ -108,6 +108,7 @@ type instance Anno Name = SrcSpanAnnN
type instance Anno Id = SrcSpanAnnN
type IsSrcSpanAnn p a = ( Anno (IdGhcP p) ~ SrcSpanAnn' (EpAnn a),
+ NoAnn a,
IsPass p)
instance UnXRec (GhcPass p) where
=====================================
compiler/GHC/Hs/Utils.hs
=====================================
@@ -232,7 +232,7 @@ mkLamCaseMatchGroup origin lam_variant (L l matches)
= mkMatchGroup origin (L l $ map fixCtxt matches)
where fixCtxt (L a match) = L a match{m_ctxt = LamAlt lam_variant}
-mkLocatedList :: Semigroup a
+mkLocatedList :: (Semigroup a, NoAnn an)
=> [GenLocated (SrcAnn a) e2] -> LocatedAn an [GenLocated (SrcAnn a) e2]
mkLocatedList ms = case nonEmpty ms of
Nothing -> noLocA []
=====================================
compiler/GHC/Parser.y
=====================================
@@ -4120,7 +4120,7 @@ sL1 :: HasLoc a => a -> b -> Located b
sL1 x = sL (getHasLoc x) -- #define sL1 sL (getLoc $1)
{-# INLINE sL1a #-}
-sL1a :: HasLoc a => a -> b -> LocatedAn t b
+sL1a :: (HasLoc a, HasAnnotation t) => a -> b -> GenLocated t b
sL1a x = sL (noAnnSrcSpan $ getHasLoc x) -- #define sL1 sL (getLoc $1)
{-# INLINE sL1n #-}
@@ -4132,7 +4132,7 @@ sLL :: (HasLoc a, HasLoc b) => a -> b -> c -> Located c
sLL x y = sL (comb2 x y) -- #define LL sL (comb2 $1 $>)
{-# INLINE sLLa #-}
-sLLa :: (HasLoc a, HasLoc b) => a -> b -> c -> LocatedAn t c
+sLLa :: (HasLoc a, HasLoc b, NoAnn t) => a -> b -> c -> LocatedAn t c
sLLa x y = sL (noAnnSrcSpan $ comb2 x y) -- #define LL sL (comb2 $1 $>)
{-# INLINE sLLl #-}
=====================================
compiler/GHC/Parser/Annotation.hs
=====================================
@@ -75,9 +75,10 @@ module GHC.Parser.Annotation (
-- ** Constructing 'GenLocated' annotation types when we do not care
-- about annotations.
- noLocA, getLocA,
+ HasAnnotation(..),
+ noLocA,
+ getLocA,
noSrcSpanA,
- noAnnSrcSpan,
-- ** Working with comments in annotations
noComments, comment, addCommentsToSrcAnn, setCommentsSrcAnn,
@@ -994,15 +995,15 @@ la2na l = noAnnSrcSpan (locA l)
-- |Helper function (temporary) during transition of names
-- Discards any annotations
-la2la :: LocatedAn ann1 a2 -> LocatedAn ann2 a2
+la2la :: (NoAnn ann2) => LocatedAn ann1 a2 -> LocatedAn ann2 a2
la2la (L la a) = L (noAnnSrcSpan (locA la)) a
l2l :: SrcSpanAnn' a -> SrcAnn ann
-l2l l = noAnnSrcSpan (locA l)
+l2l l = SrcSpanAnn EpAnnNotUsed (locA l)
-- |Helper function (temporary) during transition of names
-- Discards any annotations
-na2la :: SrcSpanAnn' a -> SrcAnn ann
+na2la :: (NoAnn ann) => SrcSpanAnn' a -> SrcAnn ann
na2la l = noAnnSrcSpan (locA l)
reLoc :: LocatedAn a e -> Located e
@@ -1022,18 +1023,21 @@ reLocN (L (SrcSpanAnn _ l) a) = L l a
-- ---------------------------------------------------------------------
-noLocA :: a -> LocatedAn an a
-noLocA = L (SrcSpanAnn EpAnnNotUsed noSrcSpan)
+class HasAnnotation e where
+ noAnnSrcSpan :: SrcSpan -> e
+
+instance (NoAnn ann) => HasAnnotation (SrcSpanAnn' (EpAnn ann)) where
+ noAnnSrcSpan l = SrcSpanAnn EpAnnNotUsed l
+
+noLocA :: (HasAnnotation e) => a -> GenLocated e a
+noLocA = L (noAnnSrcSpan noSrcSpan)
getLocA :: GenLocated (SrcSpanAnn' a) e -> SrcSpan
getLocA = getHasLoc
-noSrcSpanA :: SrcAnn ann
+noSrcSpanA :: (HasAnnotation e) => e
noSrcSpanA = noAnnSrcSpan noSrcSpan
-noAnnSrcSpan :: SrcSpan -> SrcAnn ann
-noAnnSrcSpan l = SrcSpanAnn EpAnnNotUsed l
-
-- ---------------------------------------------------------------------
class NoAnn a where
@@ -1163,7 +1167,7 @@ epAnnComments (EpAnn _ _ cs) = cs
sortLocatedA :: [GenLocated (SrcSpanAnn' a) e] -> [GenLocated (SrcSpanAnn' a) e]
sortLocatedA = sortBy (leftmost_smallest `on` getLocA)
-mapLocA :: (a -> b) -> GenLocated SrcSpan a -> GenLocated (SrcAnn ann) b
+mapLocA :: (NoAnn ann) => (a -> b) -> GenLocated SrcSpan a -> GenLocated (SrcAnn ann) b
mapLocA f (L l a) = L (noAnnSrcSpan l) (f a)
-- AZ:TODO: move this somewhere sane
@@ -1179,10 +1183,14 @@ combineSrcSpansA (SrcSpanAnn aa la) (SrcSpanAnn ab lb)
SrcSpanAnn (EpAnn (widenAnchorR anc (realSrcSpan l)) an cs) l
-- | Combine locations from two 'Located' things and add them to a third thing
-addCLocA :: GenLocated (SrcSpanAnn' a) e1 -> GenLocated SrcSpan e2 -> e3 -> GenLocated (SrcAnn ann) e3
+addCLocA :: (NoAnn ann)
+ => GenLocated (SrcSpanAnn' a) e1 -> GenLocated SrcSpan e2 -> e3
+ -> GenLocated (SrcAnn ann) e3
addCLocA a b c = L (noAnnSrcSpan $ combineSrcSpans (locA $ getLoc a) (getLoc b)) c
-addCLocAA :: GenLocated (SrcSpanAnn' a1) e1 -> GenLocated (SrcSpanAnn' a2) e2 -> e3 -> GenLocated (SrcAnn ann) e3
+addCLocAA :: (NoAnn ann)
+ => GenLocated (SrcSpanAnn' a1) e1 -> GenLocated (SrcSpanAnn' a2) e2 -> e3
+ -> GenLocated (SrcAnn ann) e3
addCLocAA a b c = L (noAnnSrcSpan $ combineSrcSpans (locA $ getLoc a) (locA $ getLoc b)) c
-- ---------------------------------------------------------------------
@@ -1332,26 +1340,33 @@ instance Semigroup EpAnnComments where
EpaCommentsBalanced cs1 as1 <> EpaCommentsBalanced cs2 as2 = EpaCommentsBalanced (cs1 ++ cs2) (as1++as2)
-instance NoAnn NoEpAnns where
- noAnn = NoEpAnns
-
instance Semigroup AnnListItem where
(AnnListItem l1) <> (AnnListItem l2) = AnnListItem (l1 <> l2)
-instance NoAnn AnnListItem where
- noAnn = AnnListItem []
-
-
instance Semigroup (AnnSortKey tag) where
NoAnnSortKey <> x = x
x <> NoAnnSortKey = x
AnnSortKey ls1 <> AnnSortKey ls2 = AnnSortKey (ls1 <> ls2)
+instance Monoid (AnnSortKey tag) where
+ mempty = NoAnnSortKey
+
+-- ---------------------------------------------------------------------
+-- NoAnn instances
+
+instance NoAnn NoEpAnns where
+ noAnn = NoEpAnns
+
+instance NoAnn AnnListItem where
+ noAnn = AnnListItem []
+
+instance NoAnn AnnContext where
+ noAnn = AnnContext Nothing [] []
+
instance NoAnn AnnList where
noAnn = AnnList Nothing Nothing Nothing [] []
-instance Monoid (AnnSortKey tag) where
- mempty = NoAnnSortKey
+-- ---------------------------------------------------------------------
instance NoAnn NameAnn where
noAnn = NameAnnTrailing []
=====================================
compiler/GHC/Rename/Utils.hs
=====================================
@@ -714,7 +714,7 @@ checkCTupSize tup_size
* *
********************************************************************* -}
-wrapGenSpan :: a -> LocatedAn an a
+wrapGenSpan :: (NoAnn an) => a -> LocatedAn an a
-- Wrap something in a "generatedSrcSpan"
-- See Note [Rebindable syntax and HsExpansion]
wrapGenSpan x = L (noAnnSrcSpan generatedSrcSpan) x
@@ -742,10 +742,10 @@ genHsVar nm = HsVar noExtField $ wrapGenSpan nm
genAppType :: HsExpr GhcRn -> HsType (NoGhcTc GhcRn) -> HsExpr GhcRn
genAppType expr ty = HsAppType noExtField (wrapGenSpan expr) noHsTok (mkEmptyWildCardBndrs (wrapGenSpan ty))
-genLHsLit :: HsLit GhcRn -> LocatedAn an (HsExpr GhcRn)
+genLHsLit :: (NoAnn an) => HsLit GhcRn -> LocatedAn an (HsExpr GhcRn)
genLHsLit = wrapGenSpan . HsLit noAnn
-genHsIntegralLit :: IntegralLit -> LocatedAn an (HsExpr GhcRn)
+genHsIntegralLit :: (NoAnn an) => IntegralLit -> LocatedAn an (HsExpr GhcRn)
genHsIntegralLit = genLHsLit . HsInt noExtField
genHsTyLit :: FastString -> HsType GhcRn
@@ -767,11 +767,15 @@ genWildPat = wrapGenSpan $ WildPat noExtField
genSimpleFunBind :: Name -> [LPat GhcRn]
-> LHsExpr GhcRn -> LHsBind GhcRn
genSimpleFunBind fun pats expr
- = L gen $ genFunBind (L gen fun)
- [mkMatch (mkPrefixFunRhs (L gen fun)) pats expr
+ = L genA $ genFunBind (L genN fun)
+ [mkMatch (mkPrefixFunRhs (L genN fun)) pats expr
emptyLocalBinds]
where
- gen = noAnnSrcSpan generatedSrcSpan
+ genA :: SrcSpanAnnA
+ genA = noAnnSrcSpan generatedSrcSpan
+
+ genN :: SrcSpanAnnN
+ genN = noAnnSrcSpan generatedSrcSpan
genFunBind :: LocatedN Name -> [LMatch GhcRn (LHsExpr GhcRn)]
-> HsBind GhcRn
=====================================
compiler/GHC/ThToHs.hs
=====================================
@@ -142,13 +142,13 @@ getL = CvtM (\_ loc -> Right (loc,loc))
setL :: SrcSpan -> CvtM ()
setL loc = CvtM (\_ _ -> Right (loc, ()))
-returnLA :: e -> CvtM (LocatedAn ann e)
+returnLA :: (NoAnn ann) => e -> CvtM (LocatedAn ann e)
returnLA x = CvtM (\_ loc -> Right (loc, L (noAnnSrcSpan loc) x))
returnJustLA :: a -> CvtM (Maybe (LocatedA a))
returnJustLA = fmap Just . returnLA
-wrapParLA :: (LocatedAn ann a -> b) -> a -> CvtM b
+wrapParLA :: (NoAnn ann) => (LocatedAn ann a -> b) -> a -> CvtM b
wrapParLA add_par x = CvtM (\_ loc -> Right (loc, add_par (L (noAnnSrcSpan loc) x)))
wrapMsg :: ThingBeingConverted -> CvtM' ConversionFailReason a -> CvtM' RunSpliceFailReason a
=====================================
utils/check-exact/Orphans.hs
=====================================
@@ -62,9 +62,6 @@ instance NoAnn AddEpAnn where
instance NoAnn AnnKeywordId where
noAnn = Annlarrowtail {- gotta pick one -}
-instance NoAnn AnnContext where
- noAnn = AnnContext Nothing [] []
-
instance NoAnn EpAnnSumPat where
noAnn = EpAnnSumPat noAnn noAnn noAnn
=====================================
utils/check-exact/Utils.hs
=====================================
@@ -371,9 +371,9 @@ setAnchorHsModule hsmod anc cs = hsmod { hsmodExt = (hsmodExt hsmod) {hsmodAnn =
-- |Version of l2l that preserves the anchor, immportant if it has an
-- updated AnchorOperation
-moveAnchor :: Monoid b => SrcAnn a -> SrcAnn b
+moveAnchor :: NoAnn b => SrcAnn a -> SrcAnn b
moveAnchor (SrcSpanAnn EpAnnNotUsed l) = noAnnSrcSpan l
-moveAnchor (SrcSpanAnn (EpAnn anc _ cs) l) = SrcSpanAnn (EpAnn anc mempty cs) l
+moveAnchor (SrcSpanAnn (EpAnn anc _ cs) l) = SrcSpanAnn (EpAnn anc noAnn cs) l
-- ---------------------------------------------------------------------
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/db83b0c157f5b5c3de6262504cbe58fdec4ff84e
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/db83b0c157f5b5c3de6262504cbe58fdec4ff84e
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/20231001/73c8d513/attachment-0001.html>
More information about the ghc-commits
mailing list