Skip to content

Commit 47db34f

Browse files
berbermanberberman
authored
Eval plugin: support ghc 9.0.1 (#1997)
* Eval plugin: support ghc 9.0.1 * Update CI and stack * Use pprTypeForUser for printing kinds * test: remove forall * test: [Char] -> String * test: update forall * Keep tests only for GHC 9 * Update nix and CI * Mark one hlint test as known broken * Re-enable tests for other ghc versions * Update test
1 parent 8aa698b commit 47db34f

18 files changed

+95
-126
lines changed

‎.github/workflows/test.yml

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -170,7 +170,7 @@ jobs:
170170
name: Test hls-class-plugin
171171
run: cabal test hls-class-plugin --test-options="-j1 --rerun-update" || cabal test hls-class-plugin --test-options="-j1 --rerun" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-class-plugin --test-options="-j1 --rerun"
172172

173-
- if: ${{ needs.pre_job.outputs.should_skip != 'true' && matrix.test && matrix.ghc != '9.0.1' }}
173+
- if: ${{ needs.pre_job.outputs.should_skip != 'true' && matrix.test && matrix.ghc }}
174174
name: Test hls-eval-plugin
175175
run: cabal test hls-eval-plugin --test-options="-j1 --rerun-update" || cabal test hls-eval-plugin --test-options="-j1 --rerun" || LSP_TEST_LOG_COLOR=0 LSP_TEST_LOG_MESSAGES=true LSP_TEST_LOG_STDERR=true cabal test hls-eval-plugin --test-options="-j1 --rerun"
176176

‎cabal-ghc901.project

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -88,7 +88,7 @@ index-state: 2021-06-30T16:00:00Z
8888

8989
constraints:
9090
-- These plugins doesn't work on GHC9 yet
91-
haskell-language-server -brittany -class -eval -fourmolu -ormolu -splice -stylishhaskell -tactic -refineImports
91+
haskell-language-server -brittany -class -fourmolu -ormolu -splice -stylishhaskell -tactic -refineImports
9292

9393

9494
allow-newer:

‎configuration-ghc-901.nix

Lines changed: 0 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -9,7 +9,6 @@ let
99
"hls-fourmolu-plugin"
1010
"hls-splice-plugin"
1111
"hls-ormolu-plugin"
12-
"hls-eval-plugin"
1312
"hls-class-plugin"
1413
"hls-refine-imports-plugin"
1514
];
@@ -106,7 +105,6 @@ let
106105
(pkgs.lib.concatStringsSep " " [
107106
"-f-brittany"
108107
"-f-class"
109-
"-f-eval"
110108
"-f-fourmolu"
111109
"-f-ormolu"
112110
"-f-splice"

‎hls-test-utils/src/Test/Hls/Util.hs

Lines changed: 4 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -112,10 +112,13 @@ data GhcVersion
112112
| GHC88
113113
| GHC86
114114
| GHC84
115+
| GHC901
115116
deriving (Eq,Show)
116117

117118
ghcVersion :: GhcVersion
118-
#if (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,10,0,0)))
119+
#if (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(9,0,1,0)))
120+
ghcVersion = GHC901
121+
#elif (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,10,0,0)))
119122
ghcVersion = GHC810
120123
#elif (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,8,0,0)))
121124
ghcVersion = GHC88

‎plugins/hls-eval-plugin/hls-eval-plugin.cabal

Lines changed: 4 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -19,13 +19,13 @@ build-type: Simple
1919
extra-source-files:
2020
LICENSE
2121
README.md
22+
test/cabal.project
23+
test/info-util/*.cabal
24+
test/info-util/*.hs
2225
test/testdata/*.cabal
2326
test/testdata/*.hs
2427
test/testdata/*.lhs
2528
test/testdata/*.yaml
26-
test/info-util/*.cabal
27-
test/info-util/*.hs
28-
test/cabal.project
2929

3030
flag pedantic
3131
description: Enable -Werror
@@ -110,3 +110,4 @@ test-suite tests
110110
, hls-test-utils ^>=1.0
111111
, lens
112112
, lsp-types
113+
, text

‎plugins/hls-eval-plugin/src/Ide/Plugin/Eval/CodeLens.hs

Lines changed: 41 additions & 24 deletions
Original file line numberDiff line numberDiff line change
@@ -152,23 +152,29 @@ import System.IO (hClose)
152152
import UnliftIO.Temporary (withSystemTempFile)
153153
import Util (OverridingBool (Never))
154154

155-
155+
import IfaceSyn (showToHeader)
156+
import PprTyThing (pprTyThingInContext, pprTypeForUser)
156157
#if MIN_VERSION_ghc(9,0,0)
157-
import GHC.Parser.Annotation (ApiAnns (apiAnnComments))
158+
import GHC.Parser.Annotation (ApiAnns (apiAnnRogueComments))
159+
import GHC.Parser.Lexer (mkParserFlags)
160+
import GHC.Driver.Ways (hostFullWays,
161+
wayGeneralFlags,
162+
wayUnsetGeneralFlags)
163+
import GHC.Types.SrcLoc (UnhelpfulSpanReason(UnhelpfulInteractive))
158164
#else
159165
import GhcPlugins (interpWays, updateWays,
160166
wayGeneralFlags,
161167
wayUnsetGeneralFlags)
162-
import IfaceSyn (showToHeader)
163-
import PprTyThing (pprTyThingInContext)
164168
#endif
165169

166170
#if MIN_VERSION_ghc(9,0,0)
167171
pattern RealSrcSpanAlready :: SrcLoc.RealSrcSpan -> SrcLoc.RealSrcSpan
168172
pattern RealSrcSpanAlready x = x
173+
apiAnnComments' :: SrcLoc.ApiAnns -> [SrcLoc.RealLocated AnnotationComment]
174+
apiAnnComments' = apiAnnRogueComments
169175
#else
170-
apiAnnComments :: SrcLoc.ApiAnns -> Map.Map SrcSpan [SrcLoc.Located AnnotationComment]
171-
apiAnnComments = snd
176+
apiAnnComments' :: SrcLoc.ApiAnns -> [SrcLoc.Located AnnotationComment]
177+
apiAnnComments' = concat . Map.elems . snd
172178

173179
pattern RealSrcSpanAlready :: SrcLoc.RealSrcSpan -> SrcSpan
174180
pattern RealSrcSpanAlready x = SrcLoc.RealSrcSpan x
@@ -190,9 +196,9 @@ codeLens st plId CodeLensParams{_textDocument} =
190196
isLHS = isLiterate fp
191197
dbg "fp" fp
192198
(ParsedModule{..}, posMap) <- liftIO $
193-
runAction "parsed" st $ useWithStale_ GetParsedModuleWithComments nfp
194-
let comments = foldMap
195-
( foldMap $ \case
199+
runAction "eval.GetParsedModuleWithComments" st $ useWithStale_ GetParsedModuleWithComments nfp
200+
let comments =
201+
foldMap (\case
196202
L (RealSrcSpanAlready real) bdy
197203
| unpackFS (srcSpanFile real) ==
198204
fromNormalizedFilePath nfp
@@ -210,16 +216,15 @@ codeLens st plId CodeLensParams{_textDocument} =
210216
_ -> mempty
211217
_ -> mempty
212218
)
213-
$ apiAnnComments pm_annotations
219+
$ apiAnnComments' pm_annotations
214220
dbg "excluded comments" $ show $ DL.toList $
215-
foldMap
216-
(foldMap $ \(L a b) ->
221+
foldMap (\(L a b) ->
217222
case b of
218223
AnnLineComment{} -> mempty
219224
AnnBlockComment{} -> mempty
220225
_ -> DL.singleton (a, b)
221226
)
222-
$ apiAnnComments pm_annotations
227+
$ apiAnnComments' pm_annotations
223228
dbg "comments" $ show comments
224229

225230
-- Extract tests from source code
@@ -546,7 +551,7 @@ evals (st, fp) df stmts = do
546551
eans <-
547552
liftIO $ try @GhcException $
548553
parseDynamicFlagsCmdLine ndf
549-
(map (L $ UnhelpfulSpan "<interactive>") flags)
554+
(map (L $ UnhelpfulSpan unhelpfulReason) flags)
550555
dbg "parsed flags" $ eans
551556
<&> (_1 %~ showDynFlags >>> _3 %~ map warnMsg)
552557
case eans of
@@ -572,7 +577,7 @@ evals (st, fp) df stmts = do
572577
Just (cmd, arg) <- parseGhciLikeCmd $ T.pack stmt =
573578
evalGhciLikeCmd cmd arg
574579
| -- A statement
575-
isStmt df stmt =
580+
isStmt pf stmt =
576581
do
577582
dbg "{STMT " stmt
578583
res <- exec stmt l
@@ -582,7 +587,7 @@ evals (st, fp) df stmts = do
582587
dbg "STMT} -> " r
583588
return r
584589
| -- An import
585-
isImport df stmt =
590+
isImport pf stmt =
586591
do
587592
dbg "{IMPORT " stmt
588593
_ <- addImport stmt
@@ -593,6 +598,13 @@ evals (st, fp) df stmts = do
593598
dbg "{DECL " stmt
594599
void $ runDecls stmt
595600
return Nothing
601+
#if !MIN_VERSION_ghc(9,0,0)
602+
pf = df
603+
unhelpfulReason = "<interactive>"
604+
#else
605+
pf = mkParserFlags df
606+
unhelpfulReason = UnhelpfulInteractive
607+
#endif
596608
exec stmt l =
597609
let opts = execOptions{execSourceFile = fp, execLineNumber = l}
598610
in myExecStmt stmt opts
@@ -739,20 +751,20 @@ doKindCmd :: Bool -> DynFlags -> Text -> Ghc (Maybe Text)
739751
doKindCmd False df arg = do
740752
let input = T.strip arg
741753
(_, kind) <- typeKind False $ T.unpack input
742-
let kindText = text (T.unpack input) <+> "::" <+> ppr kind
754+
let kindText = text (T.unpack input) <+> "::" <+> pprTypeForUser kind
743755
pure $ Just $ T.pack (showSDoc df kindText)
744756
doKindCmd True df arg = do
745757
let input = T.strip arg
746758
(ty, kind) <- typeKind True $ T.unpack input
747-
let kindDoc = text (T.unpack input) <+> "::" <+> ppr kind
748-
tyDoc = "=" <+> ppr ty
759+
let kindDoc = text (T.unpack input) <+> "::" <+> pprTypeForUser kind
760+
tyDoc = "=" <+> pprTypeForUser ty
749761
pure $ Just $ T.pack (showSDoc df $ kindDoc $$ tyDoc)
750762

751763
doTypeCmd :: DynFlags -> Text -> Ghc (Maybe Text)
752764
doTypeCmd dflags arg = do
753765
let (emod, expr) = parseExprMode arg
754766
ty <- exprType emod $ T.unpack expr
755-
let rawType = T.strip $ T.pack $ showSDoc dflags $ ppr ty
767+
let rawType = T.strip $ T.pack $ showSDoc dflags $ pprTypeForUser ty
756768
broken = T.any (\c -> c == '\r' || c == '\n') rawType
757769
pure $
758770
Just $
@@ -761,7 +773,7 @@ doTypeCmd dflags arg = do
761773
T.pack $
762774
showSDoc dflags $
763775
text (T.unpack expr)
764-
$$ nest 2 ("::" <+> ppr ty)
776+
$$ nest 2 ("::" <+> pprTypeForUser ty)
765777
else expr <> " :: " <> rawType <> "\n"
766778

767779
parseExprMode :: Text -> (TcRnExprMode, T.Text)
@@ -804,13 +816,18 @@ setupDynFlagsForGHCiLike env dflags = do
804816
, ghcLink = LinkInMemory
805817
}
806818
platform = targetPlatform dflags3
807-
dflags3a = updateWays $ dflags3{ways = interpWays}
819+
#if MIN_VERSION_ghc(9,0,0)
820+
evalWays = hostFullWays
821+
#else
822+
evalWays = interpWays
823+
#endif
824+
dflags3a = dflags3{ways = evalWays}
808825
dflags3b =
809826
foldl gopt_set dflags3a $
810-
concatMap (wayGeneralFlags platform) interpWays
827+
concatMap (wayGeneralFlags platform) evalWays
811828
dflags3c =
812829
foldl gopt_unset dflags3b $
813-
concatMap (wayUnsetGeneralFlags platform) interpWays
830+
concatMap (wayUnsetGeneralFlags platform) evalWays
814831
dflags4 =
815832
dflags3c
816833
`gopt_set` Opt_ImplicitImportQualified

‎plugins/hls-eval-plugin/test/Main.hs

Lines changed: 40 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -18,6 +18,7 @@ import Ide.Plugin.Eval.Types (EvalParams (..), Section (..),
1818
import Language.LSP.Types.Lens (arguments, command, range, title)
1919
import System.FilePath ((</>))
2020
import Test.Hls
21+
import qualified Data.Text as T
2122

2223
main :: IO ()
2324
main = defaultTestRunner tests
@@ -61,7 +62,14 @@ tests =
6162
, goldenWithEval "Refresh an evaluation" "T5" "hs"
6263
, goldenWithEval "Refresh an evaluation w/ lets" "T6" "hs"
6364
, goldenWithEval "Refresh a multiline evaluation" "T7" "hs"
64-
, goldenWithEval "Semantic and Lexical errors are reported" "T8" "hs"
65+
, testCase "Semantic and Lexical errors are reported" $ do
66+
evalInFile "T8.hs" "-- >>> noFunctionWithThisName" "-- Variable not in scope: noFunctionWithThisName"
67+
evalInFile "T8.hs" "-- >>> \"a\" + \"bc\"" $
68+
if ghcVersion == GHC901
69+
then "-- No instance for (Num String) arising from a use of ‘+’"
70+
else "-- No instance for (Num [Char]) arising from a use of ‘+’"
71+
evalInFile "T8.hs" "-- >>> \"" "-- lexical error in string/character literal at end of input"
72+
evalInFile "T8.hs" "-- >>> 3 `div` 0" "-- divide by zero"
6573
, goldenWithEval "Applies file LANGUAGE extensions" "T9" "hs"
6674
, goldenWithEval "Evaluate a type with :kind!" "T10" "hs"
6775
, goldenWithEval "Reports an error for an incorrect type with :kind!" "T11" "hs"
@@ -75,9 +83,24 @@ tests =
7583
, goldenWithEval "Returns defaulted type for :type +d reflecting the default declaration specified in the >>> prompt" "T19" "hs"
7684
, expectFailBecause "known issue - see a note in P.R. #361" $
7785
goldenWithEval ":type +d reflects the `default' declaration of the module" "T20" "hs"
78-
, goldenWithEval ":type handles a multilined result properly" "T21" "hs"
86+
, testCase ":type handles a multilined result properly" $
87+
evalInFile "T21.hs" "-- >>> :type fun" $ T.unlines [
88+
"-- fun",
89+
if ghcVersion == GHC901
90+
then "-- :: forall {k1} {k2 :: Nat} {n :: Nat} {a :: k1}."
91+
else "-- :: forall k1 (k2 :: Nat) (n :: Nat) (a :: k1).",
92+
"-- (KnownNat k2, KnownNat n, Typeable a) =>",
93+
"-- Proxy k2 -> Proxy n -> Proxy a -> ()"
94+
]
7995
, goldenWithEval ":t behaves exactly the same as :type" "T22" "hs"
80-
, goldenWithEval ":type does \"dovetails\" for short identifiers" "T23" "hs"
96+
, testCase ":type does \"dovetails\" for short identifiers" $
97+
evalInFile "T23.hs" "-- >>> :type f" $ T.unlines [
98+
if ghcVersion == GHC901
99+
then "-- f :: forall {k1} {k2 :: Nat} {n :: Nat} {a :: k1}."
100+
else "-- f :: forall k1 (k2 :: Nat) (n :: Nat) (a :: k1).",
101+
"-- (KnownNat k2, KnownNat n, Typeable a) =>",
102+
"-- Proxy k2 -> Proxy n -> Proxy a -> ()"
103+
]
81104
, goldenWithEval ":kind! treats a multilined result properly" "T24" "hs"
82105
, goldenWithEval ":kind treats a multilined result properly" "T25" "hs"
83106
, goldenWithEval "local imports" "T26" "hs"
@@ -91,6 +114,10 @@ tests =
91114
-- , goldenWithEval "Local Modules can be imported in a test" "TLocalImportInTest" "hs"
92115
, goldenWithEval "Setting language option TupleSections" "TLanguageOptionsTupleSections" "hs"
93116
, goldenWithEval ":set accepts ghci flags" "TFlags" "hs"
117+
, testCase ":set -fprint-explicit-foralls works" $ do
118+
evalInFile "T8.hs" "-- >>> :t id" "-- id :: a -> a"
119+
evalInFile "T8.hs" "-- >>> :set -fprint-explicit-foralls\n-- >>> :t id"
120+
"-- id :: forall {a}. a -> a"
94121
, goldenWithEval "The default language extensions for the eval plugin are the same as those for ghci" "TSameDefaultLanguageExtensionsAsGhci" "hs"
95122
, goldenWithEval "IO expressions are supported, stdout/stderr output is ignored" "TIO" "hs"
96123
, goldenWithEval "Property checking" "TProperty" "hs"
@@ -196,3 +223,13 @@ codeLensTestOutput codeLens = do
196223

197224
testDataDir :: FilePath
198225
testDataDir = "test" </> "testdata"
226+
227+
evalInFile :: FilePath -> T.Text -> T.Text -> IO ()
228+
evalInFile fp e expected = runSessionWithServer evalPlugin testDataDir $ do
229+
doc <- openDoc fp "haskell"
230+
origin <- documentContents doc
231+
let withEval = origin <> e
232+
changeDoc doc [TextDocumentContentChangeEvent Nothing Nothing withEval]
233+
executeLensesBackwards doc
234+
result <- fmap T.strip . T.stripPrefix withEval <$> documentContents doc
235+
liftIO $ result @?= Just (T.strip expected)

‎plugins/hls-eval-plugin/test/testdata/T21.expected.hs

Lines changed: 0 additions & 16 deletions
This file was deleted.

‎plugins/hls-eval-plugin/test/testdata/T21.hs

Lines changed: 0 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -9,4 +9,3 @@ fun :: forall k n a. (KnownNat k, KnownNat n, Typeable a)
99
=> Proxy k -> Proxy n -> Proxy a -> ()
1010
fun _ _ _ = ()
1111

12-
-- >>> :type fun

‎plugins/hls-eval-plugin/test/testdata/T23.expected.hs

Lines changed: 0 additions & 15 deletions
This file was deleted.

‎plugins/hls-eval-plugin/test/testdata/T23.hs

Lines changed: 0 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -9,4 +9,3 @@ f :: forall k n a. (KnownNat k, KnownNat n, Typeable a)
99
=> Proxy k -> Proxy n -> Proxy a -> ()
1010
f _ _ _ = ()
1111

12-
-- >>> :type f

‎plugins/hls-eval-plugin/test/testdata/T8.expected.hs

Lines changed: 0 additions & 14 deletions
This file was deleted.

‎plugins/hls-eval-plugin/test/testdata/T8.hs

Lines changed: 1 addition & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -1,10 +1,2 @@
1-
-- Semantic and Lexical errors are reported
1+
-- An empty playground
22
module T8 where
3-
4-
-- >>> noFunctionWithThisName
5-
6-
-- >>> "a" + "bc"
7-
8-
-- >>> "
9-
10-
-- >>> 3 `div` 0

0 commit comments

Comments
 (0)