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

.github/workflows/test.yml

@@ -170,7 +170,7 @@ jobs:
         name: Test hls-class-plugin
         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"
 
-      - if: ${{ needs.pre_job.outputs.should_skip != 'true' && matrix.test && matrix.ghc != '9.0.1' }}
+      - if: ${{ needs.pre_job.outputs.should_skip != 'true' && matrix.test && matrix.ghc }}
         name: Test hls-eval-plugin
         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"
 

cabal-ghc901.project

@@ -88,7 +88,7 @@ index-state: 2021-06-30T16:00:00Z
 
 constraints:
     -- These plugins doesn't work on GHC9 yet
-    haskell-language-server -brittany -class -eval -fourmolu -ormolu -splice -stylishhaskell -tactic -refineImports
+    haskell-language-server -brittany -class -fourmolu -ormolu -splice -stylishhaskell -tactic -refineImports
 
 
 allow-newer:

configuration-ghc-901.nix

@@ -9,7 +9,6 @@ let
     "hls-fourmolu-plugin"
     "hls-splice-plugin"
     "hls-ormolu-plugin"
-    "hls-eval-plugin"
     "hls-class-plugin"
     "hls-refine-imports-plugin"
   ];
@@ -106,7 +105,6 @@ let
         (pkgs.lib.concatStringsSep " " [
           "-f-brittany"
           "-f-class"
-          "-f-eval"
           "-f-fourmolu"
           "-f-ormolu"
           "-f-splice"

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

@@ -112,10 +112,13 @@ data GhcVersion
   | GHC88
   | GHC86
   | GHC84
+  | GHC901
   deriving (Eq,Show)
 
 ghcVersion :: GhcVersion
-#if (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,10,0,0)))
+#if (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(9,0,1,0)))
+ghcVersion = GHC901
+#elif (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,10,0,0)))
 ghcVersion = GHC810
 #elif (defined(MIN_VERSION_GLASGOW_HASKELL) && (MIN_VERSION_GLASGOW_HASKELL(8,8,0,0)))
 ghcVersion = GHC88

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

@@ -19,13 +19,13 @@ build-type:         Simple
 extra-source-files:
   LICENSE
   README.md
+  test/cabal.project
+  test/info-util/*.cabal
+  test/info-util/*.hs
   test/testdata/*.cabal
   test/testdata/*.hs
   test/testdata/*.lhs
   test/testdata/*.yaml
-  test/info-util/*.cabal
-  test/info-util/*.hs
-  test/cabal.project
 
 flag pedantic
   description: Enable -Werror
@@ -110,3 +110,4 @@ test-suite tests
     , hls-test-utils   ^>=1.0
     , lens
     , lsp-types
+    , text

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

@@ -152,23 +152,29 @@ import           System.IO                            (hClose)
 import           UnliftIO.Temporary                   (withSystemTempFile)
 import           Util                                 (OverridingBool (Never))
 
-
+import           IfaceSyn                             (showToHeader)
+import           PprTyThing                           (pprTyThingInContext, pprTypeForUser)
 #if MIN_VERSION_ghc(9,0,0)
-import           GHC.Parser.Annotation                (ApiAnns (apiAnnComments))
+import           GHC.Parser.Annotation                (ApiAnns (apiAnnRogueComments))
+import           GHC.Parser.Lexer                     (mkParserFlags)
+import           GHC.Driver.Ways                      (hostFullWays,
+                                                       wayGeneralFlags,
+                                                       wayUnsetGeneralFlags)
+import           GHC.Types.SrcLoc                     (UnhelpfulSpanReason(UnhelpfulInteractive))
 #else
 import           GhcPlugins                           (interpWays, updateWays,
                                                        wayGeneralFlags,
                                                        wayUnsetGeneralFlags)
-import           IfaceSyn                             (showToHeader)
-import           PprTyThing                           (pprTyThingInContext)
 #endif
 
 #if MIN_VERSION_ghc(9,0,0)
 pattern RealSrcSpanAlready :: SrcLoc.RealSrcSpan -> SrcLoc.RealSrcSpan
 pattern RealSrcSpanAlready x = x
+apiAnnComments' :: SrcLoc.ApiAnns -> [SrcLoc.RealLocated AnnotationComment]
+apiAnnComments' = apiAnnRogueComments
 #else
-apiAnnComments :: SrcLoc.ApiAnns -> Map.Map SrcSpan [SrcLoc.Located AnnotationComment]
-apiAnnComments = snd
+apiAnnComments' :: SrcLoc.ApiAnns -> [SrcLoc.Located AnnotationComment]
+apiAnnComments' = concat . Map.elems . snd
 
 pattern RealSrcSpanAlready :: SrcLoc.RealSrcSpan -> SrcSpan
 pattern RealSrcSpanAlready x = SrcLoc.RealSrcSpan x
@@ -190,9 +196,9 @@ codeLens st plId CodeLensParams{_textDocument} =
                     isLHS = isLiterate fp
                 dbg "fp" fp
                 (ParsedModule{..}, posMap) <- liftIO $
-                    runAction "parsed" st $ useWithStale_ GetParsedModuleWithComments nfp
-                let comments = foldMap
-                        ( foldMap $ \case
+                    runAction "eval.GetParsedModuleWithComments" st $ useWithStale_ GetParsedModuleWithComments nfp
+                let comments =
+                         foldMap (\case
                             L (RealSrcSpanAlready real) bdy
                                 | unpackFS (srcSpanFile real) ==
                                     fromNormalizedFilePath nfp
@@ -210,16 +216,15 @@ codeLens st plId CodeLensParams{_textDocument} =
                                         _ -> mempty
                             _ -> mempty
                         )
-                        $ apiAnnComments pm_annotations
+                        $ apiAnnComments' pm_annotations
                 dbg "excluded comments" $ show $  DL.toList $
-                    foldMap
-                    (foldMap $ \(L a b) ->
+                    foldMap (\(L a b) ->
                         case b of
                             AnnLineComment{}  -> mempty
                             AnnBlockComment{} -> mempty
                             _                 -> DL.singleton (a, b)
                     )
-                    $ apiAnnComments pm_annotations
+                    $ apiAnnComments' pm_annotations
                 dbg "comments" $ show comments
 
                 -- Extract tests from source code
@@ -546,7 +551,7 @@ evals (st, fp) df stmts = do
             eans <-
                 liftIO $ try @GhcException $
                 parseDynamicFlagsCmdLine ndf
-                (map (L $ UnhelpfulSpan "<interactive>") flags)
+                (map (L $ UnhelpfulSpan unhelpfulReason) flags)
             dbg "parsed flags" $ eans
               <&> (_1 %~ showDynFlags >>> _3 %~ map warnMsg)
             case eans of
@@ -572,7 +577,7 @@ evals (st, fp) df stmts = do
           Just (cmd, arg) <- parseGhciLikeCmd $ T.pack stmt =
             evalGhciLikeCmd cmd arg
         | -- A statement
-          isStmt df stmt =
+          isStmt pf stmt =
             do
                 dbg "{STMT " stmt
                 res <- exec stmt l
@@ -582,7 +587,7 @@ evals (st, fp) df stmts = do
                 dbg "STMT} -> " r
                 return r
         | -- An import
-          isImport df stmt =
+          isImport pf stmt =
             do
                 dbg "{IMPORT " stmt
                 _ <- addImport stmt
@@ -593,6 +598,13 @@ evals (st, fp) df stmts = do
                 dbg "{DECL " stmt
                 void $ runDecls stmt
                 return Nothing
+#if !MIN_VERSION_ghc(9,0,0)
+    pf = df
+    unhelpfulReason = "<interactive>"
+#else
+    pf = mkParserFlags df
+    unhelpfulReason = UnhelpfulInteractive
+#endif
     exec stmt l =
         let opts = execOptions{execSourceFile = fp, execLineNumber = l}
          in myExecStmt stmt opts
@@ -739,20 +751,20 @@ doKindCmd :: Bool -> DynFlags -> Text -> Ghc (Maybe Text)
 doKindCmd False df arg = do
     let input = T.strip arg
     (_, kind) <- typeKind False $ T.unpack input
-    let kindText = text (T.unpack input) <+> "::" <+> ppr kind
+    let kindText = text (T.unpack input) <+> "::" <+> pprTypeForUser kind
     pure $ Just $ T.pack (showSDoc df kindText)
 doKindCmd True df arg = do
     let input = T.strip arg
     (ty, kind) <- typeKind True $ T.unpack input
-    let kindDoc = text (T.unpack input) <+> "::" <+> ppr kind
-        tyDoc = "=" <+> ppr ty
+    let kindDoc = text (T.unpack input) <+> "::" <+> pprTypeForUser kind
+        tyDoc = "=" <+> pprTypeForUser ty
     pure $ Just $ T.pack (showSDoc df $ kindDoc $$ tyDoc)
 
 doTypeCmd :: DynFlags -> Text -> Ghc (Maybe Text)
 doTypeCmd dflags arg = do
     let (emod, expr) = parseExprMode arg
     ty <- exprType emod $ T.unpack expr
-    let rawType = T.strip $ T.pack $ showSDoc dflags $ ppr ty
+    let rawType = T.strip $ T.pack $ showSDoc dflags $ pprTypeForUser ty
         broken = T.any (\c -> c == '\r' || c == '\n') rawType
     pure $
         Just $
@@ -761,7 +773,7 @@ doTypeCmd dflags arg = do
                     T.pack $
                         showSDoc dflags $
                             text (T.unpack expr)
-                                $$ nest 2 ("::" <+> ppr ty)
+                                $$ nest 2 ("::" <+> pprTypeForUser ty)
                 else expr <> " :: " <> rawType <> "\n"
 
 parseExprMode :: Text -> (TcRnExprMode, T.Text)
@@ -804,13 +816,18 @@ setupDynFlagsForGHCiLike env dflags = do
                 , ghcLink = LinkInMemory
                 }
         platform = targetPlatform dflags3
-        dflags3a = updateWays $ dflags3{ways = interpWays}
+#if MIN_VERSION_ghc(9,0,0)
+        evalWays = hostFullWays
+#else
+        evalWays = interpWays
+#endif
+        dflags3a = dflags3{ways = evalWays}
         dflags3b =
             foldl gopt_set dflags3a $
-                concatMap (wayGeneralFlags platform) interpWays
+                concatMap (wayGeneralFlags platform) evalWays
         dflags3c =
             foldl gopt_unset dflags3b $
-                concatMap (wayUnsetGeneralFlags platform) interpWays
+                concatMap (wayUnsetGeneralFlags platform) evalWays
         dflags4 =
             dflags3c
                 `gopt_set` Opt_ImplicitImportQualified

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

@@ -18,6 +18,7 @@ import           Ide.Plugin.Eval.Types   (EvalParams (..), Section (..),
 import           Language.LSP.Types.Lens (arguments, command, range, title)
 import           System.FilePath         ((</>))
 import           Test.Hls
+import qualified Data.Text as T
 
 main :: IO ()
 main = defaultTestRunner tests
@@ -61,7 +62,14 @@ tests =
   , goldenWithEval "Refresh an evaluation" "T5" "hs"
   , goldenWithEval "Refresh an evaluation w/ lets" "T6" "hs"
   , goldenWithEval "Refresh a multiline evaluation" "T7" "hs"
-  , goldenWithEval "Semantic and Lexical errors are reported" "T8" "hs"
+  , testCase "Semantic and Lexical errors are reported" $ do
+      evalInFile "T8.hs" "-- >>> noFunctionWithThisName" "-- Variable not in scope: noFunctionWithThisName"
+      evalInFile "T8.hs" "-- >>> \"a\" + \"bc\"" $
+        if ghcVersion == GHC901
+          then "-- No instance for (Num String) arising from a use of ‘+’"
+          else "-- No instance for (Num [Char]) arising from a use of ‘+’"
+      evalInFile "T8.hs" "-- >>> \"" "-- lexical error in string/character literal at end of input"
+      evalInFile "T8.hs" "-- >>> 3 `div` 0" "-- divide by zero"
   , goldenWithEval "Applies file LANGUAGE extensions" "T9" "hs"
   , goldenWithEval "Evaluate a type with :kind!" "T10" "hs"
   , goldenWithEval "Reports an error for an incorrect type with :kind!" "T11" "hs"
@@ -75,9 +83,24 @@ tests =
   , goldenWithEval "Returns defaulted type for :type +d reflecting the default declaration specified in the >>> prompt" "T19" "hs"
   , expectFailBecause "known issue - see a note in P.R. #361" $
       goldenWithEval ":type +d reflects the `default' declaration of the module" "T20" "hs"
-  , goldenWithEval ":type handles a multilined result properly" "T21" "hs"
+  , testCase ":type handles a multilined result properly" $
+      evalInFile "T21.hs" "-- >>> :type fun" $ T.unlines [
+        "-- fun",
+        if ghcVersion == GHC901
+          then "--   :: forall {k1} {k2 :: Nat} {n :: Nat} {a :: k1}."
+          else "--   :: forall k1 (k2 :: Nat) (n :: Nat) (a :: k1).",
+        "--      (KnownNat k2, KnownNat n, Typeable a) =>",
+        "--      Proxy k2 -> Proxy n -> Proxy a -> ()"
+      ]
   , goldenWithEval ":t behaves exactly the same as :type" "T22" "hs"
-  , goldenWithEval ":type does \"dovetails\" for short identifiers" "T23" "hs"
+  , testCase ":type does \"dovetails\" for short identifiers" $
+      evalInFile "T23.hs" "-- >>> :type f" $ T.unlines [
+        if ghcVersion == GHC901
+          then "-- f :: forall {k1} {k2 :: Nat} {n :: Nat} {a :: k1}."
+          else "-- f :: forall k1 (k2 :: Nat) (n :: Nat) (a :: k1).",
+        "--      (KnownNat k2, KnownNat n, Typeable a) =>",
+        "--      Proxy k2 -> Proxy n -> Proxy a -> ()"
+      ]
   , goldenWithEval ":kind! treats a multilined result properly" "T24" "hs"
   , goldenWithEval ":kind treats a multilined result properly" "T25" "hs"
   , goldenWithEval "local imports" "T26" "hs"
@@ -91,6 +114,10 @@ tests =
   -- , goldenWithEval "Local Modules can be imported in a test" "TLocalImportInTest" "hs"
   , goldenWithEval "Setting language option TupleSections" "TLanguageOptionsTupleSections" "hs"
   , goldenWithEval ":set accepts ghci flags" "TFlags" "hs"
+  , testCase ":set -fprint-explicit-foralls works" $ do
+      evalInFile "T8.hs" "-- >>> :t id" "-- id :: a -> a"
+      evalInFile "T8.hs" "-- >>> :set -fprint-explicit-foralls\n-- >>> :t id"
+        "-- id :: forall {a}. a -> a"
   , goldenWithEval "The default language extensions for the eval plugin are the same as those for ghci" "TSameDefaultLanguageExtensionsAsGhci" "hs"
   , goldenWithEval "IO expressions are supported, stdout/stderr output is ignored" "TIO" "hs"
   , goldenWithEval "Property checking" "TProperty" "hs"
@@ -196,3 +223,13 @@ codeLensTestOutput codeLens = do
 
 testDataDir :: FilePath
 testDataDir = "test" </> "testdata"
+
+evalInFile :: FilePath -> T.Text -> T.Text -> IO ()
+evalInFile fp e expected = runSessionWithServer evalPlugin testDataDir $ do
+  doc <- openDoc fp "haskell"
+  origin <- documentContents doc
+  let withEval = origin <> e
+  changeDoc doc [TextDocumentContentChangeEvent Nothing Nothing withEval]
+  executeLensesBackwards doc
+  result <- fmap T.strip . T.stripPrefix withEval <$> documentContents doc
+  liftIO $ result @?= Just (T.strip expected)

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

@@ -9,4 +9,3 @@ fun :: forall k n a. (KnownNat k, KnownNat n, Typeable a)
     => Proxy k -> Proxy n -> Proxy a -> ()
 fun _ _ _ = ()
 
--- >>> :type fun

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

@@ -9,4 +9,3 @@ f :: forall k n a. (KnownNat k, KnownNat n, Typeable a)
   => Proxy k -> Proxy n -> Proxy a -> ()
 f _ _ _ = ()
 
--- >>> :type f

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

@@ -1,10 +1,2 @@
--- Semantic and Lexical errors are reported
+-- An empty playground
 module T8 where
-
--- >>> noFunctionWithThisName
-
--- >>> "a" + "bc"
-
--- >>> "
-
--- >>> 3 `div` 0