[Git][ghc/ghc][master] 4 commits: Add failing test case for #23492
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Mon Jul 3 07:30:39 UTC 2023
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
6074cc3c by Moisés Ackerman at 2023-07-03T03:30:13-04:00
Add failing test case for #23492
- - - - -
356a2692 by Moisés Ackerman at 2023-07-03T03:30:13-04:00
Use generated src span for catch-all case of record selector functions
This fixes #23492. The problem was that we used the real source span
of the field declaration for the generated catch-all case in the
selector function, in particular in the generated call to
`recSelError`, which meant it was included in the HIE output. Using
`generatedSrcSpan` instead means that it is not included.
- - - - -
3efe7f39 by Moisés Ackerman at 2023-07-03T03:30:13-04:00
Introduce genLHsApp and genLHsLit helpers in GHC.Rename.Utils
- - - - -
dd782343 by Moisés Ackerman at 2023-07-03T03:30:13-04:00
Construct catch-all default case using helpers
GHC.Rename.Utils concrete helpers instead of wrapGenSpan + HS AST constructors
- - - - -
5 changed files:
- compiler/GHC/Rename/Utils.hs
- compiler/GHC/Tc/TyCl/Utils.hs
- + testsuite/tests/hiefile/should_run/T23492.hs
- + testsuite/tests/hiefile/should_run/T23492.stdout
- testsuite/tests/hiefile/should_run/all.T
Changes:
=====================================
compiler/GHC/Rename/Utils.hs
=====================================
@@ -18,8 +18,9 @@ module GHC.Rename.Utils (
warnForallIdentifier,
checkUnusedRecordWildcard,
badQualBndrErr, typeAppErr, badFieldConErr,
- wrapGenSpan, genHsVar, genLHsVar, genHsApp, genHsApps, genAppType,
- genHsIntegralLit, genHsTyLit, genSimpleConPat,
+ wrapGenSpan, genHsVar, genLHsVar, genHsApp, genHsApps, genLHsApp,
+ genAppType,
+ genLHsLit, genHsIntegralLit, genHsTyLit, genSimpleConPat,
genVarPat, genWildPat,
genSimpleFunBind, genFunBind,
@@ -572,6 +573,9 @@ genHsApps fun args = foldl genHsApp (genHsVar fun) args
genHsApp :: HsExpr GhcRn -> LHsExpr GhcRn -> HsExpr GhcRn
genHsApp fun arg = HsApp noAnn (wrapGenSpan fun) arg
+genLHsApp :: HsExpr GhcRn -> LHsExpr GhcRn -> LHsExpr GhcRn
+genLHsApp fun arg = wrapGenSpan (genHsApp fun arg)
+
genLHsVar :: Name -> LHsExpr GhcRn
genLHsVar nm = wrapGenSpan $ genHsVar nm
@@ -581,8 +585,11 @@ 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 = wrapGenSpan . HsLit noAnn
+
genHsIntegralLit :: IntegralLit -> LocatedAn an (HsExpr GhcRn)
-genHsIntegralLit lit = wrapGenSpan $ HsLit noAnn (HsInt noExtField lit)
+genHsIntegralLit = genLHsLit . HsInt noExtField
genHsTyLit :: FastString -> HsType GhcRn
genHsTyLit = HsTyLit noExtField . HsStrTy NoSourceText
=====================================
compiler/GHC/Tc/TyCl/Utils.hs
=====================================
@@ -64,6 +64,8 @@ import GHC.Data.FastString
import GHC.Unit.Module
+import GHC.Rename.Utils (genHsVar, genLHsApp, genLHsLit, genWildPat)
+
import GHC.Types.Basic
import GHC.Types.FieldLabel
import GHC.Types.SrcLoc
@@ -954,10 +956,10 @@ mkOneRecordSelector all_cons idDetails fl has_sel
-- mentions this particular record selector
deflt | all dealt_with all_cons = []
| otherwise = [mkSimpleMatch CaseAlt
- [L loc' (WildPat noExtField)]
- (mkHsApp (L loc' (HsVar noExtField
- (L locn (getName rEC_SEL_ERROR_ID))))
- (L loc' (HsLit noComments msg_lit)))]
+ [genWildPat]
+ (genLHsApp
+ (genHsVar (getName rEC_SEL_ERROR_ID))
+ (genLHsLit msg_lit))]
-- Do not add a default case unless there are unmatched
-- constructors. We must take account of GADTs, else we
=====================================
testsuite/tests/hiefile/should_run/T23492.hs
=====================================
@@ -0,0 +1,44 @@
+{-# LANGUAGE OverloadedRecordDot #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+
+module Main where
+
+import TestUtils
+import qualified Data.Map as M
+import Data.Foldable
+
+-- regression test for https://gitlab.haskell.org/ghc/ghc/-/issues/23492
+data PartialFieldSelector
+ = NoFields
+ | PartialField { a :: Bool }
+-- ^
+-- 1
+
+f :: PartialFieldSelector -> Bool
+f x = a x
+-- ^
+-- 2
+
+g :: PartialFieldSelector -> Bool
+g x = x.a
+-- ^^^
+-- 345
+
+p1, p2, p3, p4, p5 :: (Int,Int)
+p1 = (13,20)
+p2 = (18,7)
+p3 = (23,7)
+p4 = (23,8)
+p5 = (23,9)
+
+selectPoint' :: HieFile -> (Int,Int) -> HieAST Int
+selectPoint' hf loc =
+ maybe (error "point not found") id $ selectPoint hf loc
+
+main = do
+ (df, hf) <- readTestHie "T23492.hie"
+ forM_ [p1,p2,p3,p4,p5] $ \point -> do
+ putStr $ "At " ++ show point ++ ", got type: "
+ let types = concatMap nodeType $ getSourcedNodeInfo $ sourcedNodeInfo $ selectPoint' hf point
+ forM_ types $ \typ -> do
+ putStrLn (renderHieType df $ recoverFullType typ (hie_types hf))
=====================================
testsuite/tests/hiefile/should_run/T23492.stdout
=====================================
@@ -0,0 +1,7 @@
+At (13,20), got type: PartialFieldSelector -> Bool
+Bool
+PartialFieldSelector
+At (18,7), got type: PartialFieldSelector -> Bool
+At (23,7), got type: PartialFieldSelector
+At (23,8), got type: PartialFieldSelector
+At (23,9), got type: Bool
=====================================
testsuite/tests/hiefile/should_run/all.T
=====================================
@@ -1,5 +1,6 @@
test('PatTypes', [extra_run_opts('"' + config.libdir + '"'), extra_files(['TestUtils.hs'])], compile_and_run, ['-package ghc -fwrite-ide-info'])
test('HieQueries', [extra_run_opts('"' + config.libdir + '"'), extra_files(['TestUtils.hs'])], compile_and_run, ['-package ghc -fwrite-ide-info'])
test('T20341', [extra_run_opts('"' + config.libdir + '"'), extra_files(['TestUtils.hs'])], compile_and_run, ['-package ghc -fwrite-ide-info'])
+test('T23492', [extra_run_opts('"' + config.libdir + '"'), extra_files(['TestUtils.hs'])], compile_and_run, ['-package ghc -fwrite-ide-info'])
test('RecordDotTypes', [extra_run_opts('"' + config.libdir + '"'), extra_files(['TestUtils.hs'])], compile_and_run, ['-package ghc -fwrite-ide-info'])
test('SpliceTypes', [req_th, extra_run_opts('"' + config.libdir + '"'), extra_files(['TestUtils.hs'])], compile_and_run, ['-package ghc -fwrite-ide-info'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/03f941f45607a5ee52ca53a358333bbb41ddb1bc...dd782343f131cfd983a7fb2431d9d4a9ae497551
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/03f941f45607a5ee52ca53a358333bbb41ddb1bc...dd782343f131cfd983a7fb2431d9d4a9ae497551
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/20230703/fa5b5a0f/attachment-0001.html>
More information about the ghc-commits
mailing list