Merge branch 'master' into fix-stuck-at-exit

Author: soulomoon

.github/actions/setup-build/action.yml

@@ -31,7 +31,7 @@ runs:
         sudo chown -R $USER /usr/local/.ghcup
       shell: bash
 
-    - uses: haskell-actions/[email protected].2
+    - uses: haskell-actions/[email protected].3
       id: HaskEnvSetup
       with:
         ghc-version  : ${{ inputs.ghc   }}

.github/workflows/bench.yml

@@ -126,7 +126,7 @@ jobs:
         example: ['cabal', 'lsp-types']
 
     steps:
-    - uses: haskell-actions/[email protected].2
+    - uses: haskell-actions/[email protected].3
       with:
         ghc-version  : ${{ matrix.ghc   }}
         cabal-version: ${{ matrix.cabal }}

bench/config.yaml

@@ -106,6 +106,8 @@ experiments:
     - "code actions after cradle edit"
     - "documentSymbols after edit"
     - "hole fit suggestions"
+    - "eval execute single-line code lens"
+    - "eval execute multi-line code lens"
 
 # An ordered list of versions to analyze
 versions:

ghcide-bench/src/Experiments.hs

@@ -241,7 +241,7 @@ experiments =
       benchWithSetup
         "hole fit suggestions"
         ( mapM_ $ \DocumentPositions{..} -> do
-            let edit  =TextDocumentContentChangeEvent $ InL $ #range .== Range bottom bottom
+            let edit = TextDocumentContentChangeEvent $ InL $ #range .== Range bottom bottom
                                                            .+ #rangeLength .== Nothing
                                                            .+ #text .== t
                 bottom = Position maxBound 0
@@ -266,6 +266,63 @@ experiments =
                 case requireDiagnostic diags (DiagnosticSeverity_Error, (fromIntegral bottom, 8), "Found hole", Nothing) of
                     Nothing   -> pure True
                     Just _err -> pure False
+        ),
+      ---------------------------------------------------------------------------------------
+      benchWithSetup
+        "eval execute single-line code lens"
+        ( mapM_ $ \DocumentPositions{..} -> do
+            let edit = TextDocumentContentChangeEvent $ InL $ #range .== Range bottom bottom
+                                                           .+ #rangeLength .== Nothing
+                                                           .+ #text .== t
+                bottom = Position maxBound 0
+                t = T.unlines
+                    [ ""
+                    , "-- >>> 1 + 2"
+                    ]
+            changeDoc doc [edit]
+        )
+        ( \docs -> do
+            not . null <$> forM docs (\DocumentPositions{..} -> do
+              lenses <- getCodeLenses doc
+              forM_ lenses $ \case
+                CodeLens { _command = Just cmd } -> do
+                  executeCommand cmd
+                  waitForProgressStart
+                  waitForProgressDone
+                _ -> return ()
+              )
+        ),
+      ---------------------------------------------------------------------------------------
+      benchWithSetup
+        "eval execute multi-line code lens"
+        ( mapM_ $ \DocumentPositions{..} -> do
+            let edit = TextDocumentContentChangeEvent $ InL $ #range .== Range bottom bottom
+                                                           .+ #rangeLength .== Nothing
+                                                           .+ #text .== t
+                bottom = Position maxBound 0
+                t = T.unlines
+                    [ ""
+                    , "data T = A | B | C | D"
+                    , "  deriving (Show, Eq, Ord, Bounded, Enum)"
+                    , ""
+                    , "{-"
+                    , ">>> import Data.List (nub)"
+                    , ">>> xs = ([minBound..maxBound] ++ [minBound..maxBound] :: [T])"
+                    , ">>> nub xs"
+                    , "-}"
+                    ]
+            changeDoc doc [edit]
+        )
+        ( \docs -> do
+            not . null <$> forM docs (\DocumentPositions{..} -> do
+              lenses <- getCodeLenses doc
+              forM_ lenses $ \case
+                CodeLens { _command = Just cmd } -> do
+                  executeCommand cmd
+                  waitForProgressStart
+                  waitForProgressDone
+                _ -> return ()
+              )
         )
     ]
     where hasDefinitions (InL (Definition (InL _)))  = True

ghcide/session-loader/Development/IDE/Session.hs

@@ -585,9 +585,21 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do
           let new_cache = newComponentCache recorder optExtensions hieYaml _cfp hscEnv
           all_target_details <- new_cache old_deps new_deps
 
-          let all_targets = concatMap fst all_target_details
-
-          let this_flags_map = HM.fromList (concatMap toFlagsMap all_targets)
+          this_dep_info <- getDependencyInfo $ maybeToList hieYaml
+          let (all_targets, this_flags_map, this_options)
+                = case HM.lookup _cfp flags_map' of
+                    Just this -> (all_targets', flags_map', this)
+                    Nothing -> (this_target_details : all_targets', HM.insert _cfp this_flags flags_map', this_flags)
+                  where all_targets' = concat all_target_details
+                        flags_map' = HM.fromList (concatMap toFlagsMap all_targets')
+                        this_target_details = TargetDetails (TargetFile _cfp) this_error_env this_dep_info [_cfp]
+                        this_flags = (this_error_env, this_dep_info)
+                        this_error_env = ([this_error], Nothing)
+                        this_error = ideErrorWithSource (Just "cradle") (Just DiagnosticSeverity_Error) _cfp
+                                       $ T.unlines
+                                       [ "No cradle target found. Is this file listed in the targets of your cradle?"
+                                       , "If you are using a .cabal file, please ensure that this module is listed in either the exposed-modules or other-modules section"
+                                       ]
 
           void $ modifyVar' fileToFlags $
               Map.insert hieYaml this_flags_map
@@ -615,7 +627,7 @@ loadSessionWithOptions recorder SessionLoadingOptions{..} dir = do
                     let !exportsMap' = createExportsMap $ mapMaybe (fmap hirModIface) modIfaces
                     liftIO $ atomically $ modifyTVar' (exportsMap shakeExtras) (exportsMap' <>)
 
-          return $ second Map.keys $ this_flags_map HM.! _cfp
+          return $ second Map.keys this_options
 
     let consultCradle :: Maybe FilePath -> FilePath -> IO (IdeResult HscEnvEq, [FilePath])
         consultCradle hieYaml cfp = do
@@ -810,7 +822,7 @@ newComponentCache
          -> HscEnv             -- ^ An empty HscEnv
          -> [ComponentInfo]    -- ^ New components to be loaded
          -> [ComponentInfo]    -- ^ old, already existing components
-         -> IO [ ([TargetDetails], (IdeResult HscEnvEq, DependencyInfo))]
+         -> IO [ [TargetDetails] ]
 newComponentCache recorder exts cradlePath _cfp hsc_env old_cis new_cis = do
     let cis = Map.unionWith unionCIs (mkMap new_cis) (mkMap old_cis)
         -- When we have multiple components with the same uid,
@@ -882,14 +894,13 @@ newComponentCache recorder exts cradlePath _cfp hsc_env old_cis new_cis = do
       henv <- createHscEnvEq thisEnv (zip uids dfs)
       let targetEnv = (if isBad ci then multi_errs else [], Just henv)
           targetDepends = componentDependencyInfo ci
-          res = ( targetEnv, targetDepends)
-      logWith recorder Debug $ LogNewComponentCache res
+      logWith recorder Debug $ LogNewComponentCache (targetEnv, targetDepends)
       evaluate $ liftRnf rwhnf $ componentTargets ci
 
       let mk t = fromTargetId (importPaths df) exts (targetId t) targetEnv targetDepends
       ctargets <- concatMapM mk (componentTargets ci)
 
-      return (L.nubOrdOn targetTarget ctargets, res)
+      return (L.nubOrdOn targetTarget ctargets)
 
 {- Note [Avoiding bad interface files]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1081,15 +1092,20 @@ setOptions cfp (ComponentOptions theOpts compRoot _) dflags = do
         -- A special target for the file which caused this wonderful
         -- component to be created. In case the cradle doesn't list all the targets for
         -- the component, in which case things will be horribly broken anyway.
-        -- Otherwise, we will immediately attempt to reload this module which
-        -- causes an infinite loop and high CPU usage.
+        --
+        -- When we have a single component that is caused to be loaded due to a
+        -- file, we assume the file is part of that component. This is useful
+        -- for bare GHC sessions, such as many of the ones used in the testsuite
         --
         -- We don't do this when we have multiple components, because each
         -- component better list all targets or there will be anarchy.
         -- It is difficult to know which component to add our file to in
         -- that case.
         -- Multi unit arguments are likely to come from cabal, which
         -- does list all targets.
+        --
+        -- If we don't end up with a target for the current file in the end, then
+        -- we will report it as an error for that file
         abs_fp <- liftIO $ makeAbsolute (fromNormalizedFilePath cfp)
         let special_target = Compat.mkSimpleTarget df abs_fp
         pure $ (df, special_target : targets) :| []

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

@@ -277,6 +277,7 @@ initialiseSessionForEval needs_quickcheck st nfp = do
                    . flip xopt_unset  LangExt.MonomorphismRestriction
                    . flip gopt_set    Opt_ImplicitImportQualified
                    . flip gopt_unset  Opt_DiagnosticsShowCaret
+                   . setBackend ghciBackend
                    $ (ms_hspp_opts ms) {
                         useColor = Never
                       , canUseColor = False }

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

@@ -88,6 +88,7 @@ tests =
   , goldenWithEval "Reports an error for an incorrect type with :kind" "T13" "hs"
   , goldenWithEval' "Returns a fully-instantiated type for :type" "T14" "hs" (if ghcVersion >= GHC98 then "ghc98.expected" else "expected") -- See https://gitlab.haskell.org/ghc/ghc/-/issues/24069
   , knownBrokenForGhcVersions [GHC92, GHC94, GHC96, GHC98] "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 "Doesn't break in module containing main function" "T4139" "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 "Reports an error when given with unknown command" "T18" "hs"

plugins/hls-eval-plugin/test/testdata/T4139.expected.hs

@@ -0,0 +1,7 @@
+module T4139 where
+
+-- >>> 'x'
+-- 'x'
+
+main :: IO ()
+main = putStrLn "Hello World!"

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

@@ -0,0 +1,6 @@
+module T4139 where
+
+-- >>> 'x'
+
+main :: IO ()
+main = putStrLn "Hello World!"