[Git][ghc/ghc][wip/backports-9.4] 2 commits: Fix nested type splices in hie files
Ben Gamari (@bgamari)
gitlab at gitlab.haskell.org
Fri Oct 28 01:58:39 UTC 2022
Ben Gamari pushed to branch wip/backports-9.4 at Glasgow Haskell Compiler / GHC
Commits:
f488340b by Matthew Pickering at 2022-10-27T21:58:32-04:00
Fix nested type splices in hie files
The issue is that when we compile a typed bracket we replace the splice
with HsSpliced (unTypeCode ...).
Then when computing types for
> [|| T $$(...) ||]
GHC is asked to compute the type of `T $$(..)`, which panics because
of the bogus type of T applied to `HsSpliced`, which is not type
correct.
The fix is to not attempt to compute the type for `HsSpliceE`
constructors if we come across them as they should have either been
already evaluated or lifted into a splice environment.
As part of the patch I made hie files traverse into the splice
environments so now we also get type information for things used inside
nested splices.
Fixes #21619
- - - - -
49852b31 by Alan Zimmerman at 2022-10-27T21:58:32-04:00
EPA: DotFieldOcc does not have exact print annotations
For the code
{-# LANGUAGE OverloadedRecordUpdate #-}
operatorUpdate f = f{(+) = 1}
There are no exact print annotations for the parens around the +
symbol, nor does normal ppr print them.
This MR fixes that.
Closes #21805
(cherry picked from commit 792ef44d455c6e987f342fb61515464322a9fa77)
- - - - -
17 changed files:
- compiler/GHC/Hs/Expr.hs
- compiler/GHC/Hs/Syn/Type.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Parser/PostProcess.hs
- compiler/Language/Haskell/Syntax/Expr.hs
- testsuite/tests/hiefile/should_compile/all.T
- + testsuite/tests/hiefile/should_compile/hie011.hs
- + testsuite/tests/hiefile/should_compile/hie011.stderr
- + testsuite/tests/hiefile/should_run/SpliceTypes.hs
- + testsuite/tests/hiefile/should_run/SpliceTypes.stdout
- testsuite/tests/hiefile/should_run/all.T
- testsuite/tests/printer/Makefile
- + testsuite/tests/printer/Test21805.hs
- testsuite/tests/printer/all.T
- utils/check-exact/ExactPrint.hs
- utils/check-exact/Main.hs
- utils/haddock
Changes:
=====================================
compiler/GHC/Hs/Expr.hs
=====================================
@@ -2063,7 +2063,7 @@ type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsExpr
type instance Anno [LocatedA (StmtLR (GhcPass pl) (GhcPass pr) (LocatedA (HsCmd (GhcPass pr))))] = SrcSpanAnnL
type instance Anno (FieldLabelStrings (GhcPass p)) = SrcAnn NoEpAnns
-type instance Anno (FieldLabelString) = SrcAnn NoEpAnns
+type instance Anno (FieldLabelString) = SrcSpanAnnN
type instance Anno (DotFieldOcc (GhcPass p)) = SrcAnn NoEpAnns
instance (Anno a ~ SrcSpanAnn' (EpAnn an))
=====================================
compiler/GHC/Hs/Syn/Type.hs
=====================================
@@ -133,9 +133,9 @@ hsExprType (HsTypedBracket (HsBracketTc _ ty _wrap _pending) _) = ty
hsExprType (HsUntypedBracket (HsBracketTc _ ty _wrap _pending) _) = ty
hsExprType e@(HsSpliceE{}) = pprPanic "hsExprType: Unexpected HsSpliceE"
(ppr e)
- -- Typed splices should have been eliminated during zonking, but we
- -- can't use `dataConCantHappen` since they are still present before
- -- than in the typechecked AST.
+ -- Typed splices should have been eliminated during zonking, but we
+ -- can't use `dataConCantHappen` since they are still present before
+ -- than in the typechecked AST
hsExprType (HsProc _ _ lcmd_top) = lhsCmdTopType lcmd_top
hsExprType (HsStatic (_, ty) _s) = ty
hsExprType (HsPragE _ _ e) = lhsExprType e
=====================================
compiler/GHC/Iface/Ext/Ast.hs
=====================================
@@ -744,6 +744,9 @@ instance HiePass p => HasType (LocatedA (HsExpr (GhcPass p))) where
RecordCon con_expr _ _ -> computeType con_expr
ExprWithTySig _ e _ -> computeLType e
HsPragE _ _ e -> computeLType e
+ -- By this point all splices are lifted into splice environments so
+ -- the remaining HsSpliceE in the syntax tree contain bogus information.
+ HsSpliceE {} -> Nothing
XExpr (ExpansionExpr (HsExpanded (HsGetField _ _ _) e)) -> Just (hsExprType e) -- for record-dot-syntax
XExpr (ExpansionExpr (HsExpanded _ e)) -> computeType e
XExpr (HsTick _ e) -> computeLType e
@@ -1873,10 +1876,10 @@ instance ToHie (HsQuote a) where
toHie _ = pure []
instance ToHie PendingRnSplice where
- toHie _ = pure []
+ toHie (PendingRnSplice _ _ e) = toHie e
instance ToHie PendingTcSplice where
- toHie _ = pure []
+ toHie (PendingTcSplice _ e) = toHie e
instance ToHie (LBooleanFormula (LocatedN Name)) where
toHie (L span form) = concatM $ makeNode form (locA span) : case form of
=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -2549,7 +2549,7 @@ mkRdrRecordUpd overloaded_on exp@(L loc _) fbinds anns = do
recFieldToProjUpdate (L l (HsFieldBind anns (L _ (FieldOcc _ (L loc rdr))) arg pun)) =
-- The idea here is to convert the label to a singleton [FastString].
let f = occNameFS . rdrNameOcc $ rdr
- fl = DotFieldOcc noAnn (L (l2l loc) f) -- AZ: what about the ann?
+ fl = DotFieldOcc noAnn (L loc f)
lf = locA loc
in mkRdrProjUpdate l (L lf [L (l2l loc) fl]) (punnedVar f) pun anns
where
=====================================
compiler/Language/Haskell/Syntax/Expr.hs
=====================================
@@ -37,6 +37,7 @@ import GHC.Core.DataCon (FieldLabelString)
import GHC.Types.Name
import GHC.Types.Basic
import GHC.Types.Fixity
+import GHC.Types.Name.Reader
import GHC.Types.SourceText
import GHC.Types.SrcLoc
import GHC.Unit.Module (ModuleName)
@@ -159,8 +160,20 @@ pprFieldLabelStrings :: forall p. (UnXRec p, Outputable (XRec p FieldLabelString
pprFieldLabelStrings (FieldLabelStrings flds) =
hcat (punctuate dot (map (ppr . unXRec @p) flds))
-instance Outputable(XRec p FieldLabelString) => Outputable (DotFieldOcc p) where
- ppr (DotFieldOcc _ s) = ppr s
+pprPrefixFieldLabelStrings :: forall p. (UnXRec p, Outputable (XRec p FieldLabelString))
+ => FieldLabelStrings p -> SDoc
+pprPrefixFieldLabelStrings (FieldLabelStrings flds) =
+ hcat (punctuate dot (map (pprPrefixFieldLabelString . unXRec @p) flds))
+
+pprPrefixFieldLabelString :: forall p. UnXRec p => DotFieldOcc p -> SDoc
+pprPrefixFieldLabelString (DotFieldOcc _ s) = (pprPrefixFastString . unXRec @p) s
+pprPrefixFieldLabelString XDotFieldOcc{} = text "XDotFieldOcc"
+
+pprPrefixFastString :: FastString -> SDoc
+pprPrefixFastString fs = pprPrefixOcc (mkVarUnqual fs)
+
+instance UnXRec p => Outputable (DotFieldOcc p) where
+ ppr (DotFieldOcc _ s) = (pprPrefixFastString . unXRec @p) s
ppr XDotFieldOcc{} = text "XDotFieldOcc"
-- Field projection updates (e.g. @foo.bar.baz = 1@). See Note
=====================================
testsuite/tests/hiefile/should_compile/all.T
=====================================
@@ -16,6 +16,7 @@ test('hie007', normal, compile, ['-fno-code -fwrite-ide-
test('hie008', normal, compile, ['-fno-code -fwrite-ide-info -fvalidate-ide-info'])
test('hie009', normal, compile, ['-fno-code -fwrite-ide-info -fvalidate-ide-info'])
test('hie010', normal, compile, ['-fno-code -fwrite-ide-info -fvalidate-ide-info'])
+test('hie011', normal, compile, ['-fno-code -fwrite-ide-info -fvalidate-ide-info'])
test('CPP', normal, compile, ['-fno-code -fwrite-ide-info -fvalidate-ide-info'])
test('Constructors', normal, compile, ['-fno-code -fwrite-ide-info -fvalidate-ide-info'])
test('Scopes', normal, compile, ['-fno-code -fwrite-ide-info -fvalidate-ide-info'])
=====================================
testsuite/tests/hiefile/should_compile/hie011.hs
=====================================
@@ -0,0 +1,15 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# OPTIONS_GHC -fwrite-ide-info #-}
+module M where
+
+import Language.Haskell.TH.Syntax
+
+newtype T = T { getT :: Int }
+
+instance Lift T where
+ lift = undefined
+ liftTyped v = [||T $$(liftTyped (getT v))||]
+
+
+top_level :: ()
+top_level = $$([|| () ||])
=====================================
testsuite/tests/hiefile/should_compile/hie011.stderr
=====================================
@@ -0,0 +1,2 @@
+Got valid scopes
+Got no roundtrip errors
=====================================
testsuite/tests/hiefile/should_run/SpliceTypes.hs
=====================================
@@ -0,0 +1,47 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module Main where
+
+import TestUtils
+import qualified Data.Map as M
+import Data.Foldable
+import Language.Haskell.TH.Syntax
+
+
+newtype T = T { getT :: Int }
+
+instance Lift T where
+ liftTyped v = [||T $$(liftTyped (getT v))||]
+-- ^ ^ ^ ^ ^
+-- 1 2 3 4 5
+--
+
+top_level :: ()
+top_level = $$([|| () ||])
+-- ^ ^
+-- 1 2
+
+p1,p2, p3, p4:: (Int,Int)
+p1 = (14,18)
+p2 = (14,21)
+p3 = (14,24)
+p4 = (14,29)
+p5 = (14,41)
+
+q1 = (20, 19)
+q2 = (20, 21)
+
+selectPoint' :: HieFile -> (Int,Int) -> HieAST Int
+selectPoint' hf loc =
+ maybe (error "point not found") id $ selectPoint hf loc
+
+main = do
+ (df, hf) <- readTestHie "SpliceTypes.hie"
+ forM_ [p1,p2,p3, p4, p5, q1, q2] $ \point -> do
+ let types = concatMap nodeType $ getSourcedNodeInfo $ sourcedNodeInfo $ selectPoint' hf point
+ case types of
+ [] -> putStrLn $ "No types at " ++ show point
+ _ -> do
+ putStr $ "At " ++ show point ++ ", got type: "
+ forM_ types $ \typ -> do
+ putStrLn (renderHieType df $ recoverFullType typ (hie_types hf))
=====================================
testsuite/tests/hiefile/should_run/SpliceTypes.stdout
=====================================
@@ -0,0 +1,9 @@
+No types at (14,18)
+At (14,21), got type: Int -> T
+No types at (14,24)
+At (14,29), got type: Int -> Code m Int
+forall t (m :: * -> *). (Lift t, Quote m) => t -> Code m t
+forall (m :: * -> *). Quote m => Int -> Code m Int
+At (14,41), got type: T
+No types at (20,19)
+No types at (20,21)
=====================================
testsuite/tests/hiefile/should_run/all.T
=====================================
@@ -2,3 +2,4 @@ test('PatTypes', [extra_run_opts('"' + config.libdir + '"')], compile_and_run, [
test('HieQueries', [extra_run_opts('"' + config.libdir + '"')], compile_and_run, ['-package ghc -fwrite-ide-info'])
test('T20341', [extra_run_opts('"' + config.libdir + '"')], 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', [extra_run_opts('"' + config.libdir + '"'), extra_files(['TestUtils.hs'])], compile_and_run, ['-package ghc -fwrite-ide-info'])
=====================================
testsuite/tests/printer/Makefile
=====================================
@@ -754,3 +754,8 @@ Test20297:
Test20846:
$(CHECK_PPR) $(LIBDIR) Test20846.hs
$(CHECK_EXACT) $(LIBDIR) Test20846.hs
+
+.PHONY: Test21805
+Test21805:
+ $(CHECK_PPR) $(LIBDIR) Test21805.hs
+ $(CHECK_EXACT) $(LIBDIR) Test21805.hs
=====================================
testsuite/tests/printer/Test21805.hs
=====================================
@@ -0,0 +1,3 @@
+{-# LANGUAGE OverloadedRecordUpdate #-}
+
+operatorUpdate f = f{(+) = 1}
=====================================
testsuite/tests/printer/all.T
=====================================
@@ -177,3 +177,4 @@ test('Test20247', [ignore_stderr, req_ppr_deps], makefile_test, ['Test20247'])
test('Test20258', [ignore_stderr, req_ppr_deps], makefile_test, ['Test20258'])
test('Test20297', [ignore_stderr, req_ppr_deps], makefile_test, ['Test20297'])
test('Test20846', [ignore_stderr, req_ppr_deps], makefile_test, ['Test20846'])
+test('Test21805', [ignore_stderr, req_ppr_deps], makefile_test, ['Test21805'])
=====================================
utils/check-exact/ExactPrint.hs
=====================================
@@ -30,8 +30,9 @@ import GHC.Data.FastString
import GHC.Types.Basic hiding (EP)
import GHC.Types.Fixity
import GHC.Types.ForeignCall
-import GHC.Types.SourceText
+import GHC.Types.Name.Reader
import GHC.Types.PkgQual
+import GHC.Types.SourceText
import GHC.Types.Var
import GHC.Utils.Outputable hiding ( (<>) )
import GHC.Unit.Module.Warnings
@@ -2291,9 +2292,11 @@ instance ExactPrint (FieldLabelStrings GhcPs) where
instance ExactPrint (DotFieldOcc GhcPs) where
getAnnotationEntry (DotFieldOcc an _) = fromAnn an
- exact (DotFieldOcc an fs) = do
+ exact (DotFieldOcc an (L loc fs)) = do
markAnnKwM an afDot AnnDot
- markAnnotated fs
+ -- The field name has a SrcSpanAnnN, print it as a
+ -- LocatedN RdrName
+ markAnnotated (L loc (mkVarUnqual fs))
-- ---------------------------------------------------------------------
=====================================
utils/check-exact/Main.hs
=====================================
@@ -198,7 +198,8 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/exactprin
-- "../../testsuite/tests/printer/PprSemis.hs" Nothing
-- "../../testsuite/tests/printer/PprEmptyMostly.hs" Nothing
-- "../../testsuite/tests/parser/should_compile/DumpSemis.hs" Nothing
- "../../testsuite/tests/ghc-api/exactprint/Test20239.hs" Nothing
+ -- "../../testsuite/tests/ghc-api/exactprint/Test20239.hs" Nothing
+ "../../testsuite/tests/printer/Test21805.hs" Nothing
-- cloneT does not need a test, function can be retired
=====================================
utils/haddock
=====================================
@@ -1 +1 @@
-Subproject commit 6113875efdc0b6be66deedb77e28d3b9e4253d1e
+Subproject commit a5cd9d902ad2667df40a0331e8ced7705238deec
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8374921e7e1b3745580fa3d6ddc434c40573865d...49852b31c3907e38c17bd75a4a221b34cd052298
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/8374921e7e1b3745580fa3d6ddc434c40573865d...49852b31c3907e38c17bd75a4a221b34cd052298
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/20221027/99fa6e38/attachment-0001.html>
More information about the ghc-commits
mailing list