[Git][ghc/ghc][wip/T23916] 2 commits: WIP
Alan Zimmerman (@alanz)
gitlab at gitlab.haskell.org
Sat Sep 23 14:49:31 UTC 2023
Alan Zimmerman pushed to branch wip/T23916 at Glasgow Haskell Compiler / GHC
Commits:
1d4f2ea7 by Alan Zimmerman at 2023-09-14T20:17:09+01:00
WIP
- - - - -
697b4eb6 by Alan Zimmerman at 2023-09-23T12:20:30+01:00
EPA: Move AnnLam to the same place for all LamAlt's
- - - - -
6 changed files:
- compiler/GHC/Parser.y
- compiler/GHC/Parser/PostProcess.hs
- testsuite/tests/printer/Ppr020.hs
- testsuite/tests/printer/PprArrowLambdaCase.hs
- utils/check-exact/ExactPrint.hs
- utils/check-exact/Main.hs
Changes:
=====================================
compiler/GHC/Parser.y
=====================================
@@ -2865,20 +2865,20 @@ aexp :: { ECP }
| PREFIX_MINUS aexp { ECP $
unECP $2 >>= \ $2 ->
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 }
| '\\' apats '->' exp
{ ECP $
unECP $4 >>= \ $4 ->
mkHsLamPV (comb2 $1 $>) (\cs -> mkMatchGroup FromSource
(sLLa $1 $>
[sLLa $1 $>
- $ Match { m_ext = EpAnn (glR $1) [mj AnnLam $1] cs
+ $ Match { m_ext = EpAnn (glR $1) [] cs
, m_ctxt = LamAlt LamSingle
, m_pats = $2
- , m_grhss = unguardedGRHSs (comb2 $3 $4) $4 (EpAnn (glR $3) (GrhsAnn Nothing (mu AnnRarrow $3)) emptyComments) }])) }
- | 'let' binds 'in' exp { ECP $
- unECP $4 >>= \ $4 ->
- mkHsLetPV (comb2 $1 $>) (hsTok $1) (unLoc $2) (hsTok $3) $4 }
+ , m_grhss = unguardedGRHSs (comb2 $3 $4) $4 (EpAnn (glR $3) (GrhsAnn Nothing (mu AnnRarrow $3)) emptyComments) }]))
+ [mj AnnLam $1] }
| '\\' 'lcase' altslist(pats1)
{ ECP $ $3 >>= \ $3 ->
mkHsLamCasePV (comb2 $1 $>) LamCase $3 [mj AnnLam $1,mj AnnCase $2] }
=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -1556,9 +1556,6 @@ class (b ~ (Body b) GhcPs, AnnoBody b) => DisambECP b where
ecpFromExp' :: LHsExpr GhcPs -> PV (LocatedA b)
mkHsProjUpdatePV :: SrcSpan -> Located [LocatedAn NoEpAnns (DotFieldOcc GhcPs)]
-> LocatedA b -> Bool -> [AddEpAnn] -> PV (LHsRecProj GhcPs (LocatedA b))
- -- | Disambiguate "\... -> ..." (lambda)
- mkHsLamPV
- :: SrcSpan -> (EpAnnComments -> MatchGroup GhcPs (LocatedA b)) -> PV (LocatedA b)
-- | Disambiguate "let ... in ..."
mkHsLetPV
:: SrcSpan
@@ -1579,6 +1576,9 @@ class (b ~ (Body b) GhcPs, AnnoBody b) => DisambECP b where
-- | Disambiguate "case ... of ..."
mkHsCasePV :: SrcSpan -> LHsExpr GhcPs -> (LocatedL [LMatch GhcPs (LocatedA b)])
-> EpAnnHsCase -> PV (LocatedA b)
+ -- | Disambiguate "\... -> ..." (lambda)
+ mkHsLamPV
+ :: SrcSpan -> (EpAnnComments -> MatchGroup GhcPs (LocatedA b)) -> [AddEpAnn] -> PV (LocatedA b)
-- | Disambiguate "\case" and "\cases"
mkHsLamCasePV :: SrcSpan -> HsLamVariant
-> (LocatedL [LMatch GhcPs (LocatedA b)]) -> [AddEpAnn]
@@ -1707,9 +1707,9 @@ instance DisambECP (HsCmd GhcPs) where
ecpFromExp' (L l e) = cmdFail (locA l) (ppr e)
mkHsProjUpdatePV l _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l $
PsErrOverloadedRecordDotInvalid
- mkHsLamPV l mg = do
+ mkHsLamPV l mg anns = do
cs <- getCommentsFor l
- return $ L (noAnnSrcSpan l) (HsCmdLam (EpAnn (spanAsAnchor l) [] cs) LamSingle (mg cs))
+ return $ L (noAnnSrcSpan l) (HsCmdLam (EpAnn (spanAsAnchor l) anns cs) LamSingle (mg cs))
mkHsLamCasePV l lam_variant (L lm m) anns = do
cs <- getCommentsFor l
@@ -1800,11 +1800,6 @@ instance DisambECP (HsExpr GhcPs) where
mkHsProjUpdatePV l fields arg isPun anns = do
cs <- getCommentsFor l
return $ mkRdrProjUpdate (noAnnSrcSpan l) fields arg isPun (EpAnn (spanAsAnchor l) anns cs)
- mkHsLamPV l mg = do
- cs <- getCommentsFor l
- let mg' = mg cs
- checkLamMatchGroup l mg'
- return $ L (noAnnSrcSpan l) (HsLam (EpAnn (spanAsAnchor l) [] cs) LamSingle mg')
mkHsLetPV l tkLet bs tkIn c = do
cs <- getCommentsFor l
return $ L (noAnnSrcSpan l) (HsLet (EpAnn (spanAsAnchor l) NoEpAnns cs) tkLet bs tkIn c)
@@ -1817,6 +1812,11 @@ instance DisambECP (HsExpr GhcPs) where
cs <- getCommentsFor l
let mg = mkMatchGroup FromSource (L lm m)
return $ L (noAnnSrcSpan l) (HsCase (EpAnn (spanAsAnchor l) anns cs) e mg)
+ mkHsLamPV l mg anns = do
+ cs <- getCommentsFor l
+ let mg' = mg cs
+ checkLamMatchGroup l mg'
+ return $ L (noAnnSrcSpan l) (HsLam (EpAnn (spanAsAnchor l) anns cs) LamSingle mg')
mkHsLamCasePV l lam_variant (L lm m) anns = do
cs <- getCommentsFor l
let mg = mkLamCaseMatchGroup FromSource lam_variant (L lm m)
@@ -1894,7 +1894,6 @@ instance DisambECP (PatBuilder GhcPs) where
type Body (PatBuilder GhcPs) = PatBuilder
ecpFromCmd' (L l c) = addFatalError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrArrowCmdInPat c
ecpFromExp' (L l e) = addFatalError $ mkPlainErrorMsgEnvelope (locA l) $ PsErrArrowExprInPat e
- mkHsLamPV l _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrLambdaInPat
mkHsLetPV l _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrLetInPat
mkHsProjUpdatePV l _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrOverloadedRecordDotInvalid
type InfixOp (PatBuilder GhcPs) = RdrName
@@ -1903,6 +1902,7 @@ instance DisambECP (PatBuilder GhcPs) where
cs <- getCommentsFor l
let anns = EpAnn (spanAsAnchor l) [] cs
return $ L (noAnnSrcSpan l) $ PatBuilderOpApp p1 op p2 anns
+ mkHsLamPV l _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrLambdaInPat
mkHsCasePV l _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrCaseInPat
mkHsLamCasePV l lam_variant _ _ = addFatalError $ mkPlainErrorMsgEnvelope l (PsErrLambdaCaseInPat lam_variant)
type FunArg (PatBuilder GhcPs) = PatBuilder GhcPs
=====================================
testsuite/tests/printer/Ppr020.hs
=====================================
@@ -17,3 +17,5 @@ foo = f >>= \cases
isAlarmSetSTM :: AlarmClock -> STM Bool
isAlarmSetSTM AlarmClock{..} = readTVar acNewSetting
>>= \case { AlarmNotSet -> readTVar acIsSet; _ -> return True }
+
+bar = g >>= \foo -> 10
=====================================
testsuite/tests/printer/PprArrowLambdaCase.hs
=====================================
@@ -24,3 +24,8 @@ foo = proc x ->
| otherwise -> returnA -< "small " ++ show x
_ Nothing -> returnA -< "none")
|) 1 x
+
+foo :: ArrowChoice p => p (Maybe Int) String
+foo = proc x ->
+ (| id \y -> returnA -< "big "
+ |) 1 x
=====================================
utils/check-exact/ExactPrint.hs
=====================================
@@ -2762,14 +2762,12 @@ instance ExactPrint (HsExpr GhcPs) where
lit' <- withPpr lit
return (HsLit an lit')
- -- ToDo: Do these two cases need to be handled separately?
- exact (HsLam an LamSingle mg) = do
- mg' <- markAnnotated mg
- return (HsLam an LamSingle mg')
exact (HsLam an lam_variant mg) = do
an0 <- markEpAnnL an lidl AnnLam
- an1 <- markEpAnnL an0 lidl (case lam_variant of LamCase -> AnnCase
- LamCases -> AnnCases)
+ an1 <- case lam_variant of
+ LamSingle -> return an0
+ LamCase -> markEpAnnL an0 lidl AnnCase
+ LamCases -> markEpAnnL an0 lidl AnnCases
mg' <- markAnnotated mg
return (HsLam an1 lam_variant mg')
@@ -3286,14 +3284,12 @@ instance ExactPrint (HsCmd GhcPs) where
e2' <- markAnnotated e2
return (HsCmdApp an e1' e2')
- exact (HsCmdLam a LamSingle match) = do
- match' <- markAnnotated match
- return (HsCmdLam a LamSingle match')
-
exact (HsCmdLam an lam_variant matches) = do
an0 <- markEpAnnL an lidl AnnLam
- an1 <- markEpAnnL an0 lidl (case lam_variant of LamCase -> AnnCase
- LamCases -> AnnCases)
+ an1 <- case lam_variant of
+ LamSingle -> return an0
+ LamCase -> markEpAnnL an0 lidl AnnCase
+ LamCases -> markEpAnnL an0 lidl AnnCases
matches' <- markAnnotated matches
return (HsCmdLam an1 lam_variant matches')
=====================================
utils/check-exact/Main.hs
=====================================
@@ -36,10 +36,10 @@ import GHC.Data.FastString
-- ---------------------------------------------------------------------
_tt :: IO ()
--- _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/master/_build/stage1/lib/"
+_tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/master/_build/stage1/lib/"
-- _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/ghc/_build/stage1/lib/"
-- _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/exactprint/_build/stage1/lib"
-_tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/epw/_build/stage1/lib"
+-- _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/epw/_build/stage1/lib"
-- "../../testsuite/tests/ghc-api/exactprint/RenameCase1.hs" (Just changeRenameCase1)
-- "../../testsuite/tests/ghc-api/exactprint/LayoutLet2.hs" (Just changeLayoutLet2)
@@ -108,7 +108,7 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/epw/_buil
-- "../../testsuite/tests/printer/Ppr017.hs" Nothing
-- "../../testsuite/tests/printer/Ppr018.hs" Nothing
-- "../../testsuite/tests/printer/Ppr019.hs" Nothing
- -- "../../testsuite/tests/printer/Ppr020.hs" Nothing
+ "../../testsuite/tests/printer/Ppr020.hs" Nothing
-- "../../testsuite/tests/printer/Ppr021.hs" Nothing
-- "../../testsuite/tests/printer/Ppr022.hs" Nothing
-- "../../testsuite/tests/printer/Ppr023.hs" Nothing
@@ -206,7 +206,7 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/epw/_buil
-- "../../testsuite/tests/printer/HsDocTy.hs" Nothing
-- "../../testsuite/tests/printer/Test22765.hs" Nothing
-- "../../testsuite/tests/printer/Test22771.hs" Nothing
- "../../testsuite/tests/printer/Test23465.hs" Nothing
+ -- "../../testsuite/tests/printer/Test23465.hs" Nothing
-- cloneT does not need a test, function can be retired
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f498a24e4abd751ca603741749dca1042c515dab...697b4eb6ee3d28a806ece79292503ae04ecdeb7b
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/f498a24e4abd751ca603741749dca1042c515dab...697b4eb6ee3d28a806ece79292503ae04ecdeb7b
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/20230923/9ce7dc5a/attachment-0001.html>
More information about the ghc-commits
mailing list