Eval Plugin: Proper handling of flags in :set (#1343)

* More precise flag parsing

* Avoid collision between ghc 8.6 and above

* Error-message compatibility

Author: konn

haskell-language-server.cabal

@@ -426,9 +426,11 @@ test-suite func-test
     , tasty-ant-xml           >=1.1.6
     , tasty-golden
     , tasty-rerun
+    , megaparsec
+    , deepseq
     , ghcide
 
-  hs-source-dirs:     test/functional plugins/hls-tactics-plugin/src plugins/hls-eval-plugin/test plugins/hls-splice-plugin/src
+  hs-source-dirs:     test/functional plugins/hls-tactics-plugin/src plugins/hls-eval-plugin/test plugins/hls-splice-plugin/src plugins/hls-eval-plugin/src
 
   main-is:            Main.hs
   other-modules:
@@ -457,6 +459,7 @@ test-suite func-test
     HaddockComments
     Ide.Plugin.Splice.Types
     Ide.Plugin.Tactic.TestTypes
+    Ide.Plugin.Eval.Types
 
   ghc-options:
     -Wall -Wno-name-shadowing -threaded -rtsopts -with-rtsopts=-N

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

@@ -1,3 +1,5 @@
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE ViewPatterns #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveGeneric #-}
@@ -24,11 +26,11 @@ module Ide.Plugin.Eval.CodeLens (
 ) where
 
 import Control.Applicative (Alternative ((<|>)))
-import Control.Arrow (second)
+import Control.Arrow (second, (>>>))
 import qualified Control.Exception as E
 import Control.Monad
     ( void,
-      when,
+      when, guard
     )
 import Control.Monad.IO.Class (MonadIO (liftIO))
 import Control.Monad.Trans.Except
@@ -44,7 +46,7 @@ import Data.Either (isRight)
 import qualified Data.HashMap.Strict as HashMap
 import Data.List
     (dropWhileEnd,
-      find
+      find, intercalate
     )
 import qualified Data.Map.Strict as Map
 import Data.Maybe
@@ -75,9 +77,9 @@ import Development.IDE
       toNormalizedUri,
       uriToFilePath',
       useWithStale_,
-      use_,
+      use_, prettyPrint
     )
-import Development.IDE.GHC.Compat (AnnotationComment(AnnBlockComment, AnnLineComment), GenLocated (L), HscEnv, ParsedModule (..), SrcSpan (RealSrcSpan), srcSpanFile)
+import Development.IDE.GHC.Compat (AnnotationComment(AnnBlockComment, AnnLineComment), GenLocated (L), HscEnv, ParsedModule (..), SrcSpan (RealSrcSpan, UnhelpfulSpan), srcSpanFile, GhcException, setInteractiveDynFlags)
 import DynamicLoading (initializePlugins)
 import FastString (unpackFS)
 import GHC
@@ -125,7 +127,7 @@ import GhcPlugins
       updateWays,
       wayGeneralFlags,
       wayUnsetGeneralFlags,
-      xopt_set,
+      xopt_set, parseDynamicFlagsCmdLine
     )
 import HscTypes
     ( InteractiveImport (IIModule),
@@ -153,7 +155,7 @@ import Ide.Plugin.Eval.GHC
       showDynFlags,
     )
 import Ide.Plugin.Eval.Parse.Comments (commentsToSections)
-import Ide.Plugin.Eval.Parse.Option (langOptions)
+import Ide.Plugin.Eval.Parse.Option (langOptions, parseSetFlags)
 import Ide.Plugin.Eval.Types
 import Ide.Plugin.Eval.Util
     ( asS,
@@ -216,8 +218,11 @@ import Text.Read (readMaybe)
 import Util (OverridingBool (Never))
 import Development.IDE.Core.PositionMapping (toCurrentRange)
 import qualified Data.DList as DL
-import Control.Lens ((^.))
+import Control.Lens ((^.), _1, (%~), (<&>), _3)
 import Language.Haskell.LSP.Types.Lens (line, end)
+import Control.Exception (try)
+import CmdLineParser
+import qualified Development.IDE.GHC.Compat as SrcLoc
 
 {- | Code Lens provider
  NOTE: Invoked every time the document is modified, not just when the document is saved.
@@ -272,9 +277,9 @@ codeLens _lsp st plId CodeLensParams{_textDocument} =
                 cmd <- liftIO $ mkLspCommand plId evalCommandName "Evaluate=..." (Just [])
                 let lenses =
                         [ CodeLens testRange (Just cmd') Nothing
-                        | (section, test) <- tests
+                        | (section, ident, test) <- tests
                         , let (testRange, resultRange) = testRanges test
-                              args = EvalParams (setupSections ++ [section]) _textDocument
+                              args = EvalParams (setupSections ++ [section]) _textDocument ident
                               cmd' =
                                 (cmd :: Command)
                                     { _arguments = Just (List [toJSON args])
@@ -308,19 +313,14 @@ evalCommandName = "evalCommand"
 evalCommand :: PluginCommand IdeState
 evalCommand = PluginCommand evalCommandName "evaluate" runEvalCmd
 
--- | Specify the test section to execute
-data EvalParams = EvalParams
-    { sections :: [Section]
-    , module_ :: !TextDocumentIdentifier
-    }
-    deriving (Eq, Show, Generic, FromJSON, ToJSON)
+type EvalId = Int
 
 runEvalCmd :: CommandFunction IdeState EvalParams
 runEvalCmd lsp st EvalParams{..} =
     let dbg = logWith st
         perf = timed dbg
         cmd = do
-            let tests = testsBySection sections
+            let tests = map (\(a,_,b) -> (a,b)) $ testsBySection sections
 
             let TextDocumentIdentifier{_uri} = module_
             fp <- handleMaybe "uri" $ uriToFilePath' _uri
@@ -444,9 +444,12 @@ moduleText lsp uri =
                     lsp
                     (toNormalizedUri uri)
 
-testsBySection :: [Section] -> [(Section, Test)]
+testsBySection :: [Section] -> [(Section, EvalId, Test)]
 testsBySection sections =
-    [(section, test) | section <- sections, test <- sectionTests section]
+    [(section, ident, test)
+    | (ident, section) <- zip [0..] sections
+    , test <- sectionTests section
+    ]
 
 type TEnv = (IdeState, String)
 
@@ -560,20 +563,36 @@ evals (st, fp) df stmts = do
     dbg = logWith st
     eval :: Statement -> Ghc (Maybe [Text])
     eval (Located l stmt)
-        | -- A :set -XLanguageOption directive
-          isRight (langOptions stmt) =
-            either
-                (return . Just . errorLines)
-                ( \es -> do
-                    dbg "{:SET" es
-                    ndf <- getInteractiveDynFlags
-                    dbg "pre set" $ showDynFlags ndf
-                    mapM_ addExtension es
-                    ndf <- getInteractiveDynFlags
-                    dbg "post set" $ showDynFlags ndf
-                    return Nothing
-                )
-                $ ghcOptions stmt
+        | -- GHCi flags
+          Just (words -> flags) <- parseSetFlags stmt = do
+            dbg "{:SET" flags
+            ndf <- getInteractiveDynFlags
+            dbg "pre set" $ showDynFlags ndf
+            eans <-
+                liftIO $ try @GhcException $
+                parseDynamicFlagsCmdLine ndf
+                (map (L $ UnhelpfulSpan "<interactive>") flags)
+            dbg "parsed flags" $ eans
+              <&> (_1 %~ showDynFlags >>> _3 %~ map warnMsg)
+            case eans of
+                Left err -> pure $ Just $ errorLines $ show err
+                Right (df', ignoreds, warns) -> do
+                    let warnings = do
+                            guard $ not $ null warns
+                            pure $ errorLines $
+                                unlines $
+                                map prettyWarn warns
+                        igns = do
+                            guard $ not $ null ignoreds
+                            pure
+                                ["Some flags have not been recognized: "
+                                <> T.pack (intercalate ", " $ map SrcLoc.unLoc ignoreds)
+                                ]
+                    dbg "post set" $ showDynFlags df'
+                    _ <- setSessionDynFlags df'
+                    sessDyns <- getSessionDynFlags
+                    setInteractiveDynFlags sessDyns
+                    pure $ warnings <> igns
         | -- A type/kind command
           Just (cmd, arg) <- parseGhciLikeCmd $ T.pack stmt =
             evalGhciLikeCmd cmd arg
@@ -616,6 +635,11 @@ evals (st, fp) df stmts = do
         let opts = execOptions{execSourceFile = fp, execLineNumber = l}
          in execStmt stmt opts
 
+prettyWarn :: Warn -> String
+prettyWarn Warn{..} =
+    prettyPrint (SrcLoc.getLoc warnMsg) <> ": warning:\n"
+    <> "    " <> SrcLoc.unLoc warnMsg
+
 runGetSession :: MonadIO m => IdeState -> NormalizedFilePath -> m HscEnvEq
 runGetSession st nfp =
     liftIO $

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

@@ -20,7 +20,7 @@ import Development.IDE.GHC.Compat
 import qualified EnumSet
 import GHC.LanguageExtensions.Type (Extension (..))
 import GhcMonad (modifySession)
-import GhcPlugins (DefUnitId (..), InstalledUnitId (..), fsLit, hsc_IC)
+import GhcPlugins (DefUnitId (..), InstalledUnitId (..), fsLit, hsc_IC, pprHsString)
 import HscTypes (InteractiveContext (ic_dflags))
 import Ide.Plugin.Eval.Util (asS, gStrictTry)
 import qualified Lexer
@@ -36,6 +36,7 @@ import Outputable (
 import qualified Parser
 import SrcLoc (mkRealSrcLoc)
 import StringBuffer (stringToStringBuffer)
+import Data.String (fromString)
 
 {- $setup
 >>> import GHC
@@ -192,6 +193,7 @@ showDynFlags df =
         [ ("extensions", ppr . extensions $ df)
         , ("extensionFlags", ppr . EnumSet.toList . extensionFlags $ df)
         , ("importPaths", vList $ importPaths df)
+        , ("generalFlags", pprHsString . fromString . show . EnumSet.toList . generalFlags $ df)
         , -- , ("includePaths", text . show $ includePaths df)
           -- ("packageEnv", ppr $ packageEnv df)
           ("pkgNames", vcat . map text $ pkgNames df)

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

@@ -3,6 +3,7 @@
 -- | GHC language options parser
 module Ide.Plugin.Eval.Parse.Option (
     langOptions,
+    parseSetFlags,
 ) where
 
 import Control.Monad.Combinators (many)
@@ -26,6 +27,13 @@ langOptions =
   left errorBundlePretty
   . parse (space *> languageOpts <* eof) ""
 
+parseSetFlags :: String -> Maybe String
+parseSetFlags = parseMaybe
+    (hspace *> chunk ":set"
+        *> hspace1 *> takeRest
+        :: Parsec Void String String
+    )
+
 -- >>> parseMaybe languageOpts ":set -XBinaryLiterals -XOverloadedStrings"
 -- Just ["BinaryLiterals","OverloadedStrings"]
 languageOpts :: Parsec Void String [String]

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

@@ -25,6 +25,7 @@ module Ide.Plugin.Eval.Types
       RawLineComment (..),
       unLoc,
       Txt,
+      EvalParams(..),
     )
 where
 
@@ -37,6 +38,7 @@ import Data.String (IsString (..))
 import Development.IDE (Range)
 import GHC.Generics (Generic)
 import qualified Text.Megaparsec as P
+import Language.Haskell.LSP.Types (TextDocumentIdentifier)
 
 -- | A thing with a location attached.
 data Located l a = Located {location :: l, located :: a}
@@ -148,3 +150,13 @@ data LineChunk = LineChunk String | WildCardChunk
 
 instance IsString LineChunk where
     fromString = LineChunk
+
+type EvalId = Int
+
+-- | Specify the test section to execute
+data EvalParams = EvalParams
+    { sections :: [Section]
+    , module_ :: !TextDocumentIdentifier
+    , evalId :: !EvalId -- ^ unique group id; for test uses
+    }
+    deriving (Eq, Show, Generic, FromJSON, ToJSON)

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

@@ -1,3 +1,5 @@
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
@@ -26,7 +28,7 @@ import Language.Haskell.LSP.Test (
 import Language.Haskell.LSP.Types (
     ApplyWorkspaceEditRequest,
     CodeLens (CodeLens, _command, _range),
-    Command (Command, _title),
+    Command (Command, _title, _arguments),
     Position (..),
     Range (..),
     TextDocumentIdentifier,
@@ -43,12 +45,16 @@ import Test.Tasty (
  )
 import Test.Tasty.ExpectedFailure (
     expectFailBecause,
-    ignoreTestBecause,
  )
 import Test.Tasty.HUnit (
     testCase,
     (@?=),
  )
+import Data.List.Extra (nubOrdOn)
+import Development.IDE (List(List))
+import Ide.Plugin.Eval.Types (EvalParams(..))
+import Data.Aeson (fromJSON)
+import Data.Aeson.Types (Result(Success))
 
 tests :: TestTree
 tests =
@@ -140,9 +146,11 @@ tests =
         , testCase "Local Modules imports are accessible in a test" $
             goldenTest "TLocalImport.hs"
         , -- , testCase "Local Modules can be imported in a test" $ goldenTest "TLocalImportInTest.hs"
-          ignoreTestBecause "Unexplained but minor issue" $
+          expectFailBecause "Unexplained but minor issue" $
             testCase "Setting language option TupleSections" $
                 goldenTest "TLanguageOptionsTupleSections.hs"
+        , testCase ":set accepts ghci flags" $
+            goldenTest "TFlags.hs"
         , testCase "IO expressions are supported, stdout/stderr output is ignored" $
             goldenTest "TIO.hs"
         , testCase "Property checking" $ goldenTest "TProperty.hs"
@@ -187,10 +195,11 @@ goldenTestBy fltr input = runSession hlsCommand fullCaps evalPath $ do
     codeLenses <- reverse <$> getCodeLensesBy fltr doc
     -- liftIO $ print codeLenses
 
-    -- Execute sequentially, waiting for a moment to
-    -- avoid mis-insertion due to staled location info.
+    -- Execute sequentially, nubbing elements to avoid
+    -- evaluating the same section with multiple tests
+    -- more than twice
     mapM_ executeCmd
-        [c | CodeLens{_command = Just c} <- codeLenses]
+        $ nubOrdOn actSectionId [c | CodeLens{_command = Just c} <- codeLenses]
 
     edited <- replaceUnicodeQuotes <$> documentContents doc
     -- liftIO $ T.putStrLn edited
@@ -204,6 +213,10 @@ goldenTestBy fltr input = runSession hlsCommand fullCaps evalPath $ do
         expected <- T.readFile expectedFile
         edited @?= expected
 
+actSectionId :: Command -> Int
+actSectionId Command{_arguments = Just (List [fromJSON -> Success EvalParams{..}])} = evalId
+actSectionId _ = error "Invalid CodeLens"
+
 getEvalCodeLenses :: TextDocumentIdentifier -> Session [CodeLens]
 getEvalCodeLenses = getCodeLensesBy isEvalTest
 

plugins/hls-eval-plugin/test/testdata/TLanguageOptions.hs renamed to plugins/hls-eval-plugin/test/testdata/TFlags.hs

@@ -1,7 +1,7 @@
 -- Support for language options
 
 {-# LANGUAGE ScopedTypeVariables #-}
-module TLanguageOptions where
+module TFlags where
 
 -- Language options set in the module source (ScopedTypeVariables)
 -- also apply to tests so this works fine
@@ -38,6 +38,31 @@ It still works
 >>> class F
 -}
 
-{- Wrong option names are reported.
->>> :set -XWrong
+{- Now -package flag is handled correctly:
+
+>>> :set -package ghc-prim
+>>> import GHC.Prim
+
+-}
+
+{- -fprint-* families
+
+>>> import Data.Proxy
+>>> :set -XPolyKinds
+>>> :t Proxy
+Proxy :: forall k (t :: k). Proxy t
+
+>>> :set -fprint-explicit-foralls
+>>> :t Proxy
+Proxy :: forall {k} {t :: k}. Proxy t
+-}
+
+{- Invalid option/flags are reported, but valid ones will be reflected
+
+>>> :set -XRank2Types -XAbsent -XDatatypeContexts -XWrong -fprint-nothing-at-all
+
+Still, Rank2Types is enabled, as in GHCi:
+
+>>> f = const 42 :: (forall x. x) -> Int
+>>> f undefined
 -}