Restore eval plugin build for GHC 9.2 (#2669)

* tests: Test for eval plugin now show correct line in output

Using `HasCallStack`, `testCase` can no pinpoint the call location
instead of pointing inside the utility function.

* Restore eval plugin build for GHC 9.2

It restores the eval plugin. Now annotations with comments are found by
walking the AST and locating specific annotations.

In order to fix unit test, I implemented a new golden test function
which accepts a different naming scheme depending on the GHC version.

* fix: remove unused log mecanism

* Refactor: move pragma to compat module

* refactor: Remove now useless dependency

* fix: remove an unused import

* Disable a test for eval plugin for GHC 9.2

Eval plugin does not report progress, I don't understand why.

* fix: type +v actually also works with GHC 9.0

Co-authored-by: Pepe Iborra <[email protected]>

Author: guibou

cabal-ghc921.project

@@ -46,7 +46,6 @@ constraints:
     +ignore-plugins-ghc-bounds
     -brittany
     -class
-    -eval
     -haddockComments
     -hlint
     -retrie

ghcide/src/Development/IDE/Core/Compile.hs

@@ -95,6 +95,14 @@ import           System.IO.Extra                   (fixIO, newTempFileWithin)
 
 -- GHC API imports
 -- GHC API imports
+#if MIN_VERSION_ghc(9,2,0)
+import           GHC                               (Anchor (anchor),
+                                                    EpaComment (EpaComment),
+                                                    EpaCommentTok (EpaBlockComment, EpaLineComment),
+                                                    epAnnComments,
+                                                    priorComments)
+import           GHC.Hs                            (LEpaComment)
+#endif
 import           GHC                               (GetDocsFailure (..),
                                                     mgModSummaries,
                                                     parsedSource)

ghcide/src/Development/IDE/GHC/Compat/Parser.hs

@@ -41,6 +41,8 @@ module Development.IDE.GHC.Compat.Parser (
 #if !MIN_VERSION_ghc(9,2,0)
     Anno.AnnotationComment(..),
 #endif
+    pattern EpaLineComment,
+    pattern EpaBlockComment
     ) where
 
 #if MIN_VERSION_ghc(9,0,0)
@@ -51,12 +53,18 @@ import qualified GHC.Parser.Annotation           as Anno
 import qualified GHC.Parser.Lexer                as Lexer
 import           GHC.Types.SrcLoc                (PsSpan (..))
 #if MIN_VERSION_ghc(9,2,0)
-import           GHC                             (pm_extra_src_files,
+import           GHC                             (Anchor (anchor),
+                                                  EpAnnComments (priorComments),
+                                                  EpaComment (EpaComment),
+                                                  EpaCommentTok (..),
+                                                  epAnnComments,
+                                                  pm_extra_src_files,
                                                   pm_mod_summary,
                                                   pm_parsed_source)
 import qualified GHC
 import qualified GHC.Driver.Config               as Config
-import           GHC.Hs                          (hpm_module, hpm_src_files)
+import           GHC.Hs                          (LEpaComment, hpm_module,
+                                                  hpm_src_files)
 import           GHC.Parser.Lexer                hiding (initParserState)
 #endif
 #else
@@ -100,6 +108,8 @@ initParserState =
 #endif
 
 #if MIN_VERSION_ghc(9,2,0)
+-- GHC 9.2 does not have ApiAnns anymore packaged in ParsedModule. Now the
+-- annotations are found in the ast.
 type ApiAnns = ()
 #else
 type ApiAnns = Anno.ApiAnns
@@ -155,3 +165,8 @@ mkApiAnns pst =
                   :annotations_comments pst))
 #endif
 #endif
+
+#if !MIN_VERSION_ghc(9,2,0)
+pattern EpaLineComment a = Anno.AnnLineComment a
+pattern EpaBlockComment a = Anno.AnnBlockComment a
+#endif

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

@@ -79,7 +79,6 @@ library
     , pretty-simple
     , QuickCheck
     , safe-exceptions
-    , temporary
     , text
     , time
     , transformers

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

@@ -73,13 +73,19 @@ import           GHC                             (ClsInst,
                                                   getInteractiveDynFlags,
                                                   isImport, isStmt, load,
                                                   parseName, pprFamInst,
-                                                  pprInstance, setLogAction,
-                                                  setTargets, typeKind)
+                                                  pprInstance, setTargets,
+                                                  typeKind)
+#if MIN_VERSION_ghc(9,2,0)
+import           GHC                             (Fixity)
+#endif
 import qualified GHC.LanguageExtensions.Type     as LangExt (Extension (..))
 
 import           Development.IDE.Core.FileStore  (setSomethingModified)
 import           Development.IDE.Types.Shake     (toKey)
 import           Ide.Plugin.Config               (Config)
+#if MIN_VERSION_ghc(9,2,0)
+import           GHC.Types.SrcLoc                (UnhelpfulSpanReason (UnhelpfulInteractive))
+#endif
 import           Ide.Plugin.Eval.Code            (Statement, asStatements,
                                                   evalSetup, myExecStmt,
                                                   propSetup, resultRange,
@@ -102,11 +108,9 @@ import           Language.LSP.Types              hiding
                                                   SemanticTokenRelative (length))
 import           Language.LSP.Types.Lens         (end, line)
 import           Language.LSP.VFS                (virtualFileText)
-import           System.FilePath                 (takeFileName)
-import           System.IO                       (hClose)
-import           UnliftIO.Temporary              (withSystemTempFile)
 
-#if MIN_VERSION_ghc(9,0,0)
+#if MIN_VERSION_ghc(9,2,0)
+#elif MIN_VERSION_ghc(9,0,0)
 import           GHC.Driver.Session              (unitDatabases, unitState)
 import           GHC.Types.SrcLoc                (UnhelpfulSpanReason (UnhelpfulInteractive))
 #else
@@ -218,7 +222,7 @@ runEvalCmd plId st EvalParams{..} =
                         (Just (textToStringBuffer mdlText, now))
 
             -- Setup environment for evaluation
-            hscEnv' <- ExceptT $ fmap join $ withSystemTempFile (takeFileName fp) $ \logFilename logHandle -> liftIO . gStrictTry . evalGhcEnv session $ do
+            hscEnv' <- ExceptT $ fmap join $ liftIO . gStrictTry . evalGhcEnv session $ do
                 env <- getSession
 
                 -- Install the module pragmas and options
@@ -247,13 +251,8 @@ runEvalCmd plId st EvalParams{..} =
                         $ idflags
                 setInteractiveDynFlags $ df'
 #if MIN_VERSION_ghc(9,0,0)
-                        { unitState =
-                            unitState
-                                df
-                        , unitDatabases =
-                            unitDatabases
-                                df
-                        , packageFlags =
+                        {
+                        packageFlags =
                             packageFlags
                                 df
                         , useColor = Never
@@ -274,15 +273,6 @@ runEvalCmd plId st EvalParams{..} =
                         }
 #endif
 
-                -- set up a custom log action
-#if MIN_VERSION_ghc(9,0,0)
-                setLogAction $ \_df _wr _sev _span _doc ->
-                    defaultLogActionHPutStrDoc _df logHandle _doc
-#else
-                setLogAction $ \_df _wr _sev _span _style _doc ->
-                    defaultLogActionHPutStrDoc _df logHandle _doc _style
-#endif
-
                 -- Load the module with its current content (as the saved module might not be up to date)
                 -- BUG: this fails for files that requires preprocessors (e.g. CPP) for ghc < 8.8
                 -- see https://gitlab.haskell.org/ghc/ghc/-/issues/17066
@@ -295,8 +285,7 @@ runEvalCmd plId st EvalParams{..} =
                 dbg "LOAD RESULT" $ asS loadResult
                 case loadResult of
                     Failed -> liftIO $ do
-                        hClose logHandle
-                        err <- readFile logFilename
+                        let err = ""
                         dbg "load ERR" err
                         return $ Left err
                     Succeeded -> do
@@ -687,7 +676,9 @@ doTypeCmd dflags arg = do
 
 parseExprMode :: Text -> (TcRnExprMode, T.Text)
 parseExprMode rawArg = case T.break isSpace rawArg of
+#if !MIN_VERSION_ghc(9,2,0)
     ("+v", rest) -> (TM_NoInst, T.strip rest)
+#endif
     ("+d", rest) -> (TM_Default, T.strip rest)
     _            -> (TM_Inst, rawArg)
 

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

@@ -36,6 +36,9 @@ import           Development.IDE.GHC.Compat
 import qualified Development.IDE.GHC.Compat           as SrcLoc
 import qualified Development.IDE.GHC.Compat.Util      as FastString
 import           Development.IDE.Graph                (alwaysRerun)
+#if MIN_VERSION_ghc(9,2,0)
+import           GHC.Parser.Annotation
+#endif
 import           Ide.Plugin.Eval.Types
 
 
@@ -53,22 +56,44 @@ queueForEvaluation ide nfp = do
     EvaluatingVar var <- getIdeGlobalState ide
     modifyIORef var (Set.insert nfp)
 
-#if MIN_VERSION_ghc(9,0,0)
+#if MIN_VERSION_ghc(9,2,0)
+getAnnotations :: Development.IDE.GHC.Compat.Located HsModule -> [LEpaComment]
+getAnnotations (L _ m@(HsModule { hsmodAnn = anns'})) =
+    priorComments annComments <> getFollowingComments annComments
+     <> concatMap getCommentsForDecl (hsmodImports m)
+     <> concatMap getCommentsForDecl (hsmodDecls m)
+       where
+         annComments = epAnnComments anns'
+
+getCommentsForDecl :: GenLocated (SrcSpanAnn' (EpAnn ann)) e
+                            -> [LEpaComment]
+getCommentsForDecl (L (SrcSpanAnn (EpAnn _ _ cs) _) _) = priorComments cs <> getFollowingComments cs
+getCommentsForDecl (L (SrcSpanAnn (EpAnnNotUsed) _) _) = []
+
+apiAnnComments' :: ParsedModule -> [SrcLoc.RealLocated EpaCommentTok]
+apiAnnComments' pm = do
+  L span (EpaComment c _) <- getAnnotations $ pm_parsed_source pm
+  pure (L (anchor span) c)
+
+pattern RealSrcSpanAlready :: SrcLoc.RealSrcSpan -> SrcLoc.RealSrcSpan
+pattern RealSrcSpanAlready x = x
+#elif MIN_VERSION_ghc(9,0,0)
+apiAnnComments' :: ParsedModule -> [SrcLoc.RealLocated AnnotationComment]
+apiAnnComments' = apiAnnRogueComments . pm_annotations
+
 pattern RealSrcSpanAlready :: SrcLoc.RealSrcSpan -> SrcLoc.RealSrcSpan
 pattern RealSrcSpanAlready x = x
-apiAnnComments' :: SrcLoc.ApiAnns -> [SrcLoc.RealLocated AnnotationComment]
-apiAnnComments' = apiAnnRogueComments
 #else
-apiAnnComments' :: SrcLoc.ApiAnns -> [SrcLoc.Located AnnotationComment]
-apiAnnComments' = concat . Map.elems . snd
+apiAnnComments' :: ParsedModule -> [SrcLoc.Located AnnotationComment]
+apiAnnComments' = concat . Map.elems . snd . pm_annotations
 
 pattern RealSrcSpanAlready :: SrcLoc.RealSrcSpan -> SrcSpan
 pattern RealSrcSpanAlready x = SrcLoc.RealSrcSpan x Nothing
 #endif
 
 evalParsedModuleRule :: Rules ()
 evalParsedModuleRule = defineEarlyCutoff $ RuleNoDiagnostics $ \GetEvalComments nfp -> do
-    (ParsedModule{..}, posMap) <- useWithStale_ GetParsedModuleWithComments nfp
+    (pm, posMap) <- useWithStale_ GetParsedModuleWithComments nfp
     let comments = foldMap (\case
                 L (RealSrcSpanAlready real) bdy
                     | FastString.unpackFS (srcSpanFile real) ==
@@ -80,14 +105,14 @@ evalParsedModuleRule = defineEarlyCutoff $ RuleNoDiagnostics $ \GetEvalComments
                         -- since Haddock parsing is unset explicitly in 'getParsedModuleWithComments',
                         -- we can concentrate on these two
                         case bdy of
-                            AnnLineComment cmt ->
+                            EpaLineComment cmt ->
                                 mempty { lineComments = Map.singleton curRan (RawLineComment cmt) }
-                            AnnBlockComment cmt ->
+                            EpaBlockComment cmt ->
                                 mempty { blockComments = Map.singleton curRan $ RawBlockComment cmt }
                             _ -> mempty
                 _ -> mempty
             )
-            $ apiAnnComments' pm_annotations
+            $ apiAnnComments' pm
         -- we only care about whether the comments are null
         -- this is valid because the only dependent is NeedsCompilation
         fingerPrint = fromString $ if nullComments comments then "" else "1"

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

@@ -1,3 +1,4 @@
+{-# LANGUAGE MultiWayIf        #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards   #-}
 {-# LANGUAGE TypeApplications  #-}
@@ -69,40 +70,43 @@ tests =
   , goldenWithEval "Refresh a multiline evaluation" "T7" "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 == GHC90
-          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" "-- >>> res = \"a\" + \"bc\"" $
+        if
+           | ghcVersion == GHC92 -> "-- No instance for (Num String) arising from a use of `+'\n-- In the expression: \"a\" + \"bc\"\n-- In an equation for `res': res = \"a\" + \"bc\""
+           | ghcVersion == GHC90 -> "-- No instance for (Num String) arising from a use of ‘+’"
+           | otherwise -> "-- 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"
-  , goldenWithEval "Shows a kind with :kind" "T12" "hs"
-  , goldenWithEval "Reports an error for an incorrect type with :kind" "T13" "hs"
+  , goldenWithEval' "Evaluate a type with :kind!" "T10" "hs" (if ghcVersion == GHC92 then "ghc92.expected" else "expected")
+  , goldenWithEval' "Reports an error for an incorrect type with :kind!" "T11" "hs" (if ghcVersion == GHC92 then "ghc92.expected" else "expected")
+  , goldenWithEval' "Shows a kind with :kind" "T12" "hs" (if ghcVersion == GHC92 then "ghc92.expected" else "expected")
+  , goldenWithEval' "Reports an error for an incorrect type with :kind" "T13" "hs" (if ghcVersion == GHC92 then "ghc92.expected" else "expected")
   , goldenWithEval "Returns a fully-instantiated type for :type" "T14" "hs"
-  , goldenWithEval "Returns an uninstantiated type for :type +v, admitting multiple whitespaces around arguments" "T15" "hs"
+  , knownBrokenForGhcVersions [GHC92] "type +v does not work anymore with 9.2" $ goldenWithEval "Returns an uninstantiated type for :type +v, admitting multiple whitespaces around arguments" "T15" "hs"
   , goldenWithEval "Returns defaulted type for :type +d, admitting multiple whitespaces around arguments" "T16" "hs"
-  , goldenWithEval ":type reports an error when given with unknown +x option" "T17" "hs"
+  , goldenWithEval' ":type reports an error when given with unknown +x option" "T17" "hs" (if ghcVersion == GHC92 then "ghc92.expected" else "expected")
   , goldenWithEval "Reports an error when given with unknown command" "T18" "hs"
   , 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 +d reflects the `default' declaration of the module" "T20" "hs" (if ghcVersion == GHC92 then "ghc92.expected" else "expected")
   , testCase ":type handles a multilined result properly" $
       evalInFile "T21.hs" "-- >>> :type fun" $ T.unlines [
         "-- fun",
-        if ghcVersion == GHC90
-          then "--   :: forall {k1} {k2 :: Nat} {n :: Nat} {a :: k1}."
-          else "--   :: forall k1 (k2 :: Nat) (n :: Nat) (a :: k1).",
+        if
+           | ghcVersion == GHC92 -> "--   :: forall {k1} (k2 :: Nat) (n :: Nat) (a :: k1)."
+           | ghcVersion == GHC90 -> "--   :: forall {k1} {k2 :: Nat} {n :: Nat} {a :: k1}."
+           | otherwise -> "--   :: 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"
   , testCase ":type does \"dovetails\" for short identifiers" $
       evalInFile "T23.hs" "-- >>> :type f" $ T.unlines [
-        if ghcVersion == GHC90
-          then "-- f :: forall {k1} {k2 :: Nat} {n :: Nat} {a :: k1}."
-          else "-- f :: forall k1 (k2 :: Nat) (n :: Nat) (a :: k1).",
+        if
+          | ghcVersion == GHC92 -> "-- f :: forall {k1} (k2 :: Nat) (n :: Nat) (a :: k1)."
+          | ghcVersion == GHC90 -> "-- f :: forall {k1} {k2 :: Nat} {n :: Nat} {a :: k1}."
+          | otherwise -> "-- f :: forall k1 (k2 :: Nat) (n :: Nat) (a :: k1).",
         "--      (KnownNat k2, KnownNat n, Typeable a) =>",
         "--      Proxy k2 -> Proxy n -> Proxy a -> ()"
       ]
@@ -119,11 +123,13 @@ tests =
   , goldenWithEval "Transitive local dependency" "TTransitive" "hs"
   -- , 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"
+  , goldenWithEval' ":set accepts ghci flags" "TFlags" "hs" (if ghcVersion == GHC92 then "ghc92.expected" else "expected")
   , 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"
+        (if ghcVersion == GHC92
+           then "-- id :: forall a. a -> a"
+           else "-- 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"
@@ -210,6 +216,12 @@ goldenWithEval :: TestName -> FilePath -> FilePath -> TestTree
 goldenWithEval title path ext =
   goldenWithHaskellDoc evalPlugin title testDataDir path "expected" ext executeLensesBackwards
 
+-- | Similar function as 'goldenWithEval' with an alternate reference file
+-- naming. Useful when reference file may change because of GHC version.
+goldenWithEval' :: TestName -> FilePath -> FilePath -> FilePath -> TestTree
+goldenWithEval' title path ext expected =
+  goldenWithHaskellDoc evalPlugin title testDataDir path expected ext executeLensesBackwards
+
 -- | Execute lenses backwards, to avoid affecting their position in the source file
 executeLensesBackwards :: TextDocumentIdentifier -> Session ()
 executeLensesBackwards doc = do
@@ -261,7 +273,7 @@ diffOffConfig =
     unObject (Object obj) = obj
     unObject _            = undefined
 
-evalInFile :: FilePath -> T.Text -> T.Text -> IO ()
+evalInFile :: HasCallStack => FilePath -> T.Text -> T.Text -> IO ()
 evalInFile fp e expected = runSessionWithServer evalPlugin testDataDir $ do
   doc <- openDoc fp "haskell"
   origin <- documentContents doc

plugins/hls-eval-plugin/test/testdata/T10.ghc92.expected

@@ -0,0 +1,11 @@
+{-# LANGUAGE DataKinds, TypeOperators #-}
+module T10 where
+import GHC.TypeNats ( type (+) )
+
+type Dummy = 1 + 1
+
+-- >>> type N = 1
+-- >>> type M = 40
+-- >>> :kind! N + M + 1
+-- N + M + 1 :: Natural
+-- = 42

plugins/hls-eval-plugin/test/testdata/T10.ghc92.expected.hs

@@ -0,0 +1,11 @@
+{-# LANGUAGE DataKinds, TypeOperators #-}
+module T10 where
+import GHC.TypeNats ( type (+) )
+
+type Dummy = 1 + 1
+
+-- >>> type N = 1
+-- >>> type M = 40
+-- >>> :kind! N + M + 1
+-- N + M + 1 :: Natural
+-- = 42

plugins/hls-eval-plugin/test/testdata/T11.ghc92.expected.hs

@@ -0,0 +1,4 @@
+module T11 where
+
+-- >>> :kind! a
+-- Not in scope: type variable `a'

plugins/hls-eval-plugin/test/testdata/T11.ghc92_expected.hs

@@ -0,0 +1,4 @@
+module T11 where
+
+-- >>> :kind! a
+-- Not in scope: type variable `a'