[Git][ghc/ghc][wip/az/epa-hslet-tokens] EPA: Introduce EpToken as simpler version of HsToken
Alan Zimmerman (@alanz)
gitlab at gitlab.haskell.org
Tue Dec 5 22:23:55 UTC 2023
Alan Zimmerman pushed to branch wip/az/epa-hslet-tokens at Glasgow Haskell Compiler / GHC
Commits:
41e67a62 by Alan Zimmerman at 2023-12-05T22:21:15+00:00
EPA: Introduce EpToken as simpler version of HsToken
This puts an EpaLocation inside, and does away with GenLocated.
Initially used only for HsCmdLet and HsLet
- - - - -
15 changed files:
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/HsToCore/Arrows.hs
- compiler/GHC/HsToCore/Ticks.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Parser.y
- compiler/GHC/Parser/Annotation.hs
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Rename/Expr.hs
- compiler/GHC/Tc/Gen/Arrow.hs
- compiler/GHC/Tc/Zonk/Type.hs
- compiler/Language/Haskell/Syntax/Expr.hs
- testsuite/tests/parser/should_compile/DumpSemis.stderr
- utils/check-exact/ExactPrint.hs
- utils/check-exact/Main.hs
- utils/check-exact/Transform.hs
Changes:
=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -75,7 +75,6 @@ import qualified Data.Kind
import Data.Maybe (isJust)
import Data.Foldable ( toList )
import Data.List.NonEmpty (NonEmpty)
-import Language.Haskell.Syntax.Concrete (LHsToken)
{- *********************************************************************
* *
@@ -290,7 +289,7 @@ type instance XMultiIf GhcPs = EpAnn [AddEpAnn]
type instance XMultiIf GhcRn = NoExtField
type instance XMultiIf GhcTc = Type
-type instance XLet GhcPs = (LHsToken "let" GhcPs, LHsToken "in" GhcPs)
+type instance XLet GhcPs = (EpToken "let", EpToken "in")
type instance XLet GhcRn = NoExtField
type instance XLet GhcTc = NoExtField
@@ -1135,7 +1134,7 @@ type instance XCmdIf GhcPs = EpAnn AnnsIf
type instance XCmdIf GhcRn = NoExtField
type instance XCmdIf GhcTc = NoExtField
-type instance XCmdLet GhcPs = EpAnnCO
+type instance XCmdLet GhcPs = (EpToken "let", EpToken "in")
type instance XCmdLet GhcRn = NoExtField
type instance XCmdLet GhcTc = NoExtField
@@ -1261,11 +1260,11 @@ ppr_cmd (HsCmdIf _ _ e ct ce)
nest 4 (ppr ce)]
-- special case: let ... in let ...
-ppr_cmd (HsCmdLet _ _ binds _ cmd@(L _ (HsCmdLet {})))
+ppr_cmd (HsCmdLet _ binds cmd@(L _ (HsCmdLet {})))
= sep [hang (text "let") 2 (hsep [pprBinds binds, text "in"]),
ppr_lcmd cmd]
-ppr_cmd (HsCmdLet _ _ binds _ cmd)
+ppr_cmd (HsCmdLet _ binds cmd)
= sep [hang (text "let") 2 (pprBinds binds),
hang (text "in") 2 (ppr cmd)]
=====================================
compiler/GHC/HsToCore/Arrows.hs
=====================================
@@ -591,7 +591,7 @@ dsCmd ids local_vars stack_ty res_ty
--
-- ---> premap (\ ((xs),stk) -> let binds in ((ys),stk)) c
-dsCmd ids local_vars stack_ty res_ty (HsCmdLet _ _ lbinds at binds _ body) env_ids = do
+dsCmd ids local_vars stack_ty res_ty (HsCmdLet _ lbinds at binds body) env_ids = do
let
defined_vars = mkVarSet (collectLocalBinders CollWithDictBinders binds)
local_vars' = defined_vars `unionVarSet` local_vars
=====================================
compiler/GHC/HsToCore/Ticks.hs
=====================================
@@ -836,11 +836,11 @@ addTickHsCmd (HsCmdIf x cnd e1 c2 c3) =
(addBinTickLHsExpr (BinBox CondBinBox) e1)
(addTickLHsCmd c2)
(addTickLHsCmd c3)
-addTickHsCmd (HsCmdLet x tkLet binds tkIn c) =
+addTickHsCmd (HsCmdLet x binds c) =
bindLocals (collectLocalBinders CollNoDictBinders binds) $ do
binds' <- addTickHsLocalBinds binds -- to think about: !patterns.
c' <- addTickLHsCmd c
- return (HsCmdLet x tkLet binds' tkIn c')
+ return (HsCmdLet x binds' c')
addTickHsCmd (HsCmdDo srcloc (L l stmts))
= do { (stmts', _) <- addTickLCmdStmts' stmts (return ())
; return (HsCmdDo srcloc (L l stmts')) }
=====================================
compiler/GHC/Iface/Ext/Ast.hs
=====================================
@@ -1512,7 +1512,7 @@ instance HiePass p => ToHie (LocatedA (HsCmd (GhcPass p))) where
, toHie b
, toHie c
]
- HsCmdLet _ _ binds _ cmd' ->
+ HsCmdLet _ binds cmd' ->
[ toHie $ RS (mkScope cmd') binds
, toHie cmd'
]
=====================================
compiler/GHC/Parser.y
=====================================
@@ -2869,7 +2869,7 @@ aexp :: { ECP }
mkHsNegAppPV (comb2 $1 $>) $2 [mj AnnMinus $1] }
| 'let' binds 'in' exp { ECP $
unECP $4 >>= \ $4 ->
- mkHsLetPV (comb2 $1 $>) (hsTok $1) (unLoc $2) (hsTok $3) $4 }
+ mkHsLetPV (comb2 $1 $>) (epTok $1) (unLoc $2) (epTok $3) $4 }
| '\\' apats '->' exp
{ ECP $
unECP $4 >>= \ $4 ->
@@ -4470,6 +4470,9 @@ listAsAnchorM (L l _:_) =
RealSrcSpan ll _ -> Just $ realSpanAsAnchor ll
_ -> Nothing
+epTok :: Located Token -> EpToken tok
+epTok (L l _) = EpTok (EpaSpan l)
+
hsTok :: Located Token -> LHsToken tok GhcPs
hsTok (L l _) = L (mkTokenLocation l) HsTok
=====================================
compiler/GHC/Parser/Annotation.hs
=====================================
@@ -1,11 +1,15 @@
-{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE StandaloneDeriving #-}
module GHC.Parser.Annotation (
-- * Core Exact Print Annotation types
AnnKeywordId(..),
+ EpToken(..), EpUniToken(..),
EpaComment(..), EpaCommentTok(..),
IsUnicodeSyntax(..),
unicodeAnn,
@@ -99,6 +103,7 @@ import Data.Function (on)
import Data.List (sortBy, foldl1')
import Data.Semigroup
import GHC.Data.FastString
+import GHC.TypeLits (Symbol, KnownSymbol)
import GHC.Types.Name
import GHC.Types.SrcLoc
import GHC.Hs.DocString
@@ -357,6 +362,21 @@ data HasE = HasE | NoE
-- ---------------------------------------------------------------------
+data EpToken (tok :: Symbol)
+ = NoEpTok
+ | EpTok !EpaLocation
+
+data EpUniToken (tok :: Symbol) (utok :: Symbol)
+ = NoEpUniTok
+ | EpNormalTok !EpaLocation
+ | EpUnicodeTok !EpaLocation
+
+deriving instance Eq (EpToken tok)
+deriving instance KnownSymbol tok => Data (EpToken tok)
+deriving instance (KnownSymbol tok, KnownSymbol utok) => Data (EpUniToken tok utok)
+
+-- ---------------------------------------------------------------------
+
data EpaComment =
EpaComment
{ ac_tok :: EpaCommentTok
@@ -1346,6 +1366,12 @@ instance NoAnn AnnParen where
instance NoAnn (GenLocated TokenLocation (HsToken s)) where
noAnn = L NoTokenLoc HsTok
+instance NoAnn (EpToken s) where
+ noAnn = NoEpTok
+
+instance NoAnn (EpUniToken s t) where
+ noAnn = NoEpUniTok
+
-- ---------------------------------------------------------------------
instance (Outputable a) => Outputable (EpAnn a) where
=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -1556,9 +1556,9 @@ class (b ~ (Body b) GhcPs, AnnoBody b) => DisambECP b where
-- | Disambiguate "let ... in ..."
mkHsLetPV
:: SrcSpan
- -> LHsToken "let" GhcPs
+ -> EpToken "let"
-> HsLocalBinds GhcPs
- -> LHsToken "in" GhcPs
+ -> EpToken "in"
-> LocatedA b
-> PV (LocatedA b)
-- | Infix operator representation
@@ -1708,7 +1708,7 @@ instance DisambECP (HsCmd GhcPs) where
mkHsLetPV l tkLet bs tkIn e = do
cs <- getCommentsFor l
- return $ L (noAnnSrcSpan l) (HsCmdLet (EpAnn (spanAsAnchor l) NoEpAnns cs) tkLet bs tkIn e)
+ return $ L (EpAnn (spanAsAnchor l) noAnn cs) (HsCmdLet (tkLet, tkIn) bs e)
type InfixOp (HsCmd GhcPs) = HsExpr GhcPs
=====================================
compiler/GHC/Rename/Expr.hs
=====================================
@@ -905,10 +905,10 @@ rnCmd (HsCmdIf _ _ p b1 b2)
; return (HsCmdIf noExtField ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2])}
-rnCmd (HsCmdLet _ tkLet binds tkIn cmd)
+rnCmd (HsCmdLet _ binds cmd)
= rnLocalBindsAndThen binds $ \ binds' _ -> do
{ (cmd',fvExpr) <- rnLCmd cmd
- ; return (HsCmdLet noExtField tkLet binds' tkIn cmd', fvExpr) }
+ ; return (HsCmdLet noExtField binds' cmd', fvExpr) }
rnCmd (HsCmdDo _ (L l stmts))
= do { ((stmts', _), fvs) <-
@@ -936,7 +936,7 @@ methodNamesCmd (HsCmdPar _ _ c _) = methodNamesLCmd c
methodNamesCmd (HsCmdIf _ _ _ c1 c2)
= methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName
-methodNamesCmd (HsCmdLet _ _ _ _ c) = methodNamesLCmd c
+methodNamesCmd (HsCmdLet _ _ c) = methodNamesLCmd c
methodNamesCmd (HsCmdDo _ (L _ stmts)) = methodNamesStmts stmts
methodNamesCmd (HsCmdApp _ c _) = methodNamesLCmd c
=====================================
compiler/GHC/Tc/Gen/Arrow.hs
=====================================
@@ -154,11 +154,11 @@ tc_cmd env (HsCmdPar x lpar cmd rpar) res_ty
= do { cmd' <- tcCmd env cmd res_ty
; return (HsCmdPar x lpar cmd' rpar) }
-tc_cmd env (HsCmdLet x tkLet binds tkIn (L body_loc body)) res_ty
+tc_cmd env (HsCmdLet x binds (L body_loc body)) res_ty
= do { (binds', body') <- tcLocalBinds binds $
setSrcSpan (locA body_loc) $
tc_cmd env body res_ty
- ; return (HsCmdLet x tkLet binds' tkIn (L body_loc body')) }
+ ; return (HsCmdLet x binds' (L body_loc body')) }
tc_cmd env in_cmd@(HsCmdCase x scrut matches) (stk, res_ty)
= addErrCtxt (cmdCtxt in_cmd) $ do
=====================================
compiler/GHC/Tc/Zonk/Type.hs
=====================================
@@ -1165,10 +1165,10 @@ zonkCmd (HsCmdIf x eCond ePred cThen cElse)
; new_cElse <- zonkLCmd cElse
; return (HsCmdIf x new_eCond new_ePred new_cThen new_cElse) }
-zonkCmd (HsCmdLet x tkLet binds tkIn cmd)
+zonkCmd (HsCmdLet x binds cmd)
= runZonkBndrT (zonkLocalBinds binds) $ \ new_binds ->
do new_cmd <- zonkLCmd cmd
- return (HsCmdLet x tkLet new_binds tkIn new_cmd)
+ return (HsCmdLet x new_binds new_cmd)
zonkCmd (HsCmdDo ty (L l stmts))
= do new_stmts <- don'tBind $ zonkStmts zonkLCmd stmts
=====================================
compiler/Language/Haskell/Syntax/Expr.hs
=====================================
@@ -889,9 +889,7 @@ data HsCmd id
-- For details on above see Note [exact print annotations] in GHC.Parser.Annotation
| HsCmdLet (XCmdLet id)
- !(LHsToken "let" id)
(HsLocalBinds id) -- let(rec)
- !(LHsToken "in" id)
(LHsCmd id)
-- ^ - 'GHC.Parser.Annotation.AnnKeywordId' : 'GHC.Parser.Annotation.AnnLet',
-- 'GHC.Parser.Annotation.AnnOpen' @'{'@,
=====================================
testsuite/tests/parser/should_compile/DumpSemis.stderr
=====================================
@@ -1952,14 +1952,10 @@
[]))
(HsLet
((,)
- (L
- (TokenLoc
- (EpaSpan { DumpSemis.hs:34:10-12 }))
- (HsTok))
- (L
- (TokenLoc
- (EpaSpan { DumpSemis.hs:34:32-33 }))
- (HsTok)))
+ (EpTok
+ (EpaSpan { DumpSemis.hs:34:10-12 }))
+ (EpTok
+ (EpaSpan { DumpSemis.hs:34:32-33 })))
(HsValBinds
(EpAnn
(EpaSpan { DumpSemis.hs:34:13-31 })
=====================================
utils/check-exact/ExactPrint.hs
=====================================
@@ -793,6 +793,13 @@ markLToken (L (RealSrcSpan aa mb) t) = do
_ -> return (L (RealSrcSpan aa mb ) t)
markLToken (L lt t) = return (L lt t)
+markEpToken :: forall m w tok . (Monad m, Monoid w, KnownSymbol tok)
+ => EpToken tok -> EP w m (EpToken tok)
+markEpToken NoEpTok = return NoEpTok
+markEpToken (EpTok aa) = do
+ aa' <- printStringAtAA aa (symbolVal (Proxy @tok))
+ return (EpTok aa')
+
markToken :: forall m w tok . (Monad m, Monoid w, KnownSymbol tok)
=> LHsToken tok GhcPs -> EP w m (LHsToken tok GhcPs)
markToken (L NoTokenLoc t) = return (L NoTokenLoc t)
@@ -3057,12 +3064,9 @@ instance ExactPrint (HsExpr GhcPs) where
exact (HsLet (tkLet, tkIn) binds e) = do
setLayoutBoth $ do -- Make sure the 'in' gets indented too
- tkLet' <- markToken tkLet
- debugM $ "HSlet:binds coming"
+ tkLet' <- markEpToken tkLet
binds' <- setLayoutBoth $ markAnnotated binds
- debugM $ "HSlet:binds done"
- tkIn' <- markToken tkIn
- debugM $ "HSlet:expr coming"
+ tkIn' <- markEpToken tkIn
e' <- markAnnotated e
return (HsLet (tkLet',tkIn') binds' e')
@@ -3427,7 +3431,7 @@ instance ExactPrint (HsCmd GhcPs) where
getAnnotationEntry (HsCmdCase an _ _) = fromAnn an
getAnnotationEntry (HsCmdLam an _ _) = fromAnn an
getAnnotationEntry (HsCmdIf an _ _ _ _) = fromAnn an
- getAnnotationEntry (HsCmdLet an _ _ _ _) = fromAnn an
+ getAnnotationEntry (HsCmdLet _ _ _) = NoEntryVal
getAnnotationEntry (HsCmdDo an _) = fromAnn an
setAnnotationAnchor (HsCmdArrApp an a b c d) anc ts cs = (HsCmdArrApp (setAnchorEpa an anc ts cs) a b c d)
@@ -3437,7 +3441,7 @@ instance ExactPrint (HsCmd GhcPs) where
setAnnotationAnchor (HsCmdPar an a b c) anc ts cs = (HsCmdPar (setAnchorEpa an anc ts cs) a b c)
setAnnotationAnchor (HsCmdCase an a b) anc ts cs = (HsCmdCase (setAnchorEpa an anc ts cs) a b)
setAnnotationAnchor (HsCmdIf an a b c d) anc ts cs = (HsCmdIf (setAnchorEpa an anc ts cs) a b c d)
- setAnnotationAnchor (HsCmdLet an a b c d) anc ts cs = (HsCmdLet (setAnchorEpa an anc ts cs) a b c d)
+ setAnnotationAnchor (HsCmdLet an a b) _ _ _s = (HsCmdLet an a b)
setAnnotationAnchor (HsCmdDo an a) anc ts cs = (HsCmdDo (setAnchorEpa an anc ts cs) a)
exact (HsCmdArrApp an arr arg o isRightToLeft) = do
@@ -3512,13 +3516,13 @@ instance ExactPrint (HsCmd GhcPs) where
e3' <- markAnnotated e3
return (HsCmdIf an4 a e1' e2' e3')
- exact (HsCmdLet an tkLet binds tkIn e) = do
+ exact (HsCmdLet (tkLet, tkIn) binds e) = do
setLayoutBoth $ do -- Make sure the 'in' gets indented too
- tkLet' <- markToken tkLet
+ tkLet' <- markEpToken tkLet
binds' <- setLayoutBoth $ markAnnotated binds
- tkIn' <- markToken tkIn
+ tkIn' <- markEpToken tkIn
e' <- markAnnotated e
- return (HsCmdLet an tkLet' binds' tkIn' e')
+ return (HsCmdLet (tkLet', tkIn') binds' e')
exact (HsCmdDo an es) = do
debugM $ "HsCmdDo"
=====================================
utils/check-exact/Main.hs
=====================================
@@ -452,7 +452,7 @@ changeLetIn1 _libdir parsed
(L _ e) = expr
a = EpAnn (EpaDelta (SameLine 1) []) noAnn emptyComments
expr' = L a e
- tkIn' = L (TokenLoc (EpaDelta (DifferentLine 1 0) [])) HsTok
+ tkIn' = EpTok (EpaDelta (DifferentLine 1 0) [])
in (HsLet (tkLet, tkIn')
(HsValBinds x (ValBinds xv bagDecls' sigs)) expr')
=====================================
utils/check-exact/Transform.hs
=====================================
@@ -884,7 +884,7 @@ instance HasDecls (LocatedA (HsExpr GhcPs)) where
let lastAnc = realSrcSpan $ spanHsLocaLBinds binds
-- TODO: may be an intervening comment, take account for lastAnc
let (tkLet', tkIn', ex',newDecls') = case (tkLet, tkIn) of
- (L (TokenLoc l) ls, L (TokenLoc i) is) ->
+ (EpTok l, EpTok i) ->
let
off = case l of
(EpaSpan (RealSrcSpan r _)) -> LayoutStartCol $ snd $ ss2pos r
@@ -895,8 +895,8 @@ instance HasDecls (LocatedA (HsExpr GhcPs)) where
newDecls'' = case newDecls of
[] -> newDecls
(d:ds) -> setEntryDPDecl d (SameLine 0) : ds
- in ( L (TokenLoc l) ls
- , L (TokenLoc (addEpaLocationDelta off lastAnc i)) is
+ in ( EpTok l
+ , EpTok (addEpaLocationDelta off lastAnc i)
, ex''
, newDecls'')
(_,_) -> (tkLet, tkIn, ex, newDecls)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/41e67a6217d2cb7790509612f821fedc803fcf63
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/41e67a6217d2cb7790509612f821fedc803fcf63
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/20231205/8904cffe/attachment-0001.html>
More information about the ghc-commits
mailing list