diff options
author | Matthew Pickering <matthewtpickering@gmail.com> | 2022-10-11 09:37:13 +0100 |
---|---|---|
committer | Ben Gamari <ben@smart-cactus.org> | 2022-11-01 17:46:56 -0400 |
commit | edfa9f4653b10cb0a897ace15b25b3b52cde5c39 (patch) | |
tree | 800d5a74d08fdd2cf06e7ad63c17834fb601248b | |
parent | 9c08d9a1b40c8c66a5fdcd6cb1b02b20121c93c4 (diff) | |
download | haskell-edfa9f4653b10cb0a897ace15b25b3b52cde5c39.tar.gz |
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
-rw-r--r-- | compiler/GHC/Hs/Syn/Type.hs | 6 | ||||
-rw-r--r-- | compiler/GHC/Iface/Ext/Ast.hs | 7 | ||||
-rw-r--r-- | testsuite/tests/hiefile/should_compile/all.T | 1 | ||||
-rw-r--r-- | testsuite/tests/hiefile/should_compile/hie011.hs | 15 | ||||
-rw-r--r-- | testsuite/tests/hiefile/should_compile/hie011.stderr | 2 | ||||
-rw-r--r-- | testsuite/tests/hiefile/should_run/SpliceTypes.hs | 47 | ||||
-rw-r--r-- | testsuite/tests/hiefile/should_run/SpliceTypes.stdout | 9 | ||||
-rw-r--r-- | testsuite/tests/hiefile/should_run/all.T | 1 | ||||
m--------- | utils/haddock | 0 |
9 files changed, 83 insertions, 5 deletions
diff --git a/compiler/GHC/Hs/Syn/Type.hs b/compiler/GHC/Hs/Syn/Type.hs index be1fd40ce0..4b49c41243 100644 --- a/compiler/GHC/Hs/Syn/Type.hs +++ b/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 diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs index e309fe7d47..86e4522043 100644 --- a/compiler/GHC/Iface/Ext/Ast.hs +++ b/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 diff --git a/testsuite/tests/hiefile/should_compile/all.T b/testsuite/tests/hiefile/should_compile/all.T index 73b98a1f94..018585a0f4 100644 --- a/testsuite/tests/hiefile/should_compile/all.T +++ b/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']) diff --git a/testsuite/tests/hiefile/should_compile/hie011.hs b/testsuite/tests/hiefile/should_compile/hie011.hs new file mode 100644 index 0000000000..63a6899fb9 --- /dev/null +++ b/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 = $$([|| () ||]) diff --git a/testsuite/tests/hiefile/should_compile/hie011.stderr b/testsuite/tests/hiefile/should_compile/hie011.stderr new file mode 100644 index 0000000000..f31d37d99f --- /dev/null +++ b/testsuite/tests/hiefile/should_compile/hie011.stderr @@ -0,0 +1,2 @@ +Got valid scopes +Got no roundtrip errors diff --git a/testsuite/tests/hiefile/should_run/SpliceTypes.hs b/testsuite/tests/hiefile/should_run/SpliceTypes.hs new file mode 100644 index 0000000000..6ea4134692 --- /dev/null +++ b/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)) diff --git a/testsuite/tests/hiefile/should_run/SpliceTypes.stdout b/testsuite/tests/hiefile/should_run/SpliceTypes.stdout new file mode 100644 index 0000000000..aa2398203a --- /dev/null +++ b/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) diff --git a/testsuite/tests/hiefile/should_run/all.T b/testsuite/tests/hiefile/should_run/all.T index 884d58c31f..a4b738d11d 100644 --- a/testsuite/tests/hiefile/should_run/all.T +++ b/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']) diff --git a/utils/haddock b/utils/haddock -Subproject 6113875efdc0b6be66deedb77e28d3b9e4253d1 +Subproject a5cd9d902ad2667df40a0331e8ced7705238dee |