Restore eval plugin build for GHC 9.2

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'